diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 4ce344540a..562c41ce4f 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -13,6 +13,7 @@ priorities and future plans. - Apply source filters installed through `Test::More::use_ok` to the caller's remaining source and preserve `print FILEHANDLE (LIST) x N` output (#1375, #1441). - Cover `Test::Needs` prerequisite scanning of quoted module names and Perl version literals (#1396). - Preserve reference-valued FETCH results from tied-hash `values()` and retain scalar-reference envelopes in Storable round trips (#1554, #1468). +- Release temporary files once an exited closure capture retaining a Catalyst request context no longer has a live Perl root. - Ignore commented-out code when checking lexical constant closures for later mutations, preserving BEGIN-time generated constants (#1785). - Pack the method-dispatch inline-cache guard key into one primitive value while preserving class and method invalidation checks. - Keep watcher maps and live `substr`-lvalue observers in lazy scalar extension state, reducing the common `RuntimeScalar` footprint. @@ -1018,6 +1019,10 @@ priorities and future plans. - Preserve strict-subs imports for `Compress::Raw::Zlib` constants. - Evaluate `ref` operands in scalar context on the interpreter backend. - Fix RFC 2047 header decoding for Email::MIME. +- Load the MIME-Header codec when `Encode::decode` first encounters it. +- Parse quoted display names and address groups in the Email::Address shim. +- Recognize inherited `fields` entries in typed hash access. +- Match Storable's default and optional export lists. - Fix XML::Parser streaming from native filehandles before `IO::Handle` has been explicitly loaded. - Bundle the complete CPAN `File::Path` 2.18 implementation, including modern diff --git a/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java b/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java index a778d9b212..110d903c0e 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java +++ b/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java @@ -23,6 +23,8 @@ import java.util.ArrayList; import java.util.Arrays; import java.util.List; +import java.util.HashSet; +import java.util.Set; import static org.perlonjava.frontend.parser.OperatorParser.ensureOneOperand; import static org.perlonjava.frontend.parser.PrototypeArgs.consumeArgsWithPrototype; @@ -69,11 +71,10 @@ private static void validateTypedFields( // key as an unknown class field. if (!GlobalVariable.existsGlobalHash(fieldsName) && !GlobalVariable.isDeclaredGlobalHash(fieldsName)) return; - RuntimeHash fields = GlobalVariable.getGlobalHash(fieldsName); for (Node key : keys.elements) { String name = key instanceof StringNode string ? string.value : key instanceof IdentifierNode id ? id.name : null; - if (name != null && !fields.containsKey(name)) { + if (name != null && !hasFieldInClassHierarchy(typeName, name, new HashSet<>())) { throw PerlCompilerException.withSourceLocation(tokenIndex, "No such class field \"" + name + "\" in variable $" + identifier.name + " of type " + typeName, @@ -82,6 +83,28 @@ private static void validateTypedFields( } } + /** + * `fields` declarations are inherited through @ISA. A typed variable of + * a child class may therefore access fields declared by any ancestor, + * even though those names are absent from the child's own %FIELDS hash. + */ + private static boolean hasFieldInClassHierarchy(String className, String fieldName, + Set visited) { + if (!visited.add(className)) return false; + + String fieldsName = className + "::FIELDS"; + if ((GlobalVariable.existsGlobalHash(fieldsName) + || GlobalVariable.isDeclaredGlobalHash(fieldsName)) + && GlobalVariable.getGlobalHash(fieldsName).containsKey(fieldName)) { + return true; + } + + for (RuntimeScalar parent : GlobalVariable.getGlobalArray(className + "::ISA").elements) { + if (hasFieldInClassHierarchy(parent.toString(), fieldName, visited)) return true; + } + return false; + } + // Non-chainable comparison operators (cannot be chained with any operator) private static final List NON_CHAINABLE_COMPARISON_OPS = Arrays.asList("<=>", "cmp", "~~"); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Encode.java b/src/main/java/org/perlonjava/runtime/perlmodule/Encode.java index 2a0c3b2bf4..82f9e2a712 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Encode.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Encode.java @@ -559,7 +559,7 @@ public static RuntimeList encode(RuntimeArray args, int ctx) { // Check %Encode::Encoding for Perl-registered encodings String encodingName = encodingArg.toString(); - RuntimeScalar perlEncObj = lookupPerlEncoding(encodingName); + RuntimeScalar perlEncObj = lookupOperationEncoding(encodingName); if (perlEncObj != null) { return dispatchToEncodingObject(perlEncObj, "encode", args, 1, 2, ctx); } @@ -680,7 +680,7 @@ public static RuntimeList decode(RuntimeArray args, int ctx) { // Check %Encode::Encoding for Perl-registered encodings String encodingName = encodingArg.toString(); - RuntimeScalar perlEncObj = lookupPerlEncoding(encodingName); + RuntimeScalar perlEncObj = lookupOperationEncoding(encodingName); if (perlEncObj != null) { return dispatchToEncodingObject(perlEncObj, "decode", args, 1, 2, ctx); } @@ -1251,6 +1251,28 @@ private static RuntimeScalar lookupPerlEncoding(String encodingName) { return null; } + /** + * Resolve codecs used by encode/decode through Perl's public lookup path + * when they are lazily loaded. In particular, Encode::MIME::Header + * registers itself from the Perl find_encoding wrapper; bypassing that + * wrapper here makes decode("MIME-Header", ...) fail on first use. + */ + private static RuntimeScalar lookupOperationEncoding(String encodingName) { + RuntimeScalar encoding = lookupPerlEncoding(encodingName); + if (encoding != null || !encodingName.toLowerCase(Locale.ROOT).startsWith("mime-")) { + return encoding; + } + + String finderName = "Encode::find_encoding"; + if (!GlobalVariable.existsGlobalCodeRef(finderName)) return null; + RuntimeArray finderArgs = new RuntimeArray(); + finderArgs.push(new RuntimeScalar(encodingName)); + RuntimeList result = RuntimeCode.apply( + GlobalVariable.getGlobalCodeRef(finderName), finderArgs, RuntimeContextType.SCALAR); + RuntimeScalar found = result.scalar(); + return found != null && RuntimeScalarType.isReference(found) ? found : null; + } + /** * Dispatches an encode or decode call to a Perl encoding object's method. * Calls $encObj->encode($string, $check) or $encObj->decode($octets, $check). diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Storable.java b/src/main/java/org/perlonjava/runtime/perlmodule/Storable.java index 304a964fe3..c81c9751ef 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Storable.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Storable.java @@ -43,7 +43,8 @@ public static void initialize() { storable.registerMethod("dclone", "$"); storable.registerMethod("last_op_in_netorder", null); - storable.defineExport("EXPORT", "store", "retrieve", "nstore", "freeze", "thaw", "nfreeze", "dclone"); + storable.defineExport("EXPORT", "store", "retrieve"); + storable.defineExport("EXPORT_OK", "nstore", "freeze", "thaw", "nfreeze", "dclone"); } catch (NoSuchMethodException e) { System.err.println("Warning: Missing Storable method: " + e.getMessage()); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java b/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java index 36e5c98603..9b6049b2eb 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/DestroyDispatch.java @@ -49,9 +49,9 @@ public static void registerIfDestroyable(RuntimeBase referent, int blessId) { if (referent == null || blessId == 0) return; String className = NameNormalizer.getBlessStr(blessId); boolean hasDestroy = className != null && classHasDestroy(blessId, className); - boolean statementBoundaryCleanup = hasDestroy - && isStatementBoundaryCleanupClassName(className); - if (hasDestroy && (className.endsWith("::Cursor") || statementBoundaryCleanup)) { + boolean statementBoundaryCleanup = isStatementBoundaryCleanupClassName(className); + if ((hasDestroy && className != null && className.endsWith("::Cursor")) + || statementBoundaryCleanup) { state().destroyableObjects.add(referent); } else { state().destroyableObjects.remove(referent); @@ -189,7 +189,8 @@ public static boolean classHasDestroy(int blessId, String className) { } private static boolean isStatementBoundaryCleanupClassName(String className) { - return "File::Temp".equals(className) || "File::Temp::Dir".equals(className); + return "File::Temp".equals(className) + || "File::Temp::Dir".equals(className); } /** diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java index c91d359197..37e74459ac 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java @@ -639,10 +639,15 @@ private static boolean isSupportedWitnessArray(RuntimeArray array) { * what data structure keeps an object alive at the Perl level. */ public static java.util.List findPathTo(RuntimeBase target) { - return findPathTo(target, false); + return findPathTo(target, false, true); } public static java.util.List findPathTo(RuntimeBase target, boolean skipLexicalSeeds) { + return findPathTo(target, skipLexicalSeeds, true); + } + + private static java.util.List findPathTo( + RuntimeBase target, boolean skipLexicalSeeds, boolean forceJvmGc) { java.util.IdentityHashMap howReached = new java.util.IdentityHashMap<>(); java.util.ArrayDeque todo = new java.util.ArrayDeque<>(); // Seed from roots with labels @@ -659,6 +664,18 @@ public static java.util.List findPathTo(RuntimeBase target, boolean skip for (Map.Entry e : GlobalVariable.globalCodeRefs.entrySet()) { seedPath(e.getValue(), "&" + e.getKey(), howReached, todo); } + int activeCodeIdx = 0; + for (RuntimeCode active : PerlRuntime.current().executionState().activeCodeStack) { + String label = ""; + if (howReached.putIfAbsent(active, label) == null) todo.add(active); + } + int argsFrameIdx = 0; + for (List args : RuntimeCode.snapshotPristineArgsStack()) { + for (RuntimeScalar arg : args) { + seedPath(arg, "", howReached, todo); + } + argsFrameIdx++; + } int rescuedIdx = 0; for (RuntimeBase rescued : DestroyDispatch.snapshotRescuedForWalk()) { if (howReached.putIfAbsent(rescued, "") == null) { @@ -672,6 +689,12 @@ public static java.util.List findPathTo(RuntimeBase target, boolean skip for (RuntimeScalar sc : org.perlonjava.runtime.WarningBitsRegistry.snapshotHintHashStackScalars()) { seedPath(sc, "", howReached, todo); } + int suspendedIdx = 0; + for (RuntimeBase suspended : MortalList.snapshotSuspendedRoots()) { + if (howReached.putIfAbsent(suspended, "") == null) { + todo.add(suspended); + } + } // Phase B1: seed from ScalarRefRegistry (same as walk()) so the // trace matches what sweepWeakRefs sees. // Phase I: force GC before snapshotting so stale @@ -681,7 +704,10 @@ public static java.util.List findPathTo(RuntimeBase target, boolean skip // through Perl-semantic data (globals/stash/rescued) only. int scIdx = 0; if (!skipLexicalSeeds) { - for (RuntimeScalar sc : ScalarRefRegistry.forceGcAndSnapshot()) { + java.util.List lexicalScalars = forceJvmGc + ? ScalarRefRegistry.forceGcAndSnapshot() + : ScalarRefRegistry.snapshot(); + for (RuntimeScalar sc : lexicalScalars) { if (sc == null) continue; if (sc.captureCount > 0) continue; if (WeakRefRegistry.isweak(sc)) continue; @@ -731,15 +757,33 @@ public static java.util.List findPathTo(RuntimeBase target, boolean skip return r; } if (cur instanceof RuntimeHash h) { + if (h.elements instanceof TieHash tieHash) { + visitScalarPath(tieHash.getSelf(), curPath + "", howReached, todo); + } for (Map.Entry ent : h.elements.entrySet()) { visitScalarPath(ent.getValue(), curPath + "{" + ent.getKey() + "}", howReached, todo); } } else if (cur instanceof RuntimeArray a) { int idx = 0; + if (a.elements instanceof TieArray tieArray) { + visitScalarPath(tieArray.getSelf(), curPath + "", howReached, todo); + } for (RuntimeScalar v : a.elements) { visitScalarPath(v, curPath + "[" + (idx++) + "]", howReached, todo); } } else if (cur instanceof RuntimeCode code) { + if (code.closedOverVariables != null) { + for (Map.Entry captured + : code.closedOverVariables.entrySet()) { + String path = curPath + ""; + RuntimeBase value = captured.getValue(); + if (value instanceof RuntimeScalar scalar) { + visitScalarPath(scalar, path, howReached, todo); + } else if (howReached.putIfAbsent(value, path) == null) { + todo.add(value); + } + } + } int stateIdx = 0; for (Map.Entry state : code.stateVariable.entrySet()) { visitScalarPath(state.getValue(), curPath + " findPathTo(RuntimeBase target, boolean skip visitReflectiveCodeScalars(code, cap -> visitScalarPath(cap, curPath + "", howReached, todo)); + final int[] reflectiveBaseIdx = {0}; + visitReflectiveCodeBases(code, captured -> { + String path = curPath + ""; + if (howReached.putIfAbsent(captured, path) == null) todo.add(captured); + }); + } else if (cur instanceof RuntimeScalar scalar + && !WeakRefRegistry.isweak(scalar) + && (scalar.type & RuntimeScalarType.REFERENCE_BIT) != 0 + && scalar.value instanceof RuntimeBase referent) { + if (howReached.putIfAbsent(referent, curPath + "->") == null) { + todo.add(referent); + } + } else if (cur instanceof RuntimeRegex regex) { + int callbackIdx = 0; + for (RuntimeCode callback : regex.executableCallbackCodes()) { + String path = curPath + ""; + if (howReached.putIfAbsent(callback, path) == null) todo.add(callback); + } } } return null; @@ -786,10 +849,7 @@ private static void seedPath(RuntimeScalar s, String label, java.util.ArrayDeque todo) { if (s == null) return; if (WeakRefRegistry.isweak(s)) return; - if ((s.type & RuntimeScalarType.REFERENCE_BIT) != 0 - && s.value instanceof RuntimeBase b) { - if (howReached.putIfAbsent(b, label) == null) todo.add(b); - } + if (howReached.putIfAbsent(s, label) == null) todo.add(s); } private static void visitScalarPath(RuntimeScalar s, String path, @@ -797,10 +857,7 @@ private static void visitScalarPath(RuntimeScalar s, String path, java.util.ArrayDeque todo) { if (s == null) return; if (WeakRefRegistry.isweak(s)) return; - if ((s.type & RuntimeScalarType.REFERENCE_BIT) != 0 - && s.value instanceof RuntimeBase b) { - if (howReached.putIfAbsent(b, path) == null) todo.add(b); - } + if (howReached.putIfAbsent(s, path) == null) todo.add(s); } private void visitScalar(RuntimeScalar s, java.util.ArrayDeque todo) { @@ -1768,6 +1825,7 @@ static ScalarRootReachabilitySnapshot scalarReachabilitySnapshot() { private static void addScalarReachabilityRoot( RuntimeBase base, Set seen, Set reachableScalars, java.util.ArrayDeque todo, ReachabilityQueryStats stats) { + if (base instanceof RuntimeScalar scalar && WeakRefRegistry.isweak(scalar)) return; if (base != null && seen.add(base)) { todo.addLast(base); if (stats != null) stats.rootsSeeded++; @@ -3096,6 +3154,13 @@ private static WeakSweepPass sweepWeakRefsPass( */ static void releaseUnreachableScopeExitedCaptureOwners( List weakReferents, Set endReachable) { + releaseUnreachableScopeExitedCaptureOwners(weakReferents, endReachable, null); + } + + private static void releaseUnreachableScopeExitedCaptureOwners( + List weakReferents, + Set endReachable, + Set statementBoundaryCandidates) { Set retainedByEnd = endReachable; ScalarRootReachabilitySnapshot scalarRoots = null; for (RuntimeBase referent : weakReferents) { @@ -3105,9 +3170,16 @@ static void releaseUnreachableScopeExitedCaptureOwners( continue; } if (retainedByEnd == null) retainedByEnd = walkEndBlockRoots(); - if (retainedByEnd.contains(padCell) || retainedByEnd.contains(referent)) continue; + boolean padInEnd = retainedByEnd.contains(padCell); + boolean referentInEnd = retainedByEnd.contains(referent); if (scalarRoots == null) scalarRoots = scalarReachabilitySnapshot(); - if (scalarRoots.isReachable(padCell)) continue; + boolean padInScalarRoots = scalarRoots.isReachable(padCell); + if (padInScalarRoots && statementBoundaryCandidates != null + && containsAnyCandidate(referent, statementBoundaryCandidates) + && findPathTo(padCell, false, false) == null) { + padInScalarRoots = false; + } + if (padInEnd || referentInEnd || padInScalarRoots) continue; if (WALKER_TRACE_CLASS != null && !WALKER_TRACE_CLASS.isEmpty()) { String className = NameNormalizer.getBlessStr(referent.blessId); if (className != null && className.contains(WALKER_TRACE_CLASS)) { @@ -3124,6 +3196,48 @@ static void releaseUnreachableScopeExitedCaptureOwners( } } + private static boolean containsAnyCandidate( + RuntimeBase root, Set candidates) { + Set seen = Collections.newSetFromMap(new IdentityHashMap<>()); + java.util.ArrayDeque todo = new java.util.ArrayDeque<>(); + todo.add(root); + while (!todo.isEmpty()) { + RuntimeBase current = todo.removeFirst(); + if (!seen.add(current)) continue; + if (candidates.contains(current)) return true; + if (current instanceof RuntimeHash hash) { + for (RuntimeScalar value : hash.elements.values()) { + if (value != null) todo.addLast(value); + } + } else if (current instanceof RuntimeArray array) { + for (RuntimeScalar value : array.elements) { + if (value != null) todo.addLast(value); + } + } else if (current instanceof RuntimeScalar scalar) { + if (!WeakRefRegistry.isweak(scalar) + && (scalar.type & RuntimeScalarType.REFERENCE_BIT) != 0 + && scalar.value instanceof RuntimeBase referent) { + todo.addLast(referent); + } + } else if (current instanceof RuntimeCode code) { + if (code.closedOverVariables != null) { + todo.addAll(code.closedOverVariables.values()); + } + if (code.capturedScalars != null) { + Collections.addAll(todo, code.capturedScalars); + } + if (code.capturedAggregates != null) { + Collections.addAll(todo, code.capturedAggregates); + } + visitReflectiveCodeScalars(code, todo::addLast); + visitReflectiveCodeBases(code, todo::addLast); + } else if (current instanceof RuntimeRegex regex) { + todo.addAll(regex.executableCallbackCodes()); + } + } + return false; + } + private static void traceWeakReferent( RuntimeBase referent, boolean live, boolean cycleProtected) { String filter = WALKER_TRACE_CLASS; @@ -3356,6 +3470,10 @@ static int sweepStatementBoundaryDestroyableObjects() { java.util.List candidates = DestroyDispatch.snapshotStatementBoundaryDestroyableObjects(); if (candidates.isEmpty()) return 0; + Set candidateSet = Collections.newSetFromMap(new IdentityHashMap<>()); + candidateSet.addAll(candidates); + releaseUnreachableScopeExitedCaptureOwners( + PerlRuntime.snapshotOwnerSlotReferents(), null, candidateSet); Set live = new ReachabilityWalker().walk(); return destroyUnreachableDestroyables(candidates, live); } diff --git a/src/main/perl/lib/Email/Address/XS.pm b/src/main/perl/lib/Email/Address/XS.pm index f7f52d429f..6852a89c6b 100644 --- a/src/main/perl/lib/Email/Address/XS.pm +++ b/src/main/perl/lib/Email/Address/XS.pm @@ -86,7 +86,23 @@ sub parse_email_addresses { s/^\s+|\s+$//g; next unless length; my ($phrase, $address); - if (/\A(.*?)\s*<([^>]+)>/) { + my ($quoted, $comment) = (0, 0); + my $open_at; + for my $i (0 .. length($_) - 1) { + my $char = substr($_, $i, 1); + next if $i && substr($_, $i - 1, 1) eq '\\'; + if ($char eq '"' && !$comment) { $quoted = !$quoted; next } + if (!$quoted && $char eq '(') { $comment++; next } + if (!$quoted && $char eq ')' && $comment) { $comment--; next } + next if $quoted || $comment; + if ($char eq '<') { $open_at = $i; last } + } + if (defined $open_at && substr($_, $open_at + 1) =~ /\A([^>]*)>/) { + $phrase = substr($_, 0, $open_at); + $address = $1; + $phrase =~ s/^\s+|\s+$//g; + $phrase =~ s/\A"(.*)"\z/$1/s; + } elsif (/\A(.*?)\s*<([^>]+)>/) { ($phrase, $address) = ($1, $2); $phrase =~ s/^\s+|\s+$//g; $phrase =~ s/\A"(.*)"\z/$1/; @@ -100,7 +116,65 @@ sub parse_email_addresses { sub parse_email_groups { my ($string, $class) = @_; - return (undef, [parse_email_addresses($string, $class)]); + $class ||= __PACKAGE__; + return (undef, []) unless defined $string; + return (undef, [$string]) if $class->is_obj($string); + my (@groups, $part, $group_name, $group_addresses, $ungrouped_addresses, + $quoted, $comment, $angle); + $part = ''; + $ungrouped_addresses = []; + for my $i (0 .. length($string) - 1) { + my $char = substr($string, $i, 1); + my $escaped = $i && substr($string, $i - 1, 1) eq '\\'; + if (!$escaped && $char eq '"' && !$comment) { + $quoted = !$quoted; + $part .= $char; + next; + } + if (!$quoted && !$escaped && $char eq '(') { $comment++; $part .= $char; next } + if (!$quoted && !$escaped && $char eq ')' && $comment) { $comment--; $part .= $char; next } + if (!$quoted && !$comment) { + $angle++ if $char eq '<'; + $angle-- if $char eq '>' && $angle; + if (!$angle && $char eq ':' && !defined $group_name) { + if (@$ungrouped_addresses) { + push @groups, undef, $ungrouped_addresses; + $ungrouped_addresses = []; + } + $group_name = $part; + $group_name =~ s/^\s+|\s+$//g; + $group_name =~ s/\A"(.*)"\z/$1/s; + $group_addresses = []; + $part = ''; + next; + } + if (!$angle && ($char eq ',' || $char eq ';')) { + my @addresses = parse_email_addresses($part, $class); + if (defined $group_name) { + push @$group_addresses, @addresses; + if ($char eq ';') { + push @groups, $group_name, $group_addresses; + undef $group_name; + undef $group_addresses; + } + } else { + push @$ungrouped_addresses, @addresses; + } + $part = ''; + next; + } + } + $part .= $char; + } + my @addresses = parse_email_addresses($part, $class); + if (defined $group_name) { + push @$group_addresses, @addresses; + push @groups, $group_name, $group_addresses; + } elsif (@addresses) { + push @$ungrouped_addresses, @addresses; + } + push @groups, undef, $ungrouped_addresses if @$ungrouped_addresses; + return @groups ? @groups : (undef, []); } sub parse { @@ -122,7 +196,12 @@ sub format_email_groups { while (@args) { my ($name, $addresses) = splice @args, 0, 2; my $formatted = format_email_addresses(@$addresses); - push @groups, defined($name) ? "$name: $formatted;" : $formatted; + if (defined $name) { + $name = qq{"$name"} if $name =~ /[:,;"<>]/; + push @groups, length($formatted) ? "$name: $formatted;" : "$name:;"; + } else { + push @groups, $formatted; + } } return join ', ', @groups; } @@ -134,7 +213,7 @@ sub format { my $result = $address; if (defined $self->{phrase} && length $self->{phrase}) { my $phrase = $self->{phrase}; - $phrase = qq{"$phrase"} if $phrase =~ /[",]/; + $phrase = qq{"$phrase"} if $phrase =~ /[,:;"<>]/; $result = "$phrase <$address>"; } $result .= " ($self->{comment})" @@ -165,6 +244,11 @@ sub address { return compose_address(@{$self}{qw(user host)}); } sub as_string { $_[0]->format } +sub as_mime_string { + my ($self, $options) = @_; + require Email::MIME::Header::AddressList; + return Email::MIME::Header::AddressList->new($self)->as_mime_string($options); +} sub original { $_[0]->{original} } sub is_obj { ref($_[1]) && eval { $_[1]->isa(__PACKAGE__) } } sub purge_cache { } diff --git a/src/main/perl/lib/Storable.pm b/src/main/perl/lib/Storable.pm index b94c00c905..eff29f5012 100644 --- a/src/main/perl/lib/Storable.pm +++ b/src/main/perl/lib/Storable.pm @@ -12,12 +12,11 @@ XSLoader::load('Storable', $VERSION); # Export the main functions use Exporter 'import'; our @EXPORT = qw( - store retrieve nstore - freeze thaw nfreeze - dclone + store retrieve ); our @EXPORT_OK = qw( + nstore freeze thaw nfreeze dclone store_fd nstore_fd fd_retrieve retrieve_fd lock_store lock_retrieve lock_nstore file_magic read_magic diff --git a/src/test/resources/unit/catalyst_request_body_tempfile_lifetime.t b/src/test/resources/unit/catalyst_request_body_tempfile_lifetime.t new file mode 100644 index 0000000000..f9a9340ee5 --- /dev/null +++ b/src/test/resources/unit/catalyst_request_body_tempfile_lifetime.t @@ -0,0 +1,68 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + # The regular unit corpus has a small HTTP::Request fixture that omits + # the API Catalyst::Test needs. Keep this integration check on the real + # cached CPAN module instead. + @INC = grep { + ref($_) || $_ !~ m{(?:^|[/\\])src/test/resources/unit/lib/?\z} + } @INC; + + my $available = eval { + require Catalyst; + require Catalyst::Controller; + require Catalyst::Test; + require HTTP::Request; + die 'HTTP::Request fixture is incomplete' unless HTTP::Request->can('push_header'); + require HTTP::Request::Common; + 1; + }; + plan skip_all => 'Catalyst test dependencies are not installed' unless $available; +} + +package CatalystUploadLifetimeApp; + +use Catalyst; +__PACKAGE__->config(name => 'CatalystUploadLifetimeApp'); + +package CatalystUploadLifetimeApp::Controller::Root; + +use base 'Catalyst::Controller'; + +our $temp_path; + +sub body :Path('/body') { + my ($self, $c) = @_; + $c->prepare_body; + $temp_path = $c->req->{_body}->body->filename; + $c->res->body('ok'); +} + +sub index :Path('/') { + $_[1]->res->body('ok'); +} + +package CatalystUploadLifetimeApp; + +__PACKAGE__->setup; + +package main; + +Catalyst::Test->import('CatalystUploadLifetimeApp'); + +plan tests => 2; + +my $request = HTTP::Request::Common::PUT( + 'http://localhost/body', + 'Content-Type' => 'application/octet-stream', + 'Content' => 'payload', + 'Content-Length' => 7, +); +my $response = request($request); +is($response->code, 200, 'octet-stream request reaches the Catalyst app'); + +my $upload_path = $CatalystUploadLifetimeApp::Controller::Root::temp_path; +request(HTTP::Request::Common::GET('/')); +ok(!-e $upload_path, 'request temp file is removed when the next request releases the old context'); diff --git a/src/test/resources/unit/email_address_xs_rfc_groups.t b/src/test/resources/unit/email_address_xs_rfc_groups.t new file mode 100644 index 0000000000..dff20dbe5b --- /dev/null +++ b/src/test/resources/unit/email_address_xs_rfc_groups.t @@ -0,0 +1,30 @@ +use strict; +use warnings; +use Test::More tests => 10; + +use Email::Address::XS qw(parse_email_addresses parse_email_groups format_email_groups); + +my @addresses = parse_email_addresses( + '"," , "Döy" ' +); +is(scalar @addresses, 2, 'angle brackets inside a quoted phrase are not mailbox delimiters'); +is($addresses[0]->phrase, ',', 'quoted display phrase is parsed'); +is($addresses[0]->address, 'test@example.com', 'the actual angle address is selected'); +my @object_group = parse_email_groups($addresses[0]); +is($object_group[0], undef, 'an address object is treated as an ungrouped address'); +is($object_group[1][0], $addresses[0], 'an address object is preserved when formatting groups'); +my @address_list = parse_email_groups('first@example.com, second@example.com'); +is(scalar @{$address_list[1]}, 2, 'ordinary comma-separated addresses share one group'); + +my @groups = parse_email_groups( + '"MIME:;": "Winston: Smith" , ' + . '"Julia:; " ;' +); +is($groups[0], 'MIME:;', 'quoted group name is parsed'); +is(scalar @{$groups[1]}, 2, 'group members are parsed'); +is($groups[1][0]->phrase, 'Winston: Smith', 'quoted colon phrase is preserved'); +is( + format_email_groups(@groups), + '"MIME:;": "Winston: Smith" , "Julia:; " ;', + 'group and special phrases are quoted when formatted', +); diff --git a/src/test/resources/unit/encode_mime_header_autoload.t b/src/test/resources/unit/encode_mime_header_autoload.t index 690f9a5810..bd201c6641 100644 --- a/src/test/resources/unit/encode_mime_header_autoload.t +++ b/src/test/resources/unit/encode_mime_header_autoload.t @@ -4,6 +4,12 @@ use Test::More; use Encode qw(decode find_encoding); use utf8; +is( + decode('MIME-Header', '=?UTF-8?B?RMO2eQ==?= '), + 'Döy ', + 'decode autoloads the MIME-Header codec on first use', +); + my $codec = find_encoding('MIME-Header'); ok(defined $codec, 'MIME-Header codec is autoloaded by find_encoding'); diff --git a/src/test/resources/unit/fields_inherited_typed_hash_access.t b/src/test/resources/unit/fields_inherited_typed_hash_access.t new file mode 100644 index 0000000000..809fba4b64 --- /dev/null +++ b/src/test/resources/unit/fields_inherited_typed_hash_access.t @@ -0,0 +1,36 @@ +use strict; +use warnings; +use Test::More tests => 3; + +{ + package Local::InheritedFields::Parent; + use fields qw(cache key); + + sub new { + my ($class, $cache, $key) = @_; + return bless { cache => $cache, key => $key }, $class; + } +} + +{ + package Local::InheritedFields::Child; + use base 'Local::InheritedFields::Parent'; + use fields qw(store_entry); + + sub inherited_cache { + my Local::InheritedFields::Child $self = shift; + return $self->{cache}; + } + + sub inherited_key { + my Local::InheritedFields::Child $self = shift; + return $self->{key}; + } +} + +my $cache = bless {}, 'Local::InheritedFields::Parent'; +my $child = Local::InheritedFields::Child->new($cache, 'entry-1'); + +is($child->inherited_cache, $cache, 'typed child accesses inherited cache field'); +is($child->inherited_key, 'entry-1', 'typed child accesses inherited key field'); +isa_ok($child, 'Local::InheritedFields::Child'); diff --git a/src/test/resources/unit/moose_shortcut_build_instance_hashref.t b/src/test/resources/unit/moose_shortcut_build_instance_hashref.t new file mode 100644 index 0000000000..645a98feac --- /dev/null +++ b/src/test/resources/unit/moose_shortcut_build_instance_hashref.t @@ -0,0 +1,53 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + eval { require Moose; require MooseX::ShortCut::BuildInstance; 1 } + or plan skip_all => 'Moose and MooseX::ShortCut::BuildInstance required'; +} + +my $base = 'DynamicHashRefBuildInstanceRegression::Base'; +my $role = 'DynamicHashRefBuildInstanceRegression::Role'; +my $package = 'DynamicHashRefBuildInstanceRegression::Built'; + +my $base_loaded = eval qq{ + package $base; + use Moose; + has defined_excel_translations => ( + is => 'ro', isa => 'HashRef', traits => ['Hash'], + default => sub { { '\@' => 'text' } }, + ); + 1; +}; +ok($base_loaded, 'Moose base class with HashRef default compiles') or diag($@); + +my $role_loaded = eval qq{ + package $role; + use Moose::Role; + has role_payload => (is => 'ro', isa => 'HashRef', default => sub { { role => 17 } }); + has _alt_epoch_year => (is => 'ro', isa => 'Int'); + 1; +}; +ok($role_loaded, 'dynamic Moose role with constructor attributes compiles') or diag($@); + +my $payload = { translations => { '@' => 'text' }, values => [1, 2, 3] }; +my $instance = MooseX::ShortCut::BuildInstance::build_instance( + package => $package, + superclasses => [$base], + add_roles_in_sequence => [$role], + add_attributes => { + payload => { is => 'ro', isa => 'HashRef', required => 1 }, + }, + payload => $payload, + _alt_epoch_year => 1904, +); + +ok($instance, 'BuildInstance constructs a dynamic class with a role'); +is_deeply($instance->payload, $payload, 'dynamic constructor preserves HashRef arguments'); +is_deeply($instance->defined_excel_translations, { '@' => 'text' }, + 'HashRef default survives BuildInstance construction'); +is_deeply($instance->role_payload, { role => 17 }, 'role HashRef default survives construction'); +is($instance->_alt_epoch_year, 1904, 'dynamic constructor preserves selected scalar arguments'); + +done_testing; diff --git a/src/test/resources/unit/storable_default_exports.t b/src/test/resources/unit/storable_default_exports.t new file mode 100644 index 0000000000..9ae6352625 --- /dev/null +++ b/src/test/resources/unit/storable_default_exports.t @@ -0,0 +1,22 @@ +use strict; +use warnings; +use Test::More tests => 2; +use Storable qw(nfreeze thaw); + +{ + package Local::StorableExportParent; + sub freeze { return 'parent freeze method'; } +} + +{ + package Local::StorableExportChild; + our @ISA = ('Local::StorableExportParent'); + use Storable; +} + +my $object = bless {}, 'Local::StorableExportChild'; +is($object->freeze, 'parent freeze method', + 'default Storable imports do not shadow inherited freeze methods'); + +my $copy = thaw(nfreeze([{ value => 17 }])); +is($copy->[0]{value}, 17, 'optional Storable exports remain importable'); diff --git a/src/test/resources/unit/storable_mldbm_portable_reference_detach.t b/src/test/resources/unit/storable_mldbm_portable_reference_detach.t new file mode 100644 index 0000000000..6cf67f1f32 --- /dev/null +++ b/src/test/resources/unit/storable_mldbm_portable_reference_detach.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test::More tests => 4; +use Storable qw(nfreeze thaw); + +# MLDBM's portable Storable serializer freezes a scalar reference at STORE +# time and dereferences the restored value at FETCH time. +my %serialized; +my $source = [17]; +$serialized{g} = nfreeze(\$source); +$source = ''; + +my $restored = thaw(delete $serialized{g}); +is(ref($restored), 'REF', 'portable serialization restores MLDBM scalar envelope'); +is(ref($$restored), 'ARRAY', 'restored envelope still contains an array reference'); +is($$restored->[0], 17, 'changing the original reference does not change stored value'); +is($source, '', 'source reference was replaced after serialization');