From 0cb83e40a0480ee29535770aa86112bcc7fbf775 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Mon, 23 Sep 2024 07:08:06 +0200 Subject: [PATCH 01/41] Clean trailing whitespaces --- class.c | 2 +- dump.c | 64 ++++++++++++++++++++++++++++----------------------------- op.c | 2 +- pad.c | 10 ++++----- 4 files changed, 39 insertions(+), 39 deletions(-) diff --git a/class.c b/class.c index 6bf703b537cb..5d75d85604c3 100644 --- a/class.c +++ b/class.c @@ -155,7 +155,7 @@ XS(injected_constructor) SV *name = ST(i); SV *val = (i+1 < items) ? ST(i+1) : &PL_sv_undef; - /* TODO: think about sanity-checking name for being + /* TODO: think about sanity-checking name for being * defined * not ref (but overloaded objects?? boo) * not duplicate diff --git a/dump.c b/dump.c index cdbbb0e2819d..f03ac0f51de3 100644 --- a/dump.c +++ b/dump.c @@ -166,7 +166,7 @@ Unused or not for public use #define PV_BYTE_HEX_LC "x%02" UVxf char * -Perl_pv_escape( pTHX_ SV *dsv, char const * const str, +Perl_pv_escape( pTHX_ SV *dsv, char const * const str, const STRLEN count, STRLEN max, STRLEN * const escaped, U32 flags ) { @@ -226,21 +226,21 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, /* This won't alter the UTF-8 flag */ SvPVCLEAR(dsv); } - + if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) isuni = 1; - + for ( ; pv < end ; pv += readsize ) { const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv; const U8 c = (U8)u; const char *source_buf = octbuf; - + if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL) || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM)))) { - if (flags & PERL_PV_ESCAPE_FIRSTCHAR) - chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, "%" UVxf, u); else if ((flags & PERL_PV_ESCAPE_NON_WC) && isWORDCHAR_uvchr(u)) { @@ -248,21 +248,21 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, source_buf = pv; } else - chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, + chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, ((flags & PERL_PV_ESCAPE_DWIM) && !isuni) ? ( use_uc_hex ? ("%c" PV_BYTE_HEX_UC) : ("%c" PV_BYTE_HEX_LC) ) : "%cx{%02" UVxf "}", esc, u); } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { - chsize = 1; - } else { + chsize = 1; + } else { if ( (c == dq) || (c == esc) || !isPRINT(c) ) { chsize = 2; switch (c) { - + case '\\' : /* FALLTHROUGH */ case '%' : if ( c == esc ) { - octbuf[1] = esc; + octbuf[1] = esc; } else { chsize = 1; } @@ -272,10 +272,10 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, case '\r' : octbuf[1] = 'r'; break; case '\n' : octbuf[1] = 'n'; break; case '\f' : octbuf[1] = 'f'; break; - case '"' : - if ( dq == '"' ) + case '"' : + if ( dq == '"' ) octbuf[1] = '"'; - else + else chsize = 1; break; default: @@ -323,7 +323,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, Perl_sv_catpvf( aTHX_ dsv, "%c", c); wrote++; } - if ( flags & PERL_PV_ESCAPE_FIRSTCHAR ) + if ( flags & PERL_PV_ESCAPE_FIRSTCHAR ) break; } if (escaped != NULL) @@ -339,7 +339,7 @@ C and supporting quoting and ellipses. If the C flag is set then the result will be double quoted with any double quotes in the string escaped. Otherwise if the C flag is set then the result be wrapped in -angle brackets. +angle brackets. If the C flag is set and not all characters in string were output then an ellipsis C<...> will be appended to the @@ -356,22 +356,22 @@ Returns a pointer to the prettified text as held by C. =for apidoc Amnh||PERL_PV_PRETTY_LTGT =for apidoc Amnh||PERL_PV_PRETTY_ELLIPSES -=cut +=cut */ char * -Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, - const STRLEN max, char const * const start_color, char const * const end_color, - const U32 flags ) +Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, + const STRLEN max, char const * const start_color, char const * const end_color, + const U32 flags ) { const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" : (flags & PERL_PV_PRETTY_LTGT) ? "<>" : NULL); STRLEN escaped; STRLEN max_adjust= 0; STRLEN orig_cur; - + PERL_ARGS_ASSERT_PV_PRETTY; - + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) { /* This won't alter the UTF-8 flag */ SvPVCLEAR(dsv); @@ -380,8 +380,8 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, if ( quotes ) Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]); - - if ( start_color != NULL ) + + if ( start_color != NULL ) sv_catpv(dsv, start_color); if ((flags & PERL_PV_PRETTY_EXACTSIZE)) { @@ -396,12 +396,12 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR ); - if ( end_color != NULL ) + if ( end_color != NULL ) sv_catpv(dsv, end_color); if ( quotes ) Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]); - + if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) ) sv_catpvs(dsv, "..."); @@ -409,7 +409,7 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, while( SvCUR(dsv) - orig_cur < max ) sv_catpvs(dsv," "); } - + return SvPVX(dsv); } @@ -795,7 +795,7 @@ S_opdump_link(pTHX_ const OP *base, const OP *o, PerlIO *file) =for apidoc_section $debugging =for apidoc dump_all -Dumps the entire optree of the current program starting at C to +Dumps the entire optree of the current program starting at C to C. Also dumps the optrees for all visible subroutines in C. @@ -2047,7 +2047,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if ((flags & SVs_PADTMP)) sv_catpvs(d, "PADTMP,"); append_flags(d, flags, first_sv_flags_names); - if (flags & SVf_ROK) { + if (flags & SVf_ROK) { sv_catpvs(d, "ROK,"); if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,"); } @@ -2350,7 +2350,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (ents) { HE *const *const last = ents + HvMAX(sv); count = last + 1 - ents; - + do { if (!*ents) --count; @@ -3375,7 +3375,7 @@ Perl_op_class(pTHX_ const OP *o) return OPclass_SVOP; #endif } - + #ifdef USE_ITHREADS if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_RCATLINE) @@ -3412,7 +3412,7 @@ Perl_op_class(pTHX_ const OP *o) case OA_PVOP_OR_SVOP: /* - * Character translations (tr///) are usually a PVOP, keeping a + * Character translations (tr///) are usually a PVOP, keeping a * pointer to a table of shorts used to look up translations. * Under utf8, however, a simple table isn't practical; instead, * the OP is an SVOP (or, under threads, a PADOP), diff --git a/op.c b/op.c index 1b5c11c58bc1..0b0a2db744db 100644 --- a/op.c +++ b/op.c @@ -6074,7 +6074,7 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) ? 2 /* Otherwise, minimum of 2 hex digits */\ : NUM_HEX_CHARS(num))))))) -/* To make evident, Configure with `-DDEBUGGING`, build, run +/* To make evident, Configure with `-DDEBUGGING`, build, run * `./perl -Ilib -Dy t/op/tr.t` */ void diff --git a/pad.c b/pad.c index 9b943b1158e4..adfa64e0613e 100644 --- a/pad.c +++ b/pad.c @@ -114,7 +114,7 @@ write is called (if necessary). The flag C is cleared on lexicals each time the C is executed, and set on scope exit. This allows the C<"Variable $x is not available"> warning -to be generated in evals, such as +to be generated in evals, such as { my $x = 1; sub f { eval '$x'} } f(); @@ -1181,7 +1181,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n", PTR2UV(cv), (long)offset, (unsigned long)*out_flags, - (unsigned long) PARENT_PAD_INDEX(*out_name) + (unsigned long) PARENT_PAD_INDEX(*out_name) )); } @@ -2008,7 +2008,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, S_unavailable(aTHX_ namesv); sv = NULL; } - else + else SvREFCNT_inc_simple_void_NN(sv); } if (!sv) { @@ -2569,8 +2569,8 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) interacts with lexicals. */ pad1a[ix] = sv_dup_inc(oldpad[ix], param); } else { - SV *sv; - + SV *sv; + if (sigil == '@') sv = MUTABLE_SV(newAV()); else if (sigil == '%') From e77f8cf274339259313489c48c26d6b1d05f5a00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Thu, 5 Dec 2024 05:54:18 +0100 Subject: [PATCH 02/41] [pad] Perl_Symbol_Table - enum for internal (pad) symbol table identification Using dedicated C tokens instead of literal values will improve readability of source code by separating intention from other usages of literal characters: - sigil (as language structure) - predefined variable name - prototype It will also make it feasible to add functionality, like - new sigil-less symbol tables (attributes, patterns, contracts, ...) - add support for custom symbol tables --- pad.h | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/pad.h b/pad.h index 0877aa6c3124..9ee41ab7b82e 100644 --- a/pad.h +++ b/pad.h @@ -313,9 +313,46 @@ current pad equal to C =for apidoc m|void|PAD_RESTORE_LOCAL|PAD *opad Restore the old pad saved into the local variable C by C +=for apidoc Ay||Perl_Symbol_Table +=for apidoc_item Perl_Symbol_Table_Array +=for apidoc_item Perl_Symbol_Table_Code +=for apidoc_item Perl_Symbol_Table_Hash +=for apidoc_item Perl_Symbol_Table_Scalar + +Symbol table identifies how symbol value is represented internally. + +For example, C<'&'> can be: + +=over + +=item Internal identification of symbol + + &foo + +=item External identification of expression + + goto &foo; + +=item Predefined variable name + + $& + +=item Prototype + + sub foo :prototype(&); + +=back + =cut */ +enum Perl_Symbol_Table { + Perl_Symbol_Table_Array = '@', + Perl_Symbol_Table_Code = '&', + Perl_Symbol_Table_Hash = '%', + Perl_Symbol_Table_Scalar = '$', +}; + #define PadlistARRAY(pl) (pl)->xpadl_arr.xpadlarr_alloc #define PadlistMAX(pl) (pl)->xpadl_max #define PadlistNAMES(pl) *((PADNAMELIST **)PadlistARRAY(pl)) From b45a669adadbd9e93acb8c2ae4063a678faf1e78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Wed, 4 Dec 2024 17:38:19 +0100 Subject: [PATCH 03/41] [pad] Perl_Symbol_Table_Scalar - identify usage of '$' as symbol type --- class.c | 8 ++++---- op.c | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/class.c b/class.c index 5d75d85604c3..e4c5d595d2e8 100644 --- a/class.c +++ b/class.c @@ -729,7 +729,7 @@ Perl_class_seal_stash(pTHX_ HV *stash) U8 op_priv = 0; switch(sigil) { - case '$': + case Perl_Symbol_Table_Scalar: if(paramname) { if(!valop) { SV *message = @@ -947,7 +947,7 @@ apply_field_attribute_param(pTHX_ PADNAME *pn, SV *value) /* Default to name minus the sigil */ value = newSVpvn_utf8(PadnamePV(pn) + 1, PadnameLEN(pn) - 1, PadnameUTF8(pn)); - if(PadnamePV(pn)[0] != '$') + if(PadnamePV(pn)[0] != Perl_Symbol_Table_Scalar) croak("Only scalar fields can take a :param attribute"); if(PadnameFIELDINFO(pn)->paramname) @@ -1029,7 +1029,7 @@ apply_field_attribute_reader(pTHX_ PADNAME *pn, SV *value) { OPCODE optype = 0; switch(PadnamePV(pn)[0]) { - case '$': optype = OP_PADSV; break; + case Perl_Symbol_Table_Scalar: optype = OP_PADSV; break; case '@': optype = OP_PADAV; break; case '%': optype = OP_PADHV; break; default: NOT_REACHED; @@ -1240,7 +1240,7 @@ Perl_class_set_field_defop(pTHX_ PADNAME *pn, OPCODE defmode, OP *defop) char sigil = PadnamePV(pn)[0]; switch(sigil) { - case '$': + case Perl_Symbol_Table_Scalar: defop = op_contextualize(defop, G_SCALAR); break; diff --git a/op.c b/op.c index 0b0a2db744db..f4b667d4d735 100644 --- a/op.c +++ b/op.c @@ -9814,7 +9814,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) PADNAME * const pn = PAD_COMPNAME(padoff); const char * const name = PadnamePV(pn); - if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_') + if (PadnameLEN(pn) == 2 && name[0] == Perl_Symbol_Table_Scalar && name[1] == '_') enteriterpflags |= OPpITER_DEF; } } @@ -14068,7 +14068,7 @@ S_simplify_sort(pTHX_ OP *o) do { if (kid->op_type == OP_PADSV) { PADNAME * const name = PAD_COMPNAME(kid->op_targ); - if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$' + if (PadnameLEN(name) == 2 && *PadnamePV(name) == Perl_Symbol_Table_Scalar && ( PadnamePV(name)[1] == 'a' || PadnamePV(name)[1] == 'b' )) /* diag_listed_as: "my %s" used in sort comparison */ From 80a78c207330cd7650c2ae7d57485e4ca8404fb7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Thu, 5 Dec 2024 06:27:14 +0100 Subject: [PATCH 04/41] [pad] Perl_Symbol_Table_Code - identify usage of '&' as symbol table --- pad.c | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/pad.c b/pad.c index adfa64e0613e..7dd0d38cb8e5 100644 --- a/pad.c +++ b/pad.c @@ -391,7 +391,7 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad)) ); - /* detach any '&' anon children in the pad; if afterwards they + /* detach any 'Perl_Symbol_Table_Code' anon children in the pad; if afterwards they * are still live, fix up their CvOUTSIDEs to point to our outside, * bypassing us. */ @@ -404,7 +404,7 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) SV ** const curpad = AvARRAY(comppad); for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) { PADNAME * const name = namepad[ix]; - if (name && PadnamePV(name) && *PadnamePV(name) == '&') { + if (name && PadnamePV(name) && *PadnamePV(name) == Perl_Symbol_Table_Code) { CV * const innercv = MUTABLE_CV(curpad[ix]); if (PadnameIsOUR(name) && CvCLONED(&cvbody)) { assert(!innercv); @@ -659,7 +659,7 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, sv_upgrade(PL_curpad[offset], SVt_PVAV); else if (namelen != 0 && *namepv == '%') sv_upgrade(PL_curpad[offset], SVt_PVHV); - else if (namelen != 0 && *namepv == '&') + else if (namelen != 0 && *namepv == Perl_Symbol_Table_Code) sv_upgrade(PL_curpad[offset], SVt_PVCV); assert(SvPADMY(PL_curpad[offset])); DEBUG_Xv(PerlIO_printf(Perl_debug_log, @@ -907,7 +907,7 @@ S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash) PL_parser->in_my == KEY_sigvar ? "my" : PL_parser->in_my == KEY_field ? "field" : "state" ), - *PadnamePV(pn) == '&' ? "subroutine" : "variable", + *PadnamePV(pn) == Perl_Symbol_Table_Code ? "subroutine" : "variable", PNfARG(pn), (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO ? "scope" : "statement")); @@ -1003,7 +1003,7 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) /* Skip the ‘our’ hack for subroutines, as the warning does not apply. */ - if (*namepv == '&') return NOT_IN_PAD; + if (*namepv == Perl_Symbol_Table_Code) return NOT_IN_PAD; /* look for an our that's being introduced; this allows * our $foo = 0 unless defined $foo; @@ -1094,7 +1094,7 @@ S_unavailable(pTHX_ PADNAME *name) /* diag_listed_as: Variable "%s" is not available */ Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), "%s \"%" PNf "\" is not available", - *PadnamePV(name) == '&' + *PadnamePV(name) == Perl_Symbol_Table_Code ? "Subroutine" : "Variable", PNfARG(name)); @@ -1218,7 +1218,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, shared */ Perl_warner(aTHX_ packWARN(WARN_CLOSURE), "%s \"%" UTF8f "\" will not stay shared", - *namepv == '&' ? "Subroutine" : "Variable", + *namepv == Perl_Symbol_Table_Code ? "Subroutine" : "Variable", UTF8fARG(1, namelen, namepv)); } @@ -1258,7 +1258,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, *out_capture = newSV_type_mortal(SVt_PVAV); else if (namelen != 0 && *namepv == '%') *out_capture = newSV_type_mortal(SVt_PVHV); - else if (namelen != 0 && *namepv == '&') + else if (namelen != 0 && *namepv == Perl_Symbol_Table_Code) *out_capture = newSV_type_mortal(SVt_PVCV); else *out_capture = newSV_type_mortal(SVt_NULL); @@ -1536,7 +1536,7 @@ Perl_pad_leavemy(pTHX) (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv) - && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) { + && *PadnamePV(sv) == Perl_Symbol_Table_Code && PadnameLEN(sv) > 1) { OP *kid = newOP(OP_INTROCV, 0); kid->op_targ = off; o = op_prepend_elem(OP_LINESEQ, kid, o); @@ -1708,7 +1708,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type) continue; namesv = namep[ix]; if (!(PadnamePV(namesv) && - (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&'))) + (!PadnameLEN(namesv) || *PadnamePV(namesv) == Perl_Symbol_Table_Code))) { SvREFCNT_dec(PL_curpad[ix]); PL_curpad[ix] = NULL; @@ -2013,7 +2013,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, } if (!sv) { const char sigil = PadnamePV(namesv)[0]; - if (sigil == '&') + if (sigil == Perl_Symbol_Table_Code) /* If there are state subs, we need to clone them, too. But they may need to close over variables we have not cloned yet. So we will have to do a second @@ -2054,7 +2054,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, else sv = newSV_type(SVt_NULL); /* reset the 'assign only once' flag on each state var */ - if (sigil != '&' && PadnameIsSTATE(namesv)) + if (sigil != Perl_Symbol_Table_Code && PadnameIsSTATE(namesv)) SvPADSTALE_on(sv); } } @@ -2092,7 +2092,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, PADNAME * const name = (ix <= fname) ? pname[ix] : NULL; if (name && name != &PL_padname_undef - && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' + && !PadnameOUTER(name) && PadnamePV(name)[0] == Perl_Symbol_Table_Code && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) { CV * const protokey = CvOUTSIDE(ppad[ix]); @@ -2119,7 +2119,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, PADNAME * const name = (ix <= fname) ? pname[ix] : NULL; if (name && name != &PL_padname_undef - && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' + && !PadnameOUTER(name) && PadnamePV(name)[0] == Perl_Symbol_Table_Code && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], @@ -2129,7 +2129,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, else for (ix = fpad; ix > 0; ix--) { PADNAME * const name = (ix <= fname) ? pname[ix] : NULL; if (name && name != &PL_padname_undef && !PadnameOUTER(name) - && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name)) + && PadnamePV(name)[0] == Perl_Symbol_Table_Code && PadnameIsSTATE(name)) S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv, NULL); } @@ -2367,7 +2367,7 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) { const PADNAME *name = namepad[ix]; if (name && name != &PL_padname_undef && !PadnameIsOUR(name) - && *PadnamePV(name) == '&') + && *PadnamePV(name) == Perl_Symbol_Table_Code) { CV *innercv = MUTABLE_CV(curpad[ix]); if (UNLIKELY(PadnameOUTER(name))) { @@ -2448,10 +2448,10 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) const char sigil = PadnamePV(names[ix])[0]; if (PadnameOUTER(names[ix]) || PadnameIsSTATE(names[ix]) - || sigil == '&') + || sigil == Perl_Symbol_Table_Code) { SV *tmp = oldpad[ix]; - if (sigil == '&' && SvTYPE(tmp) == SVt_PVCV + if (sigil == Perl_Symbol_Table_Code && SvTYPE(tmp) == SVt_PVCV && !PadnameOUTER(names[ix]) && CvLEXICAL(tmp) && CvCLONED(tmp) && !PadnameIsOUR(names[ix]) @@ -2557,7 +2557,7 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) const char sigil = PadnamePV(names[ix])[0]; if (PadnameOUTER(names[ix]) || PadnameIsSTATE(names[ix]) - || sigil == '&') + || sigil == Perl_Symbol_Table_Code) { /* outer lexical or anon code */ pad1a[ix] = sv_dup_inc(oldpad[ix], param); From f26f41dddfc41db3b14a592d8178d73157d571ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Thu, 5 Dec 2024 06:42:51 +0100 Subject: [PATCH 05/41] [pad] Perl_Symbol_Table_Array - identify usage of '@' as symbol type --- class.c | 6 +++--- pad.c | 10 +++++----- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/class.c b/class.c index e4c5d595d2e8..49015b02dce9 100644 --- a/class.c +++ b/class.c @@ -766,7 +766,7 @@ Perl_class_seal_stash(pTHX_ HV *stash) } break; - case '@': + case Perl_Symbol_Table_Array: op_priv = OPpINITFIELD_AV; break; @@ -1030,7 +1030,7 @@ apply_field_attribute_reader(pTHX_ PADNAME *pn, SV *value) OPCODE optype = 0; switch(PadnamePV(pn)[0]) { case Perl_Symbol_Table_Scalar: optype = OP_PADSV; break; - case '@': optype = OP_PADAV; break; + case Perl_Symbol_Table_Array: optype = OP_PADAV; break; case '%': optype = OP_PADHV; break; default: NOT_REACHED; } @@ -1244,7 +1244,7 @@ Perl_class_set_field_defop(pTHX_ PADNAME *pn, OPCODE defmode, OP *defop) defop = op_contextualize(defop, G_SCALAR); break; - case '@': + case Perl_Symbol_Table_Array: case '%': defop = op_contextualize(op_force_list(defop), G_LIST); break; diff --git a/pad.c b/pad.c index 7dd0d38cb8e5..e68e53643c78 100644 --- a/pad.c +++ b/pad.c @@ -655,7 +655,7 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, /* if it's not a simple scalar, replace with an AV or HV */ assert(SvTYPE(PL_curpad[offset]) == SVt_NULL); assert(SvREFCNT(PL_curpad[offset]) == 1); - if (namelen != 0 && *namepv == '@') + if (namelen != 0 && *namepv == Perl_Symbol_Table_Array) sv_upgrade(PL_curpad[offset], SVt_PVAV); else if (namelen != 0 && *namepv == '%') sv_upgrade(PL_curpad[offset], SVt_PVHV); @@ -1254,7 +1254,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, } } if (!*out_capture) { - if (namelen != 0 && *namepv == '@') + if (namelen != 0 && *namepv == Perl_Symbol_Table_Array) *out_capture = newSV_type_mortal(SVt_PVAV); else if (namelen != 0 && *namepv == '%') *out_capture = newSV_type_mortal(SVt_PVHV); @@ -2047,7 +2047,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, CvLEXICAL_on(sv); } else sv = SvREFCNT_inc(ppad[ix]); - else if (sigil == '@') + else if (sigil == Perl_Symbol_Table_Array) sv = MUTABLE_SV(newAV()); else if (sigil == '%') sv = MUTABLE_SV(newHV()); @@ -2465,7 +2465,7 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) } } else { /* our own lexical */ - if (sigil == '@') + if (sigil == Perl_Symbol_Table_Array) sv = MUTABLE_SV(newAV()); else if (sigil == '%') sv = MUTABLE_SV(newHV()); @@ -2571,7 +2571,7 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) } else { SV *sv; - if (sigil == '@') + if (sigil == Perl_Symbol_Table_Array) sv = MUTABLE_SV(newAV()); else if (sigil == '%') sv = MUTABLE_SV(newHV()); From 2ae5f3aa601ff269a544966f7b47d18e71d7e1a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Thu, 5 Dec 2024 06:44:14 +0100 Subject: [PATCH 06/41] [pad] Perl_Symbol_Table_Hash - identify usage of '%' as symbol type --- class.c | 6 +++--- pad.c | 10 +++++----- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/class.c b/class.c index 49015b02dce9..a440fd796e9a 100644 --- a/class.c +++ b/class.c @@ -770,7 +770,7 @@ Perl_class_seal_stash(pTHX_ HV *stash) op_priv = OPpINITFIELD_AV; break; - case '%': + case Perl_Symbol_Table_Hash: op_priv = OPpINITFIELD_HV; break; @@ -1031,7 +1031,7 @@ apply_field_attribute_reader(pTHX_ PADNAME *pn, SV *value) switch(PadnamePV(pn)[0]) { case Perl_Symbol_Table_Scalar: optype = OP_PADSV; break; case Perl_Symbol_Table_Array: optype = OP_PADAV; break; - case '%': optype = OP_PADHV; break; + case Perl_Symbol_Table_Hash: optype = OP_PADHV; break; default: NOT_REACHED; } @@ -1245,7 +1245,7 @@ Perl_class_set_field_defop(pTHX_ PADNAME *pn, OPCODE defmode, OP *defop) break; case Perl_Symbol_Table_Array: - case '%': + case Perl_Symbol_Table_Hash: defop = op_contextualize(op_force_list(defop), G_LIST); break; } diff --git a/pad.c b/pad.c index e68e53643c78..a4bf6b8611d8 100644 --- a/pad.c +++ b/pad.c @@ -657,7 +657,7 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, assert(SvREFCNT(PL_curpad[offset]) == 1); if (namelen != 0 && *namepv == Perl_Symbol_Table_Array) sv_upgrade(PL_curpad[offset], SVt_PVAV); - else if (namelen != 0 && *namepv == '%') + else if (namelen != 0 && *namepv == Perl_Symbol_Table_Hash) sv_upgrade(PL_curpad[offset], SVt_PVHV); else if (namelen != 0 && *namepv == Perl_Symbol_Table_Code) sv_upgrade(PL_curpad[offset], SVt_PVCV); @@ -1256,7 +1256,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, if (!*out_capture) { if (namelen != 0 && *namepv == Perl_Symbol_Table_Array) *out_capture = newSV_type_mortal(SVt_PVAV); - else if (namelen != 0 && *namepv == '%') + else if (namelen != 0 && *namepv == Perl_Symbol_Table_Hash) *out_capture = newSV_type_mortal(SVt_PVHV); else if (namelen != 0 && *namepv == Perl_Symbol_Table_Code) *out_capture = newSV_type_mortal(SVt_PVCV); @@ -2049,7 +2049,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, else sv = SvREFCNT_inc(ppad[ix]); else if (sigil == Perl_Symbol_Table_Array) sv = MUTABLE_SV(newAV()); - else if (sigil == '%') + else if (sigil == Perl_Symbol_Table_Hash) sv = MUTABLE_SV(newHV()); else sv = newSV_type(SVt_NULL); @@ -2467,7 +2467,7 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) else { /* our own lexical */ if (sigil == Perl_Symbol_Table_Array) sv = MUTABLE_SV(newAV()); - else if (sigil == '%') + else if (sigil == Perl_Symbol_Table_Hash) sv = MUTABLE_SV(newHV()); else sv = newSV_type(SVt_NULL); @@ -2573,7 +2573,7 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) if (sigil == Perl_Symbol_Table_Array) sv = MUTABLE_SV(newAV()); - else if (sigil == '%') + else if (sigil == Perl_Symbol_Table_Hash) sv = MUTABLE_SV(newHV()); else sv = newSV_type(SVt_NULL); From ef9707b27af11b683c8bddb58a1fe0a676933eab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Thu, 5 Dec 2024 06:53:49 +0100 Subject: [PATCH 07/41] [pad] Padname_Is_Symbol_Table - whether PADNAME represents symbol from symbol table Returns true value when provided `PADNAME *` represents symbol belonging to provided symbol table. --- pad.h | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/pad.h b/pad.h index 9ee41ab7b82e..d94e001756d1 100644 --- a/pad.h +++ b/pad.h @@ -313,6 +313,20 @@ current pad equal to C =for apidoc m|void|PAD_RESTORE_LOCAL|PAD *opad Restore the old pad saved into the local variable C by C + +=for apidoc Am|bool|Padname_Is_Symbol_Table|PADNAME * pn|Perl_Symbol_Table symbol_table +=for apidoc_item m|bool|Padname_Is_Symbol_Table_Array|PADNAME * pn +=for apidoc_item m|bool|Padname_Is_Symbol_Table_Code|PADNAME * pn +=for apidoc_item m|bool|Padname_Is_Symbol_Table_Hash|PADNAME * pn +=for apidoc_item m|bool|Padname_Is_Symbol_Table_Scalar|PADNAME * pn + +Whether PADNAME represents symbol for given symbol table. + + if (! Padname_Is_Symbol_Table_Code (pn)) { + ... + } + + =for apidoc Ay||Perl_Symbol_Table =for apidoc_item Perl_Symbol_Table_Array =for apidoc_item Perl_Symbol_Table_Code @@ -353,6 +367,21 @@ enum Perl_Symbol_Table { Perl_Symbol_Table_Scalar = '$', }; +#define Padname_Is_Symbol_Table(Pn, Table) \ + (PadnamePV (Pn)[0] == (Table)) + +#define Padname_Is_Symbol_Table_Array(Pn) \ + Padname_Is_Symbol_Table (Pn, Perl_Symbol_Table_Array) + +#define Padname_Is_Symbol_Table_Code(Pn) \ + Padname_Is_Symbol_Table (Pn, Perl_Symbol_Table_Code) + +#define Padname_Is_Symbol_Table_Hash(Pn) \ + Padname_Is_Symbol_Table (Pn, Perl_Symbol_Table_Hash) + +#define Padname_Is_Symbol_Table_Scalar(Pn) \ + Padname_Is_Symbol_Table (Pn, Perl_Symbol_Table_Scalar) + #define PadlistARRAY(pl) (pl)->xpadl_arr.xpadlarr_alloc #define PadlistMAX(pl) (pl)->xpadl_max #define PadlistNAMES(pl) *((PADNAMELIST **)PadlistARRAY(pl)) From cabc797f78af47a7a7dbcf68d83dae07583a5175 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Thu, 5 Dec 2024 10:48:13 +0100 Subject: [PATCH 08/41] [pad] Padname_Is_Symbol_Table_Scalar - use macro By wrapping implementation into single intent expressing token it can evolve without affecting its usage. --- class.c | 2 +- op.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/class.c b/class.c index a440fd796e9a..c17fd1b6c33e 100644 --- a/class.c +++ b/class.c @@ -947,7 +947,7 @@ apply_field_attribute_param(pTHX_ PADNAME *pn, SV *value) /* Default to name minus the sigil */ value = newSVpvn_utf8(PadnamePV(pn) + 1, PadnameLEN(pn) - 1, PadnameUTF8(pn)); - if(PadnamePV(pn)[0] != Perl_Symbol_Table_Scalar) + if(! Padname_Is_Symbol_Table_Scalar (pn)) croak("Only scalar fields can take a :param attribute"); if(PadnameFIELDINFO(pn)->paramname) diff --git a/op.c b/op.c index f4b667d4d735..a39b0f4751d7 100644 --- a/op.c +++ b/op.c @@ -9814,7 +9814,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) PADNAME * const pn = PAD_COMPNAME(padoff); const char * const name = PadnamePV(pn); - if (PadnameLEN(pn) == 2 && name[0] == Perl_Symbol_Table_Scalar && name[1] == '_') + if (PadnameLEN(pn) == 2 && Padname_Is_Symbol_Table_Scalar (pn) && name[1] == '_') enteriterpflags |= OPpITER_DEF; } } @@ -14068,7 +14068,7 @@ S_simplify_sort(pTHX_ OP *o) do { if (kid->op_type == OP_PADSV) { PADNAME * const name = PAD_COMPNAME(kid->op_targ); - if (PadnameLEN(name) == 2 && *PadnamePV(name) == Perl_Symbol_Table_Scalar + if (PadnameLEN(name) == 2 && Padname_Is_Symbol_Table_Scalar (name) && ( PadnamePV(name)[1] == 'a' || PadnamePV(name)[1] == 'b' )) /* diag_listed_as: "my %s" used in sort comparison */ From 784b6543cbc3da772b2f99d614fe88d60bd6be01 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Thu, 5 Dec 2024 11:25:26 +0100 Subject: [PATCH 09/41] [pad] Padname_Is_Symbol_Table_Code - use macro --- pad.c | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/pad.c b/pad.c index a4bf6b8611d8..2d31ed9cf010 100644 --- a/pad.c +++ b/pad.c @@ -404,7 +404,7 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) SV ** const curpad = AvARRAY(comppad); for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) { PADNAME * const name = namepad[ix]; - if (name && PadnamePV(name) && *PadnamePV(name) == Perl_Symbol_Table_Code) { + if (name && PadnamePV(name) && Padname_Is_Symbol_Table_Code (name)) { CV * const innercv = MUTABLE_CV(curpad[ix]); if (PadnameIsOUR(name) && CvCLONED(&cvbody)) { assert(!innercv); @@ -907,7 +907,7 @@ S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash) PL_parser->in_my == KEY_sigvar ? "my" : PL_parser->in_my == KEY_field ? "field" : "state" ), - *PadnamePV(pn) == Perl_Symbol_Table_Code ? "subroutine" : "variable", + Padname_Is_Symbol_Table_Code (pn) ? "subroutine" : "variable", PNfARG(pn), (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO ? "scope" : "statement")); @@ -1094,7 +1094,7 @@ S_unavailable(pTHX_ PADNAME *name) /* diag_listed_as: Variable "%s" is not available */ Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), "%s \"%" PNf "\" is not available", - *PadnamePV(name) == Perl_Symbol_Table_Code + Padname_Is_Symbol_Table_Code (name) ? "Subroutine" : "Variable", PNfARG(name)); @@ -1536,7 +1536,7 @@ Perl_pad_leavemy(pTHX) (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv) - && *PadnamePV(sv) == Perl_Symbol_Table_Code && PadnameLEN(sv) > 1) { + && Padname_Is_Symbol_Table_Code (sv) && PadnameLEN(sv) > 1) { OP *kid = newOP(OP_INTROCV, 0); kid->op_targ = off; o = op_prepend_elem(OP_LINESEQ, kid, o); @@ -1708,7 +1708,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type) continue; namesv = namep[ix]; if (!(PadnamePV(namesv) && - (!PadnameLEN(namesv) || *PadnamePV(namesv) == Perl_Symbol_Table_Code))) + (!PadnameLEN(namesv) || Padname_Is_Symbol_Table_Code (namesv)))) { SvREFCNT_dec(PL_curpad[ix]); PL_curpad[ix] = NULL; @@ -2092,7 +2092,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, PADNAME * const name = (ix <= fname) ? pname[ix] : NULL; if (name && name != &PL_padname_undef - && !PadnameOUTER(name) && PadnamePV(name)[0] == Perl_Symbol_Table_Code + && !PadnameOUTER(name) && Padname_Is_Symbol_Table_Code (name) && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) { CV * const protokey = CvOUTSIDE(ppad[ix]); @@ -2119,7 +2119,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, PADNAME * const name = (ix <= fname) ? pname[ix] : NULL; if (name && name != &PL_padname_undef - && !PadnameOUTER(name) && PadnamePV(name)[0] == Perl_Symbol_Table_Code + && !PadnameOUTER(name) && Padname_Is_Symbol_Table_Code (name) && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], @@ -2129,7 +2129,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, else for (ix = fpad; ix > 0; ix--) { PADNAME * const name = (ix <= fname) ? pname[ix] : NULL; if (name && name != &PL_padname_undef && !PadnameOUTER(name) - && PadnamePV(name)[0] == Perl_Symbol_Table_Code && PadnameIsSTATE(name)) + && Padname_Is_Symbol_Table_Code (name) && PadnameIsSTATE(name)) S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv, NULL); } @@ -2367,7 +2367,7 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) { const PADNAME *name = namepad[ix]; if (name && name != &PL_padname_undef && !PadnameIsOUR(name) - && *PadnamePV(name) == Perl_Symbol_Table_Code) + && Padname_Is_Symbol_Table_Code (name)) { CV *innercv = MUTABLE_CV(curpad[ix]); if (UNLIKELY(PadnameOUTER(name))) { From 581c4fa206a4c3f69d031bdd9fe483f1576bd261 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Fri, 6 Dec 2024 06:36:24 +0100 Subject: [PATCH 10/41] [pad] Padname_Is_Symbol - factor out duplicated predicate --- pad.c | 14 ++++++++------ pad.h | 8 ++++++++ 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/pad.c b/pad.c index 2d31ed9cf010..0f3106a55ebe 100644 --- a/pad.c +++ b/pad.c @@ -754,9 +754,11 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) * can be reused; not so for constants. */ PADNAME *pn; - if (++retval <= names_fill && - (pn = names[retval]) && PadnamePV(pn)) - continue; + if (++retval <= names_fill) { + pn = names[retval]; + if (Padname_Is_Symbol (pn)) + continue; + } sv = *av_fetch_simple(PL_comppad, retval, TRUE); if (!(SvFLAGS(sv) & #ifdef USE_PAD_RESET @@ -2059,7 +2061,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, } } } - else if (namesv && PadnamePV(namesv)) { + else if (Padname_Is_Symbol (namesv)) { sv = SvREFCNT_inc_NN(ppad[ix]); } else { @@ -2581,8 +2583,8 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) } } } - else if (( names_fill >= ix && names[ix] - && PadnamePV(names[ix]) )) { + else if (( names_fill >= ix + && Padname_Is_Symbol (names[ix]) )) { pad1a[ix] = sv_dup_inc(oldpad[ix], param); } else { diff --git a/pad.h b/pad.h index d94e001756d1..cb16a2ba3933 100644 --- a/pad.h +++ b/pad.h @@ -314,6 +314,11 @@ current pad equal to C Restore the old pad saved into the local variable C by C +=for apidoc Am|bool|Padname_Is_Symbol|PADNAME * pn +Checks whether C represents valid symbol (aka: has name, empty string ok) +Every other C or C macro expects valid symbol. + + =for apidoc Am|bool|Padname_Is_Symbol_Table|PADNAME * pn|Perl_Symbol_Table symbol_table =for apidoc_item m|bool|Padname_Is_Symbol_Table_Array|PADNAME * pn =for apidoc_item m|bool|Padname_Is_Symbol_Table_Code|PADNAME * pn @@ -367,6 +372,9 @@ enum Perl_Symbol_Table { Perl_Symbol_Table_Scalar = '$', }; +#define Padname_Is_Symbol(Pn) \ + ((Pn) && PadnamePV (Pn)) + #define Padname_Is_Symbol_Table(Pn, Table) \ (PadnamePV (Pn)[0] == (Table)) From 675f75f53d0bb2af1733ef1b87381fa4ac7b7f43 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Fri, 6 Dec 2024 06:37:53 +0100 Subject: [PATCH 11/41] [pad] Padname_Symbol_Table - extract symbol table id Using macro instead of direct access: - identifies code where such value is used / required - hides any future changes from code which uses it, eg - type change from 'char' to 'U32' --- class.c | 6 +++--- pad.c | 6 +++--- pad.h | 10 ++++++++++ 3 files changed, 16 insertions(+), 6 deletions(-) diff --git a/class.c b/class.c index c17fd1b6c33e..0a4d0bd3e1ee 100644 --- a/class.c +++ b/class.c @@ -699,7 +699,7 @@ Perl_class_seal_stash(pTHX_ HV *stash) for(SSize_t i = 0; fieldnames && i <= PadnamelistMAX(fieldnames); i++) { PADNAME *pn = PadnamelistARRAY(fieldnames)[i]; - char sigil = PadnamePV(pn)[0]; + char sigil = Padname_Symbol_Table (pn); PADOFFSET fieldix = PadnameFIELDINFO(pn)->fieldix; /* Extract the OP_{NEXT,DB}STATE op from the defop so we can @@ -1028,7 +1028,7 @@ apply_field_attribute_reader(pTHX_ PADNAME *pn, SV *value) OP *retop; { OPCODE optype = 0; - switch(PadnamePV(pn)[0]) { + switch(Padname_Symbol_Table (pn)) { case Perl_Symbol_Table_Scalar: optype = OP_PADSV; break; case Perl_Symbol_Table_Array: optype = OP_PADAV; break; case Perl_Symbol_Table_Hash: optype = OP_PADHV; break; @@ -1238,7 +1238,7 @@ Perl_class_set_field_defop(pTHX_ PADNAME *pn, OPCODE defmode, OP *defop) forbid_outofblock_ops(defop, "field initialiser expression"); - char sigil = PadnamePV(pn)[0]; + char sigil = Padname_Symbol_Table (pn); switch(sigil) { case Perl_Symbol_Table_Scalar: defop = op_contextualize(defop, G_SCALAR); diff --git a/pad.c b/pad.c index 0f3106a55ebe..f0d6fb63d917 100644 --- a/pad.c +++ b/pad.c @@ -2014,7 +2014,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, SvREFCNT_inc_simple_void_NN(sv); } if (!sv) { - const char sigil = PadnamePV(namesv)[0]; + const char sigil = Padname_Symbol_Table (namesv); if (sigil == Perl_Symbol_Table_Code) /* If there are state subs, we need to clone them, too. But they may need to close over variables we have @@ -2447,7 +2447,7 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) for ( ;ix > 0; ix--) { SV *sv; if (names_fill >= ix && PadnameLEN(names[ix])) { - const char sigil = PadnamePV(names[ix])[0]; + const char sigil = Padname_Symbol_Table (names[ix]); if (PadnameOUTER(names[ix]) || PadnameIsSTATE(names[ix]) || sigil == Perl_Symbol_Table_Code) @@ -2556,7 +2556,7 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) pad1a[ix] = NULL; } else if (names_fill >= ix && names[ix] && PadnameLEN(names[ix])) { - const char sigil = PadnamePV(names[ix])[0]; + const char sigil = Padname_Symbol_Table (names[ix]); if (PadnameOUTER(names[ix]) || PadnameIsSTATE(names[ix]) || sigil == Perl_Symbol_Table_Code) diff --git a/pad.h b/pad.h index cb16a2ba3933..01638af360a7 100644 --- a/pad.h +++ b/pad.h @@ -332,6 +332,13 @@ Whether PADNAME represents symbol for given symbol table. } +=for apidoc Am|char|Padname_Symbol_Table|PADNAME * pn +Extract symbol table identifier from valid symbol (see L). + + # pseudocode + Padname_Symbol_Table ("$self") == Perl_Symbol_Table_Scalar + + =for apidoc Ay||Perl_Symbol_Table =for apidoc_item Perl_Symbol_Table_Array =for apidoc_item Perl_Symbol_Table_Code @@ -390,6 +397,9 @@ enum Perl_Symbol_Table { #define Padname_Is_Symbol_Table_Scalar(Pn) \ Padname_Is_Symbol_Table (Pn, Perl_Symbol_Table_Scalar) +#define Padname_Symbol_Table(Pn) \ + (PadnamePV (Pn)[0]) + #define PadlistARRAY(pl) (pl)->xpadl_arr.xpadlarr_alloc #define PadlistMAX(pl) (pl)->xpadl_max #define PadlistNAMES(pl) *((PADNAMELIST **)PadlistARRAY(pl)) From cda643a223c7b1f09f85281e16355834fd8210a3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Fri, 6 Dec 2024 06:54:37 +0100 Subject: [PATCH 12/41] [pad] Padname_Symbol_Name - extract symbol name Returns name without symbol type so it will properly work when we will change symbol table id type or when we will add new symbol types. For backward compatibility user of this macro can rely on -1 being valid index. --- class.c | 4 ++-- dump.c | 2 +- op.c | 24 ++++++++++++------------ pad.c | 4 ++-- pad.h | 11 +++++++++++ 5 files changed, 28 insertions(+), 17 deletions(-) diff --git a/class.c b/class.c index 0a4d0bd3e1ee..8afbb132e8f1 100644 --- a/class.c +++ b/class.c @@ -945,7 +945,7 @@ apply_field_attribute_param(pTHX_ PADNAME *pn, SV *value) { if(!value) /* Default to name minus the sigil */ - value = newSVpvn_utf8(PadnamePV(pn) + 1, PadnameLEN(pn) - 1, PadnameUTF8(pn)); + value = newSVpvn_utf8(Padname_Symbol_Name (pn), PadnameLEN(pn) - 1, PadnameUTF8(pn)); if(! Padname_Is_Symbol_Table_Scalar (pn)) croak("Only scalar fields can take a :param attribute"); @@ -977,7 +977,7 @@ apply_field_attribute_reader(pTHX_ PADNAME *pn, SV *value) SvREFCNT_inc(value); else /* Default to name minus the sigil */ - value = newSVpvn_utf8(PadnamePV(pn) + 1, PadnameLEN(pn) - 1, PadnameUTF8(pn)); + value = newSVpvn_utf8(Padname_Symbol_Name (pn), PadnameLEN(pn) - 1, PadnameUTF8(pn)); if(!valid_identifier_sv(value)) croak("%" SVf_QUOTEDPREFIX " is not a valid name for a generated method", value); diff --git a/dump.c b/dump.c index f03ac0f51de3..e6ccb9a7fd8c 100644 --- a/dump.c +++ b/dump.c @@ -3057,7 +3057,7 @@ S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n, STRLEN cur = SvCUR(out); Perl_sv_catpvf(aTHX_ out, "[%" UTF8f, UTF8fARG(1, PadnameLEN(sv) - 1, - PadnamePV(sv) + 1)); + Padname_Symbol_Name (sv))); if (is_scalar) SvPVX(out)[cur] = '$'; } diff --git a/op.c b/op.c index a39b0f4751d7..f911b7afd4e1 100644 --- a/op.c +++ b/op.c @@ -9812,9 +9812,9 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); if (padoff) { PADNAME * const pn = PAD_COMPNAME(padoff); - const char * const name = PadnamePV(pn); + const char * const name = Padname_Symbol_Name (pn); - if (PadnameLEN(pn) == 2 && Padname_Is_Symbol_Table_Scalar (pn) && name[1] == '_') + if (PadnameLEN(pn) == 2 && Padname_Is_Symbol_Table_Scalar (pn) && name[0] == '_') enteriterpflags |= OPpITER_DEF; } } @@ -10289,7 +10289,7 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, const line_t oldline = CopLINE(PL_curcop); SV *namesv = o ? cSVOPo->op_sv - : newSVpvn_flags( PadnamePV(name)+1,PadnameLEN(name)-1, + : newSVpvn_flags( Padname_Symbol_Name (name), PadnameLEN(name)-1, (PadnameUTF8(name)) ? SVf_UTF8|SVs_TEMP : SVs_TEMP ); if (PL_parser && PL_parser->copline != NOLINE) @@ -10400,10 +10400,10 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) hek = CvNAME_HEK(*spot); else { U32 hash; - PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); + PERL_HASH(hash, Padname_Symbol_Name (name), PadnameLEN(name)-1); CvNAME_HEK_set(*spot, hek = share_hek( - PadnamePV(name)+1, + Padname_Symbol_Name (name), (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), hash ) @@ -10559,8 +10559,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (hek) (void)share_hek_hek(hek); else { U32 hash; - PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); - hek = share_hek(PadnamePV(name)+1, + PERL_HASH(hash, Padname_Symbol_Name (name), PadnameLEN(name)-1); + hek = share_hek(Padname_Symbol_Name (name), (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), hash); } @@ -10622,7 +10622,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else sv_setpvs(tmpstr, "__ANON__::"); - sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1, + sv_catpvn_flags(tmpstr, Padname_Symbol_Name (name), PadnameLEN(name)-1, PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES); (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0); hv = GvHVn(db_postponed); @@ -13068,8 +13068,8 @@ Perl_ck_fun(pTHX_ OP *o) if (kid->op_type == OP_PADSV) { PADNAME * const pn = PAD_COMPNAME_SV(kid->op_targ); - name = PadnamePV (pn); - len = PadnameLEN(pn); + name = Padname_Symbol_Name (pn); + len = PadnameLEN(pn) - 1; name_utf8 = PadnameUTF8(pn); } else if (kid->op_type == OP_RV2SV @@ -14069,8 +14069,8 @@ S_simplify_sort(pTHX_ OP *o) if (kid->op_type == OP_PADSV) { PADNAME * const name = PAD_COMPNAME(kid->op_targ); if (PadnameLEN(name) == 2 && Padname_Is_Symbol_Table_Scalar (name) - && ( PadnamePV(name)[1] == 'a' - || PadnamePV(name)[1] == 'b' )) + && ( Padname_Symbol_Name (name)[0] == 'a' + || Padname_Symbol_Name (name)[0] == 'b' )) /* diag_listed_as: "my %s" used in sort comparison */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\"%s %s\" used in sort comparison", diff --git a/pad.c b/pad.c index f0d6fb63d917..58afb5d14542 100644 --- a/pad.c +++ b/pad.c @@ -2037,12 +2037,12 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, /* Just provide a stub, but name it. It will be upgraded to the real thing on scope entry. */ U32 hash; - PERL_HASH(hash, PadnamePV(namesv)+1, + PERL_HASH(hash, Padname_Symbol_Name (namesv), PadnameLEN(namesv) - 1); sv = newSV_type(SVt_PVCV); CvNAME_HEK_set( sv, - share_hek(PadnamePV(namesv)+1, + share_hek(Padname_Symbol_Name (namesv), 1 - PadnameLEN(namesv), hash) ); diff --git a/pad.h b/pad.h index 01638af360a7..88d935ae03b2 100644 --- a/pad.h +++ b/pad.h @@ -332,6 +332,14 @@ Whether PADNAME represents symbol for given symbol table. } +=for apidoc Am|char *|Padname_Symbol_Name|PADNAME * pn +Extract symbol name from valid symbol (see L). +For backward compatibility its index C<-1> is valid index for read. + + # pseudocode + Padname_Symbol_Name ("$self") == "self" + + =for apidoc Am|char|Padname_Symbol_Table|PADNAME * pn Extract symbol table identifier from valid symbol (see L). @@ -397,6 +405,9 @@ enum Perl_Symbol_Table { #define Padname_Is_Symbol_Table_Scalar(Pn) \ Padname_Is_Symbol_Table (Pn, Perl_Symbol_Table_Scalar) +#define Padname_Symbol_Name(Pn) \ + (PadnamePV (Pn) + 1) + #define Padname_Symbol_Table(Pn) \ (PadnamePV (Pn)[0]) From 113c640f4f2ff16e8f8c34a001a3e776bee63aa4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Fri, 6 Dec 2024 07:00:39 +0100 Subject: [PATCH 13/41] [pad] Padname_Symbol_Name_Length - length of symbol name stored in pad, excluding symbol table id (sigil) eg: - `$` => 0 - `$_` => 1 - `$self` => 4 --- class.c | 4 ++-- dump.c | 2 +- op.c | 18 +++++++++--------- pad.c | 10 +++++----- pad.h | 10 ++++++++++ 5 files changed, 27 insertions(+), 17 deletions(-) diff --git a/class.c b/class.c index 8afbb132e8f1..a3d631620b38 100644 --- a/class.c +++ b/class.c @@ -945,7 +945,7 @@ apply_field_attribute_param(pTHX_ PADNAME *pn, SV *value) { if(!value) /* Default to name minus the sigil */ - value = newSVpvn_utf8(Padname_Symbol_Name (pn), PadnameLEN(pn) - 1, PadnameUTF8(pn)); + value = newSVpvn_utf8(Padname_Symbol_Name (pn), Padname_Symbol_Name_Length (pn), PadnameUTF8(pn)); if(! Padname_Is_Symbol_Table_Scalar (pn)) croak("Only scalar fields can take a :param attribute"); @@ -977,7 +977,7 @@ apply_field_attribute_reader(pTHX_ PADNAME *pn, SV *value) SvREFCNT_inc(value); else /* Default to name minus the sigil */ - value = newSVpvn_utf8(Padname_Symbol_Name (pn), PadnameLEN(pn) - 1, PadnameUTF8(pn)); + value = newSVpvn_utf8(Padname_Symbol_Name (pn), Padname_Symbol_Name_Length (pn), PadnameUTF8(pn)); if(!valid_identifier_sv(value)) croak("%" SVf_QUOTEDPREFIX " is not a valid name for a generated method", value); diff --git a/dump.c b/dump.c index e6ccb9a7fd8c..7bdba179cf8c 100644 --- a/dump.c +++ b/dump.c @@ -3056,7 +3056,7 @@ S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n, { STRLEN cur = SvCUR(out); Perl_sv_catpvf(aTHX_ out, "[%" UTF8f, - UTF8fARG(1, PadnameLEN(sv) - 1, + UTF8fARG(1, Padname_Symbol_Name_Length (sv), Padname_Symbol_Name (sv))); if (is_scalar) SvPVX(out)[cur] = '$'; diff --git a/op.c b/op.c index f911b7afd4e1..7884b6418c89 100644 --- a/op.c +++ b/op.c @@ -9814,7 +9814,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) PADNAME * const pn = PAD_COMPNAME(padoff); const char * const name = Padname_Symbol_Name (pn); - if (PadnameLEN(pn) == 2 && Padname_Is_Symbol_Table_Scalar (pn) && name[0] == '_') + if (Padname_Symbol_Name_Length (pn) == 1 && Padname_Is_Symbol_Table_Scalar (pn) && name[0] == '_') enteriterpflags |= OPpITER_DEF; } } @@ -10289,7 +10289,7 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, const line_t oldline = CopLINE(PL_curcop); SV *namesv = o ? cSVOPo->op_sv - : newSVpvn_flags( Padname_Symbol_Name (name), PadnameLEN(name)-1, + : newSVpvn_flags( Padname_Symbol_Name (name), Padname_Symbol_Name_Length (name), (PadnameUTF8(name)) ? SVf_UTF8|SVs_TEMP : SVs_TEMP ); if (PL_parser && PL_parser->copline != NOLINE) @@ -10400,11 +10400,11 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) hek = CvNAME_HEK(*spot); else { U32 hash; - PERL_HASH(hash, Padname_Symbol_Name (name), PadnameLEN(name)-1); + PERL_HASH(hash, Padname_Symbol_Name (name), Padname_Symbol_Name_Length (name)); CvNAME_HEK_set(*spot, hek = share_hek( Padname_Symbol_Name (name), - (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), + (Padname_Symbol_Name_Length (name)) * (PadnameUTF8(name) ? -1 : 1), hash ) ); @@ -10559,9 +10559,9 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (hek) (void)share_hek_hek(hek); else { U32 hash; - PERL_HASH(hash, Padname_Symbol_Name (name), PadnameLEN(name)-1); + PERL_HASH(hash, Padname_Symbol_Name (name), Padname_Symbol_Name_Length (name)); hek = share_hek(Padname_Symbol_Name (name), - (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), + (Padname_Symbol_Name_Length (name)) * (PadnameUTF8(name) ? -1 : 1), hash); } CvNAME_HEK_set(cv, hek); @@ -10622,7 +10622,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else sv_setpvs(tmpstr, "__ANON__::"); - sv_catpvn_flags(tmpstr, Padname_Symbol_Name (name), PadnameLEN(name)-1, + sv_catpvn_flags(tmpstr, Padname_Symbol_Name (name), Padname_Symbol_Name_Length (name), PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES); (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0); hv = GvHVn(db_postponed); @@ -13069,7 +13069,7 @@ Perl_ck_fun(pTHX_ OP *o) PADNAME * const pn = PAD_COMPNAME_SV(kid->op_targ); name = Padname_Symbol_Name (pn); - len = PadnameLEN(pn) - 1; + len = Padname_Symbol_Name_Length (pn); name_utf8 = PadnameUTF8(pn); } else if (kid->op_type == OP_RV2SV @@ -14068,7 +14068,7 @@ S_simplify_sort(pTHX_ OP *o) do { if (kid->op_type == OP_PADSV) { PADNAME * const name = PAD_COMPNAME(kid->op_targ); - if (PadnameLEN(name) == 2 && Padname_Is_Symbol_Table_Scalar (name) + if (Padname_Symbol_Name_Length (name) == 1 && Padname_Is_Symbol_Table_Scalar (name) && ( Padname_Symbol_Name (name)[0] == 'a' || Padname_Symbol_Name (name)[0] == 'b' )) /* diag_listed_as: "my %s" used in sort comparison */ diff --git a/pad.c b/pad.c index 58afb5d14542..08a6703a886a 100644 --- a/pad.c +++ b/pad.c @@ -577,7 +577,7 @@ S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash, } padnamelist_store(PL_comppad_name, offset, name); - if (PadnameLEN(name) > 1) + if (Padname_Symbol_Name_Length (name) > 0) PadnamelistMAXNAMED(PL_comppad_name) = offset; return offset; } @@ -1538,7 +1538,7 @@ Perl_pad_leavemy(pTHX) (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv) - && Padname_Is_Symbol_Table_Code (sv) && PadnameLEN(sv) > 1) { + && Padname_Is_Symbol_Table_Code (sv) && Padname_Symbol_Name_Length (sv) > 0) { OP *kid = newOP(OP_INTROCV, 0); kid->op_targ = off; o = op_prepend_elem(OP_LINESEQ, kid, o); @@ -2031,19 +2031,19 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, sv = newSV_type(SVt_PVCV); CvLEXICAL_on(sv); } - else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv)) + else if (Padname_Symbol_Name_Length (namesv) > 0 && !PadnameIsOUR(namesv)) { /* my sub */ /* Just provide a stub, but name it. It will be upgraded to the real thing on scope entry. */ U32 hash; PERL_HASH(hash, Padname_Symbol_Name (namesv), - PadnameLEN(namesv) - 1); + Padname_Symbol_Name_Length (namesv)); sv = newSV_type(SVt_PVCV); CvNAME_HEK_set( sv, share_hek(Padname_Symbol_Name (namesv), - 1 - PadnameLEN(namesv), + - Padname_Symbol_Name_Length (namesv), hash) ); CvLEXICAL_on(sv); diff --git a/pad.h b/pad.h index 88d935ae03b2..d6b7dfe6b97d 100644 --- a/pad.h +++ b/pad.h @@ -340,6 +340,13 @@ For backward compatibility its index C<-1> is valid index for read. Padname_Symbol_Name ("$self") == "self" +=for apidoc Am|STRLEN|Padname_Symbol_Name_Length|PADNAME * pn +Length of name of valid symbol (see L). + + # pseudocode + Padname_Symbol_Name_Length ("$self") == 4 + + =for apidoc Am|char|Padname_Symbol_Table|PADNAME * pn Extract symbol table identifier from valid symbol (see L). @@ -408,6 +415,9 @@ enum Perl_Symbol_Table { #define Padname_Symbol_Name(Pn) \ (PadnamePV (Pn) + 1) +#define Padname_Symbol_Name_Length(Pn) \ + ((STRLEN) ((PadnamePV (Pn)) ? (PadnameLEN (Pn) - 1) : 0)) + #define Padname_Symbol_Table(Pn) \ (PadnamePV (Pn)[0]) From 0db3048806909c88f4eca5e24f6973a0a506c4dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sat, 7 Dec 2024 21:00:43 +0100 Subject: [PATCH 14/41] [pad] Padname_Symbol_Is_Anonymous - whether PADNAME represents anonymous symbol --- pad.c | 6 +++--- pad.h | 7 +++++++ 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/pad.c b/pad.c index 08a6703a886a..d8d7820e06f8 100644 --- a/pad.c +++ b/pad.c @@ -577,7 +577,7 @@ S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash, } padnamelist_store(PL_comppad_name, offset, name); - if (Padname_Symbol_Name_Length (name) > 0) + if (! Padname_Symbol_Is_Anonymous (name)) PadnamelistMAXNAMED(PL_comppad_name) = offset; return offset; } @@ -1538,7 +1538,7 @@ Perl_pad_leavemy(pTHX) (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv) - && Padname_Is_Symbol_Table_Code (sv) && Padname_Symbol_Name_Length (sv) > 0) { + && Padname_Is_Symbol_Table_Code (sv) && ! Padname_Symbol_Is_Anonymous (sv)) { OP *kid = newOP(OP_INTROCV, 0); kid->op_targ = off; o = op_prepend_elem(OP_LINESEQ, kid, o); @@ -2031,7 +2031,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, sv = newSV_type(SVt_PVCV); CvLEXICAL_on(sv); } - else if (Padname_Symbol_Name_Length (namesv) > 0 && !PadnameIsOUR(namesv)) + else if (! Padname_Symbol_Is_Anonymous (namesv) && ! PadnameIsOUR(namesv)) { /* my sub */ /* Just provide a stub, but name it. It will be diff --git a/pad.h b/pad.h index d6b7dfe6b97d..f81ae059a59a 100644 --- a/pad.h +++ b/pad.h @@ -332,6 +332,10 @@ Whether PADNAME represents symbol for given symbol table. } +=for apidoc Am|bool|Padname_Symbol_Is_Anonymous|PADNAME * pn +Whether valid PADNAME represents anonymous symbol (has zero length name). + + =for apidoc Am|char *|Padname_Symbol_Name|PADNAME * pn Extract symbol name from valid symbol (see L). For backward compatibility its index C<-1> is valid index for read. @@ -412,6 +416,9 @@ enum Perl_Symbol_Table { #define Padname_Is_Symbol_Table_Scalar(Pn) \ Padname_Is_Symbol_Table (Pn, Perl_Symbol_Table_Scalar) +#define Padname_Symbol_Is_Anonymous(Pn) \ + (Padname_Symbol_Name_Length (Pn) == 0) + #define Padname_Symbol_Name(Pn) \ (PadnamePV (Pn) + 1) From f117281dd82dfa4e5a107b39b370801d07aceff7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sat, 7 Dec 2024 11:35:45 +0100 Subject: [PATCH 15/41] [pad] Perl_Sigil_To_Symbol_Table - convert sigil to symbol table identifier --- pad.h | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/pad.h b/pad.h index f81ae059a59a..73b0427fff8a 100644 --- a/pad.h +++ b/pad.h @@ -358,6 +358,12 @@ Extract symbol table identifier from valid symbol (see L). Padname_Symbol_Table ("$self") == Perl_Symbol_Table_Scalar +=for apidoc Am|char|Perl_Sigil_To_Symbol_Table|char +Converts sigil to symbol table + + Perl_Sigil_To_Symbol_Table ('$') == Perl_Symbol_Table_Scalar + + =for apidoc Ay||Perl_Symbol_Table =for apidoc_item Perl_Symbol_Table_Array =for apidoc_item Perl_Symbol_Table_Code @@ -428,6 +434,9 @@ enum Perl_Symbol_Table { #define Padname_Symbol_Table(Pn) \ (PadnamePV (Pn)[0]) +#define Perl_Sigil_To_Symbol_Table(Sigil) \ + (Sigil) + #define PadlistARRAY(pl) (pl)->xpadl_arr.xpadlarr_alloc #define PadlistMAX(pl) (pl)->xpadl_max #define PadlistNAMES(pl) *((PADNAMELIST **)PadlistARRAY(pl)) From 8af996b68350ae203fd9f7a9c3510825e34f3ece Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sat, 7 Dec 2024 14:12:22 +0100 Subject: [PATCH 16/41] [pad] Perl_Symbol_Table_Title_lc/ucfirst - factor out symbol table title into handy macros to avoid code duplication as well as simplify future changes. --- pad.c | 4 ++-- pad.h | 12 ++++++++++++ toke.c | 4 ++-- 3 files changed, 16 insertions(+), 4 deletions(-) diff --git a/pad.c b/pad.c index d8d7820e06f8..ef1c72a67b74 100644 --- a/pad.c +++ b/pad.c @@ -909,7 +909,7 @@ S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash) PL_parser->in_my == KEY_sigvar ? "my" : PL_parser->in_my == KEY_field ? "field" : "state" ), - Padname_Is_Symbol_Table_Code (pn) ? "subroutine" : "variable", + Perl_Symbol_Table_Title_lc (Padname_Symbol_Table (pn)), PNfARG(pn), (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO ? "scope" : "statement")); @@ -1220,7 +1220,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, shared */ Perl_warner(aTHX_ packWARN(WARN_CLOSURE), "%s \"%" UTF8f "\" will not stay shared", - *namepv == Perl_Symbol_Table_Code ? "Subroutine" : "Variable", + Perl_Symbol_Table_Title_ucfirst (*namepv), UTF8fARG(1, namelen, namepv)); } diff --git a/pad.h b/pad.h index 73b0427fff8a..0e7a9fc15017 100644 --- a/pad.h +++ b/pad.h @@ -394,6 +394,12 @@ For example, C<'&'> can be: =back + +=for apidoc Am|const char const *|Perl_Symbol_Table_Title_lc|Perl_Symbol_Table symbol_table +=for apidoc_item m|const char const *|Perl_Symbol_Table_Title_ucfirst|Perl_Symbol_Table symbol_table + +Expand as a title of symbol table, for example C or C. + =cut */ @@ -437,6 +443,12 @@ enum Perl_Symbol_Table { #define Perl_Sigil_To_Symbol_Table(Sigil) \ (Sigil) +#define Perl_Symbol_Table_Title_lc(Table) \ + (((Table) == Perl_Symbol_Table_Code) ? "subroutine" : "variable") + +#define Perl_Symbol_Table_Title_ucfirst(Table) \ + (((Table) == Perl_Symbol_Table_Code) ? "Subroutine" : "Variable") + #define PadlistARRAY(pl) (pl)->xpadl_arr.xpadlarr_alloc #define PadlistMAX(pl) (pl)->xpadl_max #define PadlistNAMES(pl) *((PADNAMELIST **)PadlistARRAY(pl)) diff --git a/toke.c b/toke.c index ae6c7819c444..3a078123dcd4 100644 --- a/toke.c +++ b/toke.c @@ -9933,7 +9933,7 @@ S_pending_ident(pTHX) in "our" */ yyerror_pv(Perl_form(aTHX_ "No package name allowed for " "%s %s in \"our\"", - *PL_tokenbuf=='&' ? "subroutine" : "variable", + Perl_Symbol_Table_Title_lc (Perl_Sigil_To_Symbol_Table (*PL_tokenbuf)), PL_tokenbuf), UTF ? SVf_UTF8 : 0); tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0); } @@ -9946,7 +9946,7 @@ S_pending_ident(pTHX) yyerror_pv(Perl_form(aTHX_ PL_no_myglob, PL_in_my == KEY_my ? "my" : PL_in_my == KEY_field ? "field" : "state", - *PL_tokenbuf == '&' ? "subroutine" : "variable", + Perl_Symbol_Table_Title_lc (Perl_Sigil_To_Symbol_Table (*PL_tokenbuf)), PL_tokenbuf), UTF ? SVf_UTF8 : 0); GCC_DIAG_RESTORE_STMT; From a09287fb87c57af0074f5f6d2918c7c8110a0039 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sat, 7 Dec 2024 15:05:20 +0100 Subject: [PATCH 17/41] [pad] Padname_Symbol_Table_Title_* - factor out symbol table title eg: scalar, array, and hash are "variable" --- pad.c | 6 ++---- pad.h | 13 +++++++++++++ 2 files changed, 15 insertions(+), 4 deletions(-) diff --git a/pad.c b/pad.c index ef1c72a67b74..a297505f5a3b 100644 --- a/pad.c +++ b/pad.c @@ -909,7 +909,7 @@ S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash) PL_parser->in_my == KEY_sigvar ? "my" : PL_parser->in_my == KEY_field ? "field" : "state" ), - Perl_Symbol_Table_Title_lc (Padname_Symbol_Table (pn)), + Padname_Symbol_Table_Title_lc (pn), PNfARG(pn), (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO ? "scope" : "statement")); @@ -1096,9 +1096,7 @@ S_unavailable(pTHX_ PADNAME *name) /* diag_listed_as: Variable "%s" is not available */ Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), "%s \"%" PNf "\" is not available", - Padname_Is_Symbol_Table_Code (name) - ? "Subroutine" - : "Variable", + Padname_Symbol_Table_Title_ucfirst (name), PNfARG(name)); } diff --git a/pad.h b/pad.h index 0e7a9fc15017..e0fcc47fbfa8 100644 --- a/pad.h +++ b/pad.h @@ -358,6 +358,13 @@ Extract symbol table identifier from valid symbol (see L). Padname_Symbol_Table ("$self") == Perl_Symbol_Table_Scalar +=for apidoc Am|const char const *|Padname_Symbol_Table_Title_lc|PADNAME * pn +=for apidoc_item m|const char const *|Padname_Symbol_Table_Title_ucfirst|PADNAME * pn + +Similar to L / L +but computes symbol table from valid symbol (see L). + + =for apidoc Am|char|Perl_Sigil_To_Symbol_Table|char Converts sigil to symbol table @@ -449,6 +456,12 @@ enum Perl_Symbol_Table { #define Perl_Symbol_Table_Title_ucfirst(Table) \ (((Table) == Perl_Symbol_Table_Code) ? "Subroutine" : "Variable") +#define Padname_Symbol_Table_Title_lc(Pn) \ + Perl_Symbol_Table_Title_lc (Padname_Symbol_Table (Pn)) + +#define Padname_Symbol_Table_Title_ucfirst(Pn) \ + Perl_Symbol_Table_Title_ucfirst (Padname_Symbol_Table (Pn)) + #define PadlistARRAY(pl) (pl)->xpadl_arr.xpadlarr_alloc #define PadlistMAX(pl) (pl)->xpadl_max #define PadlistNAMES(pl) *((PADNAMELIST **)PadlistARRAY(pl)) From 36d413a75843c9a1b25abf6b716fe6c1895bfa76 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Mon, 9 Dec 2024 10:11:28 +0100 Subject: [PATCH 18/41] [pad] Padname_Symbol_Printf_Format and Params Move printf format and proper expansion of parameters, into macros so when code evolves, it will be isolated from usage. --- ext/XS-APItest/APItest.pm | 2 +- ext/XS-APItest/APItest.xs | 10 ++++++++-- pad.c | 25 ++++++++++++------------- pad.h | 15 +++++++++++++++ 4 files changed, 36 insertions(+), 16 deletions(-) diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 3b7201a0daf4..085e6dc2117e 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -4,7 +4,7 @@ use strict; use warnings; use Carp; -our $VERSION = '1.40'; +our $VERSION = '1.41'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 4196bbb7004c..83775d076302 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1195,9 +1195,15 @@ static OP *THX_parse_keyword_subsignature(pTHX) case OP_ARGELEM: { PADOFFSET padix = kid->op_targ; PADNAMELIST *names = PadlistNAMES(CvPADLIST(find_runcv(0))); - char *namepv = PadnamePV(padnamelist_fetch(names, padix)); + PADNAME *pv = padnamelist_fetch(names, padix); retop = op_append_list(OP_LIST, retop, newSVOP(OP_CONST, 0, - newSVpvf(kid->op_flags & OPf_KIDS ? "argelem:%s:d" : "argelem:%s", namepv))); + newSVpvf( + kid->op_flags & OPf_KIDS + ? "argelem:" Padname_Symbol_Printf_Format ":d" + : "argelem:" Padname_Symbol_Printf_Format + , + Padname_Symbol_Printf_Params (pv) + ))); break; } default: diff --git a/pad.c b/pad.c index a297505f5a3b..4f3ed4a94278 100644 --- a/pad.c +++ b/pad.c @@ -663,8 +663,8 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, sv_upgrade(PL_curpad[offset], SVt_PVCV); assert(SvPADMY(PL_curpad[offset])); DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n", - (long)offset, PadnamePV(name), + "Pad addname: %ld \"" Padname_Symbol_Printf_Format "\" new lex=0x%" UVxf "\n", + (long)offset, Padname_Symbol_Printf_Params (name), PTR2UV(PL_curpad[offset]))); return offset; @@ -1323,10 +1323,9 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, ); DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad addname: %ld \"%.*s\" FAKE\n", + "Pad addname: %ld \"" Padname_Symbol_Printf_Format "\" FAKE\n", (long)new_offset, - (int) PadnameLEN(new_name), - PadnamePV(new_name))); + Padname_Symbol_Printf_Params (new_name))); PARENT_FAKELEX_FLAGS_set(new_name, *out_flags); PARENT_PAD_INDEX_set(new_name, 0); @@ -1477,8 +1476,8 @@ Perl_intro_my(pTHX) COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */ COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax); DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad intromy: %ld \"%s\", (%lu,%lu)\n", - (long)i, PadnamePV(sv), + "Pad intromy: %ld \"" Padname_Symbol_Printf_Format "\", (%lu,%lu)\n", + (long)i, Padname_Symbol_Printf_Params(sv), (unsigned long)COP_SEQ_RANGE_LOW(sv), (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); @@ -1530,8 +1529,8 @@ Perl_pad_leavemy(pTHX) { COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", - (long)off, PadnamePV(sv), + "Pad leavemy: %ld \"" Padname_Symbol_Printf_Format "\", (%lu,%lu)\n", + (long)off, Padname_Symbol_Printf_Params (sv), (unsigned long)COP_SEQ_RANGE_LOW(sv), (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); @@ -1831,24 +1830,24 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) if (namesv) { if (PadnameOUTER(namesv)) Perl_dump_indent(aTHX_ level+1, file, - "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n", + "%2d. 0x%" UVxf "<%lu> FAKE \"" Padname_Symbol_Printf_Format "\" flags=0x%lx index=%lu\n", (int) ix, PTR2UV(ppad[ix]), (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), - PadnamePV(namesv), + Padname_Symbol_Printf_Params (namesv), (unsigned long)PARENT_FAKELEX_FLAGS(namesv), (unsigned long)PARENT_PAD_INDEX(namesv) ); else Perl_dump_indent(aTHX_ level+1, file, - "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n", + "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"" Padname_Symbol_Printf_Format "\"\n", (int) ix, PTR2UV(ppad[ix]), (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), (unsigned long)COP_SEQ_RANGE_LOW(namesv), (unsigned long)COP_SEQ_RANGE_HIGH(namesv), - PadnamePV(namesv) + Padname_Symbol_Printf_Params (namesv) ); } else if (full) { diff --git a/pad.h b/pad.h index e0fcc47fbfa8..f821941a100f 100644 --- a/pad.h +++ b/pad.h @@ -358,6 +358,14 @@ Extract symbol table identifier from valid symbol (see L). Padname_Symbol_Table ("$self") == Perl_Symbol_Table_Scalar +=for apidoc Am|const char *|Padname_Symbol_Printf_Format +C format (as literal string) to output symbol name with its sigil + + +=for apidoc Amu|args|Padname_Symbol_Printf_Params|PADNAME * pn +C arguments required by L + + =for apidoc Am|const char const *|Padname_Symbol_Table_Title_lc|PADNAME * pn =for apidoc_item m|const char const *|Padname_Symbol_Table_Title_ucfirst|PADNAME * pn @@ -444,6 +452,13 @@ enum Perl_Symbol_Table { #define Padname_Symbol_Name_Length(Pn) \ ((STRLEN) ((PadnamePV (Pn)) ? (PadnameLEN (Pn) - 1) : 0)) +#define Padname_Symbol_Printf_Format \ + "%.*s" + +#define Padname_Symbol_Printf_Params(Pn) \ + (int) PadnameLEN (Pn), \ + PadnamePV (Pn) + #define Padname_Symbol_Table(Pn) \ (PadnamePV (Pn)[0]) From 5bbe791b99153679ea7baf46b5af277cbe67c750 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sat, 7 Dec 2024 22:16:49 +0100 Subject: [PATCH 19/41] [pad] Padname_Symbol_Printf_Format/Params - use dedicated format for sigil --- pad.h | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/pad.h b/pad.h index f821941a100f..035de33b603d 100644 --- a/pad.h +++ b/pad.h @@ -453,11 +453,12 @@ enum Perl_Symbol_Table { ((STRLEN) ((PadnamePV (Pn)) ? (PadnameLEN (Pn) - 1) : 0)) #define Padname_Symbol_Printf_Format \ - "%.*s" + "%c%.*s" #define Padname_Symbol_Printf_Params(Pn) \ - (int) PadnameLEN (Pn), \ - PadnamePV (Pn) + Perl_Symbol_Table_To_Sigil (Padname_Symbol_Table (Pn)), \ + (int) Padname_Symbol_Name_Length (Pn), \ + Padname_Symbol_Name (Pn) #define Padname_Symbol_Table(Pn) \ (PadnamePV (Pn)[0]) @@ -465,6 +466,9 @@ enum Perl_Symbol_Table { #define Perl_Sigil_To_Symbol_Table(Sigil) \ (Sigil) +#define Perl_Symbol_Table_To_Sigil(Symbol_Table) \ + (Symbol_Table) + #define Perl_Symbol_Table_Title_lc(Table) \ (((Table) == Perl_Symbol_Table_Code) ? "subroutine" : "variable") From fc1e956ed9b9edee6df160d154fd0a673107bfc5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sat, 7 Dec 2024 23:38:48 +0100 Subject: [PATCH 20/41] [pad] refactor if/else sequences into switch/case (symbol type) extracting common part of condition and using `Perl_Symbol_Table_*` constants --- pad.c | 42 ++++++++++++++++++++++++++++-------------- 1 file changed, 28 insertions(+), 14 deletions(-) diff --git a/pad.c b/pad.c index 4f3ed4a94278..687faeaf98c6 100644 --- a/pad.c +++ b/pad.c @@ -655,12 +655,19 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, /* if it's not a simple scalar, replace with an AV or HV */ assert(SvTYPE(PL_curpad[offset]) == SVt_NULL); assert(SvREFCNT(PL_curpad[offset]) == 1); - if (namelen != 0 && *namepv == Perl_Symbol_Table_Array) - sv_upgrade(PL_curpad[offset], SVt_PVAV); - else if (namelen != 0 && *namepv == Perl_Symbol_Table_Hash) - sv_upgrade(PL_curpad[offset], SVt_PVHV); - else if (namelen != 0 && *namepv == Perl_Symbol_Table_Code) - sv_upgrade(PL_curpad[offset], SVt_PVCV); + if (namelen != 0) { + switch (*namepv) { + case Perl_Symbol_Table_Array: + sv_upgrade(PL_curpad[offset], SVt_PVAV); + break; + case Perl_Symbol_Table_Hash: + sv_upgrade(PL_curpad[offset], SVt_PVHV); + break; + case Perl_Symbol_Table_Code: + sv_upgrade(PL_curpad[offset], SVt_PVCV); + break; + } + } assert(SvPADMY(PL_curpad[offset])); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad addname: %ld \"" Padname_Symbol_Printf_Format "\" new lex=0x%" UVxf "\n", @@ -1254,14 +1261,21 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, } } if (!*out_capture) { - if (namelen != 0 && *namepv == Perl_Symbol_Table_Array) - *out_capture = newSV_type_mortal(SVt_PVAV); - else if (namelen != 0 && *namepv == Perl_Symbol_Table_Hash) - *out_capture = newSV_type_mortal(SVt_PVHV); - else if (namelen != 0 && *namepv == Perl_Symbol_Table_Code) - *out_capture = newSV_type_mortal(SVt_PVCV); - else - *out_capture = newSV_type_mortal(SVt_NULL); + if (namelen != 0) { + switch (*namepv) { + case Perl_Symbol_Table_Array: + *out_capture = newSV_type_mortal(SVt_PVAV); + break; + case Perl_Symbol_Table_Hash: + *out_capture = newSV_type_mortal(SVt_PVHV); + break; + case Perl_Symbol_Table_Code: + *out_capture = newSV_type_mortal(SVt_PVCV); + break; + default: + *out_capture = newSV_type_mortal(SVt_NULL); + } + } } } From 3a2302ce1d28a58139e56290748bb6f5a00036de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sun, 8 Dec 2024 00:17:23 +0100 Subject: [PATCH 21/41] [pad] perl_symbol_table_id - type alias of symbol table id --- class.c | 4 ++-- pad.c | 6 +++--- pad.h | 7 +++++++ 3 files changed, 12 insertions(+), 5 deletions(-) diff --git a/class.c b/class.c index a3d631620b38..54bddae1e521 100644 --- a/class.c +++ b/class.c @@ -699,7 +699,7 @@ Perl_class_seal_stash(pTHX_ HV *stash) for(SSize_t i = 0; fieldnames && i <= PadnamelistMAX(fieldnames); i++) { PADNAME *pn = PadnamelistARRAY(fieldnames)[i]; - char sigil = Padname_Symbol_Table (pn); + perl_symbol_table_id sigil = Padname_Symbol_Table (pn); PADOFFSET fieldix = PadnameFIELDINFO(pn)->fieldix; /* Extract the OP_{NEXT,DB}STATE op from the defop so we can @@ -1238,7 +1238,7 @@ Perl_class_set_field_defop(pTHX_ PADNAME *pn, OPCODE defmode, OP *defop) forbid_outofblock_ops(defop, "field initialiser expression"); - char sigil = Padname_Symbol_Table (pn); + perl_symbol_table_id sigil = Padname_Symbol_Table (pn); switch(sigil) { case Perl_Symbol_Table_Scalar: defop = op_contextualize(defop, G_SCALAR); diff --git a/pad.c b/pad.c index 687faeaf98c6..4c1547fc6327 100644 --- a/pad.c +++ b/pad.c @@ -2025,7 +2025,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, SvREFCNT_inc_simple_void_NN(sv); } if (!sv) { - const char sigil = Padname_Symbol_Table (namesv); + const perl_symbol_table_id sigil = Padname_Symbol_Table (namesv); if (sigil == Perl_Symbol_Table_Code) /* If there are state subs, we need to clone them, too. But they may need to close over variables we have @@ -2458,7 +2458,7 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) for ( ;ix > 0; ix--) { SV *sv; if (names_fill >= ix && PadnameLEN(names[ix])) { - const char sigil = Padname_Symbol_Table (names[ix]); + const perl_symbol_table_id sigil = Padname_Symbol_Table (names[ix]); if (PadnameOUTER(names[ix]) || PadnameIsSTATE(names[ix]) || sigil == Perl_Symbol_Table_Code) @@ -2567,7 +2567,7 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) pad1a[ix] = NULL; } else if (names_fill >= ix && names[ix] && PadnameLEN(names[ix])) { - const char sigil = Padname_Symbol_Table (names[ix]); + const perl_symbol_table_id sigil = Padname_Symbol_Table (names[ix]); if (PadnameOUTER(names[ix]) || PadnameIsSTATE(names[ix]) || sigil == Perl_Symbol_Table_Code) diff --git a/pad.h b/pad.h index 035de33b603d..463c8080fce6 100644 --- a/pad.h +++ b/pad.h @@ -415,9 +415,16 @@ For example, C<'&'> can be: Expand as a title of symbol table, for example C or C. + +=for apidoc Ay | | perl_symbol_table_id + +Typedef how symbol table id is represented + =cut */ +typedef char perl_symbol_table_id; + enum Perl_Symbol_Table { Perl_Symbol_Table_Array = '@', Perl_Symbol_Table_Code = '&', From 8b675805292c771bdc725ce48e363f72a9c69f90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Mon, 9 Dec 2024 15:34:01 +0100 Subject: [PATCH 22/41] [pad] new_padname_symbol_pvn - newPADNAMEpvn alternative with explicit symbol table --- embed.fnc | 4 ++++ embed.h | 1 + pad.c | 51 ++++++++++++++++++++++++++++++++++++++++++++++++--- proto.h | 6 ++++++ 4 files changed, 59 insertions(+), 3 deletions(-) diff --git a/embed.fnc b/embed.fnc index 7792a28e7a3c..e3903be48d1e 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2257,6 +2257,10 @@ ARTdpx |PADNAME *|newPADNAMEouter \ |NN PADNAME *outer ARTdpx |PADNAME *|newPADNAMEpvn|NN const char *s \ |STRLEN len +ARTdpx |PADNAME *|new_padname_symbol_pvn \ + |perl_symbol_table_id symbol_table \ + |NN const char *name \ + |STRLEN name_len ARdip |OP * |newPADxVOP |I32 type \ |I32 flags \ |PADOFFSET padix diff --git a/embed.h b/embed.h index dfcc4f4881e6..494ddeb28c02 100644 --- a/embed.h +++ b/embed.h @@ -479,6 +479,7 @@ # define newWHILEOP(a,b,c,d,e,f,g) Perl_newWHILEOP(aTHX_ a,b,c,d,e,f,g) # define newXS(a,b,c) Perl_newXS(aTHX_ a,b,c) # define newXS_flags(a,b,c,d,e) Perl_newXS_flags(aTHX_ a,b,c,d,e) +# define new_padname_symbol_pvn Perl_new_padname_symbol_pvn # define new_stackinfo(a,b) Perl_new_stackinfo(aTHX_ a,b) # define new_stackinfo_flags(a,b,c) Perl_new_stackinfo_flags(aTHX_ a,b,c) # define new_version(a) Perl_new_version(aTHX_ a) diff --git a/pad.c b/pad.c index 4c1547fc6327..d717ddc1d219 100644 --- a/pad.c +++ b/pad.c @@ -2796,19 +2796,43 @@ Perl_newPADNAMEpvn(const char *s, STRLEN len) char *alloc2; /* for Newxz */ PADNAME *pn; PERL_ARGS_ASSERT_NEWPADNAMEPVN; + + if (len > 0) + return new_padname_symbol_pvn (*s, s + 1, len - 1); + + /* when called from padname_dup 'len' can be zero (-Dusethreads) */ + Newxz(alloc2, - STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1, + STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + 1, char); alloc = (struct padname_with_str *)alloc2; pn = (PADNAME *)alloc; PadnameREFCNT(pn) = 1; PadnamePV(pn) = alloc->xpadn_str; - Copy(s, PadnamePV(pn), len, char); - *(PadnamePV(pn) + len) = '\0'; + *(PadnamePV(pn)) = '\0'; PadnameLEN(pn) = len; return pn; } +/* +=for apidoc new_padname_symbol_pvn + + // allocate padname for "$foo" + PADNAME *name = new_padname_symbol (Perl_Symbol_Table_Scalar, "foo", 3); + +Constructs a new pad name. C must be a UTF-8 string. Do not +use this for pad names that point to outer lexicals. See +C>. + +=cut +*/ + +PADNAME * +Perl_new_padname_symbol_pvn( + perl_symbol_table_id symbol_table, + const char * name, + STRLEN name_len +) /* =for apidoc newPADNAMEouter @@ -2822,6 +2846,27 @@ C flag already set. =cut */ +{ + struct padname_with_str *alloc; + char *alloc2; /* for Newxz */ + PADNAME *pn; + STRLEN len = name_len + sizeof (symbol_table); + PERL_ARGS_ASSERT_NEW_PADNAME_SYMBOL_PVN; + + Newxz(alloc2, + STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1, + char); + alloc = (struct padname_with_str *)alloc2; + pn = (PADNAME *)alloc; + PadnameREFCNT(pn) = 1; + PadnamePV(pn) = alloc->xpadn_str; + Padname_Symbol_Table (pn) = symbol_table; + Copy(name, Padname_Symbol_Name (pn), name_len, char); + *(PadnamePV(pn) + len) = '\0'; + PadnameLEN(pn) = len; + return pn; +} + PADNAME * Perl_newPADNAMEouter(PADNAME *outer) { diff --git a/proto.h b/proto.h index 32e8d48f4fa7..6e681c67b16b 100644 --- a/proto.h +++ b/proto.h @@ -3193,6 +3193,12 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, XSUBADDR_t subaddr, con #define PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS \ assert(subaddr) +PERL_CALLCONV PADNAME * +Perl_new_padname_symbol_pvn(perl_symbol_table_id symbol_table, const char *name, STRLEN name_len) + __attribute__warn_unused_result__; +#define PERL_ARGS_ASSERT_NEW_PADNAME_SYMBOL_PVN \ + assert(name) + PERL_CALLCONV PERL_SI * Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems) __attribute__warn_unused_result__; From e6001bd97a065f15d2c79c66d151ca716aff96bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Mon, 25 Nov 2024 07:42:19 +0100 Subject: [PATCH 23/41] [pad] new_padname_symbol_pvn - replace usage of newPADNAMEpvn --- pad.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/pad.c b/pad.c index d717ddc1d219..54cfcd470fb3 100644 --- a/pad.c +++ b/pad.c @@ -632,7 +632,7 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf, (UV)flags); - name = newPADNAMEpvn(namepv, namelen); + name = new_padname_symbol_pvn (*namepv, namepv + 1, namelen - 1); if ((flags & (padadd_NO_DUP_CHECK)) == 0) { ENTER; @@ -819,7 +819,7 @@ PADOFFSET Perl_pad_add_anon(pTHX_ CV* func, I32 optype) { PADOFFSET ix; - PADNAME * const name = newPADNAMEpvn("&", 1); + PADNAME * const name = new_padname_symbol_pvn (Perl_Symbol_Table_Code, "", 0); PERL_ARGS_ASSERT_PAD_ADD_ANON; assert (SvTYPE(func) == SVt_PVCV); @@ -846,7 +846,7 @@ void Perl_pad_add_weakref(pTHX_ CV* func) { const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY); - PADNAME * const name = newPADNAMEpvn("&", 1); + PADNAME * const name = new_padname_symbol_pvn (Perl_Symbol_Table_Code, "", 0); SV * const rv = newRV_inc((SV *)func); PERL_ARGS_ASSERT_PAD_ADD_WEAKREF; @@ -2945,6 +2945,7 @@ Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param) dst = PadnameOUTER(src) ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param)) + /* TODO: PadnameLEN(src) sometimes evaluates to 0 */ : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src)); ptr_table_store(PL_ptr_table, src, dst); PadnameLEN(dst) = PadnameLEN(src); From 7a98c553e746892e0500936f1bd2c9d373d70b39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sun, 8 Dec 2024 10:29:07 +0100 Subject: [PATCH 24/41] [pad] pad_add_symbol_pvn - pad_add_name_pvn alternative with explicit symbol table --- embed.fnc | 7 +++++++ embed.h | 1 + pad.c | 25 ++++++++++++++++++++++--- pad.h | 2 +- proto.h | 6 ++++++ 5 files changed, 37 insertions(+), 4 deletions(-) diff --git a/embed.fnc b/embed.fnc index e3903be48d1e..b54449a54e8c 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2470,6 +2470,13 @@ Adp |PADOFFSET|pad_add_name_sv \ |U32 flags \ |NULLOK HV *typestash \ |NULLOK HV *ourstash +Adp |PADOFFSET|pad_add_symbol_pvn \ + |perl_symbol_table_id symbol_table \ + |NN const char *namepv \ + |STRLEN namelen \ + |U32 flags \ + |NULLOK HV *typestash \ + |NULLOK HV *ourstash p |void |pad_add_weakref|NN CV *func Adpx |PADOFFSET|pad_alloc |I32 optype \ |U32 tmptype diff --git a/embed.h b/embed.h index 494ddeb28c02..7d81f71d4e68 100644 --- a/embed.h +++ b/embed.h @@ -508,6 +508,7 @@ # define pad_add_name_pv(a,b,c,d) Perl_pad_add_name_pv(aTHX_ a,b,c,d) # define pad_add_name_pvn(a,b,c,d,e) Perl_pad_add_name_pvn(aTHX_ a,b,c,d,e) # define pad_add_name_sv(a,b,c,d) Perl_pad_add_name_sv(aTHX_ a,b,c,d) +# define pad_add_symbol_pvn(a,b,c,d,e,f) Perl_pad_add_symbol_pvn(aTHX_ a,b,c,d,e,f) # define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) # define pad_findmy_pv(a,b) Perl_pad_findmy_pv(aTHX_ a,b) # define pad_findmy_pvn(a,b,c) Perl_pad_findmy_pvn(aTHX_ a,b,c) diff --git a/pad.c b/pad.c index 54cfcd470fb3..8a803e6f01b6 100644 --- a/pad.c +++ b/pad.c @@ -586,6 +586,7 @@ S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash, =for apidoc pad_add_name_pv =for apidoc_item pad_add_name_pvn =for apidoc_item pad_add_name_sv +=for apidoc_item pad_add_symbol_pvn These each allocate a place in the currently-compiling pad for a named lexical variable. They store the name and other metadata in the name part of the @@ -616,23 +617,41 @@ In C, C gives the length of the input name in bytes, which means it may contain embedded NUL characters. Again, it must be encoded in UTF-8. +C uses separated symbol table and symbol name arguments. + =cut */ PADOFFSET Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags, HV *typestash, HV *ourstash) +{ + PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN; + + return pad_add_symbol_pvn (*namepv, namepv + 1, namelen - 1, flags, typestash, ourstash); +} + +PADOFFSET +Perl_pad_add_symbol_pvn( + pTHX_ + perl_symbol_table_id symbol_table, + const char *namepv, + STRLEN namelen, + U32 flags, + HV *typestash, + HV *ourstash +) { PADOFFSET offset; PADNAME *name; - PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN; + PERL_ARGS_ASSERT_PAD_ADD_SYMBOL_PVN; if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_FIELD)) Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf, (UV)flags); - name = new_padname_symbol_pvn (*namepv, namepv + 1, namelen - 1); + name = new_padname_symbol_pvn (symbol_table, namepv, namelen); if ((flags & (padadd_NO_DUP_CHECK)) == 0) { ENTER; @@ -656,7 +675,7 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, assert(SvTYPE(PL_curpad[offset]) == SVt_NULL); assert(SvREFCNT(PL_curpad[offset]) == 1); if (namelen != 0) { - switch (*namepv) { + switch (symbol_table) { case Perl_Symbol_Table_Array: sv_upgrade(PL_curpad[offset], SVt_PVAV); break; diff --git a/pad.h b/pad.h index 463c8080fce6..b2d10bec9daf 100644 --- a/pad.h +++ b/pad.h @@ -141,7 +141,7 @@ typedef enum { padtidy_FORMAT /* or a format */ } padtidy_type; -/* flags for pad_add_name_pvn. */ +/* flags for pad_add_name_pvn / pad_add_symbol_pvn. */ #define padadd_OUR 0x01 /* our declaration. */ #define padadd_STATE 0x02 /* state declaration. */ diff --git a/proto.h b/proto.h index 6e681c67b16b..84ccd0191ad9 100644 --- a/proto.h +++ b/proto.h @@ -3413,6 +3413,12 @@ Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash); assert(name); assert(!typestash || SvTYPE(typestash) == SVt_PVHV); \ assert(!ourstash || SvTYPE(ourstash) == SVt_PVHV) +PERL_CALLCONV PADOFFSET +Perl_pad_add_symbol_pvn(pTHX_ perl_symbol_table_id symbol_table, const char *namepv, STRLEN namelen, U32 flags, HV *typestash, HV *ourstash); +#define PERL_ARGS_ASSERT_PAD_ADD_SYMBOL_PVN \ + assert(namepv); assert(!typestash || SvTYPE(typestash) == SVt_PVHV); \ + assert(!ourstash || SvTYPE(ourstash) == SVt_PVHV) + PERL_CALLCONV void Perl_pad_add_weakref(pTHX_ CV *func) __attribute__visibility__("hidden"); From 1b237ce69014983e62a2018e5afb41189c36214c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sun, 8 Dec 2024 11:18:11 +0100 Subject: [PATCH 25/41] [pad] pad_add_symbol_pvn - replace usage of pad_add_name_pvn --- class.c | 9 ++++++++- op.c | 8 ++++---- pad.c | 4 ++-- 3 files changed, 14 insertions(+), 7 deletions(-) diff --git a/class.c b/class.c index 54bddae1e521..e9a057158c64 100644 --- a/class.c +++ b/class.c @@ -994,7 +994,14 @@ apply_field_attribute_reader(pTHX_ PADNAME *pn, SV *value) padix = pad_add_name_pvs("$self", 0, NULL, NULL); assert(padix == PADIX_SELF); - padix = pad_add_name_pvn(PadnamePV(pn), PadnameLEN(pn), 0, NULL, NULL); + padix = pad_add_symbol_pvn ( + /* symbol_table = */ Padname_Symbol_Table (pn), + /* namepv = */ Padname_Symbol_Name (pn), + /* namelen = */ Padname_Symbol_Name_Length (pn), + /* flags = */ 0, + /* typestash = */ NULL, + /* ourstash = */ NULL + ); intro_my(); OP *methstartop; diff --git a/op.c b/op.c index 7884b6418c89..8183d0e82891 100644 --- a/op.c +++ b/op.c @@ -809,7 +809,7 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) else if(PL_parser->in_my == KEY_field) addflags |= padadd_FIELD; - off = pad_add_name_pvn(name, len, addflags, + off = pad_add_symbol_pvn (*name, name + 1, len - 1, addflags, PL_parser->in_my_stash, (is_our /* $_ is always in main::, even with our */ @@ -8622,7 +8622,7 @@ S_newONCEOP(pTHX_ OP *initop, OP *padop) /* Store the initializedness of state vars in a separate pad entry. */ condop->op_targ = - pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0); + pad_add_symbol_pvn (Perl_Symbol_Table_Scalar, "", 0, padadd_NO_DUP_CHECK|padadd_STATE,0,0); /* hijacking PADSTALE for uninitialized state variables */ SvPADSTALE_on(PAD_SVl(condop->op_targ)); @@ -9390,10 +9390,10 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) right->op_next = flop; range->op_targ = - pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0); + pad_add_symbol_pvn (Perl_Symbol_Table_Scalar, "", 0, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0); sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); flip->op_targ = - pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);; + pad_add_symbol_pvn (Perl_Symbol_Table_Scalar, "", 0, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0); sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); SvPADTMP_on(PAD_SV(flip->op_targ)); diff --git a/pad.c b/pad.c index 8a803e6f01b6..49229f5616e9 100644 --- a/pad.c +++ b/pad.c @@ -701,7 +701,7 @@ Perl_pad_add_name_pv(pTHX_ const char *name, const U32 flags, HV *typestash, HV *ourstash) { PERL_ARGS_ASSERT_PAD_ADD_NAME_PV; - return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash); + return pad_add_symbol_pvn (*name, name + 1, strlen(name) - 1, flags, typestash, ourstash); } PADOFFSET @@ -711,7 +711,7 @@ Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash) STRLEN namelen; PERL_ARGS_ASSERT_PAD_ADD_NAME_SV; namepv = SvPVutf8(name, namelen); - return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash); + return pad_add_symbol_pvn (*namepv, namepv + 1, namelen - 1, flags, typestash, ourstash); } /* From 5c666871dcc2a1c265be927d59a6e8a347f99905 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Wed, 27 Nov 2024 19:39:07 +0100 Subject: [PATCH 26/41] [handy] EXPAND_CALL - helper macro to call macro expanding its arguments first Common problem is when macro expands as multiple arguments. Without intermediate step allowing to expand arguments before macro call there will be an error due treating such expansion as single argument. --- handy.h | 38 ++++++++++++++++++++++++++++++++++++++ pad.h | 4 ++-- 2 files changed, 40 insertions(+), 2 deletions(-) diff --git a/handy.h b/handy.h index ebb17f9cb28d..7e7c05264d7c 100644 --- a/handy.h +++ b/handy.h @@ -416,6 +416,44 @@ Perl_xxx(aTHX_ ...) form for any API calls where it's used. Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN(str), flags) #define newSVpvs_share(str) Perl_newSVpvn_share(aTHX_ STR_WITH_LEN(str), 0) +/* +=for apidoc_section $utility + +=for apidoc Amu|Function call|EXPAND_CALL|Macro, Arguments_List + +When calling macro C with arguments containing another macro +which expands as multiple arguments (for example: C) we +need to expand arguments before expanding C macro. + +Usage: + + #define my_macro(Arg1, Arg2) \ + EXPAND_CALL (Macro, (Arg1, STR_WITH_LEN (Arg2)) + +Note: C must include C<()> to enforce single expression + +Example: + + #define pad_add_symbol_pvs(Table, Name, Flags, Type, Our) \ + EXPAND_CALL ( \ + pad_add_symbol_pvn, \ + (Table, STR_WITH_LEN (Name), Flags, Type, Our) \ + ) + +In this case C is macro so calling it directly fails +because C expands as two arguments, but for preprocessor, when used +directly, it is only one. + +Using C introduces additional step where any macro used in arguments +is expanded before expanding C itself. + +=cut + +*/ + +#define EXPAND_CALL(Macro, Args) \ + Macro Args + /* =for apidoc_defn Am|void|sv_catpvs_flags|SV * const dsv|"literal string"|I32 flags =for apidoc_defn Am|void|sv_catpvs_nomg|SV * const dsv|"literal string" diff --git a/pad.h b/pad.h index b2d10bec9daf..64a331d8ec99 100644 --- a/pad.h +++ b/pad.h @@ -711,7 +711,7 @@ instead of a string/length pair. */ #define pad_add_name_pvs(name,flags,typestash,ourstash) \ - Perl_pad_add_name_pvn(aTHX_ STR_WITH_LEN(name), flags, typestash, ourstash) + EXPAND_CALL (pad_add_name_pvn, (STR_WITH_LEN(name), flags, typestash, ourstash)) /* =for apidoc_defn Am|PADOFFSET|pad_findmy_pvs|"name"|U32 flags @@ -720,7 +720,7 @@ instead of a string/length pair. */ #define pad_findmy_pvs(name,flags) \ - Perl_pad_findmy_pvn(aTHX_ STR_WITH_LEN(name), flags) + EXPAND_CALL (pad_findmy_pvn, (STR_WITH_LEN(name), flags)) struct suspended_compcv { From b3e29739be4afd261b880fcfddf988045d3f8876 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Tue, 26 Nov 2024 12:57:12 +0100 Subject: [PATCH 27/41] [pad] pad_add_symbol_pvs - pad_add_name_pvs alternative with explicit symbol table --- pad.h | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/pad.h b/pad.h index 64a331d8ec99..566a8288ec43 100644 --- a/pad.h +++ b/pad.h @@ -713,6 +713,20 @@ instead of a string/length pair. #define pad_add_name_pvs(name,flags,typestash,ourstash) \ EXPAND_CALL (pad_add_name_pvn, (STR_WITH_LEN(name), flags, typestash, ourstash)) +/* +=for apidoc Am|PADOFFSET|pad_add_symbol_pvs|symbol_table|"name"|U32 flags|HV *typestash|HV *ourstash + +Similar to L, but takes a literal string instead of a string/length pair. + + # Example: create pad entry for "$self" + pad_add_symbol_pvs (Perl_Symbol_Scalar, "self", 0, NULL, NULL); + +=cut +*/ + +#define pad_add_symbol_pvs(Symbol_Table, Name, Flags, Typestash, Ourstash) \ + EXPAND_CALL (pad_add_symbol_pvn, (Symbol_Table, STR_WITH_LEN (Name), Flags, Typestash, Ourstash)) + /* =for apidoc_defn Am|PADOFFSET|pad_findmy_pvs|"name"|U32 flags From 213328d13b450ff8c883c6242423cc81bc77e3dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Tue, 26 Nov 2024 17:50:06 +0100 Subject: [PATCH 28/41] [pad] pad_add_symbol_pvs - replace usage of pad_add_name_pvs --- class.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/class.c b/class.c index e9a057158c64..1c4f5eee2ca4 100644 --- a/class.c +++ b/class.c @@ -399,10 +399,10 @@ Perl_class_setup_stash(pTHX_ HV *stash) /* We don't want to make `$self` visible during the expression but we * still need to give it a name. Make it unusable from pure perl */ - PADOFFSET padix = pad_add_name_pvs("$(self)", 0, NULL, NULL); + PADOFFSET padix = pad_add_symbol_pvs (Perl_Symbol_Table_Scalar, "(self)", 0, NULL, NULL); assert(padix == PADIX_SELF); - padix = pad_add_name_pvs("%(params)", 0, NULL, NULL); + padix = pad_add_symbol_pvs (Perl_Symbol_Table_Hash, "(params)", 0, NULL, NULL); assert(padix == PADIX_PARAMS); PERL_UNUSED_VAR(padix); @@ -843,7 +843,7 @@ Perl_class_prepare_method_parse(pTHX_ CV *cv) PADOFFSET padix; - padix = pad_add_name_pvs("$self", 0, NULL, NULL); + padix = pad_add_symbol_pvs (Perl_Symbol_Table_Scalar, "self", 0, NULL, NULL); assert(padix == PADIX_SELF); PERL_UNUSED_VAR(padix); @@ -991,7 +991,7 @@ apply_field_attribute_reader(pTHX_ PADNAME *pn, SV *value) PADOFFSET padix; - padix = pad_add_name_pvs("$self", 0, NULL, NULL); + padix = pad_add_symbol_pvs (Perl_Symbol_Table_Scalar, "self", 0, NULL, NULL); assert(padix == PADIX_SELF); padix = pad_add_symbol_pvn ( From c51ac70d1efa8783b54e5dcd949a702f09fa4010 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Tue, 26 Nov 2024 17:59:26 +0100 Subject: [PATCH 29/41] [pad] pad_add_symbol_pv - pad_add_name_pv alternative with explicit symbol table --- embed.fnc | 6 ++++++ embed.h | 1 + pad.c | 15 +++++++++++++++ proto.h | 6 ++++++ 4 files changed, 28 insertions(+) diff --git a/embed.fnc b/embed.fnc index b54449a54e8c..c80d86fc7255 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2470,6 +2470,12 @@ Adp |PADOFFSET|pad_add_name_sv \ |U32 flags \ |NULLOK HV *typestash \ |NULLOK HV *ourstash +Adp |PADOFFSET|pad_add_symbol_pv \ + |perl_symbol_table_id symbol_table \ + |NN const char *name \ + |const U32 flags \ + |NULLOK HV *typestash \ + |NULLOK HV *ourstash Adp |PADOFFSET|pad_add_symbol_pvn \ |perl_symbol_table_id symbol_table \ |NN const char *namepv \ diff --git a/embed.h b/embed.h index 7d81f71d4e68..e1a0acf65f76 100644 --- a/embed.h +++ b/embed.h @@ -508,6 +508,7 @@ # define pad_add_name_pv(a,b,c,d) Perl_pad_add_name_pv(aTHX_ a,b,c,d) # define pad_add_name_pvn(a,b,c,d,e) Perl_pad_add_name_pvn(aTHX_ a,b,c,d,e) # define pad_add_name_sv(a,b,c,d) Perl_pad_add_name_sv(aTHX_ a,b,c,d) +# define pad_add_symbol_pv(a,b,c,d,e) Perl_pad_add_symbol_pv(aTHX_ a,b,c,d,e) # define pad_add_symbol_pvn(a,b,c,d,e,f) Perl_pad_add_symbol_pvn(aTHX_ a,b,c,d,e,f) # define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) # define pad_findmy_pv(a,b) Perl_pad_findmy_pv(aTHX_ a,b) diff --git a/pad.c b/pad.c index 49229f5616e9..2e400b1678c8 100644 --- a/pad.c +++ b/pad.c @@ -586,6 +586,7 @@ S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash, =for apidoc pad_add_name_pv =for apidoc_item pad_add_name_pvn =for apidoc_item pad_add_name_sv +=for apidoc_item pad_add_symbol_pv =for apidoc_item pad_add_symbol_pvn These each allocate a place in the currently-compiling pad for a named lexical @@ -704,6 +705,20 @@ Perl_pad_add_name_pv(pTHX_ const char *name, return pad_add_symbol_pvn (*name, name + 1, strlen(name) - 1, flags, typestash, ourstash); } +PADOFFSET +Perl_pad_add_symbol_pv( + pTHX_ + perl_symbol_table_id symbol_table, + const char *name, + const U32 flags, + HV *typestash, + HV *ourstash +) +{ + PERL_ARGS_ASSERT_PAD_ADD_SYMBOL_PV; + return pad_add_symbol_pvn (symbol_table, name, strlen(name), flags, typestash, ourstash); +} + PADOFFSET Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash) { diff --git a/proto.h b/proto.h index 84ccd0191ad9..69e7f9f70eeb 100644 --- a/proto.h +++ b/proto.h @@ -3413,6 +3413,12 @@ Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash); assert(name); assert(!typestash || SvTYPE(typestash) == SVt_PVHV); \ assert(!ourstash || SvTYPE(ourstash) == SVt_PVHV) +PERL_CALLCONV PADOFFSET +Perl_pad_add_symbol_pv(pTHX_ perl_symbol_table_id symbol_table, const char *name, const U32 flags, HV *typestash, HV *ourstash); +#define PERL_ARGS_ASSERT_PAD_ADD_SYMBOL_PV \ + assert(name); assert(!typestash || SvTYPE(typestash) == SVt_PVHV); \ + assert(!ourstash || SvTYPE(ourstash) == SVt_PVHV) + PERL_CALLCONV PADOFFSET Perl_pad_add_symbol_pvn(pTHX_ perl_symbol_table_id symbol_table, const char *namepv, STRLEN namelen, U32 flags, HV *typestash, HV *ourstash); #define PERL_ARGS_ASSERT_PAD_ADD_SYMBOL_PVN \ From c37bc9cfc8138e9a53c0aed5679a475c5b74478e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sun, 8 Dec 2024 21:53:23 +0100 Subject: [PATCH 30/41] [pad] pad_add_symbol_sv - pad_add_name_sv alternative with explicit symbol table --- embed.fnc | 6 ++++++ embed.h | 1 + pad.c | 18 ++++++++++++++++++ proto.h | 6 ++++++ 4 files changed, 31 insertions(+) diff --git a/embed.fnc b/embed.fnc index c80d86fc7255..3d4e983c2b60 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2483,6 +2483,12 @@ Adp |PADOFFSET|pad_add_symbol_pvn \ |U32 flags \ |NULLOK HV *typestash \ |NULLOK HV *ourstash +Adp |PADOFFSET|pad_add_symbol_sv \ + |perl_symbol_table_id symbol_table \ + |NN SV *name \ + |U32 flags \ + |NULLOK HV *typestash \ + |NULLOK HV *ourstash p |void |pad_add_weakref|NN CV *func Adpx |PADOFFSET|pad_alloc |I32 optype \ |U32 tmptype diff --git a/embed.h b/embed.h index e1a0acf65f76..31e64027c6ae 100644 --- a/embed.h +++ b/embed.h @@ -510,6 +510,7 @@ # define pad_add_name_sv(a,b,c,d) Perl_pad_add_name_sv(aTHX_ a,b,c,d) # define pad_add_symbol_pv(a,b,c,d,e) Perl_pad_add_symbol_pv(aTHX_ a,b,c,d,e) # define pad_add_symbol_pvn(a,b,c,d,e,f) Perl_pad_add_symbol_pvn(aTHX_ a,b,c,d,e,f) +# define pad_add_symbol_sv(a,b,c,d,e) Perl_pad_add_symbol_sv(aTHX_ a,b,c,d,e) # define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) # define pad_findmy_pv(a,b) Perl_pad_findmy_pv(aTHX_ a,b) # define pad_findmy_pvn(a,b,c) Perl_pad_findmy_pvn(aTHX_ a,b,c) diff --git a/pad.c b/pad.c index 2e400b1678c8..7e0c0e43457c 100644 --- a/pad.c +++ b/pad.c @@ -588,6 +588,7 @@ S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash, =for apidoc_item pad_add_name_sv =for apidoc_item pad_add_symbol_pv =for apidoc_item pad_add_symbol_pvn +=for apidoc_item pad_add_symbol_sv These each allocate a place in the currently-compiling pad for a named lexical variable. They store the name and other metadata in the name part of the @@ -729,6 +730,23 @@ Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash) return pad_add_symbol_pvn (*namepv, namepv + 1, namelen - 1, flags, typestash, ourstash); } +PADOFFSET +Perl_pad_add_symbol_sv ( + pTHX_ + perl_symbol_table_id symbol_table, + SV * name, + U32 flags, + HV * typestash, + HV * ourstash +) +{ + char *namepv; + STRLEN namelen; + PERL_ARGS_ASSERT_PAD_ADD_SYMBOL_SV; + namepv = SvPVutf8(name, namelen); + return pad_add_symbol_pvn (symbol_table, namepv, namelen, flags, typestash, ourstash); +} + /* =for apidoc pad_alloc diff --git a/proto.h b/proto.h index 69e7f9f70eeb..a4f6590a430a 100644 --- a/proto.h +++ b/proto.h @@ -3425,6 +3425,12 @@ Perl_pad_add_symbol_pvn(pTHX_ perl_symbol_table_id symbol_table, const char *nam assert(namepv); assert(!typestash || SvTYPE(typestash) == SVt_PVHV); \ assert(!ourstash || SvTYPE(ourstash) == SVt_PVHV) +PERL_CALLCONV PADOFFSET +Perl_pad_add_symbol_sv(pTHX_ perl_symbol_table_id symbol_table, SV *name, U32 flags, HV *typestash, HV *ourstash); +#define PERL_ARGS_ASSERT_PAD_ADD_SYMBOL_SV \ + assert(name); assert(!typestash || SvTYPE(typestash) == SVt_PVHV); \ + assert(!ourstash || SvTYPE(ourstash) == SVt_PVHV) + PERL_CALLCONV void Perl_pad_add_weakref(pTHX_ CV *func) __attribute__visibility__("hidden"); From f57c569a577fcde22691ebdbf254bdf8e3fb404d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sun, 8 Dec 2024 22:17:50 +0100 Subject: [PATCH 31/41] [pad] pad_add_symbol_sv - replace usage of pad_add_name_sv --- ext/XS-APItest/APItest.xs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 83775d076302..5d0ede52d3e5 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1259,7 +1259,7 @@ static OP *THX_parse_keyword_with_vars(pTHX) croak("unexpected '%c'; expecting an identifier", (int)c); } - varname = newSVpvs("$"); + varname = newSVpvs(""); if (lex_bufutf8()) { SvUTF8_on(varname); } @@ -1272,7 +1272,7 @@ static OP *THX_parse_keyword_with_vars(pTHX) lex_read_unichar(0); } - padoff = pad_add_name_sv(varname, padadd_NO_DUP_CHECK, NULL, NULL); + padoff = pad_add_symbol_sv (Perl_Symbol_Table_Scalar, varname, padadd_NO_DUP_CHECK, NULL, NULL); { OP *my_var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8)); @@ -4674,7 +4674,7 @@ lexical_import(SV *name, CV *cv) SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(pl); SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(pl)[1]; SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad); - off = pad_add_name_sv(sv_2mortal(newSVpvf("&%" SVf,name)), + off = pad_add_symbol_sv (Perl_Symbol_Table_Code, sv_2mortal(newSVpvf("%" SVf,name)), padadd_STATE, 0, 0); SvREFCNT_dec(PL_curpad[off]); PL_curpad[off] = SvREFCNT_inc(cv); From cdb562700a644e7ba8655b1c96e39d885f8bb933 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Wed, 4 Dec 2024 15:34:34 +0100 Subject: [PATCH 32/41] [pad] pad_findlex - make function work with explicit symbol table --- embed.fnc | 3 ++- embed.h | 2 +- pad.c | 42 +++++++++++++++++++++++++++++------------- proto.h | 2 +- 4 files changed, 33 insertions(+), 16 deletions(-) diff --git a/embed.fnc b/embed.fnc index 3d4e983c2b60..157d2e361a02 100644 --- a/embed.fnc +++ b/embed.fnc @@ -4962,7 +4962,8 @@ Sd |PADOFFSET|pad_alloc_name \ Sd |void |pad_check_dup |NN PADNAME *name \ |U32 flags \ |NULLOK const HV *ourstash -Sd |PADOFFSET|pad_findlex |NN const char *namepv \ +Sd |PADOFFSET|pad_findlex |perl_symbol_table_id find_symbol_table \ + |NN const char *namepv \ |STRLEN namelen \ |U32 flags \ |NN const CV *cv \ diff --git a/embed.h b/embed.h index 31e64027c6ae..96e22e0da4b1 100644 --- a/embed.h +++ b/embed.h @@ -1578,7 +1578,7 @@ # if defined(PERL_IN_PAD_C) # define pad_alloc_name(a,b,c,d) S_pad_alloc_name(aTHX_ a,b,c,d) # define pad_check_dup(a,b,c) S_pad_check_dup(aTHX_ a,b,c) -# define pad_findlex(a,b,c,d,e,f,g,h,i) S_pad_findlex(aTHX_ a,b,c,d,e,f,g,h,i) +# define pad_findlex(a,b,c,d,e,f,g,h,i,j) S_pad_findlex(aTHX_ a,b,c,d,e,f,g,h,i,j) # define pad_reset() S_pad_reset(aTHX) # if defined(DEBUGGING) # define cv_dump(a,b) S_cv_dump(aTHX_ a,b) diff --git a/pad.c b/pad.c index 7e0c0e43457c..685250c8f7d3 100644 --- a/pad.c +++ b/pad.c @@ -1057,7 +1057,7 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) if (!PL_compcv) return NOT_IN_PAD; - offset = pad_findlex(namepv, namelen, flags, + offset = pad_findlex (*namepv, namepv + 1, namelen - 1, flags, PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags); if (offset != NOT_IN_PAD) return offset; @@ -1160,8 +1160,19 @@ S_unavailable(pTHX_ PADNAME *name) } STATIC PADOFFSET -S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq, - int warn, SV** out_capture, PADNAME** out_name, int *out_flags) +S_pad_findlex( + pTHX_ + perl_symbol_table_id find_symbol_table, + const char * namepv, + STRLEN namelen, + U32 flags, + const CV * cv, + U32 seq, + int warn, + SV ** out_capture, + PADNAME ** out_name, + int * out_flags +) { PADOFFSET offset, new_offset; SV *new_capture; @@ -1180,8 +1191,8 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, *out_flags = 0; DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n", - PTR2UV(cv), (int)namelen, namepv, (int)seq, + "Pad findlex cv=0x%" UVxf " searching \"%c%.*s\" seq=%d%s\n", + PTR2UV(cv), find_symbol_table, (int)namelen, namepv, (int)seq, out_capture ? " capturing" : "" )); /* first, search this pad */ @@ -1193,9 +1204,13 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) { const PADNAME * const name = name_p[offset]; - if (name && PadnameLEN(name) == namelen - && ( PadnamePV(name) == namepv - || memEQ(PadnamePV(name), namepv, namelen) )) + if (Padname_Is_Symbol (name) + && Padname_Symbol_Table (name) == find_symbol_table + && Padname_Symbol_Name_Length (name) == namelen + && ( + Padname_Symbol_Name (name) == namepv + || memEQ(Padname_Symbol_Name (name), namepv, namelen) + )) { if (PadnameOUTER(name)) { fake_offset = offset; /* in case we don't find a real one */ @@ -1276,8 +1291,9 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, /* diag_listed_as: Variable "%s" will not stay shared */ Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "%s \"%" UTF8f "\" will not stay shared", - Perl_Symbol_Table_Title_ucfirst (*namepv), + "%s \"%c%" UTF8f "\" will not stay shared", + Perl_Symbol_Table_Title_ucfirst (find_symbol_table), + Perl_Symbol_Table_To_Sigil (find_symbol_table), UTF8fARG(1, namelen, namepv)); } @@ -1290,7 +1306,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n", PTR2UV(cv))); n = *out_name; - (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), + (void) pad_findlex (find_symbol_table, namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), newwarn, out_capture, out_name, out_flags); *out_name = n; @@ -1314,7 +1330,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, } if (!*out_capture) { if (namelen != 0) { - switch (*namepv) { + switch (find_symbol_table) { case Perl_Symbol_Table_Array: *out_capture = newSV_type_mortal(SVt_PVAV); break; @@ -1351,7 +1367,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, if(CvIsMETHOD(cv)) recurse_flags |= padfind_FIELD_OK; - offset = pad_findlex(namepv, namelen, recurse_flags, + offset = pad_findlex (find_symbol_table, namepv, namelen, recurse_flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1, new_capturep, out_name, out_flags); if (offset == NOT_IN_PAD) diff --git a/proto.h b/proto.h index a4f6590a430a..3ca0a577c48f 100644 --- a/proto.h +++ b/proto.h @@ -7555,7 +7555,7 @@ S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash); assert(name) STATIC PADOFFSET -S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV *cv, U32 seq, int warn, SV **out_capture, PADNAME **out_name, int *out_flags); +S_pad_findlex(pTHX_ perl_symbol_table_id find_symbol_table, const char *namepv, STRLEN namelen, U32 flags, const CV *cv, U32 seq, int warn, SV **out_capture, PADNAME **out_name, int *out_flags); # define PERL_ARGS_ASSERT_PAD_FINDLEX \ assert(namepv); assert(cv); assert(out_name); assert(out_flags) From 0d38172800997bb9af90a45ba3f0dd9b6e3f0afb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Thu, 28 Nov 2024 08:21:46 +0100 Subject: [PATCH 33/41] [XS-APItest] [pad_scalar] Export tested function id as constant to improve readability of what is actually tested --- ext/XS-APItest/APItest.xs | 29 +++++++++-- ext/XS-APItest/t/fetch_pad_names.t | 38 ++++++++------ ext/XS-APItest/t/pad_scalar.t | 80 ++++++++++++++++-------------- 3 files changed, 91 insertions(+), 56 deletions(-) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 5d0ede52d3e5..839a3a27c407 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -786,6 +786,13 @@ THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC)); } +enum Pad_Find_Method { + PAD_FINDMY_SV = 1, + PAD_FINDMY_PVN = 2, + PAD_FINDMY_PV = 3, + PAD_FINDMY_FOO = 4, +}; + STATIC OP * THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) { @@ -802,12 +809,12 @@ THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) a0 = cSVOPx_sv(argop); a1 = cSVOPx_sv(OpSIBLING(argop)); switch(SvIV(a0)) { - case 1: { + case PAD_FINDMY_SV: { SV *namesv = sv_2mortal(newSVpvs("$")); sv_catsv(namesv, a1); padoff = pad_findmy_sv(namesv, 0); } break; - case 2: { + case PAD_FINDMY_PVN: { char *namepv; STRLEN namelen; SV *namesv = sv_2mortal(newSVpvs("$")); @@ -815,14 +822,14 @@ THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) namepv = SvPV(namesv, namelen); padoff = pad_findmy_pvn(namepv, namelen, SvUTF8(namesv)); } break; - case 3: { + case PAD_FINDMY_PV: { char *namepv; SV *namesv = sv_2mortal(newSVpvs("$")); sv_catsv(namesv, a1); namepv = SvPV_nolen(namesv); padoff = pad_findmy_pv(namepv, SvUTF8(namesv)); } break; - case 4: { + case PAD_FINDMY_FOO: { padoff = pad_findmy_pvs("$foo", 0); } break; default: croak("bad type value for pad_scalar()"); @@ -4348,6 +4355,19 @@ OUTPUT: RETVAL +#define EXPORT_ENUM(Stash, Name) \ + newCONSTSUB(Stash, #Name, newSViv(Name)) + +BOOT: +{ + HV *stash = gv_stashpv("XS::APItest", TRUE); + + EXPORT_ENUM (stash, PAD_FINDMY_PV); + EXPORT_ENUM (stash, PAD_FINDMY_PVN); + EXPORT_ENUM (stash, PAD_FINDMY_FOO); + EXPORT_ENUM (stash, PAD_FINDMY_SV); +} + BOOT: { HV* stash; @@ -4360,6 +4380,7 @@ BOOT: croak("lost method 'make_temp_mg_lv'"); cv = GvCV(*meth); CvLVALUE_on(cv); + } BOOT: diff --git a/ext/XS-APItest/t/fetch_pad_names.t b/ext/XS-APItest/t/fetch_pad_names.t index 7670e9b3afa7..22f163ce4d96 100644 --- a/ext/XS-APItest/t/fetch_pad_names.t +++ b/ext/XS-APItest/t/fetch_pad_names.t @@ -12,7 +12,7 @@ else { plan tests => 77; } -use XS::APItest qw( fetch_pad_names pad_scalar ); +use XS::APItest qw( fetch_pad_names pad_scalar PAD_FINDMY_SV ); local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /Wide character in print at/ }; @@ -34,7 +34,11 @@ $cv = sub { my $zest = 'invariant'; my $zèst = 'latin-1'; - return [pad_scalar(1, "zèst"), pad_scalar(1, "z\350st"), pad_scalar(1, "z\303\250st")]; + return [ + pad_scalar (PAD_FINDMY_SV, "zèst"), + pad_scalar (PAD_FINDMY_SV, "z\350st"), + pad_scalar (PAD_FINDMY_SV, "z\303\250st"), + ]; }; my $names_av = fetch_pad_names($cv); @@ -65,7 +69,11 @@ $cv = do { sub { use utf8; my $партнеры = $ascii; - return [$партнеры, pad_scalar(1, "партнеры"), pad_scalar(1, "\320\277\320\260\321\200\321\202\320\275\320\265\321\200\321\213")]; + return [ + $партнеры, + pad_scalar (PAD_FINDMY_SV, "партнеры"), + pad_scalar (PAD_FINDMY_SV, "\320\277\320\260\321\200\321\202\320\275\320\265\321\200\321\213"), + ]; }; }; @@ -109,7 +117,7 @@ $cv = eval <<"END"; use utf8; my \$Leon = 'Invariant'; my $leon1 = 'Latin-1'; - return [ \$Leon, $leon1, $leon2, pad_scalar(1, "L\x{e9}on"), pad_scalar(1, "L\x{c3}\x{a9}on")]; + return [ \$Leon, $leon1, $leon2, pad_scalar(PAD_FINDMY_SV, "L\x{e9}on"), pad_scalar(PAD_FINDMY_SV, "L\x{c3}\x{a9}on")]; }; END @@ -225,10 +233,10 @@ $cv = sub { return [ $tèst, - pad_scalar(1, "tèst"), #"UTF-8" - pad_scalar(1, "t\350st"), #"Latin-1" - pad_scalar(1, "t\x{c3}\x{a8}st"), #"Octal" - pad_scalar(1, test()), #'UTF-8 enc' + pad_scalar (PAD_FINDMY_SV, "tèst"), #"UTF-8" + pad_scalar (PAD_FINDMY_SV, "t\350st"), #"Latin-1" + pad_scalar (PAD_FINDMY_SV, "t\x{c3}\x{a8}st"), #"Octal" + pad_scalar (PAD_FINDMY_SV, test()), #'UTF-8 enc' ]; }; @@ -261,12 +269,12 @@ $cv = do { return [ $ニコニコ, $にこにこ, - pad_scalar(1, "にこにこ"), - pad_scalar(1, "\x{306b}\x{3053}\x{306b}\x{3053}"), - pad_scalar(1, "\343\201\253\343\201\223\343\201\253\343\201\223"), - pad_scalar(1, "ニコニコ"), - pad_scalar(1, "\x{30cb}\x{30b3}\x{30cb}\x{30b3}"), - pad_scalar(1, "\343\203\213\343\202\263\343\203\213\343\202\263"), + pad_scalar (PAD_FINDMY_SV, "にこにこ"), + pad_scalar (PAD_FINDMY_SV, "\x{306b}\x{3053}\x{306b}\x{3053}"), + pad_scalar (PAD_FINDMY_SV, "\343\201\253\343\201\223\343\201\253\343\201\223"), + pad_scalar (PAD_FINDMY_SV, "ニコニコ"), + pad_scalar (PAD_FINDMY_SV, "\x{30cb}\x{30b3}\x{30cb}\x{30b3}"), + pad_scalar (PAD_FINDMY_SV, "\343\203\213\343\202\263\343\203\213\343\202\263"), ]; } }; @@ -302,7 +310,7 @@ general_tests( $cv->(), $names_av, { use constant utf8_e => $utf8_e; } my $e = 'Invariant'; - is pad_scalar(1, "e"), pad_scalar(1, utf8_e), 'Fetches the same thing, even if invariant but with differing utf8ness.'; + is pad_scalar (PAD_FINDMY_SV, "e"), pad_scalar (PAD_FINDMY_SV, utf8_e), 'Fetches the same thing, even if invariant but with differing utf8ness.'; } diff --git a/ext/XS-APItest/t/pad_scalar.t b/ext/XS-APItest/t/pad_scalar.t index 52c8812c6ba3..ebfdfe083cc6 100644 --- a/ext/XS-APItest/t/pad_scalar.t +++ b/ext/XS-APItest/t/pad_scalar.t @@ -3,39 +3,45 @@ use strict; use Test::More tests => 76; -use XS::APItest qw(pad_scalar); +use XS::APItest qw ( + PAD_FINDMY_FOO + PAD_FINDMY_PV + PAD_FINDMY_PVN + PAD_FINDMY_SV + pad_scalar +); -is pad_scalar(1, "foo"), "NOT_IN_PAD"; -is pad_scalar(2, "foo"), "NOT_IN_PAD"; -is pad_scalar(3, "foo"), "NOT_IN_PAD"; -is pad_scalar(4, "foo"), "NOT_IN_PAD"; -is pad_scalar(1, "bar"), "NOT_IN_PAD"; -is pad_scalar(2, "bar"), "NOT_IN_PAD"; -is pad_scalar(3, "bar"), "NOT_IN_PAD"; +is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_IN_PAD"; +is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_IN_PAD"; +is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_IN_PAD"; +is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_IN_PAD"; +is pad_scalar (PAD_FINDMY_SV, "bar"), "NOT_IN_PAD"; +is pad_scalar (PAD_FINDMY_PVN, "bar"), "NOT_IN_PAD"; +is pad_scalar (PAD_FINDMY_PV, "bar"), "NOT_IN_PAD"; our $foo = "wibble"; my $bar = "wobble"; -is pad_scalar(1, "foo"), "NOT_MY"; -is pad_scalar(2, "foo"), "NOT_MY"; -is pad_scalar(3, "foo"), "NOT_MY"; -is pad_scalar(4, "foo"), "NOT_MY"; -is pad_scalar(1, "bar"), "wobble"; -is pad_scalar(2, "bar"), "wobble"; -is pad_scalar(3, "bar"), "wobble"; +is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY"; +is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY"; +is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY"; +is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY"; +is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble"; +is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble"; +is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble"; sub aa($); sub aa($) { my $xyz; - ok \pad_scalar(1, "xyz") == \$xyz; - ok \pad_scalar(2, "xyz") == \$xyz; - ok \pad_scalar(3, "xyz") == \$xyz; + ok \pad_scalar (PAD_FINDMY_SV, "xyz") == \$xyz; + ok \pad_scalar (PAD_FINDMY_PVN, "xyz") == \$xyz; + ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz; aa(0) if $_[0]; - ok \pad_scalar(1, "xyz") == \$xyz; - ok \pad_scalar(2, "xyz") == \$xyz; - ok \pad_scalar(3, "xyz") == \$xyz; - is pad_scalar(1, "bar"), "wobble"; - is pad_scalar(2, "bar"), "wobble"; - is pad_scalar(3, "bar"), "wobble"; + ok \pad_scalar (PAD_FINDMY_SV, "xyz") == \$xyz; + ok \pad_scalar (PAD_FINDMY_PVN, "xyz") == \$xyz; + ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz; + is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble"; + is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble"; + is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble"; } aa(1); @@ -43,16 +49,16 @@ sub bb() { my $counter = 0; my $foo = \$counter; return sub { - ok pad_scalar(1, "foo") == \pad_scalar(1, "counter"); - ok pad_scalar(2, "foo") == \pad_scalar(1, "counter"); - ok pad_scalar(3, "foo") == \pad_scalar(1, "counter"); - ok pad_scalar(4, "foo") == \pad_scalar(1, "counter"); - if(pad_scalar(1, "counter") % 3 == 0) { - return pad_scalar(1, "counter")++; - } elsif(pad_scalar(1, "counter") % 3 == 0) { - return pad_scalar(2, "counter")++; + ok pad_scalar (PAD_FINDMY_SV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_PVN, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_PV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_FOO, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + if(pad_scalar (PAD_FINDMY_SV, "counter") % 3 == 0) { + return pad_scalar (PAD_FINDMY_SV, "counter")++; + } elsif(pad_scalar (PAD_FINDMY_SV, "counter") % 3 == 0) { + return pad_scalar (PAD_FINDMY_PVN, "counter")++; } else { - return pad_scalar(3, "counter")++; + return pad_scalar (PAD_FINDMY_PV, "counter")++; } }; } @@ -67,9 +73,9 @@ is $b->(), 1; is $a->(), 4; is $b->(), 2; -is pad_scalar(1, "foo"), "NOT_MY"; -is pad_scalar(2, "foo"), "NOT_MY"; -is pad_scalar(3, "foo"), "NOT_MY"; -is pad_scalar(4, "foo"), "NOT_MY"; +is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY"; +is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY"; +is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY"; +is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY"; 1; From db133fce0da76851321bd89bab47301c4c00494b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sun, 8 Dec 2024 20:12:25 +0100 Subject: [PATCH 34/41] [XS-APItest] [pad_scalar] Possible bug fix There were two instances of same condition. From code looking like 3-state dispatch I guess it was meant to be `1` --- ext/XS-APItest/t/pad_scalar.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ext/XS-APItest/t/pad_scalar.t b/ext/XS-APItest/t/pad_scalar.t index ebfdfe083cc6..b8bd805e55cb 100644 --- a/ext/XS-APItest/t/pad_scalar.t +++ b/ext/XS-APItest/t/pad_scalar.t @@ -55,7 +55,7 @@ sub bb() { ok pad_scalar (PAD_FINDMY_FOO, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); if(pad_scalar (PAD_FINDMY_SV, "counter") % 3 == 0) { return pad_scalar (PAD_FINDMY_SV, "counter")++; - } elsif(pad_scalar (PAD_FINDMY_SV, "counter") % 3 == 0) { + } elsif(pad_scalar (PAD_FINDMY_SV, "counter") % 3 == 1) { return pad_scalar (PAD_FINDMY_PVN, "counter")++; } else { return pad_scalar (PAD_FINDMY_PV, "counter")++; From 9520792f93876018c1df6243fb27b01ade0c69db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sun, 8 Dec 2024 20:28:02 +0100 Subject: [PATCH 35/41] [XS-APItest] [pad_scalar] Add few assert messages to express what is tested --- ext/XS-APItest/t/pad_scalar.t | 78 ++++++++++++++++++++--------------- 1 file changed, 45 insertions(+), 33 deletions(-) diff --git a/ext/XS-APItest/t/pad_scalar.t b/ext/XS-APItest/t/pad_scalar.t index b8bd805e55cb..f4f36acc2d44 100644 --- a/ext/XS-APItest/t/pad_scalar.t +++ b/ext/XS-APItest/t/pad_scalar.t @@ -1,7 +1,7 @@ use warnings; use strict; -use Test::More tests => 76; +use Test::More tests => 73; use XS::APItest qw ( PAD_FINDMY_FOO @@ -11,48 +11,60 @@ use XS::APItest qw ( pad_scalar ); -is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_IN_PAD"; -is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_IN_PAD"; -is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_IN_PAD"; -is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_IN_PAD"; -is pad_scalar (PAD_FINDMY_SV, "bar"), "NOT_IN_PAD"; -is pad_scalar (PAD_FINDMY_PVN, "bar"), "NOT_IN_PAD"; -is pad_scalar (PAD_FINDMY_PV, "bar"), "NOT_IN_PAD"; +is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_sv ()); +is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pvn ()); +is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pv ()); +is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pvs ()); + +is pad_scalar (PAD_FINDMY_SV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; using pad_findmy_sv ()); +is pad_scalar (PAD_FINDMY_PVN, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; using pad_findmy_pvn ()); +is pad_scalar (PAD_FINDMY_PV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; using pad_findmy_pv ()); our $foo = "wibble"; my $bar = "wobble"; -is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY"; -is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY"; -is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY"; -is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY"; -is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble"; -is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble"; -is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble"; +is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_sv ()); +is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pvn ()); +is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pv ()); +is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pvs ()); + +is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble", q ('my $bar'; pad_findmy_sv ()); +is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble", q ('my $bar'; pad_findmy_pvn ()); +is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble", q ('my $bar'; pad_findmy_pv ()); sub aa($); sub aa($) { my $xyz; - ok \pad_scalar (PAD_FINDMY_SV, "xyz") == \$xyz; - ok \pad_scalar (PAD_FINDMY_PVN, "xyz") == \$xyz; - ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz; - aa(0) if $_[0]; - ok \pad_scalar (PAD_FINDMY_SV, "xyz") == \$xyz; - ok \pad_scalar (PAD_FINDMY_PVN, "xyz") == \$xyz; - ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz; - is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble"; - is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble"; - is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble"; + my $prefix = $_[0] + ? '' + : '(recursive call) ' + ; + + ok \pad_scalar (PAD_FINDMY_SV, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_sv ()); + ok \pad_scalar (PAD_FINDMY_PVN, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_pvn ()); + ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_pv ()); + + if ($_[0]) { + aa(0); # recursive call + ok \pad_scalar (PAD_FINDMY_SV, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_sv ()); + ok \pad_scalar (PAD_FINDMY_PVN, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_pvn ()); + ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_pv ()); + } + + is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_sv ()); + is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_pvn ()); + is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_pv ()); } + aa(1); sub bb() { my $counter = 0; my $foo = \$counter; return sub { - ok pad_scalar (PAD_FINDMY_SV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_PVN, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_PV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_FOO, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_SV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_PVN, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_PV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_FOO, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); if(pad_scalar (PAD_FINDMY_SV, "counter") % 3 == 0) { return pad_scalar (PAD_FINDMY_SV, "counter")++; } elsif(pad_scalar (PAD_FINDMY_SV, "counter") % 3 == 1) { @@ -73,9 +85,9 @@ is $b->(), 1; is $a->(), 4; is $b->(), 2; -is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY"; -is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY"; -is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY"; -is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY"; +is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_sv ()); +is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pvn ()); +is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pv ()); +is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pvs ()); 1; From 328acf2152dad6f9cf89fa46ed3851ad28570bc3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sun, 8 Dec 2024 19:29:52 +0100 Subject: [PATCH 36/41] [pad] pad_find_my_symbol_pvn - pad_findmy_pvn alternative with explicit symbol table --- embed.fnc | 5 ++ embed.h | 1 + ext/XS-APItest/APItest.xs | 19 +++++-- ext/XS-APItest/t/pad_scalar.t | 99 +++++++++++++++++++++-------------- pad.c | 39 +++++++++++--- proto.h | 5 ++ 6 files changed, 117 insertions(+), 51 deletions(-) diff --git a/embed.fnc b/embed.fnc index 157d2e361a02..4add1a78adfc 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2501,6 +2501,11 @@ Adp |PADOFFSET|pad_findmy_pvn \ |U32 flags Adp |PADOFFSET|pad_findmy_sv|NN SV *name \ |U32 flags +Adp |PADOFFSET|pad_find_my_symbol_pvn \ + |perl_symbol_table_id find_symbol_table \ + |NN const char *namepv \ + |STRLEN namelen \ + |U32 flags dp |void |pad_fixup_inner_anons \ |NN PADLIST *padlist \ |NN CV *old_cv \ diff --git a/embed.h b/embed.h index 96e22e0da4b1..81c3f80caaff 100644 --- a/embed.h +++ b/embed.h @@ -512,6 +512,7 @@ # define pad_add_symbol_pvn(a,b,c,d,e,f) Perl_pad_add_symbol_pvn(aTHX_ a,b,c,d,e,f) # define pad_add_symbol_sv(a,b,c,d,e) Perl_pad_add_symbol_sv(aTHX_ a,b,c,d,e) # define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) +# define pad_find_my_symbol_pvn(a,b,c,d) Perl_pad_find_my_symbol_pvn(aTHX_ a,b,c,d) # define pad_findmy_pv(a,b) Perl_pad_findmy_pv(aTHX_ a,b) # define pad_findmy_pvn(a,b,c) Perl_pad_findmy_pvn(aTHX_ a,b,c) # define pad_findmy_sv(a,b) Perl_pad_findmy_sv(aTHX_ a,b) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 839a3a27c407..45d441116254 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -787,10 +787,11 @@ THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) } enum Pad_Find_Method { - PAD_FINDMY_SV = 1, - PAD_FINDMY_PVN = 2, - PAD_FINDMY_PV = 3, - PAD_FINDMY_FOO = 4, + PAD_FINDMY_FOO, + PAD_FINDMY_PV, + PAD_FINDMY_PVN, + PAD_FINDMY_SV, + PAD_FIND_MY_SYMBOL_PVN, }; STATIC OP * @@ -832,6 +833,13 @@ THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) case PAD_FINDMY_FOO: { padoff = pad_findmy_pvs("$foo", 0); } break; + case PAD_FIND_MY_SYMBOL_PVN: { + char *namepv; + STRLEN namelen; + namepv = SvPV(a1, namelen); + padoff = pad_find_my_symbol_pvn (Perl_Symbol_Table_Scalar, namepv, namelen, SvUTF8(a1)); + break; + } default: croak("bad type value for pad_scalar()"); } op_free(entersubop); @@ -4362,10 +4370,11 @@ BOOT: { HV *stash = gv_stashpv("XS::APItest", TRUE); + EXPORT_ENUM (stash, PAD_FINDMY_FOO); EXPORT_ENUM (stash, PAD_FINDMY_PV); EXPORT_ENUM (stash, PAD_FINDMY_PVN); - EXPORT_ENUM (stash, PAD_FINDMY_FOO); EXPORT_ENUM (stash, PAD_FINDMY_SV); + EXPORT_ENUM (stash, PAD_FIND_MY_SYMBOL_PVN); } BOOT: diff --git a/ext/XS-APItest/t/pad_scalar.t b/ext/XS-APItest/t/pad_scalar.t index f4f36acc2d44..c110c0b2b9e4 100644 --- a/ext/XS-APItest/t/pad_scalar.t +++ b/ext/XS-APItest/t/pad_scalar.t @@ -1,35 +1,40 @@ use warnings; use strict; -use Test::More tests => 73; +use Test::More tests => 92; use XS::APItest qw ( PAD_FINDMY_FOO PAD_FINDMY_PV PAD_FINDMY_PVN PAD_FINDMY_SV + PAD_FIND_MY_SYMBOL_PVN pad_scalar ); -is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_sv ()); -is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pvn ()); -is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pv ()); -is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pvs ()); +is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_sv ()); +is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pvn ()); +is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pv ()); +is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pvs ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_find_my_symbol_pvn ()); -is pad_scalar (PAD_FINDMY_SV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; using pad_findmy_sv ()); -is pad_scalar (PAD_FINDMY_PVN, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; using pad_findmy_pvn ()); -is pad_scalar (PAD_FINDMY_PV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; using pad_findmy_pv ()); +is pad_scalar (PAD_FINDMY_SV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_findmy_sv ()); +is pad_scalar (PAD_FINDMY_PVN, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_findmy_pvn ()); +is pad_scalar (PAD_FINDMY_PV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_findmy_pv ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_find_my_symbol_pvn ()); our $foo = "wibble"; my $bar = "wobble"; -is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_sv ()); -is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pvn ()); -is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pv ()); -is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pvs ()); +is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_sv ()); +is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pvn ()); +is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pv ()); +is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pvs ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo"), "NOT_MY", q ('our $foo'; pad_find_my_symbol_pvn ()); -is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble", q ('my $bar'; pad_findmy_sv ()); -is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble", q ('my $bar'; pad_findmy_pvn ()); -is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble", q ('my $bar'; pad_findmy_pv ()); +is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble", q ('my $bar'; pad_findmy_sv ()); +is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble", q ('my $bar'; pad_findmy_pvn ()); +is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble", q ('my $bar'; pad_findmy_pv ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "bar"), "wobble", q ('my $bar'; pad_find_my_symbol_pvn ()); sub aa($); sub aa($) { @@ -39,39 +44,52 @@ sub aa($) { : '(recursive call) ' ; - ok \pad_scalar (PAD_FINDMY_SV, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_sv ()); - ok \pad_scalar (PAD_FINDMY_PVN, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_pvn ()); - ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_pv ()); + ok \pad_scalar (PAD_FINDMY_SV, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_sv ()); + ok \pad_scalar (PAD_FINDMY_PVN, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_pvn ()); + ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_pv ()); + ok \pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "xyz") == \$xyz, $prefix . q (private variable; pad_find_my_symbol_pvn ()); if ($_[0]) { aa(0); # recursive call - ok \pad_scalar (PAD_FINDMY_SV, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_sv ()); - ok \pad_scalar (PAD_FINDMY_PVN, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_pvn ()); - ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_pv ()); + ok \pad_scalar (PAD_FINDMY_SV, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_sv ()); + ok \pad_scalar (PAD_FINDMY_PVN, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_pvn ()); + ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_pv ()); + ok \pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "xyz") == \$xyz, q (private variable (after recursive call); pad_find_my_symbol_pvn ()); } - is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_sv ()); - is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_pvn ()); - is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_pv ()); + is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_sv ()); + is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_pvn ()); + is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_pv ()); + is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_find_my_symbol_pvn ()); } aa(1); +my $all_increment_called = 0; + sub bb() { my $counter = 0; my $foo = \$counter; return sub { - ok pad_scalar (PAD_FINDMY_SV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_PVN, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_PV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_FOO, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - if(pad_scalar (PAD_FINDMY_SV, "counter") % 3 == 0) { - return pad_scalar (PAD_FINDMY_SV, "counter")++; - } elsif(pad_scalar (PAD_FINDMY_SV, "counter") % 3 == 1) { - return pad_scalar (PAD_FINDMY_PVN, "counter")++; - } else { - return pad_scalar (PAD_FINDMY_PV, "counter")++; - } + ok pad_scalar (PAD_FINDMY_SV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_PVN, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_PV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_FOO, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + + my $modulus = pad_scalar (PAD_FINDMY_SV, "counter") % 4; + + return pad_scalar (PAD_FINDMY_SV, "counter")++ + if $modulus == 0; + + return pad_scalar (PAD_FINDMY_PVN, "counter")++ + if $modulus == 1; + + return pad_scalar (PAD_FINDMY_PV, "counter")++ + if $modulus == 2; + + $all_increment_called = 1; + return pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "counter")++; }; } my $a = bb(); @@ -85,9 +103,12 @@ is $b->(), 1; is $a->(), 4; is $b->(), 2; -is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_sv ()); -is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pvn ()); -is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pv ()); -is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pvs ()); +ok $all_increment_called, q (all pad scalar methods called for increment); + +is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_sv ()); +is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pvn ()); +is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pv ()); +is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pvs ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_find_my_symbol_pvn ()); 1; diff --git a/pad.c b/pad.c index 685250c8f7d3..b1c6267239ba 100644 --- a/pad.c +++ b/pad.c @@ -1035,11 +1035,35 @@ C is reserved and must be zero. =for apidoc Amnh||NOT_IN_PAD +=for apidoc pad_find_my_symbol_pvn + +Similar to C but with explicit symbol table parameter. + +Difference: + + pad_findmy_pvn ("$self", 5, 0); + + pad_find_my_symbol_pvn (Perl_Symbol_Scalar, "self", 5); + =cut */ PADOFFSET Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) +{ + PERL_ARGS_ASSERT_PAD_FINDMY_PVN; + + return pad_find_my_symbol_pvn (*namepv, namepv + 1, namelen - 1, flags); +} + +PADOFFSET +Perl_pad_find_my_symbol_pvn( + pTHX_ + perl_symbol_table_id find_symbol_table, + const char * namepv, + STRLEN namelen, + U32 flags +) { PADNAME *out_pn; int out_flags; @@ -1047,24 +1071,24 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) const PADNAMELIST *namelist; PADNAME **name_p; - PERL_ARGS_ASSERT_PAD_FINDMY_PVN; + PERL_ARGS_ASSERT_PAD_FIND_MY_SYMBOL_PVN; if (flags) - Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf, + Perl_croak(aTHX_ "panic: pad_find_my_symbol_pvn illegal flag bits 0x%" UVxf, (UV)flags); /* compilation errors can zero PL_compcv */ if (!PL_compcv) return NOT_IN_PAD; - offset = pad_findlex (*namepv, namepv + 1, namelen - 1, flags, + offset = pad_findlex (find_symbol_table, namepv, namelen, flags, PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags); if (offset != NOT_IN_PAD) return offset; /* Skip the ‘our’ hack for subroutines, as the warning does not apply. */ - if (*namepv == Perl_Symbol_Table_Code) return NOT_IN_PAD; + if (find_symbol_table == Perl_Symbol_Table_Code) return NOT_IN_PAD; /* look for an our that's being introduced; this allows * our $foo = 0 unless defined $foo; @@ -1074,11 +1098,12 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) name_p = PadnamelistARRAY(namelist); for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) { const PADNAME * const name = name_p[offset]; - if (name && PadnameLEN(name) == namelen + if (Padname_Is_Symbol (name) + && Padname_Symbol_Name_Length (name) == namelen && !PadnameOUTER(name) && (PadnameIsOUR(name)) - && ( PadnamePV(name) == namepv - || memEQ(PadnamePV(name), namepv, namelen) ) + && ( Padname_Symbol_Name (name) == namepv + || memEQ(Padname_Symbol_Name (name), namepv, namelen) ) && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO ) return offset; diff --git a/proto.h b/proto.h index 3ca0a577c48f..43f6c9904598 100644 --- a/proto.h +++ b/proto.h @@ -3447,6 +3447,11 @@ Perl_pad_block_start(pTHX_ int full) __attribute__visibility__("hidden"); #define PERL_ARGS_ASSERT_PAD_BLOCK_START +PERL_CALLCONV PADOFFSET +Perl_pad_find_my_symbol_pvn(pTHX_ perl_symbol_table_id find_symbol_table, const char *namepv, STRLEN namelen, U32 flags); +#define PERL_ARGS_ASSERT_PAD_FIND_MY_SYMBOL_PVN \ + assert(namepv) + PERL_CALLCONV PADOFFSET Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags); #define PERL_ARGS_ASSERT_PAD_FINDMY_PV \ From 543056c74443c70ef31822fcf66e09ea9f2c5748 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Thu, 28 Nov 2024 07:42:37 +0100 Subject: [PATCH 37/41] [pad] pad_find_my_symbol_pvn - replace usage of pad_findmy_pvn --- op.c | 6 +----- pad.c | 4 ++-- toke.c | 19 ++++++------------- 3 files changed, 9 insertions(+), 20 deletions(-) diff --git a/op.c b/op.c index 8183d0e82891..00b0c480bc50 100644 --- a/op.c +++ b/op.c @@ -13973,14 +13973,10 @@ Perl_ck_sort(pTHX_ OP *o) } else if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) { - char tmpbuf[256]; STRLEN len; PADOFFSET off; const char * const name = SvPV(kSVOP_sv, len); - *tmpbuf = '&'; - assert (len < 256); - Copy(name, tmpbuf+1, len, char); - off = pad_findmy_pvn(tmpbuf, len+1, 0); + off = pad_find_my_symbol_pvn (Perl_Symbol_Table_Code, name, len, 0); if (off != NOT_IN_PAD) { if (PAD_COMPNAME_FLAGS_isOUR(off)) { SV * const fq = diff --git a/pad.c b/pad.c index b1c6267239ba..8396121d5809 100644 --- a/pad.c +++ b/pad.c @@ -1115,7 +1115,7 @@ PADOFFSET Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags) { PERL_ARGS_ASSERT_PAD_FINDMY_PV; - return pad_findmy_pvn(name, strlen(name), flags); + return pad_find_my_symbol_pvn (*name, name + 1, strlen(name) - 1, flags); } PADOFFSET @@ -1125,7 +1125,7 @@ Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags) STRLEN namelen; PERL_ARGS_ASSERT_PAD_FINDMY_SV; namepv = SvPVutf8(name, namelen); - return pad_findmy_pvn(namepv, namelen, flags); + return pad_find_my_symbol_pvn (*namepv, namepv + 1, namelen - 1, flags); } /* diff --git a/toke.c b/toke.c index 3a078123dcd4..59a7d544094c 100644 --- a/toke.c +++ b/toke.c @@ -5558,8 +5558,8 @@ yyl_sub(pTHX_ char *s, const int key) format_name = S_newSV_maybe_utf8(aTHX_ s, d - s); *PL_tokenbuf = '&'; if (memchr(tmpbuf, ':', len) || key != KEY_sub - || pad_findmy_pvn( - PL_tokenbuf, len + 1, 0 + || pad_find_my_symbol_pvn ( + Perl_Symbol_Table_Code, PL_tokenbuf + 1, len, 0 ) != NOT_IN_PAD) sv_setpvn(PL_subname, tmpbuf, len); else { @@ -9001,10 +9001,7 @@ yyl_keylookup(pTHX_ char *s, GV *gv) /* Check for lexical sub */ if (PL_expect != XOPERATOR) { - char tmpbuf[sizeof PL_tokenbuf + 1]; - *tmpbuf = '&'; - Copy(PL_tokenbuf, tmpbuf+1, len, char); - c.off = pad_findmy_pvn(tmpbuf, len+1, 0); + c.off = pad_find_my_symbol_pvn (Perl_Symbol_Table_Code, PL_tokenbuf, len, 0); if (c.off != NOT_IN_PAD) { assert(c.off); /* we assume this is boolean-true below */ if (PAD_COMPNAME_FLAGS_isOUR(c.off)) { @@ -9985,8 +9982,7 @@ S_pending_ident(pTHX) if (!has_colon) { if (!PL_in_my) - tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len, - 0); + tmp = pad_find_my_symbol_pvn (*PL_tokenbuf, PL_tokenbuf + 1, tokenbuf_len - 1, 0); if (tmp != NOT_IN_PAD) { /* might be an "our" variable" */ if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { @@ -10102,10 +10098,7 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what) return; if (s - w <= 254) { PADOFFSET off; - char tmpbuf[256]; - Copy(w, tmpbuf+1, s - w, char); - *tmpbuf = '&'; - off = pad_findmy_pvn(tmpbuf, s-w+1, 0); + off = pad_find_my_symbol_pvn (Perl_Symbol_Table_Code, w, s-w, 0); if (off != NOT_IN_PAD) return; } Perl_croak(aTHX_ "No comma allowed after %s", what); @@ -11443,7 +11436,7 @@ S_scan_inputsymbol(pTHX_ char *start) /* try to find it in the pad for this block, otherwise find add symbol table ops */ - const PADOFFSET tmp = pad_findmy_pvn(d, len, 0); + const PADOFFSET tmp = pad_find_my_symbol_pvn (Perl_Symbol_Table_Scalar, d + 1, len - 1, 0); if (tmp != NOT_IN_PAD) { if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { HV * const stash = PAD_COMPNAME_OURSTASH(tmp); From 04606c25d8cd8eb63f3445e94b5c734435f5aff7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sun, 8 Dec 2024 21:31:47 +0100 Subject: [PATCH 38/41] [pad] pad_find_my_symbol_pv - pad_findmy_pv alternative with explicit symbol table --- embed.fnc | 4 ++++ embed.h | 1 + ext/XS-APItest/APItest.xs | 7 +++++++ ext/XS-APItest/t/pad_scalar.t | 27 ++++++++++++++++++++------- pad.c | 23 +++++++++++++++++++---- proto.h | 5 +++++ 6 files changed, 56 insertions(+), 11 deletions(-) diff --git a/embed.fnc b/embed.fnc index 4add1a78adfc..67d87d69fbfa 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2501,6 +2501,10 @@ Adp |PADOFFSET|pad_findmy_pvn \ |U32 flags Adp |PADOFFSET|pad_findmy_sv|NN SV *name \ |U32 flags +Adp |PADOFFSET|pad_find_my_symbol_pv \ + |perl_symbol_table_id find_symbol_table \ + |NN const char *name \ + |U32 flags Adp |PADOFFSET|pad_find_my_symbol_pvn \ |perl_symbol_table_id find_symbol_table \ |NN const char *namepv \ diff --git a/embed.h b/embed.h index 81c3f80caaff..fda0efa1ad9f 100644 --- a/embed.h +++ b/embed.h @@ -512,6 +512,7 @@ # define pad_add_symbol_pvn(a,b,c,d,e,f) Perl_pad_add_symbol_pvn(aTHX_ a,b,c,d,e,f) # define pad_add_symbol_sv(a,b,c,d,e) Perl_pad_add_symbol_sv(aTHX_ a,b,c,d,e) # define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) +# define pad_find_my_symbol_pv(a,b,c) Perl_pad_find_my_symbol_pv(aTHX_ a,b,c) # define pad_find_my_symbol_pvn(a,b,c,d) Perl_pad_find_my_symbol_pvn(aTHX_ a,b,c,d) # define pad_findmy_pv(a,b) Perl_pad_findmy_pv(aTHX_ a,b) # define pad_findmy_pvn(a,b,c) Perl_pad_findmy_pvn(aTHX_ a,b,c) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 45d441116254..297472e81b4b 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -791,6 +791,7 @@ enum Pad_Find_Method { PAD_FINDMY_PV, PAD_FINDMY_PVN, PAD_FINDMY_SV, + PAD_FIND_MY_SYMBOL_PV, PAD_FIND_MY_SYMBOL_PVN, }; @@ -833,6 +834,11 @@ THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) case PAD_FINDMY_FOO: { padoff = pad_findmy_pvs("$foo", 0); } break; + case PAD_FIND_MY_SYMBOL_PV: { + char *namepv = SvPV_nolen(a1); + padoff = pad_find_my_symbol_pv (Perl_Symbol_Table_Scalar, namepv, SvUTF8(a1)); + break; + } case PAD_FIND_MY_SYMBOL_PVN: { char *namepv; STRLEN namelen; @@ -4374,6 +4380,7 @@ BOOT: EXPORT_ENUM (stash, PAD_FINDMY_PV); EXPORT_ENUM (stash, PAD_FINDMY_PVN); EXPORT_ENUM (stash, PAD_FINDMY_SV); + EXPORT_ENUM (stash, PAD_FIND_MY_SYMBOL_PV); EXPORT_ENUM (stash, PAD_FIND_MY_SYMBOL_PVN); } diff --git a/ext/XS-APItest/t/pad_scalar.t b/ext/XS-APItest/t/pad_scalar.t index c110c0b2b9e4..7a21ce10efd1 100644 --- a/ext/XS-APItest/t/pad_scalar.t +++ b/ext/XS-APItest/t/pad_scalar.t @@ -1,13 +1,14 @@ use warnings; use strict; -use Test::More tests => 92; +use Test::More tests => 110; use XS::APItest qw ( PAD_FINDMY_FOO PAD_FINDMY_PV PAD_FINDMY_PVN PAD_FINDMY_SV + PAD_FIND_MY_SYMBOL_PV PAD_FIND_MY_SYMBOL_PVN pad_scalar ); @@ -16,11 +17,13 @@ is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_IN_PAD", q (undeclared '$foo is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pvn ()); is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pv ()); is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pvs ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_find_my_symbol_pvn ()); is pad_scalar (PAD_FINDMY_SV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_findmy_sv ()); is pad_scalar (PAD_FINDMY_PVN, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_findmy_pvn ()); is pad_scalar (PAD_FINDMY_PV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_findmy_pv ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_find_my_symbol_pvn ()); our $foo = "wibble"; @@ -29,11 +32,13 @@ is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY", q ('our $foo'; pad_find is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pvn ()); is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pv ()); is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pvs ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo"), "NOT_MY", q ('our $foo'; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo"), "NOT_MY", q ('our $foo'; pad_find_my_symbol_pvn ()); is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble", q ('my $bar'; pad_findmy_sv ()); is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble", q ('my $bar'; pad_findmy_pvn ()); is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble", q ('my $bar'; pad_findmy_pv ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "bar"), "wobble", q ('my $bar'; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "bar"), "wobble", q ('my $bar'; pad_find_my_symbol_pvn ()); sub aa($); @@ -47,6 +52,7 @@ sub aa($) { ok \pad_scalar (PAD_FINDMY_SV, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_sv ()); ok \pad_scalar (PAD_FINDMY_PVN, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_pvn ()); ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_pv ()); + ok \pad_scalar (PAD_FIND_MY_SYMBOL_PV, "xyz") == \$xyz, $prefix . q (private variable; pad_find_my_symbol_pv ()); ok \pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "xyz") == \$xyz, $prefix . q (private variable; pad_find_my_symbol_pvn ()); if ($_[0]) { @@ -54,12 +60,14 @@ sub aa($) { ok \pad_scalar (PAD_FINDMY_SV, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_sv ()); ok \pad_scalar (PAD_FINDMY_PVN, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_pvn ()); ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_pv ()); + ok \pad_scalar (PAD_FIND_MY_SYMBOL_PV, "xyz") == \$xyz, q (private variable (after recursive call); pad_find_my_symbol_pv ()); ok \pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "xyz") == \$xyz, q (private variable (after recursive call); pad_find_my_symbol_pvn ()); } is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_sv ()); is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_pvn ()); is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_pv ()); + is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_find_my_symbol_pvn ()); } @@ -71,13 +79,14 @@ sub bb() { my $counter = 0; my $foo = \$counter; return sub { - ok pad_scalar (PAD_FINDMY_SV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_PVN, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_PV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_FOO, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_SV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_PVN, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_PV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_FOO, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); - my $modulus = pad_scalar (PAD_FINDMY_SV, "counter") % 4; + my $modulus = pad_scalar (PAD_FINDMY_SV, "counter") % 5; return pad_scalar (PAD_FINDMY_SV, "counter")++ if $modulus == 0; @@ -88,6 +97,9 @@ sub bb() { return pad_scalar (PAD_FINDMY_PV, "counter")++ if $modulus == 2; + return pad_scalar (PAD_FIND_MY_SYMBOL_PV, "counter")++ + if $modulus == 3; + $all_increment_called = 1; return pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "counter")++; }; @@ -109,6 +121,7 @@ is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY", q ('my $foo' still unde is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pvn ()); is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pv ()); is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pvs ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_find_my_symbol_pvn ()); 1; diff --git a/pad.c b/pad.c index 8396121d5809..00bbd25ee509 100644 --- a/pad.c +++ b/pad.c @@ -1035,15 +1035,18 @@ C is reserved and must be zero. =for apidoc Amnh||NOT_IN_PAD -=for apidoc pad_find_my_symbol_pvn +=for apidoc pad_find_my_symbol_pv +=for apidoc_item pad_find_my_symbol_pvn -Similar to C but with explicit symbol table parameter. +Similar to C but with explicit symbol table parameter. Difference: - pad_findmy_pvn ("$self", 5, 0); + pad_findmy_pv ("$self", 0); + pad_find_my_symbol_pv (Perl_Symbol_Scalar, "self", 0); - pad_find_my_symbol_pvn (Perl_Symbol_Scalar, "self", 5); + pad_findmy_pvn ("$self", 5, 0); + pad_find_my_symbol_pvn (Perl_Symbol_Scalar, "self", 5, 0); =cut */ @@ -1118,6 +1121,18 @@ Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags) return pad_find_my_symbol_pvn (*name, name + 1, strlen(name) - 1, flags); } +PADOFFSET +Perl_pad_find_my_symbol_pv( + pTHX_ + perl_symbol_table_id find_symbol_table, + const char * name, + U32 flags +) +{ + PERL_ARGS_ASSERT_PAD_FIND_MY_SYMBOL_PV; + return pad_find_my_symbol_pvn (find_symbol_table, name, strlen (name), flags); +} + PADOFFSET Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags) { diff --git a/proto.h b/proto.h index 43f6c9904598..cad07ee772f6 100644 --- a/proto.h +++ b/proto.h @@ -3447,6 +3447,11 @@ Perl_pad_block_start(pTHX_ int full) __attribute__visibility__("hidden"); #define PERL_ARGS_ASSERT_PAD_BLOCK_START +PERL_CALLCONV PADOFFSET +Perl_pad_find_my_symbol_pv(pTHX_ perl_symbol_table_id find_symbol_table, const char *name, U32 flags); +#define PERL_ARGS_ASSERT_PAD_FIND_MY_SYMBOL_PV \ + assert(name) + PERL_CALLCONV PADOFFSET Perl_pad_find_my_symbol_pvn(pTHX_ perl_symbol_table_id find_symbol_table, const char *namepv, STRLEN namelen, U32 flags); #define PERL_ARGS_ASSERT_PAD_FIND_MY_SYMBOL_PVN \ From e41bdd070c0cbec6cdfe5744e0d6bf182c39c1db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sat, 30 Nov 2024 19:02:54 +0100 Subject: [PATCH 39/41] [pad] pad_find_my_symbol_pvs - pad_findmy_pvs alternative with explicit symbol table --- ext/XS-APItest/APItest.xs | 6 ++++++ ext/XS-APItest/t/pad_scalar.t | 18 +++++++++++------- pad.c | 4 ++++ pad.h | 9 +++++++++ 4 files changed, 30 insertions(+), 7 deletions(-) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 297472e81b4b..3977577c623a 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -791,6 +791,7 @@ enum Pad_Find_Method { PAD_FINDMY_PV, PAD_FINDMY_PVN, PAD_FINDMY_SV, + PAD_FIND_MY_SYMBOL_FOO, PAD_FIND_MY_SYMBOL_PV, PAD_FIND_MY_SYMBOL_PVN, }; @@ -834,6 +835,10 @@ THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) case PAD_FINDMY_FOO: { padoff = pad_findmy_pvs("$foo", 0); } break; + case PAD_FIND_MY_SYMBOL_FOO: { + padoff = pad_find_my_symbol_pvs (Perl_Symbol_Table_Scalar, "foo", 0); + break; + } case PAD_FIND_MY_SYMBOL_PV: { char *namepv = SvPV_nolen(a1); padoff = pad_find_my_symbol_pv (Perl_Symbol_Table_Scalar, namepv, SvUTF8(a1)); @@ -4380,6 +4385,7 @@ BOOT: EXPORT_ENUM (stash, PAD_FINDMY_PV); EXPORT_ENUM (stash, PAD_FINDMY_PVN); EXPORT_ENUM (stash, PAD_FINDMY_SV); + EXPORT_ENUM (stash, PAD_FIND_MY_SYMBOL_FOO); EXPORT_ENUM (stash, PAD_FIND_MY_SYMBOL_PV); EXPORT_ENUM (stash, PAD_FIND_MY_SYMBOL_PVN); } diff --git a/ext/XS-APItest/t/pad_scalar.t b/ext/XS-APItest/t/pad_scalar.t index 7a21ce10efd1..89ceb10eb0ea 100644 --- a/ext/XS-APItest/t/pad_scalar.t +++ b/ext/XS-APItest/t/pad_scalar.t @@ -1,13 +1,14 @@ use warnings; use strict; -use Test::More tests => 110; +use Test::More tests => 113; use XS::APItest qw ( PAD_FINDMY_FOO PAD_FINDMY_PV PAD_FINDMY_PVN PAD_FINDMY_SV + PAD_FIND_MY_SYMBOL_FOO PAD_FIND_MY_SYMBOL_PV PAD_FIND_MY_SYMBOL_PVN pad_scalar @@ -17,6 +18,7 @@ is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_IN_PAD", q (undeclared '$foo is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pvn ()); is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pv ()); is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_findmy_pvs ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_FOO, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_find_my_symbol_pvs ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_find_my_symbol_pvn ()); @@ -32,6 +34,7 @@ is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY", q ('our $foo'; pad_find is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pvn ()); is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pv ()); is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY", q ('our $foo'; pad_findmy_pvs ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_FOO, "foo"), "NOT_MY", q ('our $foo'; pad_find_my_symbol_pvs ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo"), "NOT_MY", q ('our $foo'; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo"), "NOT_MY", q ('our $foo'; pad_find_my_symbol_pvn ()); @@ -79,12 +82,12 @@ sub bb() { my $counter = 0; my $foo = \$counter; return sub { - ok pad_scalar (PAD_FINDMY_SV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_PVN, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_PV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_FOO, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_SV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_PVN, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_PV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_FOO, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); my $modulus = pad_scalar (PAD_FINDMY_SV, "counter") % 5; @@ -121,6 +124,7 @@ is pad_scalar (PAD_FINDMY_SV, "foo"), "NOT_MY", q ('my $foo' still unde is pad_scalar (PAD_FINDMY_PVN, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pvn ()); is pad_scalar (PAD_FINDMY_PV, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pv ()); is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_findmy_pvs ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_FOO, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_find_my_symbol_pvs ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_find_my_symbol_pvn ()); diff --git a/pad.c b/pad.c index 00bbd25ee509..abb6ba801731 100644 --- a/pad.c +++ b/pad.c @@ -1037,6 +1037,7 @@ C is reserved and must be zero. =for apidoc pad_find_my_symbol_pv =for apidoc_item pad_find_my_symbol_pvn +=for apidoc_item pad_find_my_symbol_pvs Similar to C but with explicit symbol table parameter. @@ -1048,6 +1049,9 @@ Similar to C but with explicit symbol table parameter. pad_findmy_pvn ("$self", 5, 0); pad_find_my_symbol_pvn (Perl_Symbol_Scalar, "self", 5, 0); + pad_findmy_pvs ("$self", 0); + pad_find_my_symbol_pvs (Perl_Symbol_Scalar, "self", 0); + =cut */ diff --git a/pad.h b/pad.h index 566a8288ec43..fdc1e5e14515 100644 --- a/pad.h +++ b/pad.h @@ -736,6 +736,15 @@ Similar to L, but takes a literal string instead of a strin #define pad_findmy_pvs(name,flags) \ EXPAND_CALL (pad_findmy_pvn, (STR_WITH_LEN(name), flags)) +/* +=for apidoc_defn Am|PADOFFSET|pad_find_my_symbol_pvs|"symbol_table"|"name"|U32 flags + +=cut +*/ + +#define pad_find_my_symbol_pvs(Symbol_Table, Name, Flags) \ + EXPAND_CALL (pad_find_my_symbol_pvn, (Symbol_Table, STR_WITH_LEN(Name), Flags)) + struct suspended_compcv { CV *compcv; From 8dc2fc1c4d5605ad12d1f979fe17ba2c22ad2b86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sun, 8 Dec 2024 21:35:38 +0100 Subject: [PATCH 40/41] [pad] pad_find_my_symbol_sv - pad_findmy_sv alternative with explicit symbol table --- embed.fnc | 4 ++++ embed.h | 1 + ext/XS-APItest/APItest.xs | 5 +++++ ext/XS-APItest/t/pad_scalar.t | 32 +++++++++++++++++++++++--------- pad.c | 20 ++++++++++++++++++++ proto.h | 5 +++++ 6 files changed, 58 insertions(+), 9 deletions(-) diff --git a/embed.fnc b/embed.fnc index 67d87d69fbfa..c355966f2c37 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2510,6 +2510,10 @@ Adp |PADOFFSET|pad_find_my_symbol_pvn \ |NN const char *namepv \ |STRLEN namelen \ |U32 flags +Adp |PADOFFSET|pad_find_my_symbol_sv \ + |perl_symbol_table_id find_symbol_table \ + |NN SV *name \ + |U32 flags dp |void |pad_fixup_inner_anons \ |NN PADLIST *padlist \ |NN CV *old_cv \ diff --git a/embed.h b/embed.h index fda0efa1ad9f..f2783df55cce 100644 --- a/embed.h +++ b/embed.h @@ -514,6 +514,7 @@ # define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) # define pad_find_my_symbol_pv(a,b,c) Perl_pad_find_my_symbol_pv(aTHX_ a,b,c) # define pad_find_my_symbol_pvn(a,b,c,d) Perl_pad_find_my_symbol_pvn(aTHX_ a,b,c,d) +# define pad_find_my_symbol_sv(a,b,c) Perl_pad_find_my_symbol_sv(aTHX_ a,b,c) # define pad_findmy_pv(a,b) Perl_pad_findmy_pv(aTHX_ a,b) # define pad_findmy_pvn(a,b,c) Perl_pad_findmy_pvn(aTHX_ a,b,c) # define pad_findmy_sv(a,b) Perl_pad_findmy_sv(aTHX_ a,b) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 3977577c623a..c6f9fcebba94 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -794,6 +794,7 @@ enum Pad_Find_Method { PAD_FIND_MY_SYMBOL_FOO, PAD_FIND_MY_SYMBOL_PV, PAD_FIND_MY_SYMBOL_PVN, + PAD_FIND_MY_SYMBOL_SV, }; STATIC OP * @@ -851,6 +852,9 @@ THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) padoff = pad_find_my_symbol_pvn (Perl_Symbol_Table_Scalar, namepv, namelen, SvUTF8(a1)); break; } + case PAD_FIND_MY_SYMBOL_SV: { + padoff = pad_find_my_symbol_sv (Perl_Symbol_Table_Scalar, a1, 0); + } break; default: croak("bad type value for pad_scalar()"); } op_free(entersubop); @@ -4388,6 +4392,7 @@ BOOT: EXPORT_ENUM (stash, PAD_FIND_MY_SYMBOL_FOO); EXPORT_ENUM (stash, PAD_FIND_MY_SYMBOL_PV); EXPORT_ENUM (stash, PAD_FIND_MY_SYMBOL_PVN); + EXPORT_ENUM (stash, PAD_FIND_MY_SYMBOL_SV); } BOOT: diff --git a/ext/XS-APItest/t/pad_scalar.t b/ext/XS-APItest/t/pad_scalar.t index 89ceb10eb0ea..b7bf21e29006 100644 --- a/ext/XS-APItest/t/pad_scalar.t +++ b/ext/XS-APItest/t/pad_scalar.t @@ -1,7 +1,7 @@ use warnings; use strict; -use Test::More tests => 113; +use Test::More tests => 139; use XS::APItest qw ( PAD_FINDMY_FOO @@ -11,6 +11,7 @@ use XS::APItest qw ( PAD_FIND_MY_SYMBOL_FOO PAD_FIND_MY_SYMBOL_PV PAD_FIND_MY_SYMBOL_PVN + PAD_FIND_MY_SYMBOL_SV pad_scalar ); @@ -21,12 +22,14 @@ is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_IN_PAD", q (undeclared '$foo is pad_scalar (PAD_FIND_MY_SYMBOL_FOO, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_find_my_symbol_pvs ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_find_my_symbol_pvn ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_SV, "foo"), "NOT_IN_PAD", q (undeclared '$foo'; pad_find_my_symbol_sv ()); is pad_scalar (PAD_FINDMY_SV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_findmy_sv ()); is pad_scalar (PAD_FINDMY_PVN, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_findmy_pvn ()); is pad_scalar (PAD_FINDMY_PV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_findmy_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_find_my_symbol_pvn ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_SV, "bar"), "NOT_IN_PAD", q (undeclared '$bar'; pad_find_my_symbol_sv ()); our $foo = "wibble"; my $bar = "wobble"; @@ -37,12 +40,14 @@ is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY", q ('our $foo'; pad_find is pad_scalar (PAD_FIND_MY_SYMBOL_FOO, "foo"), "NOT_MY", q ('our $foo'; pad_find_my_symbol_pvs ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo"), "NOT_MY", q ('our $foo'; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo"), "NOT_MY", q ('our $foo'; pad_find_my_symbol_pvn ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_SV, "foo"), "NOT_MY", q ('our $foo'; pad_find_my_symbol_sv ()); is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble", q ('my $bar'; pad_findmy_sv ()); is pad_scalar (PAD_FINDMY_PVN, "bar"), "wobble", q ('my $bar'; pad_findmy_pvn ()); is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble", q ('my $bar'; pad_findmy_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "bar"), "wobble", q ('my $bar'; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "bar"), "wobble", q ('my $bar'; pad_find_my_symbol_pvn ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_SV, "bar"), "wobble", q ('my $bar'; pad_find_my_symbol_sv ()); sub aa($); sub aa($) { @@ -57,6 +62,7 @@ sub aa($) { ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz, $prefix . q (private variable; pad_findmy_pv ()); ok \pad_scalar (PAD_FIND_MY_SYMBOL_PV, "xyz") == \$xyz, $prefix . q (private variable; pad_find_my_symbol_pv ()); ok \pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "xyz") == \$xyz, $prefix . q (private variable; pad_find_my_symbol_pvn ()); + ok \pad_scalar (PAD_FIND_MY_SYMBOL_SV, "xyz") == \$xyz, $prefix . q (private variable; pad_find_my_symbol_sv ()); if ($_[0]) { aa(0); # recursive call @@ -65,6 +71,7 @@ sub aa($) { ok \pad_scalar (PAD_FINDMY_PV, "xyz") == \$xyz, q (private variable (after recursive call); pad_findmy_pv ()); ok \pad_scalar (PAD_FIND_MY_SYMBOL_PV, "xyz") == \$xyz, q (private variable (after recursive call); pad_find_my_symbol_pv ()); ok \pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "xyz") == \$xyz, q (private variable (after recursive call); pad_find_my_symbol_pvn ()); + ok \pad_scalar (PAD_FIND_MY_SYMBOL_SV, "xyz") == \$xyz, q (private variable (after recursive call); pad_find_my_symbol_sv ()); } is pad_scalar (PAD_FINDMY_SV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_sv ()); @@ -72,6 +79,7 @@ sub aa($) { is pad_scalar (PAD_FINDMY_PV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_findmy_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_find_my_symbol_pvn ()); + is pad_scalar (PAD_FIND_MY_SYMBOL_SV, "bar"), "wobble", $prefix . q (Global 'my $bar'; pad_find_my_symbol_sv ()); } aa(1); @@ -82,14 +90,15 @@ sub bb() { my $counter = 0; my $foo = \$counter; return sub { - ok pad_scalar (PAD_FINDMY_SV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_PVN, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_PV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FINDMY_FOO, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); - ok pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo") == \pad_scalar (PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_SV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_PVN, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_PV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FINDMY_FOO, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); + ok pad_scalar (PAD_FIND_MY_SYMBOL_SV, "foo") == \pad_scalar(PAD_FINDMY_SV, "counter"); - my $modulus = pad_scalar (PAD_FINDMY_SV, "counter") % 5; + my $modulus = pad_scalar (PAD_FINDMY_SV, "counter") % 6; return pad_scalar (PAD_FINDMY_SV, "counter")++ if $modulus == 0; @@ -103,8 +112,11 @@ sub bb() { return pad_scalar (PAD_FIND_MY_SYMBOL_PV, "counter")++ if $modulus == 3; + return pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "counter")++ + if $modulus == 4; + $all_increment_called = 1; - return pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "counter")++; + return pad_scalar (PAD_FIND_MY_SYMBOL_SV, "counter")++; }; } my $a = bb(); @@ -117,6 +129,7 @@ is $b->(), 0; is $b->(), 1; is $a->(), 4; is $b->(), 2; +is $a->(), 5; ok $all_increment_called, q (all pad scalar methods called for increment); @@ -127,5 +140,6 @@ is pad_scalar (PAD_FINDMY_FOO, "foo"), "NOT_MY", q ('my $foo' still unde is pad_scalar (PAD_FIND_MY_SYMBOL_FOO, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_find_my_symbol_pvs ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PV, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_find_my_symbol_pv ()); is pad_scalar (PAD_FIND_MY_SYMBOL_PVN, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_find_my_symbol_pvn ()); +is pad_scalar (PAD_FIND_MY_SYMBOL_SV, "foo"), "NOT_MY", q ('my $foo' still undeclared; pad_find_my_symbol_sv ()); 1; diff --git a/pad.c b/pad.c index abb6ba801731..dc7103006b3c 100644 --- a/pad.c +++ b/pad.c @@ -1038,6 +1038,7 @@ C is reserved and must be zero. =for apidoc pad_find_my_symbol_pv =for apidoc_item pad_find_my_symbol_pvn =for apidoc_item pad_find_my_symbol_pvs +=for apidoc_item pad_find_my_symbol_sv Similar to C but with explicit symbol table parameter. @@ -1052,6 +1053,10 @@ Similar to C but with explicit symbol table parameter. pad_findmy_pvs ("$self", 0); pad_find_my_symbol_pvs (Perl_Symbol_Scalar, "self", 0); + // sv (string) means SV * with context "string" + pad_findmy_sv (sv ("$self"), 0); + pad_find_my_symbol_pvs (Perl_Symbol_Scalar, sv ("self"), 0); + =cut */ @@ -1147,6 +1152,21 @@ Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags) return pad_find_my_symbol_pvn (*namepv, namepv + 1, namelen - 1, flags); } +PADOFFSET +Perl_pad_find_my_symbol_sv( + pTHX_ + perl_symbol_table_id find_symbol_table, + SV * name, + U32 flags +) +{ + char *namepv; + STRLEN namelen; + PERL_ARGS_ASSERT_PAD_FIND_MY_SYMBOL_SV; + namepv = SvPVutf8(name, namelen); + return pad_find_my_symbol_pvn (find_symbol_table, namepv, namelen, flags); +} + /* =for apidoc find_rundefsv diff --git a/proto.h b/proto.h index cad07ee772f6..ca1724801733 100644 --- a/proto.h +++ b/proto.h @@ -3457,6 +3457,11 @@ Perl_pad_find_my_symbol_pvn(pTHX_ perl_symbol_table_id find_symbol_table, const #define PERL_ARGS_ASSERT_PAD_FIND_MY_SYMBOL_PVN \ assert(namepv) +PERL_CALLCONV PADOFFSET +Perl_pad_find_my_symbol_sv(pTHX_ perl_symbol_table_id find_symbol_table, SV *name, U32 flags); +#define PERL_ARGS_ASSERT_PAD_FIND_MY_SYMBOL_SV \ + assert(name) + PERL_CALLCONV PADOFFSET Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags); #define PERL_ARGS_ASSERT_PAD_FINDMY_PV \ From 7f7f7c758a29065236d74916b23e6b92d3445943 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Branislav=20Zahradn=C3=ADk?= Date: Sun, 1 Dec 2024 18:42:19 +0100 Subject: [PATCH 41/41] [pad] pad_find_my_symbol_sv - replace usage of pad_findmy_sv --- builtin.c | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/builtin.c b/builtin.c index ac9f5b9bb857..02879ffbf05b 100644 --- a/builtin.c +++ b/builtin.c @@ -692,15 +692,11 @@ static bool S_cv_is_builtin(pTHX_ CV *cv) void Perl_import_builtin_bundle(pTHX_ U16 ver) { - SV *ampname = sv_newmortal(); - for(int i = 0; builtins[i].name; i++) { - sv_setpvf(ampname, "&%s", builtins[i].name); - bool want = (builtins[i].since_ver <= ver); bool got = false; - PADOFFSET off = pad_findmy_sv(ampname, 0); + PADOFFSET off = pad_find_my_symbol_pv (Perl_Symbol_Table_Code, builtins[i].name, 0); CV *cv; if(off != NOT_IN_PAD && SvTYPE((cv = (CV *)PL_curpad[off])) == SVt_PVCV &&