diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 25d12c4dc..104621074 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -3325,7 +3325,12 @@ public static RuntimeList callerWithSub(RuntimeList args, int ctx, RuntimeScalar } } else if (frame >= stackTraceSize) { RuntimeCode activeCode = hasExplicitExpr ? getActiveCodeAt(originalFrame) : null; - if (activeCode != null && activeCode.explicitlyRenamed) { + String activeSubName = activeCode != null + ? applyAnonNameOverride(callerSubNameForCode(activeCode)) + : null; + if (activeCode != null && !calledFromDB + && hasExplicitlyRenamedActiveCode() + && activeSubName != null && !activeSubName.isEmpty()) { String pkg = normalizeCallerPackage(activeCode.packageName); if (ctx == RuntimeContextType.SCALAR) { res.add(new RuntimeScalar(pkg)); @@ -3333,10 +3338,7 @@ public static RuntimeList callerWithSub(RuntimeList args, int ctx, RuntimeScalar res.add(new RuntimeScalar(pkg)); res.add(new RuntimeScalar(activeCode.cvStartFile != null ? activeCode.cvStartFile : "")); res.add(new RuntimeScalar(activeCode.cvStartLine)); - String subName = applyAnonNameOverride(callerSubNameForCode(activeCode)); - res.add(subName != null && !subName.isEmpty() - ? new RuntimeScalar(subName) - : RuntimeScalarCache.scalarUndef); + res.add(new RuntimeScalar(activeSubName)); Boolean hasArgsFromStack = getHasArgsAt(originalFrame); res.add(hasArgsFromStack != null && hasArgsFromStack ? RuntimeScalarCache.scalarTrue @@ -3394,6 +3396,15 @@ private static String callerSubNameForCode(RuntimeCode code) { return pkg + "::" + code.subName; } + private static boolean hasExplicitlyRenamedActiveCode() { + for (RuntimeCode active : activeCodeStack.get()) { + if (active.explicitlyRenamed) { + return true; + } + } + return false; + } + private static String applyAnonNameOverride(String subName) { if (subName != null && subName.endsWith("::__ANON__")) { String anonPkg = subName.substring(0, diff --git a/src/main/perl/lib/CPAN/Config.pm b/src/main/perl/lib/CPAN/Config.pm index fbc36dcb5..255065747 100644 --- a/src/main/perl/lib/CPAN/Config.pm +++ b/src/main/perl/lib/CPAN/Config.pm @@ -70,6 +70,7 @@ sub _bootstrap_prefs { 'Test-File-ShareDir.yml' => 'PerlOnJava/CpanDistroprefs/Test-File-ShareDir.yml', 'DateTime-Locale.yml' => 'PerlOnJava/CpanDistroprefs/DateTime-Locale.yml', 'Test-File.yml' => 'PerlOnJava/CpanDistroprefs/Test-File.yml', + 'Test-SharedFork.yml' => 'PerlOnJava/CpanDistroprefs/Test-SharedFork.yml', 'UNIVERSAL-can.yml' => 'PerlOnJava/CpanDistroprefs/UNIVERSAL-can.yml', 'UNIVERSAL-isa.yml' => 'PerlOnJava/CpanDistroprefs/UNIVERSAL-isa.yml', 'Test-MockObject.yml' => 'PerlOnJava/CpanDistroprefs/Test-MockObject.yml', diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-SharedFork.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-SharedFork.yml new file mode 100644 index 000000000..84e352426 --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-SharedFork.yml @@ -0,0 +1,14 @@ +--- +comment: | + PerlOnJava distroprefs for Test::SharedFork. + + PerlOnJava does not implement fork, and Test::SharedFork's own test suite + intentionally exercises fork coordination. Some downstream pure-Perl + distributions, such as Module::Build::Pluggable, load Test::SharedFork as a + test harness helper while their useful behavior remains independently covered + by their own tests. Build the module but skip its fork-only upstream tests so + CPAN can stage it for those downstream test phases. +match: + distribution: "^EXODIST/Test-SharedFork-" +test: + commandline: "PERLONJAVA_SKIP" diff --git a/src/test/resources/unit/caller_line_number.t b/src/test/resources/unit/caller_line_number.t index 7c28bf975..91bb9e5b1 100644 --- a/src/test/resources/unit/caller_line_number.t +++ b/src/test/resources/unit/caller_line_number.t @@ -1,7 +1,7 @@ #!/usr/bin/perl use strict; use warnings; -use Test::More tests => 13; +use Test::More tests => 14; use Eval::Closure qw(eval_closure); use Sub::Util qw(set_subname); @@ -138,4 +138,28 @@ is( CallerLineNumber::GeneratedAccessor::generated(), 'CallerLineNumber::GeneratedAccessor::generated', 'caller(1)[3] uses explicit set_subname for generated accessors' ); +{ + package CallerLineNumber::TiedHash; + require Tie::Hash; + our @ISA = qw(Tie::StdHash); + sub FETCH { + main::is('x', 'x', 'Test::More context survives set_subname accessor tied FETCH'); + return 42; + } + + package CallerLineNumber::SetSubnameAccessor; + sub new { + my %store; + tie %store, 'CallerLineNumber::TiedHash'; + return bless \%store, shift; + } + + my $accessor = sub { return $_[0]{value} }; + Sub::Util::set_subname('CallerLineNumber::SetSubnameAccessor::value', $accessor); + no strict 'refs'; + *{'CallerLineNumber::SetSubnameAccessor::value'} = $accessor; +} + +my $tied_fetch_value = CallerLineNumber::SetSubnameAccessor->new->value(); + # End of tests