diff --git a/docs/about/changelog.md b/docs/about/changelog.md index a5ebb30201..5f4e5230e3 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -6,6 +6,7 @@ priorities and future plans. ## Work in progress +- Preserve hash-reference constant calls after typeglob undefinition, dereference glob-backed hash values during Morpheus configuration traversal, parse Error.pm's dynamic `catch $class with { ... }` form on both backends, and retain integer scalar identity through `int()` for decimal stringification; preserve regex referent types through blessed scalar references and cover Morpheus relational overload dispatch and caller filename normalization (#1342, #1376, #1427, #1428). - Implement `Time::HiRes::stat` with high-resolution file timestamps (#1912). - Export `fieldhash` from `Hash::Util` for compatibility with core Perl. diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index 7d9b7c7892..fe555c7d81 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -6360,7 +6360,10 @@ void compileVariableReference(OperatorNode node, String op) { if (node.getBooleanAnnotation("directNamedCall")) { int rd = allocateOutputRegister(); int nameIdx = addToStringPool(subName); - int cacheIdx = addToConstantPool(new RuntimeScalar()); + RuntimeScalar cachedCallRef = node.getBooleanAnnotation("preserveHashConstantCall") + && node.getAnnotation("parseTimeCodeRef") instanceof RuntimeScalar codeRef + ? codeRef : new RuntimeScalar(); + int cacheIdx = addToConstantPool(cachedCallRef); Object classMethod = node.getAnnotation("directClassMethod"); int classNameIdx = classMethod instanceof String className ? addToStringPool(className) : -1; diff --git a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java index 2057935cf4..a6d0ca7363 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java @@ -213,6 +213,7 @@ static Node parseSubroutineCall(Parser parser, boolean isMethod) { String prototype = null; List attributes = null; RuntimeScalar parseTimeCodeRef = null; + boolean preserveHashConstantCall = false; String prototypeErrorName = fullName; if (!isNewMethod && !isMethod) { RuntimeScalar codeRef = null; @@ -521,7 +522,12 @@ && isValidIndirectMethod(sourceSubName, parser) // Handle indirect object syntax with variable class: new $type $arg -> $type->new($arg) // This is similar to the IDENTIFIER case above, but for variable class names // Only applies when the subroutine doesn't exist (otherwise it's a function call) - if (!subExists && peek(parser).text.equals("$") && isValidIndirectMethod(subName) && !prototypeHasGlob) { + // The legacy Error.pm form `catch $class with { ... }` remains an + // indirect method call even when the core `try` feature is enabled; + // the core catch grammar requires a parenthesized exception variable. + boolean dynamicCatchClass = subName.equals("catch"); + if ((!subExists || dynamicCatchClass) && peek(parser).text.equals("$") + && (dynamicCatchClass || isValidIndirectMethod(subName)) && !prototypeHasGlob) { int currentIndex2 = parser.tokenIndex; // Parse the variable that holds the class name // Set flag so Variable.parseVariable allows ( after the variable @@ -881,6 +887,19 @@ && isValidIndirectMethod(sourceSubName, parser) } if (parseTimeCodeRef != null) { Object target = parseTimeCodeRef.value; + if (target instanceof RuntimeCode constantCode + && isHashReferenceConstant(constantCode) + && parser.ctx.symbolTable.getCurrentSubroutine() != null + && !parser.ctx.symbolTable.getCurrentSubroutine().isEmpty()) { + // A named body may be emitted only when first called, + // after runtime has executed `undef *CONSTANT`. Keep the + // constant CV captured by this body independent from the + // mutable CODE slot so hash-reference constants retain + // their compile-time value on both backends. + parseTimeCodeRef = new RuntimeScalar(constantCode.cloneForClosure()); + target = parseTimeCodeRef.value; + preserveHashConstantCall = true; + } boolean knownAtParseTime = target instanceof RuntimeCode runtimeCode && (runtimeCode.defined() || runtimeCode.isDeclared); codeRefNode.setAnnotation("subroutineKnownAtParseTime", knownAtParseTime); @@ -903,6 +922,9 @@ && isValidIndirectMethod(sourceSubName, parser) codeRefNode.setAnnotation("directLvalueCall", true); } } + if (preserveHashConstantCall) { + codeRefNode.setAnnotation("preserveHashConstantCall", true); + } BinaryOperatorNode call = new BinaryOperatorNode("(", codeRefNode, arguments, @@ -929,6 +951,19 @@ private static void throwNumberAfterBarewordDiagnostic(Parser parser, String sub + subName + "\"?)" + at + "syntax error" + at); } + private static boolean isHashReferenceConstant(RuntimeCode code) { + if (code.constantValue == null || code.constantValue.elements.size() != 1 + || !(code.constantValue.elements.getFirst() instanceof RuntimeScalar value)) { + return false; + } + while (value.type == RuntimeScalarType.READONLY_SCALAR + && value.value instanceof RuntimeScalar inner) { + value = inner; + } + return value.type == RuntimeScalarType.HASHREFERENCE + && value.value instanceof RuntimeHash; + } + private static boolean isValidIndirectMethod(String subName) { return isValidIndirectMethod(subName, null); } diff --git a/src/main/java/org/perlonjava/runtime/operators/MathOperators.java b/src/main/java/org/perlonjava/runtime/operators/MathOperators.java index cb11232a1e..4a04200e49 100644 --- a/src/main/java/org/perlonjava/runtime/operators/MathOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/MathOperators.java @@ -1829,8 +1829,15 @@ private static RuntimeScalar integerUnpropagated(RuntimeScalar arg1) { return new RuntimeScalar(value); // Return infinity or NaN as-is } - // Use truncate to get integer part (truncates towards zero) - return new RuntimeScalar(truncate(value)); + // Use truncate to get integer part (truncates towards zero). Perl's + // int() produces an IV when the result fits, even when the input was + // an NV. Keeping that integer flag matters for later arithmetic and + // stringification (for example, epoch microseconds). + double truncated = truncate(value); + if (truncated >= -0x1.0p63 && truncated < 0x1.0p63) { + return getScalarInt((long) truncated); + } + return new RuntimeScalar(truncated); } diff --git a/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java b/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java index 6c9cf65989..259354130a 100644 --- a/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java @@ -131,16 +131,6 @@ private static RuntimeScalar bless(RuntimeScalar runtimeScalar, RuntimeScalar cl if (referent instanceof RuntimeRegex regex) { regex.setBlessId(newBlessId); } - // qr// values can reach bless as a reference whose referent is a - // scalar wrapper around the actual RuntimeRegex. Keep the regex - // payload's class in sync so its mutable scalar view stringifies - // as the blessed object after $$qr assignment. - if (referent instanceof RuntimeScalar scalar - && scalar.type == REGEX - && scalar.value instanceof RuntimeRegex regex) { - regex.setBlessId(newBlessId); - } - propagateNestedRegexBlessing(runtimeScalar, newBlessId); // Blessing into a package materializes its stash in Perl. Method // lookup uses stash existence to decide whether to show the // "perhaps you forgot to load" hint. @@ -286,19 +276,6 @@ private static RuntimeScalar bless(RuntimeScalar runtimeScalar, RuntimeScalar cl return runtimeScalar; } - private static void propagateNestedRegexBlessing(RuntimeScalar scalar, int blessId) { - RuntimeScalar current = scalar; - for (int depth = 0; depth < 8; depth++) { - if (current.type == REGEX && current.value instanceof RuntimeRegex regex) { - current.setBlessId(blessId); - regex.setBlessId(blessId); - return; - } - if (current.type != REFERENCE || !(current.value instanceof RuntimeScalar next)) return; - current = next; - } - } - /** * Returns the type of a reference or its blessed package name. * Implements Perl's ref() built-in function. diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java index 7edd678928..a7566dd347 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java @@ -2531,6 +2531,18 @@ public static RuntimeScalar getGlobalCodeRefForDirectCall(String key, RuntimeSca if (current == null && !resolvedKey.equals(key)) { current = globalCodeRefs.get(key); } + // Hash-reference constants used by a compiled body retain their CV + // after `undef *NAME`; the cached value is an independent constant-CV + // snapshot, while the visible glob slot becomes undef. Ordinary direct + // calls continue to prefer the currently visible CODE slot below. + if (cached != null && cached.type == RuntimeScalarType.CODE + && cached.value instanceof RuntimeCode cachedCode + && cachedCode.constantValue != null + && (current == null || current.type != RuntimeScalarType.CODE + || !(current.value instanceof RuntimeCode currentCode) + || currentCode.constantValue == null)) { + return cached; + } if (current != null) { cached.type = current.type; cached.value = current.value; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java index de8f972ad8..b2eabcdf5b 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java @@ -4126,7 +4126,16 @@ public RuntimeHash hashDeref() { if (value instanceof RuntimeIO) { throw new PerlCompilerException("Not a HASH reference"); } - RuntimeGlob glob = (RuntimeGlob) value; + // A glob's scalar slot can itself carry the hash payload while + // Perl code traverses a glob reference with ${*{$glob}}{key}. + // In that representation the value is already the hash; it is + // not a RuntimeGlob wrapper. + if (value instanceof RuntimeHash hash) { + yield hash; + } + if (!(value instanceof RuntimeGlob glob)) { + throw new PerlCompilerException("Not a HASH reference"); + } // For anonymous globs, use the getGlobHash method which handles local slots yield glob.getGlobHash(); } @@ -4180,20 +4189,7 @@ public RuntimeScalar scalarDeref() { yield newScalar; } case REFERENCE -> { - RuntimeScalar referent = (RuntimeScalar) value; - // A blessed qr// is represented as a reference to a REGEX - // scalar. Dereferencing it must expose the mutable PV view, - // retaining the blessing that lives on the reference cell. - if (referent.type == REGEX && referent.value instanceof RuntimeRegex regex) { - int regexBlessId = referent.blessId != 0 ? referent.blessId - : this.blessId != 0 ? this.blessId - : blessedId(this) != 0 ? blessedId(this) : regex.blessId; - if (regexBlessId != 0) { - regex.setBlessId(regexBlessId); - yield new RegexScalarLvalue(regex, regexBlessId).propagateTaint(referent); - } - } - yield referent; + yield (RuntimeScalar) value; } case REGEX -> dereferencedRegexScalar(); case GLOB -> { @@ -4308,15 +4304,7 @@ public RuntimeScalar scalarDerefNonStrict(String packageName) { return switch (type) { case REFERENCE -> { - RuntimeScalar referent = (RuntimeScalar) value; - if (referent.type == REGEX && referent.value instanceof RuntimeRegex regex) { - int regexBlessId = referent.blessId != 0 ? referent.blessId - : this.blessId != 0 ? this.blessId - : blessedId(this) != 0 ? blessedId(this) : regex.blessId; - if (regexBlessId != 0) regex.setBlessId(regexBlessId); - yield new RegexScalarLvalue(regex, regexBlessId).propagateTaint(referent); - } - yield referent; + yield (RuntimeScalar) value; } case REGEX -> dereferencedRegexScalar(); case GLOB -> { diff --git a/src/test/java/org/perlonjava/runtime/runtimetypes/RuntimeScalarGlobHashDerefTest.java b/src/test/java/org/perlonjava/runtime/runtimetypes/RuntimeScalarGlobHashDerefTest.java new file mode 100644 index 0000000000..5476eefef0 --- /dev/null +++ b/src/test/java/org/perlonjava/runtime/runtimetypes/RuntimeScalarGlobHashDerefTest.java @@ -0,0 +1,22 @@ +package org.perlonjava.runtime.runtimetypes; + +import org.junit.jupiter.api.Tag; +import org.junit.jupiter.api.Test; + +import static org.junit.jupiter.api.Assertions.assertSame; + +class RuntimeScalarGlobHashDerefTest { + + @Tag("unit") + @Test + void hashDereferenceAcceptsHashPayloadStoredOnGlobScalar() { + RuntimeHash hash = new RuntimeHash(); + hash.put("1", new RuntimeScalar("value")); + + RuntimeScalar globScalar = new RuntimeScalar(); + globScalar.type = RuntimeScalarType.GLOB; + globScalar.value = hash; + + assertSame(hash, globScalar.hashDeref()); + } +} diff --git a/src/test/resources/unit/issue_1342_overloaded_relational_dispatch.t b/src/test/resources/unit/issue_1342_overloaded_relational_dispatch.t new file mode 100644 index 0000000000..76a2a63547 --- /dev/null +++ b/src/test/resources/unit/issue_1342_overloaded_relational_dispatch.t @@ -0,0 +1,63 @@ +use strict; +use warnings; +use Test::More; + +{ + package Local::PartialOrderKey; + + use overload + 'eq' => sub { + @_ = upgrade(@_); + my ($left, $right) = @_; + $$left eq $$right; + }, + 'lt' => \&less, + 'le' => sub { + @_ = upgrade(@_); + my ($left, $right) = @_; + $left lt $right || $left eq $right; + }, + 'gt' => sub { @_ = upgrade(@_); $_[1] lt $_[0] }, + 'ge' => sub { + @_ = upgrade(@_); + my ($left, $right) = @_; + $right lt $left || $left eq $right; + }, + '""' => sub { ${$_[0]} }; + + sub less ($$) { + @_ = upgrade(@_); + my ($left, $right) = @_; + my ($a, $b) = ("$left", "$right"); + length($a) < length($b) && substr($b, 0, length($a) + 1) eq "$a/"; + } + + sub new { + my ($class, $key) = @_; + $key =~ s{/+}{/}g; + $key =~ s{^/*}{/}; + $key =~ s{/+$}{}; + return bless \$key, $class; + } + + sub upgrade { + map { ref $_ ? $_ : __PACKAGE__->new($_) } @_; + } +} + +sub compare_dynamically { + my ($left, $right) = @_; + return $left le $right; +} + +my $parent = Local::PartialOrderKey->new('/foo'); +my $child = Local::PartialOrderKey->new('/foo/bar'); +my $sibling = Local::PartialOrderKey->new('/other'); + +ok(compare_dynamically($parent, $child), + 'relational overloads dispatch through dynamically typed subroutine arguments'); +ok(compare_dynamically($parent, '/foo'), + 'relational overloads upgrade a string operand inside an overload method'); +ok(!($parent eq $sibling), 'key equality remains independent of ordering'); + +done_testing; diff --git a/src/test/resources/unit/issue_1376_constant_hashref_deref_after_undef.t b/src/test/resources/unit/issue_1376_constant_hashref_deref_after_undef.t new file mode 100644 index 0000000000..29c5146e71 --- /dev/null +++ b/src/test/resources/unit/issue_1376_constant_hashref_deref_after_undef.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use Test::More; + +{ + package Local::HashReferenceConstant; + + use constant TABLE => { + answer => [42], + }; + + sub values_for { + my ($key) = @_; + return exists TABLE->{$key} ? @{ TABLE->{$key} } : (); + } +} + +# Perl compiles the constant dereferences into values before runtime removes +# the visible typeglob. A lazily compiled body must retain that same value. +undef *Local::HashReferenceConstant::TABLE; + +my @values = Local::HashReferenceConstant::values_for('answer'); +is(scalar @values, 1, 'hash-reference constant remains available after its typeglob is undefined'); +is($values[0], 42, 'constant hash dereference returns the original array value'); + +done_testing; diff --git a/src/test/resources/unit/issue_1427_dynamic_catch_syntax.t b/src/test/resources/unit/issue_1427_dynamic_catch_syntax.t new file mode 100644 index 0000000000..daaa0267ee --- /dev/null +++ b/src/test/resources/unit/issue_1427_dynamic_catch_syntax.t @@ -0,0 +1,21 @@ +use strict; +use warnings; +use Test::More; + +{ + package Local::DynamicCatch; + + sub catch { + my ($class, $handler) = @_; + return $class . ':' . $handler->(); + } +} + +sub with (&;$) { return $_[0] } + +my $exception_class = 'Local::DynamicCatch'; +my $caught = catch $exception_class with { 'handler ran' }; +is($caught, 'Local::DynamicCatch:handler ran', + 'dynamic class name dispatches catch with its with block'); + +done_testing; diff --git a/src/test/resources/unit/issue_1427_regex_scalar_ref_bless_isolation.t b/src/test/resources/unit/issue_1427_regex_scalar_ref_bless_isolation.t new file mode 100644 index 0000000000..67db5c269d --- /dev/null +++ b/src/test/resources/unit/issue_1427_regex_scalar_ref_bless_isolation.t @@ -0,0 +1,35 @@ +use strict; +use warnings; +use Test::More; + +{ + package Local::RegexScalarHolder; + + use overload '""' => sub { 'regex assertion' }; + + sub new { + my $class = shift; + my $regex = shift; + return bless \$regex, $class; + } + + sub do_assertion { + my $self = shift; + my $target = shift; + return $target =~ $$self; + } +} + +my $arguments = ['fixed', qr/x/]; +my $holder = Local::RegexScalarHolder->new($arguments->[1]); + +is(ref($holder), 'Local::RegexScalarHolder', + 'blessing a reference to a copied regex scalar blesses the scalar reference'); +ok($holder->do_assertion($arguments->[0]), + 'a scalar reference to the regex can still perform a match'); +is(ref($arguments->[1]), 'Regexp', + 'dereferencing the assertion does not bless the caller regex'); +like('fixed', $arguments->[1], + 'the caller regex remains usable after blessing the scalar copy'); + +done_testing; diff --git a/src/test/resources/unit/issue_1428_integer_stringification.t b/src/test/resources/unit/issue_1428_integer_stringification.t new file mode 100644 index 0000000000..e6b5451c64 --- /dev/null +++ b/src/test/resources/unit/issue_1428_integer_stringification.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; + +my $microseconds = 1051470597; +$microseconds *= 1e6; +$microseconds += int(0.8 * 1e6); + +is("$microseconds", '1051470597800000', + 'large integral arithmetic with int() stringifies as decimal'); + +like("" . (1.5 * 1_000_000_000_000_000), qr/[eE+]/, + 'large fractional NV values retain scientific notation'); + +like("" . 1e20, qr/[eE+]/, + 'large floating literals retain scientific notation'); + +done_testing;