Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
42 changes: 42 additions & 0 deletions dev/known-bugs/local_list_assign_eval_string.pl
Original file line number Diff line number Diff line change
@@ -0,0 +1,42 @@
#!/usr/bin/env perl
# Minimal reproduction of PerlOnJava bug:
# `local (HASH_OR_ARRAY_ELEMENT) = value;` inside eval-STRING-compiled
# subs is a no-op for the value assignment (scope restoration still works).
#
# See dev/modules/dbi_test_parity.md "Root cause of t/06attrs.t and
# t/08keeperr.t failures" for context. Blocks proper DBI::PurePerl
# error-message formatting.
#
# Run with both:
# ./jperl dev/known-bugs/local_list_assign_eval_string.pl
# perl dev/known-bugs/local_list_assign_eval_string.pl
# and compare outputs.

use strict;
use warnings;

my $h = { x => 0 };
my @a = (0);

# Case A: direct file-scope compile — works on both
sub directA { local ($h->{x}) = 42; print "A: h->{x}=$h->{x}\n"; }
directA();
print "A: after: h->{x}=$h->{x}\n";

# Case B: eval-STRING compiled sub, hash-element, list form — BUG on jperl
my $subB = eval q{ sub { local ($h->{x}) = 99; print "B: h->{x}=$h->{x}\n"; } };
die $@ if $@;
$subB->();

# Case C: eval-STRING compiled sub, hash-element, SCALAR form — works
my $subC = eval q{ sub { local $h->{x} = 77; print "C: h->{x}=$h->{x}\n"; } };
die $@ if $@;
$subC->();

# Case D: eval-STRING compiled sub, array-element, list form — BUG on jperl
my $subD = eval q{ sub { local ($a[0]) = 88; print "D: a[0]=$a[0]\n"; } };
die $@ if $@;
$subD->();

print "\nExpected (real perl):\n";
print "A: h->{x}=42\nA: after: h->{x}=0\nB: h->{x}=99\nC: h->{x}=77\nD: a[0]=88\n";
482 changes: 375 additions & 107 deletions dev/modules/dbi_test_parity.md

Large diffs are not rendered by default.

Original file line number Diff line number Diff line change
Expand Up @@ -261,6 +261,24 @@ private static boolean handleLocalListAssignment(BytecodeCompiler bc, BinaryOper
bc.lastResultReg = localReg;
return true;
}
// Single-element list with an lvalue like $h->{k}, $a[i], $obj->method->{k}, etc.
// Delegate to the scalar-local handler (matches the `local EXPR = RHS` path at
// line 20). Without this, the element falls through the main loop below and
// emits nothing - a silent no-op assignment. Reproduced by:
// local ($h->{x}) = 99; inside an eval-STRING-compiled sub
if (element instanceof BinaryOperatorNode binOp) {
bc.compileNode(binOp, -1, rhsContext);
int elemReg = bc.lastResultReg;
bc.emit(Opcodes.PUSH_LOCAL_VARIABLE);
bc.emitReg(elemReg);
bc.compileNode(node.right, -1, rhsContext);
int valueReg = bc.lastResultReg;
bc.emit(Opcodes.SET_SCALAR);
bc.emitReg(elemReg);
bc.emitReg(valueReg);
bc.lastResultReg = elemReg;
return true;
}
}
bc.compileNode(node.right, -1, rhsContext);
int valueReg = bc.lastResultReg;
Expand Down Expand Up @@ -292,6 +310,26 @@ private static boolean handleLocalListAssignment(BytecodeCompiler bc, BinaryOper
bc.emitReg(localReg);
bc.emitReg(elemReg);
if (i == 0) bc.lastResultReg = localReg;
} else if (element instanceof BinaryOperatorNode binOp) {
// Element is an lvalue expression (e.g. $h->{k}, $a[i], $obj->attr).
// Compile to get the element reference, localize it, and assign RHS[i].
bc.compileNode(binOp, -1, RuntimeContextType.SCALAR);
int elemLvalReg = bc.lastResultReg;
bc.emit(Opcodes.PUSH_LOCAL_VARIABLE);
bc.emitReg(elemLvalReg);
int idxReg = bc.allocateRegister();
bc.emit(Opcodes.LOAD_INT);
bc.emitReg(idxReg);
bc.emit(i);
int rhsElemReg = bc.allocateRegister();
bc.emit(Opcodes.ARRAY_GET);
bc.emitReg(rhsElemReg);
bc.emitReg(valueReg);
bc.emitReg(idxReg);
bc.emit(Opcodes.SET_SCALAR);
bc.emitReg(elemLvalReg);
bc.emitReg(rhsElemReg);
if (i == 0) bc.lastResultReg = elemLvalReg;
}
}
return true;
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -828,9 +828,12 @@ public static void visitOperator(BytecodeCompiler bytecodeCompiler, OperatorNode
}
bytecodeCompiler.symbolTable.setCurrentPackage(packageName, isClass);
if (isClass) ClassRegistry.registerClass(packageName);
boolean isScoped = Boolean.TRUE.equals(node.getAnnotation("isScoped"));
// Always emit PUSH_PACKAGE so the runtime tracker is restored when
// the enclosing block/sub/file exits. Perl 5's `package Foo;` is
// lexically scoped; the `isScoped` annotation used to distinguish
// `package Foo { BLOCK }` but bare `package Foo;` is equally scoped.
int nameIdx = bytecodeCompiler.addToStringPool(packageName);
bytecodeCompiler.emit(isScoped ? Opcodes.PUSH_PACKAGE : Opcodes.SET_PACKAGE);
bytecodeCompiler.emit(Opcodes.PUSH_PACKAGE);
bytecodeCompiler.emit(nameIdx);
bytecodeCompiler.lastResultReg = -1;
} else {
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -54,6 +54,23 @@ public class InterpreterState {
public static void setCurrentPackageStatic(String name) {
currentPackage.get().set(name);
}

/**
* Scoped variant of {@link #setCurrentPackageStatic}: pushes the current
* package value onto the DynamicVariableManager stack so it will be
* restored when the enclosing scope exits, then sets the new value.
* <p>
* Matches Perl 5 semantics: {@code package Foo;} is lexically scoped to
* the enclosing block / eval / file. Without the push, a {@code package Foo;}
* inside e.g. {@code Carp::caller_info}'s {@code { package DB; ... }} block
* would leak "DB" past the block, corrupting subsequent {@code do FILE}
* calls (which inherit the caller's package).
*/
public static void setCurrentPackageLocal(String name) {
RuntimeScalar pkg = currentPackage.get();
org.perlonjava.runtime.runtimetypes.DynamicVariableManager.pushLocalVariable(pkg);
pkg.set(name);
}
private static final ThreadLocal<Deque<InterpreterFrame>> frameStack =
ThreadLocal.withInitial(ArrayDeque::new);
// Use ArrayList of mutable int holders for O(1) PC updates (no pop/push overhead)
Expand Down
11 changes: 8 additions & 3 deletions src/main/java/org/perlonjava/backend/jvm/EmitOperator.java
Original file line number Diff line number Diff line change
Expand Up @@ -1123,13 +1123,18 @@ static void handlePackageOperator(EmitterVisitor emitterVisitor, OperatorNode no
// `require FILE` (which inspects InterpreterState.currentPackage to
// compile the required file in the correct namespace) see the right
// package after a `package Foo;` declaration in JVM-compiled code.
// Without this, the runtime tracker stays at "main" in compiled code,
// and `require FILE` incorrectly installs subs in main::.
//
// Use the *scoped* (local) variant so the runtime tracker is restored
// when the enclosing block / sub / file exits. Perl 5's `package Foo;`
// is lexically scoped; without the restore, a `package DB;` inside
// e.g. Carp::caller_info's inner `{ package DB; ... }` block would
// leak past the block and break subsequent `do FILE` calls which
// compile the loaded file in the *current* runtime package.
emitterVisitor.ctx.mv.visitLdcInsn(name);
emitterVisitor.ctx.mv.visitMethodInsn(
org.objectweb.asm.Opcodes.INVOKESTATIC,
"org/perlonjava/backend/bytecode/InterpreterState",
"setCurrentPackageStatic",
"setCurrentPackageLocal",
"(Ljava/lang/String;)V",
false);
// Set debug information for the file name.
Expand Down
4 changes: 2 additions & 2 deletions src/main/java/org/perlonjava/core/Configuration.java
Original file line number Diff line number Diff line change
Expand Up @@ -33,7 +33,7 @@ public final class Configuration {
* Automatically populated by Gradle/Maven during build.
* DO NOT EDIT MANUALLY - this value is replaced at build time.
*/
public static final String gitCommitId = "1cdf0926f";
public static final String gitCommitId = "7a0687aef";

/**
* Git commit date of the build (ISO format: YYYY-MM-DD).
Expand All @@ -48,7 +48,7 @@ public final class Configuration {
* Parsed by App::perlbrew and other tools via: perl -V | grep "Compiled at"
* DO NOT EDIT MANUALLY - this value is replaced at build time.
*/
public static final String buildTimestamp = "Apr 23 2026 13:55:28";
public static final String buildTimestamp = "Apr 23 2026 18:51:50";

// Prevent instantiation
private Configuration() {
Expand Down
82 changes: 82 additions & 0 deletions src/main/java/org/perlonjava/runtime/perlmodule/XSLoader.java
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,30 @@ public class XSLoader extends PerlModuleBase {
"XSLoader"
);

/**
* Modules that are pure-XS in real Perl with no PerlOnJava-side implementation.
* When XSLoader::load is called for one of these, we die cleanly so that
* {@code eval { require SomeModule }} in CPAN code (and test suites that
* probe for optional backends like DBM engines) correctly falls through
* to alternatives instead of silently "succeeding" and then crashing
* later when methods are actually called.
* <p>
* Rule of thumb: the module's whole functionality lives in a shared
* library shipped with CPAN, and there is no pure-Perl or Java-backed
* replacement in PerlOnJava. Pre-registered Java modules (File::Glob,
* Encode, Time::HiRes, etc.) must NOT appear here.
* <p>
* Kept in sync with the Perl-side copy in {@code lib/XSLoader.pm}.
*/
private static final Set<String> XS_ONLY_NOT_SUPPORTED = Set.of(
"DB_File",
"BerkeleyDB",
"GDBM_File",
"NDBM_File",
"ODBM_File",
"SDBM_File"
);

/**
* Constructor for XSLoader.
* Initializes the module with the name "XSLoader".
Expand All @@ -57,6 +81,41 @@ public static void initialize() {
}
}

/**
* Installs no-op Perl subroutines for XS symbols that a failed-to-load
* module's END block is known to call. Without these, the END queue
* aborts on interpreter shutdown with a non-zero exit status, which
* prove/TAP::Harness counts as a failed test program even when the
* program's actual assertions all passed or were SKIPped.
*
* Keyed by the module name passed to {@code XSLoader::load}.
*/
private static void installEndBlockStubs(String moduleName) {
String[] symbols = switch (moduleName) {
case "BerkeleyDB" -> new String[] { "BerkeleyDB::Term::close_everything" };
default -> null;
};
if (symbols == null) return;
try {
java.lang.invoke.MethodHandle mh = RuntimeCode.lookup.findStatic(
XSLoader.class, "noopStub", RuntimeCode.methodType);
for (String sym : symbols) {
if (GlobalVariable.existsGlobalCodeRef(sym)) continue;
RuntimeCode code = new RuntimeCode(mh, null, null);
code.isStatic = true;
GlobalVariable.getGlobalCodeRef(sym).set(new RuntimeScalar(code));
}
} catch (Exception e) {
// Non-fatal: the test program may still report a spurious non-zero
// exit, but the module-load failure path is unaffected.
}
}

/** No-op Perl sub used by {@link #installEndBlockStubs}. */
public static RuntimeList noopStub(RuntimeArray args, int ctx) {
return new RuntimeList();
}

/**
* Loads a PerlOnJava module.
* <p>
Expand Down Expand Up @@ -90,6 +149,29 @@ public static RuntimeList load(RuntimeArray args, int ctx) {
moduleName = args.getFirst().toString();
}

// Bail out cleanly for pure-XS modules PerlOnJava can't back.
// Without this, modules like DB_File load but their XS helpers
// (constant, etc.) are undefined, leading to infinite AUTOLOAD
// recursion (StackOverflowError) the first time the module is
// actually used. CPAN test suites commonly probe optional backends
// with `eval { require SomeDBM }` and rely on require FAILING to
// fall through to alternatives; silent success breaks them.
if (XS_ONLY_NOT_SUPPORTED.contains(moduleName)) {
// Install no-op stubs for any functions the module registers in an
// END block — the `.pm` file was already compiled end-to-end before
// we reach this `load`, so its END queue entries will fire at
// interpreter shutdown regardless of whether `require` succeeds.
// Without these, CPAN prove-style runners report the (otherwise-
// passing / SKIPped) test program as "exited 1" from the END die.
installEndBlockStubs(moduleName);

return WarnDie.die(
new RuntimeScalar("Can't load '" + moduleName + "' for module " + moduleName
+ ": XS module not supported on PerlOnJava"),
new RuntimeScalar("\n")
).getList();
}

// Convert Perl::Module::Name to org.perlonjava.runtime.perlmodule.PerlModuleName
String[] parts = moduleName.split("::");
StringBuilder className1 = new StringBuilder("org.perlonjava.runtime.perlmodule.");
Expand Down
36 changes: 33 additions & 3 deletions src/main/perl/lib/XSLoader.pm
Original file line number Diff line number Diff line change
Expand Up @@ -15,26 +15,56 @@ package XSLoader;

our $VERSION = "0.32";

# Modules that are pure-XS in real Perl with no PerlOnJava-side implementation.
# When XSLoader::load is called for one of these, we die cleanly so that
# `eval { require SomeModule }` in CPAN code (and test suites that probe for
# optional backends like DBM engines) correctly falls through to alternatives
# instead of silently "succeeding" and then crashing later when methods are
# actually called.
#
# Rule of thumb for adding to this list: the module's whole functionality
# lives in a `.so`/DLL shipped with CPAN, and there is no pure-Perl or
# Java-backed replacement in PerlOnJava. Pre-registered Java modules
# (File::Glob, Encode, Time::HiRes, etc.) must NOT appear here.
our %XS_ONLY_NOT_SUPPORTED = map { $_ => 1 } qw(
DB_File
BerkeleyDB
GDBM_File
NDBM_File
ODBM_File
SDBM_File
);

# Only define our load() if it's not already defined by Java
BEGIN {
unless (defined &load) {
*load = sub {
my ($module, $version) = @_;
$module = caller() unless defined $module;


# Bail out cleanly for pure-XS modules PerlOnJava can't back.
# Without this, modules like DB_File load but XS functions such
# as `constant` are undefined, which triggers infinite AUTOLOAD
# recursion (StackOverflowError) the first time the module is
# actually used.
if ($XS_ONLY_NOT_SUPPORTED{$module}) {
die "Can't load '$module' for module $module: "
. "XS module not supported on PerlOnJava\n";
}

# Check if the module has a bootstrap function (like standard XSLoader)
my $boots = "${module}::bootstrap";
if (defined &{$boots}) {
goto &{$boots};
}

# For Java-backed modules, the methods are already registered.
# For pure-Perl modules, nothing needs to be done.
# Either way, just return success.
return 1;
};
}

# Alias for compatibility
*bootstrap_inherit = \&load unless defined &bootstrap_inherit;
}
Expand Down
Loading