diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java index 8fd31b8fc..361c3346a 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java @@ -31,6 +31,7 @@ static RuntimeScalar ensureMutableScalar(RuntimeBase val) { copy.type = ro.type; copy.value = ro.value; copy.numericLiteralText = ro.numericLiteralText; + copy.numericContextSeen = ro.numericContextSeen; return copy; } if (val instanceof ScalarSpecialVariable sv) { @@ -39,6 +40,7 @@ static RuntimeScalar ensureMutableScalar(RuntimeBase val) { copy.type = src.type; copy.value = src.value; copy.numericLiteralText = src.numericLiteralText; + copy.numericContextSeen = src.numericContextSeen; return copy; } return (RuntimeScalar) val; diff --git a/src/main/java/org/perlonjava/backend/bytecode/InlineOpcodeHandler.java b/src/main/java/org/perlonjava/backend/bytecode/InlineOpcodeHandler.java index c7232b20e..6ac3d9bff 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/InlineOpcodeHandler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/InlineOpcodeHandler.java @@ -39,6 +39,7 @@ static RuntimeScalar ensureMutableScalar(RuntimeBase val) { copy.type = ro.type; copy.value = ro.value; copy.numericLiteralText = ro.numericLiteralText; + copy.numericContextSeen = ro.numericContextSeen; return copy; } if (val instanceof ScalarSpecialVariable sv) { @@ -47,6 +48,7 @@ static RuntimeScalar ensureMutableScalar(RuntimeBase val) { copy.type = src.type; copy.value = src.value; copy.numericLiteralText = src.numericLiteralText; + copy.numericContextSeen = src.numericContextSeen; return copy; } return (RuntimeScalar) val; diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/DataDumper.java b/src/main/java/org/perlonjava/runtime/perlmodule/DataDumper.java index c3bef87f4..0142dec3e 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/DataDumper.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/DataDumper.java @@ -4,6 +4,7 @@ import org.perlonjava.runtime.runtimetypes.RuntimeArray; import org.perlonjava.runtime.runtimetypes.RuntimeCode; import org.perlonjava.runtime.runtimetypes.RuntimeList; +import org.perlonjava.runtime.runtimetypes.RuntimeScalar; public class DataDumper extends PerlModuleBase { @@ -22,6 +23,7 @@ public static void initialize() { DataDumper dataDumper = new DataDumper(); try { dataDumper.registerMethod("Dumpxs", null); + dataDumper.registerMethod("_perlonjava_numified_safe_decimal", "$"); } catch (NoSuchMethodException e) { System.err.println("Warning: Missing Data::Dumper method: " + e.getMessage()); } @@ -40,4 +42,11 @@ public static RuntimeList Dumpxs(RuntimeArray args, int ctx) { return RuntimeCode.apply( GlobalVariable.getGlobalCodeRef("Data::Dumper::Dumpperl"), args, ctx); } + + public static RuntimeList _perlonjava_numified_safe_decimal(RuntimeArray args, int ctx) { + if (args.size() != 1) { + throw new IllegalStateException("Bad number of arguments for _perlonjava_numified_safe_decimal() method"); + } + return new RuntimeScalar(args.get(0).isDataDumperNumifiedSafeDecimal()).getList(); + } } diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/DataUUID.java b/src/main/java/org/perlonjava/runtime/perlmodule/DataUUID.java index b9b3c3cba..7656e4356 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/DataUUID.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/DataUUID.java @@ -211,19 +211,19 @@ public static RuntimeList compare(RuntimeArray args, int ctx) { // --- Exported NameSpace constants --------------------------------------- public static RuntimeList NameSpace_DNS(RuntimeArray args, int ctx) { - return new RuntimeScalar(NS_DNS).getList(); + return byteStringScalar(NS_DNS).getList(); } public static RuntimeList NameSpace_URL(RuntimeArray args, int ctx) { - return new RuntimeScalar(NS_URL).getList(); + return byteStringScalar(NS_URL).getList(); } public static RuntimeList NameSpace_OID(RuntimeArray args, int ctx) { - return new RuntimeScalar(NS_OID).getList(); + return byteStringScalar(NS_OID).getList(); } public static RuntimeList NameSpace_X500(RuntimeArray args, int ctx) { - return new RuntimeScalar(NS_X500).getList(); + return byteStringScalar(NS_X500).getList(); } // --- Internal helpers --------------------------------------------------- @@ -296,7 +296,7 @@ private static byte[] createFromNameBytes(RuntimeArray args) { private static RuntimeList makeRet(byte[] u, int type) { switch (type) { case F_BIN: - return new RuntimeScalar(bytesToLatin1(u)).getList(); + return byteStringScalar(bytesToLatin1(u)).getList(); case F_STR: { String hex = bytesToUpperHex(u); StringBuilder sb = new StringBuilder(36); @@ -382,6 +382,12 @@ private static String bytesToLatin1(byte[] bytes) { return new String(bytes, StandardCharsets.ISO_8859_1); } + private static RuntimeScalar byteStringScalar(String value) { + RuntimeScalar scalar = new RuntimeScalar(value); + scalar.type = RuntimeScalarType.BYTE_STRING; + return scalar; + } + private static String bytesToUpperHex(byte[] bytes) { StringBuilder sb = new StringBuilder(bytes.length * 2); for (byte b : bytes) { diff --git a/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java b/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java index 575136909..27b67ac25 100644 --- a/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java +++ b/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java @@ -972,7 +972,8 @@ public static RuntimeScalar getQuotedRegex(RuntimeScalar patternString, RuntimeS */ public static RuntimeScalar getReplacementRegex(RuntimeScalar patternString, RuntimeScalar replacement, RuntimeScalar modifiers) { // Use resolveRegex to properly handle qr objects and qr overloading - RuntimeRegex resolvedRegex = resolveRegex(patternString); + ResolvedRegex resolved = resolveRegexWithOrigin(patternString); + RuntimeRegex resolvedRegex = resolved.regex(); String modifierStr = modifiers.toString(); // Create a new regex instance with the replacement @@ -995,7 +996,9 @@ public static RuntimeScalar getReplacementRegex(RuntimeScalar patternString, Run // Only recompile if we have new modifiers that actually change the flags if (!modifierStr.isEmpty()) { - RegexFlags newFlags = mergeRegexFlags(resolvedRegex.regexFlags, modifierStr, resolvedRegex.patternString); + RegexFlags newFlags = resolved.fromCompiledRegex() + ? mergeOperationFlags(resolvedRegex.regexFlags, modifierStr, resolvedRegex.patternString) + : mergeRegexFlags(resolvedRegex.regexFlags, modifierStr, resolvedRegex.patternString); // Check if the merged flags are actually different boolean flagsChanged = false; @@ -1006,7 +1009,7 @@ public static RuntimeScalar getReplacementRegex(RuntimeScalar patternString, Run } // Only recompile if flags actually changed (this is needed for /x preprocessing) - if (flagsChanged) { + if (flagsChanged && !resolved.fromCompiledRegex()) { RuntimeRegex recompiledRegex = compile(resolvedRegex.patternString, newFlags.toFlagString()); regex.pattern = recompiledRegex.pattern; regex.patternUnicode = recompiledRegex.patternUnicode; @@ -1022,7 +1025,9 @@ public static RuntimeScalar getReplacementRegex(RuntimeScalar patternString, Run regex.hasCodeBlockCaptures = recompiledRegex.hasCodeBlockCaptures; regex.warningsOnUse = new ArrayList<>(recompiledRegex.warningsOnUse); } else { - // Just update the flags without recompiling + // Just update the flags without recompiling. A compiled qr// used + // as the whole substitution pattern keeps its own pattern flags; + // outer s/// flags like /x or /i must not reinterpret its source. regex.regexFlags = newFlags; regex.hasPreservesMatch = regex.hasPreservesMatch || newFlags.preservesMatch(); regex.useGAssertion = newFlags.useGAssertion(); @@ -2441,6 +2446,32 @@ private static boolean hasInlineAsciiModifier(String pattern) { return false; } + private record ResolvedRegex(RuntimeRegex regex, boolean fromCompiledRegex) {} + + private static RegexFlags mergeOperationFlags(RegexFlags baseFlags, String modifiers, String patternString) { + RegexFlags base = baseFlags != null ? baseFlags : fromModifiers("", patternString); + RegexFlags operation = fromModifiers(modifiers == null ? "" : modifiers, patternString); + + return new RegexFlags( + base.isGlobalMatch() || operation.isGlobalMatch(), + base.keepCurrentPosition() || operation.keepCurrentPosition(), + base.isNonDestructive() || operation.isNonDestructive(), + base.isMatchExactlyOnce(), + base.useGAssertion(), + base.isExtendedWhitespace(), + base.isNonCapturing(), + base.isOptimized() || operation.isOptimized(), + base.isCaseInsensitive(), + base.isMultiLine(), + base.isDotAll(), + base.isExtended(), + base.preservesMatch() || operation.preservesMatch(), + base.isUnicode(), + base.isAscii(), + base.allowEvalGroup() || operation.allowEvalGroup() + ); + } + /** * Resolves a scalar to a RuntimeRegex, handling qr overloading if necessary. * @@ -2449,11 +2480,15 @@ private static boolean hasInlineAsciiModifier(String pattern) { * @throws PerlCompilerException if qr overload doesn't return proper regex */ private static RuntimeRegex resolveRegex(RuntimeScalar quotedRegex) { + return resolveRegexWithOrigin(quotedRegex).regex(); + } + + private static ResolvedRegex resolveRegexWithOrigin(RuntimeScalar quotedRegex) { // Unwrap readonly scalar if (quotedRegex.type == RuntimeScalarType.READONLY_SCALAR) quotedRegex = (RuntimeScalar) quotedRegex.value; if (quotedRegex.type == RuntimeScalarType.REGEX) { - return (RuntimeRegex) quotedRegex.value; + return new ResolvedRegex((RuntimeRegex) quotedRegex.value, true); } // Check if the object has qr overloading @@ -2466,7 +2501,7 @@ private static RuntimeRegex resolveRegex(RuntimeScalar quotedRegex) { if (overloadedResult != null) { // The result must be a compiled regex if (overloadedResult.type == RuntimeScalarType.REGEX) { - return (RuntimeRegex) overloadedResult.value; + return new ResolvedRegex((RuntimeRegex) overloadedResult.value, true); } throw new PerlCompilerException("Overloaded qr did not return a REGEXP"); } @@ -2474,13 +2509,13 @@ private static RuntimeRegex resolveRegex(RuntimeScalar quotedRegex) { // Try fallback to string conversion RuntimeScalar fallbackResult = overloadCtx.tryOverloadFallback(quotedRegex, "(\"\""); if (fallbackResult != null) { - return compile(fallbackResult.toString(), ""); + return new ResolvedRegex(compile(fallbackResult.toString(), ""), false); } } } // Default: compile as string - return compile(quotedRegex.toString(), ""); + return new ResolvedRegex(compile(quotedRegex.toString(), ""), false); } @Override diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java index ee210fcc0..4e1e65468 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java @@ -80,6 +80,14 @@ private static boolean mightBeInteger(String s) { */ public String numericLiteralText; + /** + * True once a string scalar has been used in numeric context. Perl keeps a + * numeric slot alongside the string slot on the same SV; this lightweight + * bit is enough for compatibility code that needs to distinguish an + * untouched numeric-looking string from a numified string. + */ + public boolean numericContextSeen; + /** * True if this scalar was the direct target of an {@code open()} call that * created a new anonymous filehandle glob. Used by {@link #scopeExitCleanup} @@ -344,6 +352,7 @@ public RuntimeScalar(RuntimeScalar scalar) { this.utf8UncheckedOctets = scalar.utf8UncheckedOctets; this.tainted = scalar.tainted; this.numericLiteralText = scalar.numericLiteralText; + this.numericContextSeen = scalar.numericContextSeen; if (this.type == GLOBREFERENCE && this.value instanceof RuntimeGlob glob && glob.globName == null) { glob.ioHolderCount++; @@ -422,6 +431,7 @@ public RuntimeScalar(Object value) { this.utf8UncheckedOctets = scalar.utf8UncheckedOctets; this.tainted = scalar.tainted; this.numericLiteralText = scalar.numericLiteralText; + this.numericContextSeen = scalar.numericContextSeen; } case Long longValue -> initializeWithLong(longValue); default -> { @@ -492,8 +502,43 @@ public boolean isString() { return t == STRING || t == BYTE_STRING || t == VSTRING; } + private void markNumericContextSeen() { + int t = this.type; + if (t == STRING || t == BYTE_STRING || t == VSTRING) { + this.numericContextSeen = true; + } else if (t == READONLY_SCALAR) { + ((RuntimeScalar) this.value).markNumericContextSeen(); + } else if (t == TIED_SCALAR) { + this.tiedFetch().markNumericContextSeen(); + } + } + + public boolean isDataDumperNumifiedSafeDecimal() { + RuntimeScalar scalar = this; + if (scalar instanceof ScalarSpecialVariable ssv) { + scalar = ssv.getValueAsScalar(); + } + if (scalar.type == READONLY_SCALAR) { + scalar = (RuntimeScalar) scalar.value; + } + if (scalar.type != INTEGER && scalar.type != DOUBLE + && (!scalar.numericContextSeen || !(scalar.type == STRING || scalar.type == BYTE_STRING))) { + return false; + } + String s = scalar.toString(); + if (s.length() != 10) return false; + char first = s.charAt(0); + if (first < '1' || first > '9') return false; + for (int i = 1; i < s.length(); i++) { + char c = s.charAt(i); + if (c < '0' || c > '9') return false; + } + return true; + } + private void initializeWithLong(Long value) { this.tainted = false; + this.numericContextSeen = false; if (value > Integer.MAX_VALUE || value < Integer.MIN_VALUE) { // Java double can only exactly represent integers up to 2^53. // Beyond that, storing as DOUBLE loses precision and breaks exact pack/unpack @@ -540,6 +585,7 @@ public RuntimeScalar getNumber(String operation) { } // For string types, pass operation context so warnings include "in " if (type == STRING || type == BYTE_STRING || type == VSTRING) { + markNumericContextSeen(); return NumberParser.parseNumber(this, operation); } return getNumberLarge(); @@ -550,9 +596,15 @@ public RuntimeScalar getNumberLarge() { // Cases 0-8 are listed in order from RuntimeScalarType, and compile to fast tableswitch return switch (type) { case INTEGER, DOUBLE -> this; - case STRING, BYTE_STRING -> NumberParser.parseNumber(this); + case STRING, BYTE_STRING -> { + markNumericContextSeen(); + yield NumberParser.parseNumber(this); + } case UNDEF -> scalarZero; - case VSTRING -> NumberParser.parseNumber(this); + case VSTRING -> { + markNumericContextSeen(); + yield NumberParser.parseNumber(this); + } case BOOLEAN -> (boolean) value ? scalarOne : scalarZero; case GLOB -> scalarOne; // Assuming globs are truthy, so 1 case JAVAOBJECT -> value != null ? scalarOne : scalarZero; @@ -577,9 +629,15 @@ public RuntimeScalar getNumberLarge() { public RuntimeScalar getNumberNoOverload() { return switch (type) { case INTEGER, DOUBLE -> this; - case STRING, BYTE_STRING -> NumberParser.parseNumber(this); + case STRING, BYTE_STRING -> { + markNumericContextSeen(); + yield NumberParser.parseNumber(this); + } case UNDEF -> scalarZero; - case VSTRING -> NumberParser.parseNumber(this); + case VSTRING -> { + markNumericContextSeen(); + yield NumberParser.parseNumber(this); + } case BOOLEAN -> (boolean) value ? scalarOne : scalarZero; case GLOB -> scalarOne; case JAVAOBJECT -> value != null ? scalarOne : scalarZero; @@ -621,6 +679,7 @@ public RuntimeScalar getNumberWarn(String operation) { } // For string types, pass operation context so "isn't numeric" warnings include it if (type == STRING || type == BYTE_STRING || type == VSTRING) { + markNumericContextSeen(); return NumberParser.parseNumber(this, operation); } // All other types are defined, just convert to number @@ -659,6 +718,7 @@ private int getIntLarge() { case INTEGER -> (int) value; case DOUBLE -> (int) ((double) value); case STRING, BYTE_STRING -> { + markNumericContextSeen(); // Avoid recursion when NumberParser.parseNumber() returns a cached scalar // that is also STRING. Add fast-path for plain integer strings. String s = (String) value; @@ -709,6 +769,7 @@ public BigInteger getBigint() { } else if (type == RuntimeScalarType.UNDEF) { return BigInteger.ZERO; } else { + markNumericContextSeen(); // String types - parse exactly without precision loss String str = this.toString().trim(); @@ -781,6 +842,7 @@ public BigInteger getUnsignedLong() { } else if (type == RuntimeScalarType.UNDEF) { return BigInteger.ZERO; } else { + markNumericContextSeen(); // String types - parse carefully to preserve precision String str = this.toString().trim(); @@ -830,6 +892,7 @@ public long getLong() { case INTEGER -> (int) value; case DOUBLE -> (long) ((double) value); case STRING, BYTE_STRING -> { + markNumericContextSeen(); // Avoid recursion when large integer strings are preserved as STRING to keep // precision (e.g. values > 2^53). NumberParser.parseNumber() may return a scalar // that is also STRING, and calling getLong() on it would recurse indefinitely. @@ -873,6 +936,7 @@ private double getDoubleLarge() { case INTEGER -> (int) value; case DOUBLE -> (double) value; case STRING, BYTE_STRING -> { + markNumericContextSeen(); // Avoid recursion when numeric values are preserved as STRING and also stored in // NumberParser's numification cache. If parseNumber() returns a scalar whose // conversion path leads back to getDouble(), this can recurse indefinitely. @@ -1215,6 +1279,7 @@ public RuntimeScalar set(RuntimeScalar value) { this.utf8UncheckedOctets = value.utf8UncheckedOctets; this.tainted = value.tainted; this.numericLiteralText = value.numericLiteralText; + this.numericContextSeen = value.numericContextSeen; RuntimePosLvalue.invalidatePos(this); } else { this.type = value.type; @@ -1222,6 +1287,7 @@ public RuntimeScalar set(RuntimeScalar value) { this.utf8UncheckedOctets = value.utf8UncheckedOctets; this.tainted = value.tainted; this.numericLiteralText = value.numericLiteralText; + this.numericContextSeen = value.numericContextSeen; } return this; } @@ -1274,6 +1340,7 @@ private RuntimeScalar setLarge(RuntimeScalar value) { this.value = null; this.tainted = false; this.numericLiteralText = null; + this.numericContextSeen = false; return this; } // Unwrap source special types via switch dispatcher @@ -1313,6 +1380,7 @@ private RuntimeScalar setLarge(RuntimeScalar value) { this.utf8UncheckedOctets = value.utf8UncheckedOctets; this.tainted = value.tainted; this.numericLiteralText = value.numericLiteralText; + this.numericContextSeen = value.numericContextSeen; return this; } @@ -1356,6 +1424,7 @@ private RuntimeScalar setLargeRefCounted(RuntimeScalar value) { this.utf8UncheckedOctets = value.utf8UncheckedOctets; this.tainted = value.tainted; this.numericLiteralText = value.numericLiteralText; + this.numericContextSeen = value.numericContextSeen; return this; } } @@ -1478,6 +1547,7 @@ private RuntimeScalar setLargeRefCounted(RuntimeScalar value) { this.utf8UncheckedOctets = value.utf8UncheckedOctets; this.tainted = value.tainted; this.numericLiteralText = value.numericLiteralText; + this.numericContextSeen = value.numericContextSeen; if (this.globalCodeRefFqn != null && this.value instanceof RuntimeCode code) { code.hadStashRef = true; } @@ -1671,6 +1741,7 @@ public RuntimeScalar set(int value) { this.value = value; this.tainted = false; this.numericLiteralText = null; + this.numericContextSeen = false; return this; } @@ -1684,6 +1755,7 @@ public RuntimeScalar set(long value) { this.initializeWithLong(value); this.tainted = false; this.numericLiteralText = null; + this.numericContextSeen = false; return this; } @@ -1722,6 +1794,7 @@ else if (value.abs().compareTo(BigInteger.valueOf(9007199254740992L)) <= 0) { // } this.tainted = false; this.numericLiteralText = null; + this.numericContextSeen = false; return this; } @@ -1736,6 +1809,7 @@ public RuntimeScalar set(boolean value) { this.value = value; this.tainted = false; this.numericLiteralText = null; + this.numericContextSeen = false; return this; } @@ -1755,6 +1829,7 @@ public RuntimeScalar set(String value) { this.utf8UncheckedOctets = false; this.tainted = false; this.numericLiteralText = null; + this.numericContextSeen = false; return this; } @@ -2260,6 +2335,7 @@ public RuntimeScalar scalarDeref() { this.value = newScalar; this.type = RuntimeScalarType.REFERENCE; this.numericLiteralText = null; + this.numericContextSeen = false; yield newScalar; } case REFERENCE -> (RuntimeScalar) value; @@ -2745,6 +2821,7 @@ public RuntimeScalar undefine() { this.value = new RuntimeCode((String) null, null); this.tainted = false; this.numericLiteralText = null; + this.numericContextSeen = false; // Invalidate the method resolution cache InheritanceResolver.invalidateCache(); if (releasedCode && WeakRefRegistry.weakRefsExist && !ModuleInitGuard.inModuleInit()) { @@ -2772,6 +2849,7 @@ public RuntimeScalar undefine() { this.value = null; this.tainted = false; this.numericLiteralText = null; + this.numericContextSeen = false; // Decrement AFTER clearing (Perl 5 semantics: DESTROY sees the new state) boolean undefOnBlessedWithDestroy = false; @@ -3119,6 +3197,7 @@ public boolean getDefinedBoolean() { public RuntimeScalar preAutoIncrement() { this.numericLiteralText = null; + this.numericContextSeen = false; // Cases 0-11 are listed in order from RuntimeScalarType, and compile to fast tableswitch switch (type) { case INTEGER -> { // 0 @@ -3238,6 +3317,7 @@ private RuntimeScalar postAutoIncrementLarge() { RuntimeScalar old = this.type == RuntimeScalarType.UNDEF ? new RuntimeScalar(0) : new RuntimeScalar(this); this.numericLiteralText = null; + this.numericContextSeen = false; // Cases 0-11 are listed in order from RuntimeScalarType, and compile to fast tableswitch switch (type) { @@ -3338,6 +3418,7 @@ private RuntimeScalar postAutoIncrementLarge() { public RuntimeScalar preAutoDecrement() { this.numericLiteralText = null; + this.numericContextSeen = false; // Cases 0-11 are listed in order from RuntimeScalarType, and compile to fast tableswitch switch (type) { case INTEGER -> // 0 @@ -3441,6 +3522,7 @@ public boolean isBlessed() { public RuntimeScalar postAutoDecrement() { RuntimeScalar old = new RuntimeScalar(this); this.numericLiteralText = null; + this.numericContextSeen = false; // Cases 0-11 are listed in order from RuntimeScalarType, and compile to fast tableswitch switch (type) { @@ -3588,6 +3670,7 @@ public void dynamicSaveState() { currentState.referencedByScalarReference = this.referencedByScalarReference; currentState.tainted = this.tainted; currentState.numericLiteralText = this.numericLiteralText; + currentState.numericContextSeen = this.numericContextSeen; // Push the current state onto the stack dynamicStateStack.push(currentState); // Clear the current type and value @@ -3597,6 +3680,7 @@ public void dynamicSaveState() { this.ownsScalarReferenceContents = false; this.tainted = false; this.numericLiteralText = null; + this.numericContextSeen = false; } /** @@ -3628,6 +3712,7 @@ public void dynamicRestoreState() { previousState.referencedByScalarReference || referencedDuringLocal; this.tainted = previousState.tainted; this.numericLiteralText = previousState.numericLiteralText; + this.numericContextSeen = previousState.numericContextSeen; releaseScalarReferenceContents(scalarReferenceContents); diff --git a/src/main/perl/lib/Data/Dump.pm b/src/main/perl/lib/Data/Dump.pm index e679e585f..5460de3d1 100644 --- a/src/main/perl/lib/Data/Dump.pm +++ b/src/main/perl/lib/Data/Dump.pm @@ -1,98 +1,730 @@ package Data::Dump; use strict; -use warnings; -use subs qw(dump); -use Exporter qw(import); -use Scalar::Util qw(blessed reftype); +use vars qw(@EXPORT @EXPORT_OK $VERSION $DEBUG); +use subs qq(dump); -our $VERSION = '1.25'; -our $DEBUG; -our @FILTERS; -our @EXPORT = qw(dd ddx); -our @EXPORT_OK = qw(dump pp dumpf quote); +require Exporter; +*import = \&Exporter::import; +@EXPORT = qw(dd ddx); +@EXPORT_OK = qw(dump pp dumpf quote); +$VERSION = "1.25"; $DEBUG = 0; -sub dump { - my @dumped = map { _dump_filtered($_) } @_; - my $out = @dumped == 0 ? '()' - : @dumped == 1 ? $dumped[0] - : '(' . join(', ', @dumped) . ')'; - print STDERR "$out\n" unless defined wantarray; - return $out; -} +use overload (); +use vars qw(%seen %refcnt @dump @fixup %require $TRY_BASE64 @FILTERS $INDENT $LINEWIDTH); -sub _dump_filtered { - my ($value) = @_; +$TRY_BASE64 = 50 unless defined $TRY_BASE64; +$INDENT = " " unless defined $INDENT; +$LINEWIDTH = 60 unless defined $LINEWIDTH; - if (@FILTERS) { - require Data::Dump::FilterContext; - - my $is_ref = ref($value) ? 1 : 0; - my $object = $is_ref ? $value : \$value; - my $class = blessed($object) || ''; - my $type = reftype($object) || ($is_ref ? ref($object) : 'SCALAR'); - my $ctx = Data::Dump::FilterContext->new( - $object, $class, $type, $is_ref, undef, undef, [] - ); - - for my $filter (@FILTERS) { - my $filtered = $filter->($ctx, $object) or next; - if (exists $filtered->{dump}) { - return $filtered->{dump}; - } - if (exists $filtered->{object}) { - local @FILTERS; - return _dump_filtered($filtered->{object}); - } - } - } - - return _dump_plain($value); -} +sub dump +{ + local %seen; + local %refcnt; + local %require; + local @fixup; -sub _dump_plain { - require Data::Dumper; - my $dumper = Data::Dumper->new([@_]); - $dumper->Terse(1); - $dumper->Indent(1); - $dumper->Sortkeys(1); - my $out = $dumper->Dump; - chomp $out; - return $out; -} + require Data::Dump::FilterContext if @FILTERS; -sub pp { dump(@_) } + my $name = "a"; + my @dump; -sub dumpf { - require Data::Dump::Filtered; - goto &Data::Dump::Filtered::dump_filtered; + for my $v (@_) { + my $val = _dump($v, $name, [], tied($v)); + push(@dump, [$name, $val]); + } continue { + $name++; + } + + my $out = ""; + if (%require) { + for (sort keys %require) { + $out .= "require $_;\n"; + } + } + if (%refcnt) { + # output all those with refcounts first + for (@dump) { + my $name = $_->[0]; + if ($refcnt{$name}) { + $out .= "my \$$name = $_->[1];\n"; + undef $_->[1]; + } + } + for (@fixup) { + $out .= "$_;\n"; + } + } + + my $paren = (@dump != 1); + $out .= "(" if $paren; + $out .= format_list($paren, undef, + map {defined($_->[1]) ? $_->[1] : "\$".$_->[0]} + @dump + ); + $out .= ")" if $paren; + + if (%refcnt || %require) { + $out .= ";\n"; + $out =~ s/^/$INDENT/gm; + $out = "do {\n$out}"; + } + + print STDERR "$out\n" unless defined wantarray; + $out; } +*pp = \&dump; + sub dd { print dump(@_), "\n"; } sub ddx { - my (undef, $file, $line) = caller; - $file =~ s{.*[\\/]}{}; + my(undef, $file, $line) = caller; + $file =~ s,.*[\\/],,; my $out = "$file:$line: " . dump(@_) . "\n"; $out =~ s/^/# /gm; print $out; } -sub quote { - my $str = defined $_[0] ? $_[0] : ''; - $str =~ s/\\/\\\\/g; - $str =~ s/"/\\"/g; - $str =~ s/\n/\\n/g; - return qq{"$str"}; +sub dumpf { + require Data::Dump::Filtered; + goto &Data::Dump::Filtered::dump_filtered; +} + +sub _dump +{ + my $ref = ref $_[0]; + my $rval = $ref ? $_[0] : \$_[0]; + shift; + + my($name, $idx, $dont_remember, $pclass, $pidx) = @_; + + my($class, $type, $id); + my $strval = overload::StrVal($rval); + # Parse $strval without using regexps, in order not to clobber $1, $2,... + if ((my $i = rindex($strval, "=")) >= 0) { + $class = substr($strval, 0, $i); + $strval = substr($strval, $i+1); + } + if ((my $i = index($strval, "(0x")) >= 0) { + $type = substr($strval, 0, $i); + $id = substr($strval, $i + 2, -1); + } + else { + die "Can't parse " . overload::StrVal($rval); + } + if ($] < 5.008 && $type eq "SCALAR") { + $type = "REF" if $ref eq "REF"; + } + warn "\$$name(@$idx) $class $type $id ($ref)" if $DEBUG; + + my $out; + my $comment; + my $hide_keys; + if (@FILTERS) { + my $pself = ""; + $pself = fullname("self", [@$idx[$pidx..(@$idx - 1)]]) if $pclass; + my $ctx = Data::Dump::FilterContext->new($rval, $class, $type, $ref, $pclass, $pidx, $idx); + my @bless; + for my $filter (@FILTERS) { + if (my $f = $filter->($ctx, $rval)) { + if (my $v = $f->{object}) { + local @FILTERS; + $out = _dump($v, $name, $idx, 1); + $dont_remember++; + } + if (defined(my $c = $f->{bless})) { + push(@bless, $c); + } + if (my $c = $f->{comment}) { + $comment = $c; + } + if (defined(my $c = $f->{dump})) { + $out = $c; + $dont_remember++; + } + if (my $h = $f->{hide_keys}) { + if (ref($h) eq "ARRAY") { + $hide_keys = sub { + for my $k (@$h) { + return 1 if $k eq $_[0]; + } + return 0; + }; + } + } + } + } + push(@bless, "") if defined($out) && !@bless; + if (@bless) { + $class = shift(@bless); + warn "More than one filter callback tried to bless object" if @bless; + } + } + + unless ($dont_remember) { + if (my $s = $seen{$id}) { + my($sname, $sidx) = @$s; + $refcnt{$sname}++; + my $sref = fullname($sname, $sidx, + ($ref && $type eq "SCALAR")); + warn "SEEN: [\$$name(@$idx)] => [\$$sname(@$sidx)] ($ref,$sref)" if $DEBUG; + return $sref unless $sname eq $name; + $refcnt{$name}++; + push(@fixup, fullname($name,$idx)." = $sref"); + return "do{my \$fix}" if @$idx && $idx->[-1] eq '$'; + return "'fix'"; + } + $seen{$id} = [$name, $idx]; + } + + if ($class) { + $pclass = $class; + $pidx = @$idx; + } + + if (defined $out) { + # keep it + } + elsif ($type eq "SCALAR" || $type eq "REF" || $type eq "REGEXP") { + if ($ref) { + if ($class && $class eq "Regexp") { + my $v = "$rval"; + + my $mod = ""; + if ($v =~ /^\(\?\^?([msix-]*):([\x00-\xFF]*)\)\z/) { + $mod = $1; + $v = $2; + $mod =~ s/-.*//; + } + + my $sep = '/'; + my $sep_count = ($v =~ tr/\///); + if ($sep_count) { + # see if we can find a better one + for ('|', ',', ':', '#') { + my $c = eval "\$v =~ tr/\Q$_\E//"; + #print "SEP $_ $c $sep_count\n"; + if ($c < $sep_count) { + $sep = $_; + $sep_count = $c; + last if $sep_count == 0; + } + } + } + $v =~ s/\Q$sep\E/\\$sep/g; + + $out = "qr$sep$v$sep$mod"; + undef($class); + } + else { + delete $seen{$id} if $type eq "SCALAR"; # will be seen again shortly + my $val = _dump($$rval, $name, [@$idx, "\$"], 0, $pclass, $pidx); + $out = $class ? "do{\\(my \$o = $val)}" : "\\$val"; + } + } else { + if (!defined $$rval) { + $out = "undef"; + } + elsif ($$rval =~ /^-?(?:nan|inf)/i) { + $out = str($$rval); + } + elsif (do {no warnings 'numeric'; $$rval + 0 eq $$rval}) { + $out = $$rval; + } + else { + $out = str($$rval); + } + if ($class && !@$idx) { + # Top is an object, not a reference to one as perl needs + $refcnt{$name}++; + my $obj = fullname($name, $idx); + my $cl = quote($class); + push(@fixup, "bless \\$obj, $cl"); + } + } + } + elsif ($type eq "GLOB") { + if ($ref) { + delete $seen{$id}; + my $val = _dump($$rval, $name, [@$idx, "*"], 0, $pclass, $pidx); + $out = "\\$val"; + if ($out =~ /^\\\*Symbol::/) { + $require{Symbol}++; + $out = "Symbol::gensym()"; + } + } else { + my $val = "$$rval"; + $out = "$$rval"; + + for my $k (qw(SCALAR ARRAY HASH)) { + my $gval = *$$rval{$k}; + next unless defined $gval; + next if $k eq "SCALAR" && ! defined $$gval; # always there + my $f = scalar @fixup; + push(@fixup, "RESERVED"); # overwritten after _dump() below + $gval = _dump($gval, $name, [@$idx, "*{$k}"], 0, $pclass, $pidx); + $refcnt{$name}++; + my $gname = fullname($name, $idx); + $fixup[$f] = "$gname = $gval"; #XXX indent $gval + } + } + } + elsif ($type eq "ARRAY") { + my @vals; + my $tied = tied_str(tied(@$rval)); + my $i = 0; + for my $v (@$rval) { + push(@vals, _dump($v, $name, [@$idx, "[$i]"], $tied, $pclass, $pidx)); + $i++; + } + $out = "[" . format_list(1, $tied, @vals) . "]"; + } + elsif ($type eq "HASH") { + my(@keys, @vals); + my $tied = tied_str(tied(%$rval)); + + # statistics to determine variation in key lengths + my $kstat_max = 0; + my $kstat_sum = 0; + my $kstat_sum2 = 0; + + my @orig_keys = keys %$rval; + if ($hide_keys) { + @orig_keys = grep !$hide_keys->($_), @orig_keys; + } + my $text_keys = 0; + for (@orig_keys) { + $text_keys++, last unless /^[-+]?(?:0|[1-9]\d*)(?:\.\d+)?\z/; + } + + if ($text_keys) { + @orig_keys = sort { lc($a) cmp lc($b) } @orig_keys; + } + else { + @orig_keys = sort { $a <=> $b } @orig_keys; + } + + my $quote; + for my $key (@orig_keys) { + next if $key =~ /^-?[a-zA-Z_]\w*\z/; + next if $key =~ /^-?[1-9]\d{0,8}\z/; + $quote++; + last; + } + + for my $key (@orig_keys) { + my $val = \$rval->{$key}; # capture value before we modify $key + $key = quote($key) if $quote; + $kstat_max = length($key) if length($key) > $kstat_max; + $kstat_sum += length($key); + $kstat_sum2 += length($key)*length($key); + + push(@keys, $key); + push(@vals, _dump($$val, $name, [@$idx, "{$key}"], $tied, $pclass, $pidx)); + } + my $nl = ""; + my $klen_pad = 0; + my $tmp = "@keys @vals"; + if (length($tmp) > $LINEWIDTH || $tmp =~ /\n/ || $tied) { + $nl = "\n"; + + # Determine what padding to add + if ($kstat_max < 4) { + $klen_pad = $kstat_max; + } + elsif (@keys >= 2) { + my $n = @keys; + my $avg = $kstat_sum/$n; + my $stddev = sqrt(($kstat_sum2 - $n * $avg * $avg) / ($n - 1)); + + # I am not actually very happy with this heuristics + if ($stddev / $kstat_max < 0.25) { + $klen_pad = $kstat_max; + } + if ($DEBUG) { + push(@keys, "__S"); + push(@vals, sprintf("%.2f (%d/%.1f/%.1f)", + $stddev / $kstat_max, + $kstat_max, $avg, $stddev)); + } + } + } + $out = "{$nl"; + $out .= "$INDENT# $tied$nl" if $tied; + while (@keys) { + my $key = shift @keys; + my $val = shift @vals; + my $vpad = $INDENT . (" " x ($klen_pad ? $klen_pad + 4 : 0)); + $val =~ s/\n/\n$vpad/gm; + my $kpad = $nl ? $INDENT : " "; + $key .= " " x ($klen_pad - length($key)) if $nl && $klen_pad > length($key); + $out .= "$kpad$key => $val,$nl"; + } + $out =~ s/,$/ / unless $nl; + $out .= "}"; + } + elsif ($type eq "CODE") { + $out = 'sub { ... }'; + } + elsif ($type eq "VSTRING") { + $out = sprintf +($ref ? '\v%vd' : 'v%vd'), $$rval; + } + else { + warn "Can't handle $type data"; + $out = "'#$type#'"; + } + + if ($class && $ref) { + $out = "bless($out, " . quote($class) . ")"; + } + if ($comment) { + $comment =~ s/^/# /gm; + $comment .= "\n" unless $comment =~ /\n\z/; + $comment =~ s/^#[ \t]+\n/\n/; + $out = "$comment$out"; + } + return $out; +} + +sub tied_str { + my $tied = shift; + if ($tied) { + if (my $tied_ref = ref($tied)) { + $tied = "tied $tied_ref"; + } + else { + $tied = "tied"; + } + } + return $tied; +} + +sub fullname +{ + my($name, $idx, $ref) = @_; + substr($name, 0, 0) = "\$"; + + my @i = @$idx; # need copy in order to not modify @$idx + if ($ref && @i && $i[0] eq "\$") { + shift(@i); # remove one deref + $ref = 0; + } + while (@i && $i[0] eq "\$") { + shift @i; + $name = "\$$name"; + } + + my $last_was_index; + for my $i (@i) { + if ($i eq "*" || $i eq "\$") { + $last_was_index = 0; + $name = "$i\{$name}"; + } elsif ($i =~ s/^\*//) { + $name .= $i; + $last_was_index++; + } else { + $name .= "->" unless $last_was_index++; + $name .= $i; + } + } + $name = "\\$name" if $ref; + $name; } -sub fullname { - my ($top, $idx) = @_; - return '$' . $top . join('', @$idx); +sub format_list +{ + my $paren = shift; + my $comment = shift; + my $indent_lim = $paren ? 0 : 1; + if (@_ > 3) { + # can we use range operator to shorten the list? + my $i = 0; + while ($i < @_) { + my $j = $i + 1; + my $v = $_[$i]; + while ($j < @_) { + # XXX allow string increment too? + if ($v eq "0" || $v =~ /^-?[1-9]\d{0,9}\z/) { + $v++; + } + elsif ($v =~ /^"([A-Za-z]{1,3}\d*)"\z/) { + $v = $1; + $v++; + $v = qq("$v"); + } + else { + last; + } + last if $_[$j] ne $v; + $j++; + } + if ($j - $i > 3) { + splice(@_, $i, $j - $i, "$_[$i] .. $_[$j-1]"); + } + $i++; + } + } + my $tmp = "@_"; + if ($comment || (@_ > $indent_lim && (length($tmp) > $LINEWIDTH || $tmp =~ /\n/))) { + my @elem = @_; + for (@elem) { s/^/$INDENT/gm; } + return "\n" . ($comment ? "$INDENT# $comment\n" : "") . + join(",\n", @elem, ""); + } else { + return join(", ", @_); + } +} + +sub str { + if (length($_[0]) > 20) { + for ($_[0]) { + # Check for repeated string + if (/^(.)\1\1\1/s) { + # seems to be a repeating sequence, let's check if it really is + # without backtracking + unless (/[^\Q$1\E]/) { + my $base = quote($1); + my $repeat = length; + return "($base x $repeat)" + } + } + # Length protection because the RE engine will blow the stack [RT#33520] + if (length($_) < 16 * 1024 && /^(.{2,5}?)\1*\z/s) { + my $base = quote($1); + my $repeat = length($_)/length($1); + return "($base x $repeat)"; + } + } + } + + local $_ = "e; + + if (length($_) > 40 && !/\\x\{/ && length($_) > (length($_[0]) * 2)) { + # too much binary data, better to represent as a hex/base64 string + + # Base64 is more compact than hex when string is longer than + # 17 bytes (not counting any require statement needed). + # But on the other hand, hex is much more readable. + if ($TRY_BASE64 && length($_[0]) > $TRY_BASE64 && + (defined &utf8::is_utf8 && !utf8::is_utf8($_[0])) && + eval { require MIME::Base64 }) + { + $require{"MIME::Base64"}++; + return "MIME::Base64::decode(\"" . + MIME::Base64::encode($_[0],"") . + "\")"; + } + return "pack(\"H*\",\"" . unpack("H*", $_[0]) . "\")"; + } + + return $_; +} + +my %esc = ( + "\a" => "\\a", + "\b" => "\\b", + "\t" => "\\t", + "\n" => "\\n", + "\f" => "\\f", + "\r" => "\\r", + "\e" => "\\e", +); + +# put a string value in double quotes +sub quote { + local($_) = $_[0]; + # If there are many '"' we might want to use qq() instead + s/([\\\"\@\$])/\\$1/g; + return qq("$_") unless /[^\040-\176]/; # fast exit + + s/([\a\b\t\n\f\r\e])/$esc{$1}/g; + + # no need for 3 digits in escape for these + s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg; + + s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg; + s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg; + + return qq("$_"); } 1; + +__END__ + +=head1 NAME + +Data::Dump - Pretty printing of data structures + +=head1 SYNOPSIS + + use Data::Dump qw(dump); + + $str = dump(@list); + @copy_of_list = eval $str; + + # or use it for easy debug printout + use Data::Dump; dd localtime; + +=head1 DESCRIPTION + +This module provides a few functions that traverse their +argument list and return a string containing Perl code that, +when Ced, produces a deep copy of the original arguments. + +The main feature of the module is that it strives to produce output +that is easy to read. Example: + + @a = (1, [2, 3], {4 => 5}); + dump(@a); + +Produces: + + "(1, [2, 3], { 4 => 5 })" + +If you dump just a little data, it is output on a single line. If +you dump data that is more complex or there is a lot of it, line breaks +are automatically added to keep it easy to read. + +The following functions are provided (only the dd* functions are exported by default): + +=over + +=item dump( ... ) + +=item pp( ... ) + +Returns a string containing a Perl expression. If you pass this +string to Perl's built-in eval() function it should return a copy of +the arguments you passed to dump(). + +If you call the function with multiple arguments then the output will +be wrapped in parenthesis "( ..., ... )". If you call the function with a +single argument the output will not have the wrapping. If you call the function with +a single scalar (non-reference) argument it will just return the +scalar quoted if needed, but never break it into multiple lines. If you +pass multiple arguments or references to arrays of hashes then the +return value might contain line breaks to format it for easier +reading. The returned string will never be "\n" terminated, even if +contains multiple lines. This allows code like this to place the +semicolon in the expected place: + + print '$obj = ', dump($obj), ";\n"; + +If dump() is called in void context, then the dump is printed on +STDERR and then "\n" terminated. You might find this useful for quick +debug printouts, but the dd*() functions might be better alternatives +for this. + +There is no difference between dump() and pp(), except that dump() +shares its name with a not-so-useful perl builtin. Because of this +some might want to avoid using that name. + +=item quote( $string ) + +Returns a quoted version of the provided string. + +It differs from C in that it will quote even numbers and +not try to come up with clever expressions that might shorten the +output. If a non-scalar argument is provided then it's just stringified +instead of traversed. + +=item dd( ... ) + +=item ddx( ... ) + +These functions will call dump() on their argument and print the +result to STDOUT (actually, it's the currently selected output handle, but +STDOUT is the default for that). + +The difference between them is only that ddx() will prefix the lines +it prints with "# " and mark the first line with the file and line +number where it was called. This is meant to be useful for debug +printouts of state within programs. + +=item dumpf( ..., \&filter ) + +Short hand for calling the dump_filtered() function of L. +This works like dump(), but the last argument should be a filter callback +function. As objects are visited the filter callback is invoked and it +can modify how the objects are dumped. + +=back + +=head1 CONFIGURATION + +There are a few global variables that can be set to modify the output +generated by the dump functions. It's wise to localize the setting of +these. + +=over + +=item $Data::Dump::INDENT + +This holds the string that's used for indenting multiline data structures. +It's default value is " " (two spaces). Set it to "" to suppress indentation. +Setting it to "| " makes for nice visuals even if the dump output then fails to +be valid Perl. + +=item $Data::Dump::TRY_BASE64 + +How long must a binary string be before we try to use the base64 encoding +for the dump output. The default is 50. Set it to 0 to disable base64 dumps. + +=item $Data::Dump::LINEWIDTH + +This controls how wide the string should before we add a line break. The +default is 60. + +=back + + +=head1 LIMITATIONS + +Code references will be dumped as C<< sub { ... } >>. Thus, Cing them will +not reproduce the original routine. The C<...>-operator used will also require +perl-5.12 or better to be evaled. + +If you forget to explicitly import the C function, your code will +core dump. That's because you just called the builtin C function +by accident, which intentionally dumps core. Because of this you can +also import the same function as C, mnemonic for "pretty-print". + +=head1 HISTORY + +The C module grew out of frustration with Sarathy's +in-most-cases-excellent C. Basic ideas and some code +are shared with Sarathy's module. + +The C module provides a much simpler interface than +C. No OO interface is available and there are fewer +configuration options to worry about. The other benefit is +that the dump produced does not try to set any variables. It only +returns what is needed to produce a copy of the arguments. This means +that C simply returns C<'"foo"'>, and C simply +returns C<'(1, 2, 3)'>. + +=head1 SEE ALSO + +L, L, L, L, +L + +=head1 AUTHORS + +The C module is written by Gisle Aas , based +on C by Gurusamy Sarathy . + + Copyright 1998-2010 Gisle Aas. + Copyright 1996-1998 Gurusamy Sarathy. + +This distribution is currenly maintained by Breno G. de Oliveira. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/src/main/perl/lib/Data/Dumper.pm b/src/main/perl/lib/Data/Dumper.pm index 0ebe3485d..76ade90b3 100644 --- a/src/main/perl/lib/Data/Dumper.pm +++ b/src/main/perl/lib/Data/Dumper.pm @@ -580,6 +580,10 @@ sub _dump { $out .= sprintf "v%vd", $val; } # \d here would treat "1\x{660}" as a safe decimal number + elsif (defined &Data::Dumper::_perlonjava_numified_safe_decimal + and Data::Dumper::_perlonjava_numified_safe_decimal($val)) { + $out .= $val; + } elsif ($val =~ /^(?:0|-?[1-9][0-9]{0,8})\z/) { # safe decimal number $out .= $val; } diff --git a/src/main/perl/lib/XML/Parser.pm b/src/main/perl/lib/XML/Parser.pm index ccdca2edd..000d146e1 100644 --- a/src/main/perl/lib/XML/Parser.pm +++ b/src/main/perl/lib/XML/Parser.pm @@ -221,11 +221,13 @@ sub parsefile { my $old_base = $self->{Base}; $self->{Base} = $file; + # Pass an old-style typeglob for compatibility with subclasses that + # identify filehandles by probing *{$arg}{IO}. if (wantarray) { - eval { @ret = $self->parse( $fh, @_ ); }; + eval { @ret = $self->parse( *{$fh}, @_ ); }; } else { - eval { $ret = $self->parse( $fh, @_ ); }; + eval { $ret = $self->parse( *{$fh}, @_ ); }; } my $err = $@; $self->{Base} = $old_base; diff --git a/src/test/resources/unit/data_dumper_numified.t b/src/test/resources/unit/data_dumper_numified.t new file mode 100644 index 000000000..066381503 --- /dev/null +++ b/src/test/resources/unit/data_dumper_numified.t @@ -0,0 +1,31 @@ +use strict; +use warnings; +use Test::More; +use Data::Dumper; +use Scalar::Util qw(looks_like_number); + +local $Data::Dumper::Terse = 1; +local $Data::Dumper::Useqq = 1; + +my $untouched = '1556933584'; +is(Dumper($untouched), qq("1556933584"\n), 'untouched ten-digit numeric string stays quoted'); + +my $literal = 1556933584; +is(Dumper($literal), "1556933584\n", 'ten-digit numeric literal dumps as numeric'); + +my $numified = '1556933584'; +my $n = 0 + $numified; +is(Dumper($numified), "1556933584\n", 'ten-digit string used in numeric context dumps as numeric'); + +my $copied = $numified; +is(Dumper($copied), "1556933584\n", 'assignment preserves numified scalar state'); + +my $checked = '1556933584'; +ok(looks_like_number($checked), 'looks_like_number recognizes numeric string'); +is(Dumper($checked), qq("1556933584"\n), 'looks_like_number does not numify scalar'); + +my $intified = '1556933584'; +my $i = int($intified); +is(Dumper($intified), "1556933584\n", 'int() marks ten-digit string as numified'); + +done_testing; diff --git a/src/test/resources/unit/regex/qr_substitution_flags.t b/src/test/resources/unit/regex/qr_substitution_flags.t new file mode 100644 index 000000000..f4d1d0b34 --- /dev/null +++ b/src/test/resources/unit/regex/qr_substitution_flags.t @@ -0,0 +1,30 @@ +use strict; +use warnings; +use Test::More; + +my $strip = qr{\(registry time\)\z}; +my $date = '2011-04-26 00:00:00 (registry time)'; +$date =~ s{$strip}{}mx; +is($date, '2011-04-26 00:00:00 ', 's///x preserves spaces inside compiled qr pattern'); + +my $case = qr{foo}; +my $subject = 'FOO'; +$subject =~ s{$case}{bar}i; +is($subject, 'FOO', 's///i does not add case-insensitive matching to compiled qr'); + +my $anchored = qr{^a$}; +my $lines = "a\nb"; +$lines =~ s{$anchored}{X}m; +is($lines, "a\nb", 's///m does not add multiline matching to compiled qr'); + +my $global = qr{a}; +my $text = 'aa'; +$text =~ s{$global}{X}g; +is($text, 'XX', 's///g still applies globally with compiled qr'); + +my $copy = 'a'; +my $replaced = $copy =~ s{$global}{X}r; +is($copy, 'a', 's///r leaves source unchanged with compiled qr'); +is($replaced, 'X', 's///r returns replaced copy with compiled qr'); + +done_testing;