From aa97ec55f2ed1f871f0ff7538deda5836b9b0782 Mon Sep 17 00:00:00 2001 From: Shane McCarron Date: Sun, 14 Jun 2026 10:23:10 -0500 Subject: [PATCH] fix(perl-lsp): address QA round 1 F1: dot the Exporter import target so seeded CPAN exported subs resolve. perl_collect_qw_imports built colon-form targets (Scalar::Util::blessed) but the stdlib registry keys curated CPAN subs in dotted form (Scalar.Util.blessed) and lookup is exact-match. Wire in perl_pkg_to_dot to dot the module portion and drop the now-unnecessary (void) cast. F2: add a recursion-depth guard (CBM_LSP_PERL_MAX_WALK_DEPTH=512) to both AST walkers (perl_resolve_calls_in_node, perl_pass1_scan) via a depth- guarded wrapper + inner split, mirroring java_lsp's JAVA_LSP_MAX_WALK_DEPTH. Past the cap a subtree is skipped (graceful degradation, no wrong edge), preventing stack overflow on pathologically nested input. F3: lock the shared last-"::"-segment normalization in lsp_resolve.h with a direct regression test over cbm_pipeline_find_lsp_resolution: a qualified static call still resolves AND the cross-namespace mis-attribution edge case is bounded by caller-QN equality + the confidence floor. F4: implement SUPER:: dispatch. Populate enclosing_parent_qn from the enclosing package's first @ISA parent and resolve $self->SUPER::method() to that parent's method (strategy perl_method_super). No known parent or unresolved method emits no edge (zero-edge guarantee preserved). Tests: perllsp_cpan_exported_function, perllsp_super_dispatch, perllsp_super_no_parent_no_edge, lsp_perl_deep_expression_no_crash, lsp_resolve_qualified_static_call_normalizes_colons, lsp_resolve_misattribution_is_bounded. Signed-off-by: Shane McCarron --- internal/cbm/lsp/perl_lsp.c | 74 ++++++++++++++++++++++++++++--- internal/cbm/lsp/perl_lsp.h | 4 ++ tests/test_parallel.c | 87 +++++++++++++++++++++++++++++++++++++ tests/test_perl_lsp.c | 73 +++++++++++++++++++++++++++++++ tests/test_stack_overflow.c | 27 ++++++++++++ 5 files changed, 260 insertions(+), 5 deletions(-) diff --git a/internal/cbm/lsp/perl_lsp.c b/internal/cbm/lsp/perl_lsp.c index 56d2b8700..bb6c83b56 100644 --- a/internal/cbm/lsp/perl_lsp.c +++ b/internal/cbm/lsp/perl_lsp.c @@ -63,12 +63,24 @@ #define PERL_CONF_LITERAL 0.95f /* bless($r, 'Literal'); resolved call */ #define PERL_CONF_INFERRED 0.75f /* ref($class)||$class idiom */ +/* Maximum AST-walk recursion depth for the resolution/scan passes. Mirrors + * java_lsp's JAVA_LSP_MAX_WALK_DEPTH: the per-child recursion of + * perl_resolve_calls_in_node / perl_pass1_scan can stack-overflow on + * pathologically nested real-world sources, the same failure mode that + * produced documented SIGSEGVs in the Java/C++ walkers. Past the cap the + * subtree is skipped — its calls stay unresolved (graceful degradation, not a + * crash). The zero-edge guarantee is preserved: a skipped subtree emits no + * edges, never a wrong one. */ +#define CBM_LSP_PERL_MAX_WALK_DEPTH 512 + /* ── forward declarations ───────────────────────────────────────── */ static void perl_resolve_calls_in_node(PerlLSPContext *ctx, TSNode node); +static void perl_resolve_calls_in_node_inner(PerlLSPContext *ctx, TSNode node); static void process_subroutine(PerlLSPContext *ctx, TSNode node); static void process_package_decl(PerlLSPContext *ctx, TSNode node); static void perl_pass1_scan(PerlLSPContext *ctx, TSNode node); +static void perl_pass1_scan_inner(PerlLSPContext *ctx, TSNode node); static const CBMType *perl_eval_function_call_type(PerlLSPContext *ctx, TSNode node); static const CBMType *perl_eval_method_call_type(PerlLSPContext *ctx, TSNode node); static const CBMType *perl_eval_new_type(PerlLSPContext *ctx, TSNode node); @@ -643,6 +655,23 @@ static void perl_resolve_method_call(PerlLSPContext *ctx, TSNode call) { if (!mname || !mname[0]) return; + /* $self->SUPER::method() — dispatch to the enclosing package's parent + * (MRO root recorded in process_package_decl). Resolve `method` starting + * at the parent so an overridden method in the child is skipped. No known + * parent or unresolved method → no edge (zero-edge guarantee). */ + if (strncmp(mname, "SUPER::", 7) == 0) { + const char *super_method = mname + 7; + if (!super_method[0]) + return; + const char *parent_qn = ctx->enclosing_parent_qn; + if (!parent_qn || !parent_qn[0]) + return; + const CBMRegisteredFunc *sf = perl_lookup_method(ctx, parent_qn, super_method); + if (sf) + perl_emit_resolved(ctx, sf->qualified_name, "perl_method_super", PERL_CONF_LITERAL); + return; + } + const char *class_qn = NULL; const char *strategy = "perl_method_typed"; if (!ts_node_is_null(inv)) { @@ -704,7 +733,19 @@ static void perl_process_assignment(PerlLSPContext *ctx, TSNode assign) { /* ── body walk ──────────────────────────────────────────────────── */ +/* Depth-guarded entry: the AST walk recurses per nesting level and can stack- + * overflow on pathologically nested sources (the same failure mode documented + * for the Java/C++ walkers). Past CBM_LSP_PERL_MAX_WALK_DEPTH the subtree is + * skipped — graceful degradation, never a wrong edge. */ static void perl_resolve_calls_in_node(PerlLSPContext *ctx, TSNode node) { + if (ctx->walk_depth >= CBM_LSP_PERL_MAX_WALK_DEPTH) + return; + ctx->walk_depth++; + perl_resolve_calls_in_node_inner(ctx, node); + ctx->walk_depth--; +} + +static void perl_resolve_calls_in_node_inner(PerlLSPContext *ctx, TSNode node) { if (ts_node_is_null(node)) return; const char *k = ts_node_type(node); @@ -860,6 +901,18 @@ static void process_package_decl(PerlLSPContext *ctx, TSNode node) { return; ctx->current_package_qn = cbm_arena_strdup(ctx->arena, pkg); ctx->enclosing_package_qn = ctx->current_package_qn; + + /* Record the package's first @ISA parent for SUPER:: dispatch. The ISA + * table is fully populated by PASS 1 before this runs in PASS 2, so the + * MRO root is available here. NULL when the package has no known parent — + * SUPER:: then resolves to nothing (zero-edge guarantee). */ + ctx->enclosing_parent_qn = NULL; + for (int i = 0; i < ctx->isa_count; i++) { + if (ctx->isa_pkg_qns[i] && strcmp(ctx->isa_pkg_qns[i], pkg) == 0) { + ctx->enclosing_parent_qn = ctx->isa_parent_qns[i]; + break; + } + } } /* Parse the `qw(a b c)` list inside a node into the import map for module @@ -880,7 +933,13 @@ static void perl_collect_qw_imports(PerlLSPContext *ctx, TSNode container, const char *fn = perl_strip_sigil(word); /* allow &func imports */ if (!fn || !fn[0] || !(isalpha((unsigned char)fn[0]) || fn[0] == '_')) continue; - char *target = cbm_arena_sprintf(ctx->arena, "%s::%s", module_name, fn); + /* Registry QNs are fully dotted (e.g. "Scalar.Util.blessed"): the + * module portion uses "." not "::". Dot the module so the import + * target matches the registry key for exact-match lookup. */ + const char *module_dot = perl_pkg_to_dot(ctx->arena, module_name); + if (!module_dot) + module_dot = module_name; + char *target = cbm_arena_sprintf(ctx->arena, "%s.%s", module_dot, fn); perl_lsp_add_use(ctx, fn, target); } } @@ -1027,7 +1086,16 @@ static void perl_collect_isa_assignment(PerlLSPContext *ctx, TSNode assign) { /* Recursively scan (PASS 1) for package context, @ISA assignments, and `use` * statements. */ +/* Depth-guarded entry (see perl_resolve_calls_in_node for the rationale). */ static void perl_pass1_scan(PerlLSPContext *ctx, TSNode node) { + if (ctx->walk_depth >= CBM_LSP_PERL_MAX_WALK_DEPTH) + return; + ctx->walk_depth++; + perl_pass1_scan_inner(ctx, node); + ctx->walk_depth--; +} + +static void perl_pass1_scan_inner(PerlLSPContext *ctx, TSNode node) { if (ts_node_is_null(node)) return; const char *k = ts_node_type(node); @@ -1302,8 +1370,4 @@ void cbm_run_perl_lsp(CBMArena *arena, CBMFileResult *result, const char *source r->strategy, r->confidence); } } - - /* Silence unused-helper warnings for API symbols kept for the header / - * future cross-file plan. */ - (void)perl_pkg_to_dot; } diff --git a/internal/cbm/lsp/perl_lsp.h b/internal/cbm/lsp/perl_lsp.h index 201d461b4..53e3cbd8f 100644 --- a/internal/cbm/lsp/perl_lsp.h +++ b/internal/cbm/lsp/perl_lsp.h @@ -65,6 +65,10 @@ typedef struct { /* Recursion guard for perl_eval_expr_type. */ int eval_depth; + /* Recursion guard for the AST-walk passes (perl_resolve_calls_in_node / + * perl_pass1_scan). Bounds stack depth on pathologically nested input. */ + int walk_depth; + /* Debug mode (CBM_LSP_DEBUG env). */ bool debug; } PerlLSPContext; diff --git a/tests/test_parallel.c b/tests/test_parallel.c index 919351af2..9706db2b7 100644 --- a/tests/test_parallel.c +++ b/tests/test_parallel.c @@ -1059,9 +1059,96 @@ TEST(grpc_no_phantom_route_from_plain_var_issue294) { PASS(); } +/* ── Shared "::" normalization in cbm_pipeline_find_lsp_resolution (QA F3) ─ + * + * The last-"::"-segment normalization in lsp_resolve.h widens matching for + * qualified static callees (Perl `Pkg::sub`, C++ `Ns::fn`, etc.) across ALL + * languages, not just Perl. These tests lock the intended behavior directly + * against cbm_pipeline_find_lsp_resolution: (1) a qualified static call still + * resolves to the right resolved entry, and (2) the theoretical + * mis-attribution edge case (two same-named subs from different namespaces) is + * bounded by caller-QN equality + the confidence floor. */ +static CBMResolvedCall make_rc(const char *caller, const char *callee, float conf) { + CBMResolvedCall rc; + memset(&rc, 0, sizeof(rc)); + rc.caller_qn = caller; + rc.callee_qn = callee; + rc.strategy = "test"; + rc.confidence = conf; + return rc; +} + +static CBMCall make_call(const char *enclosing, const char *callee_name) { + CBMCall c; + memset(&c, 0, sizeof(c)); + c.enclosing_func_qn = enclosing; + c.callee_name = callee_name; + return c; +} + +TEST(lsp_resolve_qualified_static_call_normalizes_colons) { + /* A qualified static call `Pkg::sub` (callee_name keeps the package + * prefix) must still match a resolved entry whose callee_qn short-name is + * the bare `sub`. This is the cross-language "::"-normalization contract. */ + CBMResolvedCall items[] = { + make_rc("proj.mod.caller", "proj.Pkg.sub", 0.9f), + }; + CBMResolvedCallArray arr = {items, 1, 1}; + CBMCall call = make_call("proj.mod.caller", "Pkg::sub"); + const CBMResolvedCall *hit = cbm_pipeline_find_lsp_resolution(&arr, &call, false); + ASSERT(hit != NULL); + ASSERT(strcmp(hit->callee_qn, "proj.Pkg.sub") == 0); + + /* A bare call (no "::") to the same short name resolves identically — + * normalization must not regress the common case. */ + CBMCall bare = make_call("proj.mod.caller", "sub"); + const CBMResolvedCall *bare_hit = cbm_pipeline_find_lsp_resolution(&arr, &bare, false); + ASSERT(bare_hit != NULL); + ASSERT(strcmp(bare_hit->callee_qn, "proj.Pkg.sub") == 0); + PASS(); +} + +TEST(lsp_resolve_misattribution_is_bounded) { + /* Two same-named subs from different namespaces (A::foo, B::foo) resolved + * within the same enclosing function. Both resolved short-names normalize + * to `foo`, so a textual `B::foo` matches both by short-name — the + * theoretical mis-attribution. The function bounds this: it returns the + * highest-confidence match (deterministic, never both), and the bound is + * enforced by caller-QN equality + the confidence floor. */ + CBMResolvedCall items[] = { + make_rc("proj.mod.caller", "proj.A.foo", 0.7f), + make_rc("proj.mod.caller", "proj.B.foo", 0.9f), + /* Below the confidence floor: must be ignored entirely. */ + make_rc("proj.mod.caller", "proj.C.foo", 0.3f), + /* Different caller: must never match regardless of short-name. */ + make_rc("proj.mod.other", "proj.D.foo", 0.95f), + }; + CBMResolvedCallArray arr = {items, 4, 4}; + CBMCall call = make_call("proj.mod.caller", "B::foo"); + const CBMResolvedCall *hit = cbm_pipeline_find_lsp_resolution(&arr, &call, false); + ASSERT(hit != NULL); + /* Highest-confidence qualifying entry wins; the cross-caller 0.95 entry is + * excluded by caller-QN equality, the 0.3 entry by the floor. */ + ASSERT(strcmp(hit->callee_qn, "proj.B.foo") == 0); + + /* The cross-caller high-confidence entry only matches its own caller. */ + CBMCall other = make_call("proj.mod.other", "D::foo"); + const CBMResolvedCall *other_hit = cbm_pipeline_find_lsp_resolution(&arr, &other, false); + ASSERT(other_hit != NULL); + ASSERT(strcmp(other_hit->callee_qn, "proj.D.foo") == 0); + + /* A caller with no qualifying entry resolves to nothing (no widening can + * manufacture an edge across callers). */ + CBMCall absent = make_call("proj.mod.absent", "foo"); + ASSERT(cbm_pipeline_find_lsp_resolution(&arr, &absent, false) == NULL); + PASS(); +} + /* ── Suite Registration ──────────────────────────────────────────── */ SUITE(parallel) { + RUN_TEST(lsp_resolve_qualified_static_call_normalizes_colons); + RUN_TEST(lsp_resolve_misattribution_is_bounded); RUN_TEST(grpc_service_name_preserves_service_suffix_issue294); RUN_TEST(grpc_no_phantom_route_from_plain_var_issue294); /* Graph buffer merge/shared-ID tests */ diff --git a/tests/test_perl_lsp.c b/tests/test_perl_lsp.c index 7eb5cabbf..9f697597d 100644 --- a/tests/test_perl_lsp.c +++ b/tests/test_perl_lsp.c @@ -238,6 +238,31 @@ TEST(perllsp_exported_function) { PASS(); } +/* ── 8b. Seeded CPAN Exporter import (use Scalar::Util qw(blessed)) ─ + * + * Regression for the import-map "::" vs "." mismatch (QA round 1, F1): + * perl_collect_qw_imports used to build the colon-form target + * "Scalar::Util::blessed", but the stdlib registry keys curated CPAN subs in + * dotted form ("Scalar.Util.blessed") and lookup is exact-match — so the + * import never resolved. The import target must be dotted to match. */ +TEST(perllsp_cpan_exported_function) { + /* blessed is a curated CPAN export (Scalar::Util) seeded by + * cbm_perl_stdlib_register as "Scalar.Util.blessed". The bare call must + * resolve to that seeded registry symbol via the Exporter import map. */ + const char *src = "package main;\n" + "use Scalar::Util qw(blessed);\n" + "sub run {\n" + " my $x = bless {}, 'Foo';\n" + " blessed($x);\n" + "}\n"; + CBMFileResult *r = extract_perl(src); + ASSERT(r); + /* Resolves to the dotted registry QN Scalar.Util.blessed. */ + ASSERT(require_resolved(r, "main.run", "Scalar.Util.blessed") >= 0); + cbm_free_result(r); + PASS(); +} + /* ── 9. require fallback (require Foo; Foo->bar()) ─────────────── */ TEST(perllsp_require_fallback) { @@ -255,6 +280,51 @@ TEST(perllsp_require_fallback) { PASS(); } +/* ── 9b. SUPER:: dispatch ($self->SUPER::method) ────────────────── + * + * Regression for the dead enclosing_parent_qn field (QA round 1, F4). The + * header advertised SUPER:: support but the field was never populated/read, so + * $self->SUPER::method() resolved to nothing. Now process_package_decl records + * the package's first @ISA parent and perl_resolve_method_call routes a + * SUPER:: call to that parent's method. */ +TEST(perllsp_super_dispatch) { + /* Child overrides greet and calls $self->SUPER::greet(); the SUPER call + * must resolve to Base::greet (the parent), tagged perl_method_super. */ + const char *src = "package Base;\n" + "sub new { return bless {}, shift; }\n" + "sub greet { return 'base'; }\n" + "package Child;\n" + "our @ISA = ('Base');\n" + "sub greet {\n" + " my $self = shift;\n" + " return $self->SUPER::greet();\n" + "}\n"; + CBMFileResult *r = extract_perl(src); + ASSERT(r); + /* The SUPER:: call resolves to a greet sub via the dedicated strategy. */ + const CBMResolvedCall *rc = + find_resolved_with_strategy(r, "main.greet", "main.greet", "perl_method_super"); + ASSERT(rc != NULL); + cbm_free_result(r); + PASS(); +} + +/* ── 9c. SUPER:: with no known parent emits NO edge (zero-edge) ─── */ +TEST(perllsp_super_no_parent_no_edge) { + /* Orphan has no @ISA parent; SUPER::greet() must resolve to nothing rather + * than guessing an edge. */ + const char *src = "package Orphan;\n" + "sub greet {\n" + " my $self = shift;\n" + " return $self->SUPER::greet();\n" + "}\n"; + CBMFileResult *r = extract_perl(src); + ASSERT(r); + ASSERT(find_resolved_with_strategy(r, "main.greet", "greet", "perl_method_super") == NULL); + cbm_free_result(r); + PASS(); +} + /* ── 10. Unresolvable receiver emits NO spurious edge (negative) ─ */ TEST(perllsp_unindexed_receiver_emits_block) { @@ -288,6 +358,9 @@ SUITE(perl_lsp) { RUN_TEST(perllsp_use_parent_inheritance); RUN_TEST(perllsp_use_base_inheritance); RUN_TEST(perllsp_exported_function); + RUN_TEST(perllsp_cpan_exported_function); RUN_TEST(perllsp_require_fallback); + RUN_TEST(perllsp_super_dispatch); + RUN_TEST(perllsp_super_no_parent_no_edge); RUN_TEST(perllsp_unindexed_receiver_emits_block); } diff --git a/tests/test_stack_overflow.c b/tests/test_stack_overflow.c index 9a93e3d22..69286489e 100644 --- a/tests/test_stack_overflow.c +++ b/tests/test_stack_overflow.c @@ -512,6 +512,32 @@ TEST(lsp_python_deep_expression_no_crash) { PASS(); } +TEST(lsp_perl_deep_expression_no_crash) { + /* Deeply nested Perl call expressions f(f(f(...f(1)...))). The Perl AST + * walkers (perl_resolve_calls_in_node / perl_pass1_scan) recurse per child + * with no depth bound before QA round 1 — the same SIGSEGV-prone shape as + * the Java/C++ walkers. The CBM_LSP_PERL_MAX_WALK_DEPTH guard must cap the + * recursion so this does not overflow the stack. See + * lsp_java_deep_nesting_no_crash on the depth choice. */ + const int DEPTH = 30000; + size_t sz = (size_t)DEPTH * 3 + 256; + char *src = malloc(sz); + ASSERT_NOT_NULL(src); + char *p = src; + p += snprintf(p, sz, "sub f { return $_[0]; }\nsub g { return "); + for (int i = 0; i < DEPTH; i++) { + *p++ = 'f'; + *p++ = '('; + } + *p++ = '1'; + memset(p, ')', DEPTH); + p += DEPTH; + snprintf(p, sz - (size_t)(p - src), "; }\n"); + ASSERT_FALSE(so_extract_crashes(src, CBM_LANG_PERL, "deep.pl")); + free(src); + PASS(); +} + TEST(lsp_java_lambda_args_exceed_params_no_crash) { /* A call with MORE arguments than the resolved method's declared params: * bind_lambda_args indexed the NULL-terminated signature param_types array @@ -649,6 +675,7 @@ SUITE(stack_overflow) { RUN_TEST(lsp_java_lambda_args_exceed_params_no_crash); RUN_TEST(lsp_cpp_deep_expression_no_crash); RUN_TEST(lsp_python_deep_expression_no_crash); + RUN_TEST(lsp_perl_deep_expression_no_crash); RUN_TEST(lsp_ts_cyclic_types_no_crash); RUN_TEST(lsp_python_deep_nesting_no_crash); RUN_TEST(lsp_go_deep_nesting_no_crash);