diff --git a/src/main/java/org/perlonjava/app/cli/ArgumentParser.java b/src/main/java/org/perlonjava/app/cli/ArgumentParser.java index f9b30b9ff..9c26910f3 100644 --- a/src/main/java/org/perlonjava/app/cli/ArgumentParser.java +++ b/src/main/java/org/perlonjava/app/cli/ArgumentParser.java @@ -13,6 +13,8 @@ import java.util.ArrayList; import java.util.Arrays; import java.util.List; +import java.util.regex.Matcher; +import java.util.regex.Pattern; import static org.perlonjava.core.Configuration.getPerlVersionBundle; @@ -317,31 +319,152 @@ private static void processNonSwitchArgument(String[] args, CompilerOptions pars */ private static void processShebangLine(String[] args, CompilerOptions parsedArgs, String fileContent, int index) { String[] lines = fileContent.split("\n", 2); - if (lines.length > 0 && lines[0].startsWith("#!")) { - // Extract the shebang line and process it - String shebangLine = lines[0].substring(2).trim(); - int perlIndex = shebangLine.indexOf("perl"); - if (perlIndex != -1) { - String relevantPart = shebangLine.substring(perlIndex + 4).trim(); - // Strip emacs mode line marker (e.g. "-*- mode: cperl -*-") which real - // perl tolerates in #! lines but not on the command line. - int emacsStart = relevantPart.indexOf("-*-"); - if (emacsStart != -1) { - int emacsEnd = relevantPart.indexOf("-*-", emacsStart + 3); - if (emacsEnd != -1) { - relevantPart = relevantPart.substring(0, emacsStart) - + relevantPart.substring(emacsEnd + 3); - } else { - relevantPart = relevantPart.substring(0, emacsStart); - } + if (lines.length == 0 || !lines[0].startsWith("#!")) { + return; + } + String shebangLine = lines[0].substring(2).trim(); + if (shebangLine.isEmpty()) { + return; + } + + // perlrun: parsing of #! switches starts at a *word* "perl" or "indir". + // Substrings like "jperl" must NOT match (matches stock perl behavior). + Matcher perlWord = Pattern.compile("\\b(?:perl|indir)\\b", Pattern.CASE_INSENSITIVE).matcher(shebangLine); + if (perlWord.find()) { + String relevantPart = shebangLine.substring(perlWord.end()).trim(); + // Strip emacs mode line marker (e.g. "-*- mode: cperl -*-") which real + // perl tolerates in #! lines but not on the command line. + int emacsStart = relevantPart.indexOf("-*-"); + if (emacsStart != -1) { + int emacsEnd = relevantPart.indexOf("-*-", emacsStart + 3); + if (emacsEnd != -1) { + relevantPart = relevantPart.substring(0, emacsStart) + + relevantPart.substring(emacsEnd + 3); + } else { + relevantPart = relevantPart.substring(0, emacsStart); } - String[] shebangArgs = relevantPart.trim().split("\\s+"); - // Filter out empty args from shebang processing - String[] nonEmptyArgs = Arrays.stream(shebangArgs) - .filter(arg -> !arg.isEmpty()) - .toArray(String[]::new); - processArgs(nonEmptyArgs, parsedArgs); } + String[] shebangArgs = relevantPart.trim().split("\\s+"); + String[] nonEmptyArgs = Arrays.stream(shebangArgs) + .filter(arg -> !arg.isEmpty()) + .toArray(String[]::new); + processArgs(nonEmptyArgs, parsedArgs); + return; + } + + // Alternate interpreter (perlrun): if there is no word "perl"/"indir", exec the named program. + // Example: Inline's TestML tests start with "#!inc/bin/testml-cpan". + String[] tokens = shebangLine.split("\\s+"); + if (tokens.length == 0) { + return; + } + if (isPerlOnJavaExecutable(Paths.get(tokens[0]))) { + // Same binary as this runtime (e.g. "#!/path/to/jperl"): compile here; do not re-exec. + return; + } + List cmd = buildShebangCommand(tokens); + delegateToShebangInterpreter(args, cmd, index); + } + + /** + * Build argv for an alternate #! interpreter. + * When {@code PERLONJAVA_EXECUTABLE} points at our launcher, prefer {@code jperl /abs/script} + * over executing {@code script} directly so ENOEXEC/shell-fallback (bash parsing Perl) + * cannot occur — CPAN's Inline bundles "#!inc/bin/testml-cpan" wrappers whose kernel + * exec path is fragile under JVM-spawned children on some platforms. + */ + private static List buildShebangCommand(String[] shebangTokens) { + java.nio.file.Path interpScript = + Paths.get(shebangTokens[0]).toAbsolutePath().normalize(); + String perlExe = System.getenv("PERLONJAVA_EXECUTABLE"); + List out = new ArrayList<>(); + if (perlExe != null && !perlExe.isEmpty() && interpreterScriptUsesPerlOnJava(interpScript)) { + out.add(perlExe); + out.add(interpScript.toString()); + for (int i = 1; i < shebangTokens.length; i++) { + out.add(shebangTokens[i]); + } + return out; + } + out.add(interpScript.toString()); + for (int i = 1; i < shebangTokens.length; i++) { + out.add(shebangTokens[i]); + } + return out; + } + + /** True when {@code script}'s own shebang names this PerlOnJava launcher (absolute path). */ + private static boolean interpreterScriptUsesPerlOnJava(java.nio.file.Path script) { + try { + List lines = java.nio.file.Files.readAllLines(script, java.nio.charset.StandardCharsets.UTF_8); + if (lines.isEmpty()) { + return false; + } + String line = lines.getFirst().trim(); + if (!line.startsWith("#!")) { + return false; + } + String body = line.substring(2).trim(); + if (body.isEmpty()) { + return false; + } + String[] parts = body.split("\\s+"); + return isPerlOnJavaExecutable(Paths.get(parts[0])); + } catch (IOException e) { + return false; + } + } + + /** + * True when {@code interpreterPath} resolves to the same file as {@code PERLONJAVA_EXECUTABLE}. + */ + private static boolean isPerlOnJavaExecutable(java.nio.file.Path interpreterPath) { + String self = System.getenv("PERLONJAVA_EXECUTABLE"); + if (self == null || self.isEmpty()) { + return false; + } + try { + java.nio.file.Path a = interpreterPath.toAbsolutePath().normalize().toRealPath(); + java.nio.file.Path b = Paths.get(self).toAbsolutePath().normalize().toRealPath(); + return a.equals(b); + } catch (IOException e) { + try { + java.io.File fa = interpreterPath.toAbsolutePath().normalize().toFile(); + java.io.File fb = Paths.get(self).toAbsolutePath().normalize().toFile(); + return fa.getCanonicalPath().equals(fb.getCanonicalPath()); + } catch (IOException e2) { + return false; + } + } + } + + /** + * Spawn the alternate #! interpreter with this script and trailing argv, then exit the JVM + * with its status (matches perl's exec semantics closely enough for harness-driven tests). + */ + private static void delegateToShebangInterpreter(String[] args, List interpreterArgv0, int scriptArgIndex) { + // Preserve the argv spelling (usually relative, e.g. t/foo.t). Some wrappers + // (Inline's inc/bin/testml-cpan) regex-rewrite paths assuming a distribution-relative name; + // canonical absolute paths break their compiled-.tml lookup. + List cmd = new ArrayList<>(interpreterArgv0); + cmd.add(args[scriptArgIndex]); + for (int i = scriptArgIndex + 1; i < args.length; i++) { + cmd.add(args[i]); + } + ProcessBuilder pb = new ProcessBuilder(cmd); + pb.inheritIO(); + try { + Process p = pb.start(); + int exit = p.waitFor(); + System.exit(exit); + } catch (IOException e) { + System.err.println("Error: unable to run shebang interpreter \"" + + interpreterArgv0.get(0) + "\": " + e.getMessage()); + System.exit(255); + } catch (InterruptedException e) { + Thread.currentThread().interrupt(); + System.err.println("Error: interrupted while running shebang interpreter"); + System.exit(255); } } diff --git a/src/main/java/org/perlonjava/frontend/parser/CoreOperatorResolver.java b/src/main/java/org/perlonjava/frontend/parser/CoreOperatorResolver.java index a04defac7..f0ce13fa8 100644 --- a/src/main/java/org/perlonjava/frontend/parser/CoreOperatorResolver.java +++ b/src/main/java/org/perlonjava/frontend/parser/CoreOperatorResolver.java @@ -36,6 +36,15 @@ public class CoreOperatorResolver { * @return A Node representing the parsed operator and its operands. */ public static Node parseCoreOperator(Parser parser, LexerToken token, int startIndex) { + return parseCoreOperator(parser, token, startIndex, false); + } + + /** + * @param coreQualified when true, the call was written as {@code CORE::name(...)} — always use + * CORE's prototype for arity, never the current package's subroutine of + * the same name (e.g. {@code CORE::close($fh)} with {@code sub close ()}). + */ + public static Node parseCoreOperator(Parser parser, LexerToken token, int startIndex, boolean coreQualified) { int currentIndex = parser.tokenIndex; String operatorName = token.text; @@ -128,12 +137,14 @@ public static Node parseCoreOperator(Parser parser, LexerToken token, int startI "endhostent", "endnetent", "endprotoent", "endservent", "gethostent", "getnetbyaddr", "getnetbyname", "getnetent", "getprotoent", "getservent", "sethostent", - "setnetent", "setprotoent", "setservent", "reverse" -> parseWithPrototype(parser, token, currentIndex); - default -> parseWithPrototype(parser, token, currentIndex); + "setnetent", "setprotoent", "setservent", "reverse" -> + parseWithPrototype(parser, token, currentIndex, coreQualified); + default -> parseWithPrototype(parser, token, currentIndex, coreQualified); }; } - private static Node parseWithPrototype(Parser parser, LexerToken token, int currentIndex) { + private static Node parseWithPrototype( + Parser parser, LexerToken token, int currentIndex, boolean coreQualified) { String operator = token.text; String fq = parser.ctx.symbolTable.getCurrentPackage() + "::" + operator; @@ -150,7 +161,11 @@ private static Node parseWithPrototype(Parser parser, LexerToken token, int curr // // When coreProto != null, a defined package CV with an explicit prototype overrides // arity checking (Net::hostent gethostbyaddr ($;$) vs CORE $$). - if (coreProto != null + // + // Explicit CORE::name(...) must never take the package CV's prototype — real Perl + // always dispatches to the builtin (Image::BMP's "sub close ()" vs CORE::close $fh). + if (!coreQualified + && coreProto != null && GlobalVariable.existsGlobalCodeRef(fq)) { RuntimeScalar ref = GlobalVariable.getGlobalCodeRef(fq); if (ref.type == RuntimeScalarType.CODE && ref.value instanceof RuntimeCode code && code.defined() diff --git a/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java b/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java index d3f0311d3..4cf768b3b 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java +++ b/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java @@ -220,7 +220,7 @@ private static Node parseIdentifier(Parser parser, int startIndex, LexerToken to // Try to parse as a core operator/keyword if (operatorEnabled) { - Node operation = CoreOperatorResolver.parseCoreOperator(parser, token, startIndex); + Node operation = CoreOperatorResolver.parseCoreOperator(parser, token, startIndex, calledWithCore); if (operation != null) { return operation; } diff --git a/src/main/java/org/perlonjava/runtime/operators/BitwiseOperators.java b/src/main/java/org/perlonjava/runtime/operators/BitwiseOperators.java index a8dbb0781..5f6104055 100644 --- a/src/main/java/org/perlonjava/runtime/operators/BitwiseOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/BitwiseOperators.java @@ -1,5 +1,6 @@ package org.perlonjava.runtime.operators; + import org.perlonjava.frontend.parser.NumberParser; import org.perlonjava.runtime.runtimetypes.*; @@ -484,8 +485,8 @@ public static RuntimeScalar shiftLeft(RuntimeScalar runtimeScalar, RuntimeScalar return shiftRightInternal(value, shift, false); } - // Perl uses 32-bit word size for shift operations - // Shifts >= 32 return 0 + // 32-bit Perl: UV shifts wrap at 32 bits; (1<<32) and larger shifts are 0 + // (perl5_t/t/op/bop.t; Config ivsize=4). if (shift >= 32) { return RuntimeScalarCache.scalarZero; } diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java index d6aa79810..8c532a957 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java @@ -579,6 +579,16 @@ public static RuntimeList getcwd(RuntimeArray args, int ctx) { */ public static RuntimeList abs_path(RuntimeArray args, int ctx) { String path = args.size() > 0 ? args.get(0).toString() : "."; + // jar:PERL5LIB & jar:PERL5LIB/… paths live in the embedded Perl library. + // File.exists/canonicalPath cannot see them, but FileTestOperator and @INC do. + // Inline::derive_minus_I maps abs_path over @INC entries; returning undef here + // produced bare "-I" flags and broke Inline's config subprocess. + if (path.startsWith("jar:")) { + if (Jar.isJarDirectory(path) || Jar.exists(path)) { + return new RuntimeScalar(path).getList(); + } + return new RuntimeScalar().getList(); + } try { java.io.File file = new java.io.File(path); if (!file.isAbsolute()) { diff --git a/src/main/perl/lib/CPAN/Config.pm b/src/main/perl/lib/CPAN/Config.pm index c12f75f65..9612967f2 100644 --- a/src/main/perl/lib/CPAN/Config.pm +++ b/src/main/perl/lib/CPAN/Config.pm @@ -36,6 +36,7 @@ sub _bootstrap_prefs { 'Net-Server.yml' => 'PerlOnJava/CpanDistroprefs/Net-Server.yml', 'CPAN-FindDependencies.yml' => 'PerlOnJava/CpanDistroprefs/CPAN-FindDependencies.yml', 'IO-Async.yml' => 'PerlOnJava/CpanDistroprefs/IO-Async.yml', + 'Image-BMP.yml' => 'PerlOnJava/CpanDistroprefs/Image-BMP.yml', ); $pref_install{'OpenAI-API.yml'} = $ENV{PERLONJAVA_OPENAI_LIVE_TESTING} ? 'PerlOnJava/CpanDistroprefs/OpenAI-API.live.yml' @@ -126,6 +127,8 @@ sub _bootstrap_patches { 'PerlOnJava/CpanPatches/OpenAI-API-0.37/EventLoop.patch' ], [ 'OpenAI-API-0.37/NoNetworkTests.patch', 'PerlOnJava/CpanPatches/OpenAI-API-0.37/NoNetworkTests.patch' ], + [ 'Image-BMP-1.26/BMP.pm.patch', + 'PerlOnJava/CpanPatches/Image-BMP-1.26/BMP.pm.patch' ], ); my $slurp = sub { diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Image-BMP.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Image-BMP.yml new file mode 100644 index 000000000..d564b1e29 --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Image-BMP.yml @@ -0,0 +1,12 @@ +--- +comment: | + PerlOnJava distroprefs for Image::BMP. + + On 32-bit IV builds, 1<<32 is 0, but BMP info headers use ColorsUsed==0 to + mean 2**BitCount entries (e.g. 2**32 for 32bpp). Use exponentiation so + jcpan tests and runtime match the module author's intent on PerlOnJava + (ivsize=4; see perl5_t/t/op/bop.t). +match: + distribution: "^.*/Image-BMP-1\\.26" +patches: + - "Image-BMP-1.26/BMP.pm.patch" diff --git a/src/main/perl/lib/PerlOnJava/CpanPatches/Image-BMP-1.26/BMP.pm.patch b/src/main/perl/lib/PerlOnJava/CpanPatches/Image-BMP-1.26/BMP.pm.patch new file mode 100644 index 000000000..ed44f73e6 --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanPatches/Image-BMP-1.26/BMP.pm.patch @@ -0,0 +1,29 @@ +--- lib/Image/BMP.pm.orig ++++ lib/Image/BMP.pm +@@ -292,7 +292,7 @@ + sub split_bits { + my ($val,$bits) = @_; + fatal("Can't handle >32b numbers") if $bits>32; +- fatal("Tried fitting [$val] into $bits bits") if $val>=(1<<$bits); ++ fatal("Tried fitting [$val] into $bits bits") if $val>=(2**$bits); + split('',substr(unpack("B32",pack("N",$val)),32-$bits)); + } + +@@ -382,7 +382,7 @@ + $bmp->{YpixelsPerM} = read_bmp($bmp,4); + $bmp->{ColorsUsed} = read_bmp($bmp,4); + $bmp->{ColorsImportant} = read_bmp($bmp,4); +- $bmp->{ColorsUsed} = 1<<$bmp->{BitCount} if $bmp->{ColorsUsed} == 0; ++ $bmp->{ColorsUsed} = 2**$bmp->{BitCount} if $bmp->{ColorsUsed} == 0; + + $bmp->_debug(1,"Image: $bmp->{BitCount}/$bmp->{ColorsUsed} colors. Geometry: $bmp->{Width}x$bmp->{Height} $bmp->{ImageSize} [comp: $compStr ($bmp->{Compression})]\n"); + +@@ -401,7 +401,7 @@ + # BITMAPV4HEADER has 68 more bytes to read + read_bmp($bmp,68) if $bmp->{HeaderSize}==108; + +- $bmp->{_colors} = $bmp->{ColorsUsed} || 1<<$bmp->{BitCount}; ++ $bmp->{_colors} = $bmp->{ColorsUsed} || 2**$bmp->{BitCount}; + $bmp->{_colors} = 0 if $bmp->{_colors}==(1<<24); # No truecolor map + + # Treat mask colors as color indexes (just to skip them) and reset diff --git a/src/main/perl/lib/diagnostics.pm b/src/main/perl/lib/diagnostics.pm index 8ba7c1b07..f41ea5d5d 100644 --- a/src/main/perl/lib/diagnostics.pm +++ b/src/main/perl/lib/diagnostics.pm @@ -573,13 +573,22 @@ sub death_trap { # See if we are coming from anywhere within an eval. If so we don't # want to explain the exception because it's going to get caught. - my $in_eval = 0; - my $i = 0; - while (my $caller = (caller($i++))[3]) { - if ($caller eq '(eval)') { - $in_eval = 1; - last; - } + # + # PerlOnJava note: caller()[3] inside $SIG{__DIE__} may not include the + # synthetic "(eval)" frame yet (stack differs from perl's XS caller). + # Inline's tests hit this via `eval "require Missing::Mod"` under + # diagnostics; missing the eval frame makes splain+die recurse badly. + # When the exception already carries an "(eval N) line" location, treat + # it as eval-bound — matching perl's behavior for $@ caught by eval. + my $in_eval = ($exception =~ /\bat \(eval \d+\) line\b/); + unless ($in_eval) { + my $i = 0; + while (my $caller = (caller($i++))[3]) { + if ($caller eq '(eval)') { + $in_eval = 1; + last; + } + } } splainthis($exception) unless $in_eval; diff --git a/src/test/resources/unit/core_qualified_builtin_prototype.t b/src/test/resources/unit/core_qualified_builtin_prototype.t new file mode 100644 index 000000000..ae766490a --- /dev/null +++ b/src/test/resources/unit/core_qualified_builtin_prototype.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 1; + +# Image::BMP and similar modules define `sub close ()` and call CORE::close($fh). +# The compiler must use the builtin prototype for CORE::..., not the package sub's (). +eval q{ + package JpctCoreClose; + sub close () { return 'package' } + sub use_builtin_close { + my $fh; + CORE::close($fh); + } + 1; +}; +is $@, q{}, 'CORE::close($fh) parses when package defines sub close ()';