From 34eacc026ea7c2983ce90dab35323902fb67590b Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Tue, 28 Jul 2026 15:39:01 +0200 Subject: [PATCH 1/5] fix: support selected CPAN module test suites Add missing core modules, improve compile-time warning delivery and version overflow handling, and provide targeted pure-Perl compatibility patches for the requested CPAN distributions. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex --- dev/import-perl5/config.yaml | 11 + .../analysis/ConstantFoldingVisitor.java | 14 + .../runtime/perlmodule/Version.java | 34 +- .../runtime/perlmodule/Warnings.java | 21 +- src/main/perl/lib/CPAN/Config.pm | 12 + src/main/perl/lib/I18N/LangTags/List.pm | 1779 +++++++++++++++++ .../CpanDistroprefs/DateTime-Format-CLDR.yml | 12 + .../PerlOnJava/CpanDistroprefs/LRU-Cache.yml | 11 + .../CpanDistroprefs/Term-ANSIColor-Markup.yml | 13 + .../CpanDistroprefs/Test-FailWarnings.yml | 12 + .../ByteSafePatternLiterals.patch | 16 + .../CpanPatches/LRU-Cache-1.00/PurePerl.patch | 120 ++ .../PortableAccessors.patch | 94 + .../CallerOrigin.patch | 10 + src/main/perl/lib/Time/localtime.pm | 83 + src/main/perl/lib/Time/tm.pm | 30 + .../resources/unit/compile_warning_handler.t | 27 + .../resources/unit/cpan_requested_compat.t | 20 + src/test/resources/unit/time_localtime_core.t | 9 + .../resources/unit/version_overflow_compare.t | 13 + 20 files changed, 2338 insertions(+), 3 deletions(-) create mode 100644 src/main/perl/lib/I18N/LangTags/List.pm create mode 100644 src/main/perl/lib/PerlOnJava/CpanDistroprefs/DateTime-Format-CLDR.yml create mode 100644 src/main/perl/lib/PerlOnJava/CpanDistroprefs/LRU-Cache.yml create mode 100644 src/main/perl/lib/PerlOnJava/CpanDistroprefs/Term-ANSIColor-Markup.yml create mode 100644 src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-FailWarnings.yml create mode 100644 src/main/perl/lib/PerlOnJava/CpanPatches/DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch create mode 100644 src/main/perl/lib/PerlOnJava/CpanPatches/LRU-Cache-1.00/PurePerl.patch create mode 100644 src/main/perl/lib/PerlOnJava/CpanPatches/Term-ANSIColor-Markup-0.06/PortableAccessors.patch create mode 100644 src/main/perl/lib/PerlOnJava/CpanPatches/Test-FailWarnings-0.008/CallerOrigin.patch create mode 100644 src/main/perl/lib/Time/localtime.pm create mode 100644 src/main/perl/lib/Time/tm.pm create mode 100644 src/test/resources/unit/compile_warning_handler.t create mode 100644 src/test/resources/unit/cpan_requested_compat.t create mode 100644 src/test/resources/unit/time_localtime_core.t create mode 100644 src/test/resources/unit/version_overflow_compare.t diff --git a/dev/import-perl5/config.yaml b/dev/import-perl5/config.yaml index 662eeace9..c4ba8db8a 100644 --- a/dev/import-perl5/config.yaml +++ b/dev/import-perl5/config.yaml @@ -308,6 +308,17 @@ imports: - source: perl5/cpan/Locale-Maketext-Simple/lib/Locale/Maketext/Simple.pm target: src/main/perl/lib/Locale/Maketext/Simple.pm + # Core language-tag name table used by Data::Identifier + - source: perl5/dist/I18N-LangTags/lib/I18N/LangTags/List.pm + target: src/main/perl/lib/I18N/LangTags/List.pm + + # Core named-field wrapper around localtime(), used by Date::Utils tests + - source: perl5/lib/Time/localtime.pm + target: src/main/perl/lib/Time/localtime.pm + + - source: perl5/lib/Time/tm.pm + target: src/main/perl/lib/Time/tm.pm + # Tests for distribution - source: perl5/cpan/Locale-Maketext-Simple/t target: perl5_t/Locale-Maketext-Simple diff --git a/src/main/java/org/perlonjava/frontend/analysis/ConstantFoldingVisitor.java b/src/main/java/org/perlonjava/frontend/analysis/ConstantFoldingVisitor.java index 931204ef8..c60378eee 100644 --- a/src/main/java/org/perlonjava/frontend/analysis/ConstantFoldingVisitor.java +++ b/src/main/java/org/perlonjava/frontend/analysis/ConstantFoldingVisitor.java @@ -742,6 +742,20 @@ private Node foldBinaryOperation(String operator, Node left, Node right, int tok } } + // Warning-producing numeric conversions must remain runtime operations. + // Constant folding runs outside an emitted Perl frame, so it cannot + // faithfully apply the expression's lexical warning bits. Leaving the + // operation intact also lets an earlier BEGIN/use-installed __WARN__ + // handler observe the warning, as it does in Perl. + switch (operator) { + case "+": case "-": case "*": case "/": case "%": case "**": + if (!ScalarUtils.looksLikeNumber(leftValue) + || !ScalarUtils.looksLikeNumber(rightValue)) { + return null; + } + break; + } + try { RuntimeScalar result; switch (operator) { diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Version.java b/src/main/java/org/perlonjava/runtime/perlmodule/Version.java index 194ce8b6b..989b5eebd 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Version.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Version.java @@ -2,8 +2,11 @@ import org.perlonjava.runtime.operators.ReferenceOperators; import org.perlonjava.runtime.operators.VersionHelper; +import org.perlonjava.runtime.operators.WarnDie; import org.perlonjava.runtime.runtimetypes.*; +import java.math.BigInteger; + import static org.perlonjava.runtime.runtimetypes.GlobalVariable.getGlobalCodeRef; import static org.perlonjava.runtime.runtimetypes.GlobalVariable.getGlobalVariable; import static org.perlonjava.runtime.runtimetypes.RuntimeScalarCache.*; @@ -199,6 +202,9 @@ else if (versionStr.type == VSTRING) { // Parse components String normalized = normalizeDottedVersion(version); versionObj.put("version", new RuntimeScalar(normalized)); + if (normalized.contains("Inf")) { + originalVersionStr = new RuntimeScalar("v.Inf"); + } } else { // Decimal format boolean isAlpha = version.contains("_"); @@ -228,7 +234,14 @@ private static String normalizeDottedVersion(String version) { StringBuilder dotted = new StringBuilder(); for (int i = 0; i < parts.length; i++) { if (i > 0) dotted.append("."); - dotted.append(Integer.parseInt(parts[i])); + BigInteger component = new BigInteger(parts[i]); + if (component.compareTo(BigInteger.valueOf(Integer.MAX_VALUE)) > 0) { + WarnDie.warn(new RuntimeScalar("Integer overflow in version"), + RuntimeScalarCache.scalarEmptyString); + return "Inf"; + } else { + dotted.append(component.intValue()); + } } return dotted.toString(); } @@ -471,6 +484,17 @@ public static RuntimeList VCMP(RuntimeArray args, int ctx) { // Check if arguments were swapped (third argument from overload) boolean swapped = args.size() > 2 && args.get(2).getBoolean(); + // Perl's version XS normalizes any overflowing dotted component to + // v.Inf. Overload dispatch may pass the peer either as the original + // version object or as its stringified "v.Inf" value, so handle the + // sentinel before attempting ordinary numeric version parsing. + boolean v1Infinite = isInfiniteVersion(v1); + boolean v2Infinite = isInfiniteVersion(v2); + if (v1Infinite || v2Infinite) { + int cmp = v1Infinite == v2Infinite ? 0 : (v1Infinite ? 1 : -1); + return new RuntimeScalar(swapped ? -cmp : cmp).getList(); + } + // Handle non-version objects - treat undef/empty as version 0 if (!v1.isBlessed() || !NameNormalizer.getBlessStr(v1.blessId).equals("version")) { String v1Str = v1.toString().trim(); @@ -523,6 +547,14 @@ public static RuntimeList VCMP(RuntimeArray args, int ctx) { return new RuntimeScalar(cmp).getList(); } + private static boolean isInfiniteVersion(RuntimeScalar value) { + if (value.isBlessed() && "version".equals(NameNormalizer.getBlessStr(value.blessId))) { + return "Inf".equals(value.hashDeref().get("version").toString()); + } + String stringValue = value.toString().trim(); + return "v.Inf".equals(stringValue) || "Inf".equals(stringValue); + } + /** * Implementation of UNIVERSAL::VERSION. */ diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Warnings.java b/src/main/java/org/perlonjava/runtime/perlmodule/Warnings.java index ac9a97a2c..67180f307 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Warnings.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Warnings.java @@ -473,6 +473,15 @@ public static RuntimeList enabled(RuntimeArray args, int ctx) { } else { bits = getWarningBitsAtLevel(0); } + if (bits == null || !WarningFlags.isEnabledInBits(bits, category)) { + ScopedSymbolTable compileScope = getCurrentScope(); + if (compileScope != null) { + String compileBits = compileScope.getWarningBitsString(); + if (compileBits != null && WarningFlags.isEnabledInBits(compileBits, category)) { + bits = compileBits; + } + } + } // Check scope-based runtime suppression first (from "no warnings 'category'" blocks) if (WarningFlags.isWarningSuppressedAtRuntime(category)) { return new RuntimeScalar(false).getList(); @@ -529,6 +538,15 @@ public static RuntimeList fatalEnabled(RuntimeArray args, int ctx) { } else { bits = getWarningBitsAtLevel(0); } + if (bits == null || !WarningFlags.isFatalInBits(bits, category)) { + ScopedSymbolTable compileScope = getCurrentScope(); + if (compileScope != null) { + String compileBits = compileScope.getWarningBitsString(); + if (compileBits != null && WarningFlags.isFatalInBits(compileBits, category)) { + bits = compileBits; + } + } + } // Check scope-based runtime suppression first if (WarningFlags.isWarningSuppressedAtRuntime(category)) { return new RuntimeScalar(false).getList(); @@ -567,8 +585,7 @@ public static RuntimeList warn(RuntimeArray args, int ctx) { if (args.size() < 1) { throw new IllegalStateException("Bad number of arguments for warn()"); } - String message = args.get(0).toString(); - System.err.println("Warning: " + message); + WarnDie.warn(args.get(0), getCallerLocation(0)); return new RuntimeScalar().getList(); } diff --git a/src/main/perl/lib/CPAN/Config.pm b/src/main/perl/lib/CPAN/Config.pm index e578e7819..4c7b9b600 100644 --- a/src/main/perl/lib/CPAN/Config.pm +++ b/src/main/perl/lib/CPAN/Config.pm @@ -119,6 +119,10 @@ sub _bootstrap_prefs { 'WWW-Suffit.yml' => 'PerlOnJava/CpanDistroprefs/WWW-Suffit.yml', 'WWW-Suffit-UserAgent.yml' => 'PerlOnJava/CpanDistroprefs/WWW-Suffit-UserAgent.yml', 'XML-FromPerl.yml' => 'PerlOnJava/CpanDistroprefs/XML-FromPerl.yml', + 'Test-FailWarnings.yml' => 'PerlOnJava/CpanDistroprefs/Test-FailWarnings.yml', + 'Term-ANSIColor-Markup.yml' => 'PerlOnJava/CpanDistroprefs/Term-ANSIColor-Markup.yml', + 'LRU-Cache.yml' => 'PerlOnJava/CpanDistroprefs/LRU-Cache.yml', + 'DateTime-Format-CLDR.yml' => 'PerlOnJava/CpanDistroprefs/DateTime-Format-CLDR.yml', ); $pref_install{'OpenAI-API.yml'} = $ENV{PERLONJAVA_OPENAI_LIVE_TESTING} ? 'PerlOnJava/CpanDistroprefs/OpenAI-API.live.yml' @@ -265,6 +269,14 @@ sub _bootstrap_patches { 'PerlOnJava/CpanPatches/Graph-0.9735/AdjacencyMap.pm.patch' ], [ 'Graph-0.9735/AdjacencyMap-Light.pm.patch', 'PerlOnJava/CpanPatches/Graph-0.9735/AdjacencyMap-Light.pm.patch' ], + [ 'Test-FailWarnings-0.008/CallerOrigin.patch', + 'PerlOnJava/CpanPatches/Test-FailWarnings-0.008/CallerOrigin.patch' ], + [ 'Term-ANSIColor-Markup-0.06/PortableAccessors.patch', + 'PerlOnJava/CpanPatches/Term-ANSIColor-Markup-0.06/PortableAccessors.patch' ], + [ 'LRU-Cache-1.00/PurePerl.patch', + 'PerlOnJava/CpanPatches/LRU-Cache-1.00/PurePerl.patch' ], + [ 'DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch', + 'PerlOnJava/CpanPatches/DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch' ], ); my $slurp = sub { diff --git a/src/main/perl/lib/I18N/LangTags/List.pm b/src/main/perl/lib/I18N/LangTags/List.pm new file mode 100644 index 000000000..17ac9b111 --- /dev/null +++ b/src/main/perl/lib/I18N/LangTags/List.pm @@ -0,0 +1,1779 @@ + +require 5; +package I18N::LangTags::List; +# Time-stamp: "2004-10-06 23:26:21 ADT" +use strict; +our (%Name, %Is_Disrec, $Debug); +our $VERSION = '0.41'; +# POD at the end. + +#---------------------------------------------------------------------- +{ +# read the table out of our own POD! + my $seeking = 1; + my $count = 0; + my($disrec,$tag,$name); + my $last_name = ''; + while() { + if($seeking) { + $seeking = 0 if m/=for woohah/; + } elsif( ($disrec, $tag, $name) = + m/(\[?)\{([-0-9a-zA-Z]+)\}(?:\s*:)?\s*([^\[\]]+)/ + ) { + $name =~ s/\s*[;\.]*\s*$//g; + next unless $name; + ++$count; + print "<$tag> <$name>\n" if $Debug; + $last_name = $Name{$tag} = $name; + $Is_Disrec{$tag} = 1 if $disrec; + } elsif (m/[Ff]ormerly \"([-a-z0-9]+)\"/) { + $Name{$1} = "$last_name (old tag)" if $last_name; + $Is_Disrec{$1} = 1; + } + } + die "No tags read??" unless $count; +} +#---------------------------------------------------------------------- + +sub name { + my $tag = lc($_[0] || return); + $tag =~ s/^\s+//s; + $tag =~ s/\s+$//s; + + my $alt; + if($tag =~ m/^x-(.+)/) { + $alt = "i-$1"; + } elsif($tag =~ m/^i-(.+)/) { + $alt = "x-$1"; + } else { + $alt = ''; + } + + my $subform = ''; + my $name = ''; + print "Input: {$tag}\n" if $Debug; + while(length $tag) { + last if $name = $Name{$tag}; + last if $name = $Name{$alt}; + if($tag =~ s/(-[a-z0-9]+)$//s) { + print "Shaving off: $1 leaving $tag\n" if $Debug; + $subform = "$1$subform"; + # and loop around again + + $alt =~ s/(-[a-z0-9]+)$//s && $Debug && print " alt -> $alt\n"; + } else { + # we're trying to pull a subform off a primary tag. TILT! + print "Aborting on: {$name}{$subform}\n" if $Debug; + last; + } + } + print "Output: {$name}{$subform}\n" if $Debug; + + return unless $name; # Failure + return $name unless $subform; # Exact match + $subform =~ s/^-//s; + $subform =~ s/-$//s; + return "$name (Subform \"$subform\")"; +} + +#-------------------------------------------------------------------------- + +sub is_decent { + my $tag = lc($_[0] || return 0); + #require I18N::LangTags; + + return 0 unless + $tag =~ + /^(?: # First subtag + [xi] | [a-z]{2,3} + ) + (?: # Subtags thereafter + - # separator + [a-z0-9]{1,8} # subtag + )* + $/xs; + + my @supers = (); + foreach my $bit (split('-', $tag)) { + push @supers, + scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit; + } + return 0 unless @supers; + shift @supers if $supers[0] =~ m<^(i|x|sgn)$>s; + return 0 unless @supers; + + foreach my $f ($tag, @supers) { + return 0 if $Is_Disrec{$f}; + return 2 if $Name{$f}; + # so that decent subforms of indecent tags are decent + } + return 2 if $Name{$tag}; # not only is it decent, it's known! + return 1; +} + +#-------------------------------------------------------------------------- +1; + +__DATA__ + +=head1 NAME + +I18N::LangTags::List -- tags and names for human languages + +=head1 SYNOPSIS + + use I18N::LangTags::List; + print "Parlez-vous... ", join(', ', + I18N::LangTags::List::name('elx') || 'unknown_language', + I18N::LangTags::List::name('ar-Kw') || 'unknown_language', + I18N::LangTags::List::name('en') || 'unknown_language', + I18N::LangTags::List::name('en-CA') || 'unknown_language', + ), "?\n"; + +prints: + + Parlez-vous... Elamite, Kuwait Arabic, English, Canadian English? + +=head1 DESCRIPTION + +This module provides a function +C ) > that takes +a language tag (see L) +and returns the best attempt at an English name for it, or +undef if it can't make sense of the tag. + +The function I18N::LangTags::List::name(...) is not exported. + +This module also provides a function +C )> that returns true iff +the language tag is syntactically valid and is for general use (like +"fr" or "fr-ca", below). That is, it returns false for tags that are +syntactically invalid and for tags, like "aus", that are listed in +brackets below. This function is not exported. + +The map of tags-to-names that it uses is accessible as +%I18N::LangTags::List::Name, and it's the same as the list +that follows in this documentation, which should be useful +to you even if you don't use this module. + +=head1 ABOUT LANGUAGE TAGS + +Internet language tags, as defined in RFC 3066, are a formalism +for denoting human languages. The two-letter ISO 639-1 language +codes are well known (as "en" for English), as are their forms +when qualified by a country code ("en-US"). Less well-known are the +arbitrary-length non-ISO codes (like "i-mingo"), and the +recently (in 2001) introduced three-letter ISO-639-2 codes. + +Remember these important facts: + +=over + +=item * + +Language tags are not locale IDs. A locale ID is written with a "_" +instead of a "-", (almost?) always matches C, and +I something different than a language tag. A language tag +denotes a language. A locale ID denotes a language I +a particular place, in combination with non-linguistic +location-specific information such as what currency is used +there. Locales I often denote character set information, +as in "en_US.ISO8859-1". + +=item * + +Language tags are not for computer languages. + +=item * + +"Dialect" is not a useful term, since there is no objective +criterion for establishing when two language-forms are +dialects of eachother, or are separate languages. + +=item * + +Language tags are not case-sensitive. en-US, en-us, En-Us, etc., +are all the same tag, and denote the same language. + +=item * + +Not every language tag really refers to a single language. Some +language tags refer to conditions: i-default (system-message text +in English plus maybe other languages), und (undetermined +language). Others (notably lots of the three-letter codes) are +bibliographic tags that classify whole groups of languages, as +with cus "Cushitic (Other)" (i.e., a +language that has been classed as Cushtic, but which has no more +specific code) or the even less linguistically coherent +sai for "South American Indian (Other)". Though useful in +bibliography, B. For further guidance, email me. + +=item * + +Language tags are not country codes. In fact, they are often +distinct codes, as with language tag ja for Japanese, and +ISO 3166 country code C<.jp> for Japan. + +=back + +=head1 LIST OF LANGUAGES + +The first part of each item is the language tag, between +{...}. It +is followed by an English name for the language or language-group. +Language tags that I judge to be not for general use, are bracketed. + +This list is in alphabetical order by English name of the language. + +=for reminder + The name in the =item line MUST NOT have E<...>'s in it!! + +=for woohah START + +=over + +=item {ab} : Abkhazian + +eq Abkhaz + +=item {ace} : Achinese + +=item {ach} : Acoli + +=item {ada} : Adangme + +=item {ady} : Adyghe + +eq Adygei + +=item {aa} : Afar + +=item {afh} : Afrihili + +(Artificial) + +=item {af} : Afrikaans + +=item [{afa} : Afro-Asiatic (Other)] + +=item {ak} : Akan + +(Formerly "aka".) + +=item {akk} : Akkadian + +(Historical) + +=item {sq} : Albanian + +=item {ale} : Aleut + +=item [{alg} : Algonquian languages] + +NOT Algonquin! + +=item [{tut} : Altaic (Other)] + +=item {am} : Amharic + +NOT Aramaic! + +=item {i-ami} : Ami + +eq Amis. eq 'Amis. eq Pangca. + +=item [{apa} : Apache languages] + +=item {ar} : Arabic + +Many forms are mutually un-intelligible in spoken media. +Notable forms: +{ar-ae} UAE Arabic; +{ar-bh} Bahrain Arabic; +{ar-dz} Algerian Arabic; +{ar-eg} Egyptian Arabic; +{ar-iq} Iraqi Arabic; +{ar-jo} Jordanian Arabic; +{ar-kw} Kuwait Arabic; +{ar-lb} Lebanese Arabic; +{ar-ly} Libyan Arabic; +{ar-ma} Moroccan Arabic; +{ar-om} Omani Arabic; +{ar-qa} Qatari Arabic; +{ar-sa} Sauda Arabic; +{ar-sy} Syrian Arabic; +{ar-tn} Tunisian Arabic; +{ar-ye} Yemen Arabic. + +=item {arc} : Aramaic + +NOT Amharic! NOT Samaritan Aramaic! + +=item {arp} : Arapaho + +=item {arn} : Araucanian + +=item {arw} : Arawak + +=item {hy} : Armenian + +=item {an} : Aragonese + +=item [{art} : Artificial (Other)] + +=item {ast} : Asturian + +eq Bable. + +=item {as} : Assamese + +=item [{ath} : Athapascan languages] + +eq Athabaskan. eq Athapaskan. eq Athabascan. + +=item [{aus} : Australian languages] + +=item [{map} : Austronesian (Other)] + +=item {av} : Avaric + +(Formerly "ava".) + +=item {ae} : Avestan + +eq Zend + +=item {awa} : Awadhi + +=item {ay} : Aymara + +=item {az} : Azerbaijani + +eq Azeri + +Notable forms: +{az-arab} Azerbaijani in Arabic script; +{az-cyrl} Azerbaijani in Cyrillic script; +{az-latn} Azerbaijani in Latin script. + +=item {ban} : Balinese + +=item [{bat} : Baltic (Other)] + +=item {bal} : Baluchi + +=item {bm} : Bambara + +(Formerly "bam".) + +=item [{bai} : Bamileke languages] + +=item {bad} : Banda + +=item [{bnt} : Bantu (Other)] + +=item {bas} : Basa + +=item {ba} : Bashkir + +=item {eu} : Basque + +=item {btk} : Batak (Indonesia) + +=item {bej} : Beja + +=item {be} : Belarusian + +eq Belarussian. eq Byelarussian. +eq Belorussian. eq Byelorussian. +eq White Russian. eq White Ruthenian. +NOT Ruthenian! + +=item {bem} : Bemba + +=item {bn} : Bengali + +eq Bangla. + +=item [{ber} : Berber (Other)] + +=item {bho} : Bhojpuri + +=item {bh} : Bihari + +=item {bik} : Bikol + +=item {bin} : Bini + +=item {bi} : Bislama + +eq Bichelamar. + +=item {bs} : Bosnian + +=item {bra} : Braj + +=item {br} : Breton + +=item {bug} : Buginese + +=item {bg} : Bulgarian + +=item {i-bnn} : Bunun + +=item {bua} : Buriat + +=item {my} : Burmese + +=item {cad} : Caddo + +=item {car} : Carib + +=item {ca} : Catalan + +eq CatalEn. eq Catalonian. + +=item [{cau} : Caucasian (Other)] + +=item {ceb} : Cebuano + +=item [{cel} : Celtic (Other)] + +Notable forms: +{cel-gaulish} Gaulish (Historical) + +=item [{cai} : Central American Indian (Other)] + +=item {chg} : Chagatai + +(Historical?) + +=item [{cmc} : Chamic languages] + +=item {ch} : Chamorro + +=item {ce} : Chechen + +=item {chr} : Cherokee + +eq Tsalagi + +=item {chy} : Cheyenne + +=item {chb} : Chibcha + +(Historical) NOT Chibchan (which is a language family). + +=item {ny} : Chichewa + +eq Nyanja. eq Chinyanja. + +=item {zh} : Chinese + +Many forms are mutually un-intelligible in spoken media. +Notable forms: +{zh-hans} Chinese, in simplified script; +{zh-hant} Chinese, in traditional script; +{zh-tw} Taiwan Chinese; +{zh-cn} PRC Chinese; +{zh-sg} Singapore Chinese; +{zh-mo} Macau Chinese; +{zh-hk} Hong Kong Chinese; +{zh-guoyu} Mandarin [Putonghua/Guoyu]; +{zh-hakka} Hakka [formerly "i-hakka"]; +{zh-min} Hokkien; +{zh-min-nan} Southern Hokkien; +{zh-wuu} Shanghaiese; +{zh-xiang} Hunanese; +{zh-gan} Gan; +{zh-yue} Cantonese. + +=for etc +{i-hakka} Hakka (old tag) + +=item {chn} : Chinook Jargon + +eq Chinook Wawa. + +=item {chp} : Chipewyan + +=item {cho} : Choctaw + +=item {cu} : Church Slavic + +eq Old Church Slavonic. + +=item {chk} : Chuukese + +eq Trukese. eq Chuuk. eq Truk. eq Ruk. + +=item {cv} : Chuvash + +=item {cop} : Coptic + +=item {kw} : Cornish + +=item {co} : Corsican + +eq Corse. + +=item {cr} : Cree + +NOT Creek! (Formerly "cre".) + +=item {mus} : Creek + +NOT Cree! + +=item [{cpe} : English-based Creoles and pidgins (Other)] + +=item [{cpf} : French-based Creoles and pidgins (Other)] + +=item [{cpp} : Portuguese-based Creoles and pidgins (Other)] + +=item [{crp} : Creoles and pidgins (Other)] + +=item {hr} : Croatian + +eq Croat. + +=item [{cus} : Cushitic (Other)] + +=item {cs} : Czech + +=item {dak} : Dakota + +eq Nakota. eq Latoka. + +=item {da} : Danish + +=item {dar} : Dargwa + +=item {day} : Dayak + +=item {i-default} : Default (Fallthru) Language + +Defined in RFC 2277, this is for tagging text +(which must include English text, and might/should include text +in other appropriate languages) that is emitted in a context +where language-negotiation wasn't possible -- in SMTP mail failure +messages, for example. + +=item {del} : Delaware + +=item {din} : Dinka + +=item {dv} : Divehi + +eq Maldivian. (Formerly "div".) + +=item {doi} : Dogri + +NOT Dogrib! + +=item {dgr} : Dogrib + +NOT Dogri! + +=item [{dra} : Dravidian (Other)] + +=item {dua} : Duala + +=item {nl} : Dutch + +eq Netherlander. Notable forms: +{nl-nl} Netherlands Dutch; +{nl-be} Belgian Dutch. + +=item {dum} : Middle Dutch (ca.1050-1350) + +(Historical) + +=item {dyu} : Dyula + +=item {dz} : Dzongkha + +=item {efi} : Efik + +=item {egy} : Ancient Egyptian + +(Historical) + +=item {eka} : Ekajuk + +=item {elx} : Elamite + +(Historical) + +=item {en} : English + +Notable forms: +{en-au} Australian English; +{en-bz} Belize English; +{en-ca} Canadian English; +{en-gb} UK English; +{en-ie} Irish English; +{en-jm} Jamaican English; +{en-nz} New Zealand English; +{en-ph} Philippine English; +{en-tt} Trinidad English; +{en-us} US English; +{en-za} South African English; +{en-zw} Zimbabwe English. + +=item {enm} : Old English (1100-1500) + +(Historical) + +=item {ang} : Old English (ca.450-1100) + +eq Anglo-Saxon. (Historical) + +=item {i-enochian} : Enochian (Artificial) + +=item {myv} : Erzya + +=item {eo} : Esperanto + +(Artificial) + +=item {et} : Estonian + +=item {ee} : Ewe + +(Formerly "ewe".) + +=item {ewo} : Ewondo + +=item {fan} : Fang + +=item {fat} : Fanti + +=item {fo} : Faroese + +=item {fj} : Fijian + +=item {fi} : Finnish + +=item [{fiu} : Finno-Ugrian (Other)] + +eq Finno-Ugric. NOT Ugaritic! + +=item {fon} : Fon + +=item {fr} : French + +Notable forms: +{fr-fr} France French; +{fr-be} Belgian French; +{fr-ca} Canadian French; +{fr-ch} Swiss French; +{fr-lu} Luxembourg French; +{fr-mc} Monaco French. + +=item {frm} : Middle French (ca.1400-1600) + +(Historical) + +=item {fro} : Old French (842-ca.1400) + +(Historical) + +=item {fy} : Frisian + +=item {fur} : Friulian + +=item {ff} : Fulah + +(Formerly "ful".) + +=item {gaa} : Ga + +=item {gd} : Scots Gaelic + +NOT Scots! + +=item {gl} : Gallegan + +eq Galician + +=item {lg} : Ganda + +(Formerly "lug".) + +=item {gay} : Gayo + +=item {gba} : Gbaya + +=item {gez} : Geez + +eq Ge'ez + +=item {ka} : Georgian + +=item {de} : German + +Notable forms: +{de-at} Austrian German; +{de-be} Belgian German; +{de-ch} Swiss German; +{de-de} Germany German; +{de-li} Liechtenstein German; +{de-lu} Luxembourg German. + +=item {gmh} : Middle High German (ca.1050-1500) + +(Historical) + +=item {goh} : Old High German (ca.750-1050) + +(Historical) + +=item [{gem} : Germanic (Other)] + +=item {gil} : Gilbertese + +=item {gon} : Gondi + +=item {gor} : Gorontalo + +=item {got} : Gothic + +(Historical) + +=item {grb} : Grebo + +=item {grc} : Ancient Greek + +(Historical) (Until 15th century or so.) + +=item {el} : Modern Greek + +(Since 15th century or so.) + +=item {gn} : Guarani + +GuaranE + +=item {gu} : Gujarati + +=item {gwi} : Gwich'in + +eq Gwichin + +=item {hai} : Haida + +=item {ht} : Haitian + +eq Haitian Creole + +=item {ha} : Hausa + +=item {haw} : Hawaiian + +Hawai'ian + +=item {he} : Hebrew + +(Formerly "iw".) + +=for etc +{iw} Hebrew (old tag) + +=item {hz} : Herero + +=item {hil} : Hiligaynon + +=item {him} : Himachali + +=item {hi} : Hindi + +=item {ho} : Hiri Motu + +=item {hit} : Hittite + +(Historical) + +=item {hmn} : Hmong + +=item {hu} : Hungarian + +=item {hup} : Hupa + +=item {iba} : Iban + +=item {is} : Icelandic + +=item {io} : Ido + +(Artificial) + +=item {ig} : Igbo + +(Formerly "ibo".) + +=item {ijo} : Ijo + +=item {ilo} : Iloko + +=item [{inc} : Indic (Other)] + +=item [{ine} : Indo-European (Other)] + +=item {id} : Indonesian + +(Formerly "in".) + +=for etc +{in} Indonesian (old tag) + +=item {inh} : Ingush + +=item {ia} : Interlingua (International Auxiliary Language Association) + +(Artificial) NOT Interlingue! + +=item {ie} : Interlingue + +(Artificial) NOT Interlingua! + +=item {iu} : Inuktitut + +A subform of "Eskimo". + +=item {ik} : Inupiaq + +A subform of "Eskimo". + +=item [{ira} : Iranian (Other)] + +=item {ga} : Irish + +=item {mga} : Middle Irish (900-1200) + +(Historical) + +=item {sga} : Old Irish (to 900) + +(Historical) + +=item [{iro} : Iroquoian languages] + +=item {it} : Italian + +Notable forms: +{it-it} Italy Italian; +{it-ch} Swiss Italian. + +=item {ja} : Japanese + +(NOT "jp"!) + +=item {jv} : Javanese + +(Formerly "jw" because of a typo.) + +=item {jrb} : Judeo-Arabic + +=item {jpr} : Judeo-Persian + +=item {kbd} : Kabardian + +=item {kab} : Kabyle + +=item {kac} : Kachin + +=item {kl} : Kalaallisut + +eq Greenlandic "Eskimo" + +=item {xal} : Kalmyk + +=item {kam} : Kamba + +=item {kn} : Kannada + +eq Kanarese. NOT Canadian! + +=item {kr} : Kanuri + +(Formerly "kau".) + +=item {krc} : Karachay-Balkar + +=item {kaa} : Kara-Kalpak + +=item {kar} : Karen + +=item {ks} : Kashmiri + +=item {csb} : Kashubian + +eq Kashub + +=item {kaw} : Kawi + +=item {kk} : Kazakh + +=item {kha} : Khasi + +=item {km} : Khmer + +eq Cambodian. eq Kampuchean. + +=item [{khi} : Khoisan (Other)] + +=item {kho} : Khotanese + +=item {ki} : Kikuyu + +eq Gikuyu. + +=item {kmb} : Kimbundu + +=item {rw} : Kinyarwanda + +=item {ky} : Kirghiz + +=item {i-klingon} : Klingon + +=item {kv} : Komi + +=item {kg} : Kongo + +(Formerly "kon".) + +=item {kok} : Konkani + +=item {ko} : Korean + +=item {kos} : Kosraean + +=item {kpe} : Kpelle + +=item {kro} : Kru + +=item {kj} : Kuanyama + +=item {kum} : Kumyk + +=item {ku} : Kurdish + +=item {kru} : Kurukh + +=item {kut} : Kutenai + +=item {lad} : Ladino + +eq Judeo-Spanish. NOT Ladin (a minority language in Italy). + +=item {lah} : Lahnda + +NOT Lamba! + +=item {lam} : Lamba + +NOT Lahnda! + +=item {lo} : Lao + +eq Laotian. + +=item {la} : Latin + +(Historical) NOT Ladin! NOT Ladino! + +=item {lv} : Latvian + +eq Lettish. + +=item {lb} : Letzeburgesch + +eq Luxemburgian, eq Luxemburger. (Formerly "i-lux".) + +=for etc +{i-lux} Letzeburgesch (old tag) + +=item {lez} : Lezghian + +=item {li} : Limburgish + +eq Limburger, eq Limburgan. NOT Letzeburgesch! + +=item {ln} : Lingala + +=item {lt} : Lithuanian + +=item {nds} : Low German + +eq Low Saxon. eq Low German. eq Low Saxon. + +=item {art-lojban} : Lojban (Artificial) + +=item {loz} : Lozi + +=item {lu} : Luba-Katanga + +(Formerly "lub".) + +=item {lua} : Luba-Lulua + +=item {lui} : Luiseno + +eq LuiseEo. + +=item {lun} : Lunda + +=item {luo} : Luo (Kenya and Tanzania) + +=item {lus} : Lushai + +=item {mk} : Macedonian + +eq the modern Slavic language spoken in what was Yugoslavia. +NOT the form of Greek spoken in Greek Macedonia! + +=item {mad} : Madurese + +=item {mag} : Magahi + +=item {mai} : Maithili + +=item {mak} : Makasar + +=item {mg} : Malagasy + +=item {ms} : Malay + +NOT Malayalam! + +=item {ml} : Malayalam + +NOT Malay! + +=item {mt} : Maltese + +=item {mnc} : Manchu + +=item {mdr} : Mandar + +NOT Mandarin! + +=item {man} : Mandingo + +=item {mni} : Manipuri + +eq Meithei. + +=item [{mno} : Manobo languages] + +=item {gv} : Manx + +=item {mi} : Maori + +NOT Mari! + +=item {mr} : Marathi + +=item {chm} : Mari + +NOT Maori! + +=item {mh} : Marshall + +eq Marshallese. + +=item {mwr} : Marwari + +=item {mas} : Masai + +=item [{myn} : Mayan languages] + +=item {men} : Mende + +=item {mic} : Micmac + +=item {min} : Minangkabau + +=item {i-mingo} : Mingo + +eq the Irquoian language West Virginia Seneca. NOT New York Seneca! + +=item [{mis} : Miscellaneous languages] + +Don't use this. + +=item {moh} : Mohawk + +=item {mdf} : Moksha + +=item {mo} : Moldavian + +eq Moldovan. + +=item [{mkh} : Mon-Khmer (Other)] + +=item {lol} : Mongo + +=item {mn} : Mongolian + +eq Mongol. + +=item {mos} : Mossi + +=item [{mul} : Multiple languages] + +Not for normal use. + +=item [{mun} : Munda languages] + +=item {nah} : Nahuatl + +=item {nap} : Neapolitan + +=item {na} : Nauru + +=item {nv} : Navajo + +eq Navaho. (Formerly "i-navajo".) + +=for etc +{i-navajo} Navajo (old tag) + +=item {nd} : North Ndebele + +=item {nr} : South Ndebele + +=item {ng} : Ndonga + +=item {ne} : Nepali + +eq Nepalese. Notable forms: +{ne-np} Nepal Nepali; +{ne-in} India Nepali. + +=item {new} : Newari + +=item {nia} : Nias + +=item [{nic} : Niger-Kordofanian (Other)] + +=item [{ssa} : Nilo-Saharan (Other)] + +=item {niu} : Niuean + +=item {nog} : Nogai + +=item {non} : Old Norse + +(Historical) + +=item [{nai} : North American Indian] + +Do not use this. + +=item {no} : Norwegian + +Note the two following forms: + +=item {nb} : Norwegian Bokmal + +eq BokmEl, (A form of Norwegian.) (Formerly "no-bok".) + +=for etc +{no-bok} Norwegian Bokmal (old tag) + +=item {nn} : Norwegian Nynorsk + +(A form of Norwegian.) (Formerly "no-nyn".) + +=for etc +{no-nyn} Norwegian Nynorsk (old tag) + +=item [{nub} : Nubian languages] + +=item {nym} : Nyamwezi + +=item {nyn} : Nyankole + +=item {nyo} : Nyoro + +=item {nzi} : Nzima + +=item {oc} : Occitan (post 1500) + +eq ProvenEal, eq Provencal + +=item {oj} : Ojibwa + +eq Ojibwe. (Formerly "oji".) + +=item {or} : Oriya + +=item {om} : Oromo + +=item {osa} : Osage + +=item {os} : Ossetian; Ossetic + +=item [{oto} : Otomian languages] + +Group of languages collectively called "OtomE". + +=item {pal} : Pahlavi + +eq Pahlevi + +=item {i-pwn} : Paiwan + +eq Pariwan + +=item {pau} : Palauan + +=item {pi} : Pali + +(Historical?) + +=item {pam} : Pampanga + +=item {pag} : Pangasinan + +=item {pa} : Panjabi + +eq Punjabi + +=item {pap} : Papiamento + +eq Papiamentu. + +=item [{paa} : Papuan (Other)] + +=item {fa} : Persian + +eq Farsi. eq Iranian. + +=item {peo} : Old Persian (ca.600-400 B.C.) + +=item [{phi} : Philippine (Other)] + +=item {phn} : Phoenician + +(Historical) + +=item {pon} : Pohnpeian + +NOT Pompeiian! + +=item {pl} : Polish + +=item {pt} : Portuguese + +eq Portugese. Notable forms: +{pt-pt} Portugal Portuguese; +{pt-br} Brazilian Portuguese. + +=item [{pra} : Prakrit languages] + +=item {pro} : Old Provencal (to 1500) + +eq Old ProvenEal. (Historical.) + +=item {ps} : Pushto + +eq Pashto. eq Pushtu. + +=item {qu} : Quechua + +eq Quecha. + +=item {rm} : Raeto-Romance + +eq Romansh. + +=item {raj} : Rajasthani + +=item {rap} : Rapanui + +=item {rar} : Rarotongan + +=item [{qaa - qtz} : Reserved for local use.] + +=item [{roa} : Romance (Other)] + +NOT Romanian! NOT Romany! NOT Romansh! + +=item {ro} : Romanian + +eq Rumanian. NOT Romany! + +=item {rom} : Romany + +eq Rom. NOT Romanian! + +=item {rn} : Rundi + +=item {ru} : Russian + +NOT White Russian! NOT Rusyn! + +=item [{sal} : Salishan languages] + +Large language group. + +=item {sam} : Samaritan Aramaic + +NOT Aramaic! + +=item {se} : Northern Sami + +eq Lappish. eq Lapp. eq (Northern) Saami. + +=item {sma} : Southern Sami + +=item {smn} : Inari Sami + +=item {smj} : Lule Sami + +=item {sms} : Skolt Sami + +=item [{smi} : Sami languages (Other)] + +=item {sm} : Samoan + +=item {sad} : Sandawe + +=item {sg} : Sango + +=item {sa} : Sanskrit + +(Historical) + +=item {sat} : Santali + +=item {sc} : Sardinian + +eq Sard. + +=item {sas} : Sasak + +=item {sco} : Scots + +NOT Scots Gaelic! + +=item {sel} : Selkup + +=item [{sem} : Semitic (Other)] + +=item {sr} : Serbian + +eq Serb. NOT Sorbian. + +Notable forms: +{sr-cyrl} : Serbian in Cyrillic script; +{sr-latn} : Serbian in Latin script. + +=item {srr} : Serer + +=item {shn} : Shan + +=item {sn} : Shona + +=item {sid} : Sidamo + +=item {sgn-...} : Sign Languages + +Always use with a subtag. Notable forms: +{sgn-gb} British Sign Language (BSL); +{sgn-ie} Irish Sign Language (ESL); +{sgn-ni} Nicaraguan Sign Language (ISN); +{sgn-us} American Sign Language (ASL). + +(And so on with other country codes as the subtag.) + +=item {bla} : Siksika + +eq Blackfoot. eq Pikanii. + +=item {sd} : Sindhi + +=item {si} : Sinhalese + +eq Sinhala. + +=item [{sit} : Sino-Tibetan (Other)] + +=item [{sio} : Siouan languages] + +=item {den} : Slave (Athapascan) + +("Slavey" is a subform.) + +=item [{sla} : Slavic (Other)] + +=item {sk} : Slovak + +eq Slovakian. + +=item {sl} : Slovenian + +eq Slovene. + +=item {sog} : Sogdian + +=item {so} : Somali + +=item {son} : Songhai + +=item {snk} : Soninke + +=item {wen} : Sorbian languages + +eq Wendish. eq Sorb. eq Lusatian. eq Wend. NOT Venda! NOT Serbian! + +=item {nso} : Northern Sotho + +=item {st} : Southern Sotho + +eq Sutu. eq Sesotho. + +=item [{sai} : South American Indian (Other)] + +=item {es} : Spanish + +Notable forms: +{es-ar} Argentine Spanish; +{es-bo} Bolivian Spanish; +{es-cl} Chilean Spanish; +{es-co} Colombian Spanish; +{es-do} Dominican Spanish; +{es-ec} Ecuadorian Spanish; +{es-es} Spain Spanish; +{es-gt} Guatemalan Spanish; +{es-hn} Honduran Spanish; +{es-mx} Mexican Spanish; +{es-pa} Panamanian Spanish; +{es-pe} Peruvian Spanish; +{es-pr} Puerto Rican Spanish; +{es-py} Paraguay Spanish; +{es-sv} Salvadoran Spanish; +{es-us} US Spanish; +{es-uy} Uruguayan Spanish; +{es-ve} Venezuelan Spanish. + +=item {suk} : Sukuma + +=item {sux} : Sumerian + +(Historical) + +=item {su} : Sundanese + +=item {sus} : Susu + +=item {sw} : Swahili + +eq Kiswahili + +=item {ss} : Swati + +=item {sv} : Swedish + +Notable forms: +{sv-se} Sweden Swedish; +{sv-fi} Finland Swedish. + +=item {syr} : Syriac + +=item {tl} : Tagalog + +=item {ty} : Tahitian + +=item [{tai} : Tai (Other)] + +NOT Thai! + +=item {tg} : Tajik + +=item {tmh} : Tamashek + +=item {ta} : Tamil + +=item {i-tao} : Tao + +eq Yami. + +=item {tt} : Tatar + +=item {i-tay} : Tayal + +eq Atayal. eq Atayan. + +=item {te} : Telugu + +=item {ter} : Tereno + +=item {tet} : Tetum + +=item {th} : Thai + +NOT Tai! + +=item {bo} : Tibetan + +=item {tig} : Tigre + +=item {ti} : Tigrinya + +=item {tem} : Timne + +eq Themne. eq Timene. + +=item {tiv} : Tiv + +=item {tli} : Tlingit + +=item {tpi} : Tok Pisin + +=item {tkl} : Tokelau + +=item {tog} : Tonga (Nyasa) + +NOT Tsonga! + +=item {to} : Tonga (Tonga Islands) + +(Pronounced "Tong-a", not "Tong-ga") + +NOT Tsonga! + +=item {tsi} : Tsimshian + +eq Sm'algyax + +=item {ts} : Tsonga + +NOT Tonga! + +=item {i-tsu} : Tsou + +=item {tn} : Tswana + +Same as Setswana. + +=item {tum} : Tumbuka + +=item [{tup} : Tupi languages] + +=item {tr} : Turkish + +(Typically in Roman script) + +=item {ota} : Ottoman Turkish (1500-1928) + +(Typically in Arabic script) (Historical) + +=item {crh} : Crimean Turkish + +eq Crimean Tatar + +=item {tk} : Turkmen + +eq Turkmeni. + +=item {tvl} : Tuvalu + +=item {tyv} : Tuvinian + +eq Tuvan. eq Tuvin. + +=item {tw} : Twi + +=item {udm} : Udmurt + +=item {uga} : Ugaritic + +NOT Ugric! + +=item {ug} : Uighur + +=item {uk} : Ukrainian + +=item {umb} : Umbundu + +=item {und} : Undetermined + +Not a tag for normal use. + +=item {ur} : Urdu + +=item {uz} : Uzbek + +eq Ezbek + +Notable forms: +{uz-cyrl} Uzbek in Cyrillic script; +{uz-latn} Uzbek in Latin script. + +=item {vai} : Vai + +=item {ve} : Venda + +NOT Wendish! NOT Wend! NOT Avestan! (Formerly "ven".) + +=item {vi} : Vietnamese + +eq Viet. + +=item {vo} : Volapuk + +eq VolapEk. (Artificial) + +=item {vot} : Votic + +eq Votian. eq Vod. + +=item [{wak} : Wakashan languages] + +=item {wa} : Walloon + +=item {wal} : Walamo + +eq Wolaytta. + +=item {war} : Waray + +Presumably the Philippine language Waray-Waray (SamareEo), +not the smaller Philippine language Waray Sorsogon, nor the extinct +Australian language Waray. + +=item {was} : Washo + +eq Washoe + +=item {cy} : Welsh + +=item {wo} : Wolof + +=item {x-...} : Unregistered (Semi-Private Use) + +"x-" is a prefix for language tags that are not registered with ISO +or IANA. Example, x-double-dutch + +=item {xh} : Xhosa + +=item {sah} : Yakut + +=item {yao} : Yao + +(The Yao in Malawi?) + +=item {yap} : Yapese + +eq Yap + +=item {ii} : Sichuan Yi + +=item {yi} : Yiddish + +Formerly "ji". Usually in Hebrew script. + +Notable forms: +{yi-latn} Yiddish in Latin script + +=item {yo} : Yoruba + +=item [{ypk} : Yupik languages] + +Several "Eskimo" languages. + +=item {znd} : Zande + +=item [{zap} : Zapotec] + +(A group of languages.) + +=item {zen} : Zenaga + +NOT Zend. + +=item {za} : Zhuang + +=item {zu} : Zulu + +=item {zun} : Zuni + +eq ZuEi + +=back + +=for woohah END + +=head1 SEE ALSO + +L and its "See Also" section. + +=head1 COPYRIGHT AND DISCLAIMER + +Copyright (c) 2001+ Sean M. Burke. All rights reserved. + +You can redistribute and/or +modify this document under the same terms as Perl itself. + +This document is provided in the hope that it will be +useful, but without any warranty; +without even the implied warranty of accuracy, authoritativeness, +completeness, merchantability, or fitness for a particular purpose. + +Email any corrections or questions to me. + +=head1 AUTHOR + +Sean M. Burke, sburkeE<64>cpan.org + +=cut + + +# To generate a list of just the two and three-letter codes: + +#!/usr/local/bin/perl -w + +require 5; # Time-stamp: "2001-03-13 21:53:39 MST" + # Sean M. Burke, sburke@cpan.org + # This program is for generating the language_codes.txt file +use strict; +use LWP::Simple; +use HTML::TreeBuilder 3.10; +my $root = HTML::TreeBuilder->new(); +my $url = 'http://lcweb.loc.gov/standards/iso639-2/bibcodes.html'; +$root->parse(get($url) || die "Can't get $url"); +$root->eof(); + +my @codes; + +foreach my $tr ($root->find_by_tag_name('tr')) { + my @f = map $_->as_text(), $tr->content_list(); + #print map("<$_> ", @f), "\n"; + next unless @f == 5; + pop @f; # nix the French name + next if $f[-1] eq 'Language Name (English)'; # it's a header line + my $xx = splice(@f, 2,1); # pull out the two-letter code + $f[-1] =~ s/^\s+//; + $f[-1] =~ s/\s+$//; + if($xx =~ m/[a-zA-Z]/) { # there's a two-letter code for it + push @codes, [ lc($f[-1]), "$xx\t$f[-1]\n" ]; + } else { # print the three-letter codes. + if($f[0] eq $f[1]) { + push @codes, [ lc($f[-1]), "$f[1]\t$f[2]\n" ]; + } else { # shouldn't happen + push @codes, [ lc($f[-1]), "@f !!!!!!!!!!\n" ]; + } + } +} + +print map $_->[1], sort {; $a->[0] cmp $b->[0] } @codes; +print "[ based on $url\n at ", scalar(localtime), "]\n", + "[Note: doesn't include IANA-registered codes.]\n"; +exit; +__END__ + diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/DateTime-Format-CLDR.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/DateTime-Format-CLDR.yml new file mode 100644 index 000000000..2df6ab145 --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/DateTime-Format-CLDR.yml @@ -0,0 +1,12 @@ +--- +comment: | + PerlOnJava distroprefs for DateTime::Format::CLDR. + + Quote non-ASCII literal pattern bytes as explicit hexadecimal regex escapes. + This preserves both byte-string patterns from source files without `use + utf8` and decoded Unicode patterns when the dynamically assembled parser + regex is compiled on the JVM. +match: + distribution: "^MAROS/DateTime-Format-CLDR-" +patches: + - "DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch" diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/LRU-Cache.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/LRU-Cache.yml new file mode 100644 index 000000000..d6dcd6dfc --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/LRU-Cache.yml @@ -0,0 +1,11 @@ +--- +comment: | + PerlOnJava distroprefs for LRU::Cache. + + LRU::Cache 1.00 is XS-only. Replace its loader with a pure-Perl fallback + preserving the public method and function APIs and least-recently-used + ordering semantics. +match: + distribution: "^LNATION/LRU-Cache-" +patches: + - "LRU-Cache-1.00/PurePerl.patch" diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Term-ANSIColor-Markup.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Term-ANSIColor-Markup.yml new file mode 100644 index 000000000..ec24b30d9 --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Term-ANSIColor-Markup.yml @@ -0,0 +1,13 @@ +--- +comment: | + PerlOnJava distroprefs for Term::ANSIColor::Markup. + + The distribution uses lvalue accessors only for two internal assignments, + pulling in the XS-only Want module through Class::Accessor::Lvalue::Fast. + Use ordinary Class::Accessor::Fast accessors and method-style setters instead. + Also declare the Test::Base build dependency omitted by the old + Module::Install metadata. +match: + distribution: "^KENTARO/Term-ANSIColor-Markup-" +patches: + - "Term-ANSIColor-Markup-0.06/PortableAccessors.patch" diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-FailWarnings.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-FailWarnings.yml new file mode 100644 index 000000000..d67e8440a --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-FailWarnings.yml @@ -0,0 +1,12 @@ +--- +comment: | + PerlOnJava distroprefs for Test::FailWarnings. + + warnings::warn is implemented by a Java-backed core module, so warning + handlers see its synthetic Warnings.java dispatch frame before the actual + Perl caller. Teach Test::FailWarnings' source walker to ignore that internal + frame so -allow_from continues to match the originating package. +match: + distribution: "^DAGOLDEN/Test-FailWarnings-" +patches: + - "Test-FailWarnings-0.008/CallerOrigin.patch" diff --git a/src/main/perl/lib/PerlOnJava/CpanPatches/DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch b/src/main/perl/lib/PerlOnJava/CpanPatches/DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch new file mode 100644 index 000000000..58675f4c7 --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanPatches/DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch @@ -0,0 +1,16 @@ +--- lib/DateTime/Format/CLDR.pm ++++ lib/DateTime/Format/CLDR.pm +@@ -957,7 +957,12 @@ + return $quote + if ref($quote) eq 'Regexp'; + +- $quote =~ s/([^[:alnum:][:space:]])/\\$1/g; ++ # Backslashing each byte of an undecoded UTF-8 literal creates invalid ++ # byte sequences between the slashes. Explicit code-point escapes work ++ # for both byte strings and decoded Unicode strings. ++ $quote =~ s/([^[:alnum:][:space:]])/ ++ ord($1) > 127 ? sprintf('\\x{%x}', ord($1)) : "\\$1" ++ /gex; + $quote =~ s/\s+/\\s+/g; + return $quote; + } diff --git a/src/main/perl/lib/PerlOnJava/CpanPatches/LRU-Cache-1.00/PurePerl.patch b/src/main/perl/lib/PerlOnJava/CpanPatches/LRU-Cache-1.00/PurePerl.patch new file mode 100644 index 000000000..5c5ee34a1 --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanPatches/LRU-Cache-1.00/PurePerl.patch @@ -0,0 +1,120 @@ +--- lib/LRU/Cache.pm ++++ lib/LRU/Cache.pm +@@ -2,8 +2,115 @@ + use strict; + use warnings; + our $VERSION = '1.00'; +-require XSLoader; +-XSLoader::load('LRU::Cache', $VERSION); ++ ++my @FUNCTIONS = qw( ++ lru_get lru_set lru_exists lru_peek lru_delete ++ lru_oldest lru_newest ++); ++ ++sub import { ++ my ($class, @requested) = @_; ++ return unless @requested; ++ ++ my $caller = caller; ++ no strict 'refs'; ++ for my $name (@FUNCTIONS) { ++ *{"${caller}::$name"} = \&{$name}; ++ } ++} ++ ++sub new { ++ my ($class, $capacity) = @_; ++ $class = __PACKAGE__ unless defined($class) && $class eq __PACKAGE__; ++ die "capacity must be a positive integer\n" ++ unless defined($capacity) && $capacity =~ /^\d+$/ && $capacity > 0; ++ ++ return bless { ++ capacity => 0 + $capacity, ++ data => {}, ++ order => [], ++ }, $class; ++} ++ ++sub _promote { ++ my ($self, $key) = @_; ++ @{$self->{order}} = ($key, grep { $_ ne $key } @{$self->{order}}); ++} ++ ++sub set { ++ my ($self, $key, $value) = @_; ++ $key = "$key"; ++ $self->{data}{$key} = $value; ++ $self->_promote($key); ++ ++ if (@{$self->{order}} > $self->{capacity}) { ++ my $evicted = pop @{$self->{order}}; ++ delete $self->{data}{$evicted}; ++ } ++ return $value; ++} ++ ++sub get { ++ my ($self, $key) = @_; ++ $key = "$key"; ++ return undef unless exists $self->{data}{$key}; ++ $self->_promote($key); ++ return $self->{data}{$key}; ++} ++ ++sub peek { ++ my ($self, $key) = @_; ++ $key = "$key"; ++ return exists($self->{data}{$key}) ? $self->{data}{$key} : undef; ++} ++ ++sub exists { ++ my ($self, $key) = @_; ++ return CORE::exists $self->{data}{"$key"}; ++} ++ ++sub delete { ++ my ($self, $key) = @_; ++ $key = "$key"; ++ return undef unless exists $self->{data}{$key}; ++ my $value = delete $self->{data}{$key}; ++ @{$self->{order}} = grep { $_ ne $key } @{$self->{order}}; ++ return $value; ++} ++ ++sub size { scalar keys %{$_[0]{data}} } ++sub capacity { $_[0]{capacity} } ++sub keys { @{$_[0]{order}} } ++ ++sub clear { ++ my ($self) = @_; ++ %{$self->{data}} = (); ++ @{$self->{order}} = (); ++ return; ++} ++ ++sub oldest { ++ my ($self) = @_; ++ return () unless @{$self->{order}}; ++ my $key = $self->{order}[-1]; ++ return ($key, $self->{data}{$key}); ++} ++ ++sub newest { ++ my ($self) = @_; ++ return () unless @{$self->{order}}; ++ my $key = $self->{order}[0]; ++ return ($key, $self->{data}{$key}); ++} ++ ++sub lru_set { $_[0]->set($_[1], $_[2]) } ++sub lru_get { $_[0]->get($_[1]) } ++sub lru_exists { $_[0]->exists($_[1]) } ++sub lru_peek { $_[0]->peek($_[1]) } ++sub lru_delete { $_[0]->delete($_[1]) } ++sub lru_oldest { $_[0]->oldest } ++sub lru_newest { $_[0]->newest } ++ + 1; + + __END__ diff --git a/src/main/perl/lib/PerlOnJava/CpanPatches/Term-ANSIColor-Markup-0.06/PortableAccessors.patch b/src/main/perl/lib/PerlOnJava/CpanPatches/Term-ANSIColor-Markup-0.06/PortableAccessors.patch new file mode 100644 index 000000000..e9f70662c --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanPatches/Term-ANSIColor-Markup-0.06/PortableAccessors.patch @@ -0,0 +1,94 @@ +--- Makefile.PL ++++ Makefile.PL +@@ -6,11 +6,12 @@ + license 'MIT'; + all_from 'lib/Term/ANSIColor/Markup.pm'; + +-requires 'Class::Accessor::Lvalue::Fast'; ++requires 'Class::Accessor'; + requires 'HTML::Parser'; + + build_requires 'Test::More'; + build_requires 'Test::Exception'; ++build_requires 'Test::Base'; + use_test_base; + author_tests 'xt'; + auto_include_deps; +--- lib/Term/ANSIColor/Markup.pm ++++ lib/Term/ANSIColor/Markup.pm +@@ -3,7 +3,7 @@ + use strict; + use warnings; + use Term::ANSIColor::Markup::Parser; +-use base qw(Class::Accessor::Lvalue::Fast); ++use base qw(Class::Accessor::Fast); + + our $VERSION = '0.06'; + +@@ -21,7 +21,7 @@ + my ($self, $text) = @_; + $self->parser->parse($text); + $self->parser->eof; +- $self->text = $self->parser->text; ++ $self->text($self->parser->text); + } + + sub colorize { +--- lib/Term/ANSIColor/Markup/Parser.pm ++++ lib/Term/ANSIColor/Markup/Parser.pm +@@ -4,7 +4,7 @@ + use Carp qw(croak); + use base qw( + HTML::Parser +- Class::Accessor::Lvalue::Fast ++ Class::Accessor::Fast + ); + + # copied from Term::ANSIColor +@@ -35,8 +35,8 @@ + sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); +- $self->result = ''; +- $self->stack = []; ++ $self->result(''); ++ $self->stack([]); + $self; + } + +@@ -44,29 +44,29 @@ + my ($self, $tagname, $attr, $attrseq, $text) = @_; + if (my $escape_sequence = $self->get_escape_sequence($tagname)) { + push @{$self->stack}, $tagname; +- $self->result .= $escape_sequence; ++ $self->result($self->result . $escape_sequence); + } + else { +- $self->result .= $text; ++ $self->result($self->result . $text); + } + } + + sub text { + my ($self, $text) = @_; +- $self->result .= $self->unescape($text); ++ $self->result($self->result . $self->unescape($text)); + } + + sub end { + my ($self, $tagname, $text) = @_; + if (my $color = $self->get_escape_sequence($tagname)) { + my $top = pop @{$self->stack}; + croak "Invalid end tag was found: $text" if $top ne $tagname; +- $self->result .= $self->get_escape_sequence('reset'); ++ $self->result($self->result . $self->get_escape_sequence('reset')); + if (scalar @{$self->stack}) { +- $self->result .= $self->get_escape_sequence($self->stack->[-1]); ++ $self->result($self->result . $self->get_escape_sequence($self->stack->[-1])); + } + } + else { +- $self->result .= $text; ++ $self->result($self->result . $text); + } + } diff --git a/src/main/perl/lib/PerlOnJava/CpanPatches/Test-FailWarnings-0.008/CallerOrigin.patch b/src/main/perl/lib/PerlOnJava/CpanPatches/Test-FailWarnings-0.008/CallerOrigin.patch new file mode 100644 index 000000000..1490b7b71 --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanPatches/Test-FailWarnings-0.008/CallerOrigin.patch @@ -0,0 +1,10 @@ +--- lib/Test/FailWarnings.pm ++++ lib/Test/FailWarnings.pm +@@ -62,6 +62,7 @@ + my ( $pkg, $filename, $line ) = caller( $i++ ); + return caller( $i - 2 ) unless defined $pkg; + next if $pkg =~ /^(?:Carp|warnings)/; ++ next if $filename =~ m{(?:^|/)Warnings\.java$}; + return ( $pkg, $filename, $line ); + } + } diff --git a/src/main/perl/lib/Time/localtime.pm b/src/main/perl/lib/Time/localtime.pm new file mode 100644 index 000000000..58ffaa4a7 --- /dev/null +++ b/src/main/perl/lib/Time/localtime.pm @@ -0,0 +1,83 @@ +package Time::localtime 1.04; +use v5.38; + +use parent 'Time::tm'; + +our ( + $tm_sec, $tm_min, $tm_hour, $tm_mday, + $tm_mon, $tm_year, $tm_wday, $tm_yday, + $tm_isdst +); + +use Exporter 'import'; +our @EXPORT = qw(localtime ctime); +our @EXPORT_OK = qw( + $tm_sec $tm_min $tm_hour $tm_mday + $tm_mon $tm_year $tm_wday $tm_yday + $tm_isdst + ); +our %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + +sub populate { + return unless @_; + my $tmob = Time::tm->new(); + @$tmob = ( + $tm_sec, $tm_min, $tm_hour, $tm_mday, + $tm_mon, $tm_year, $tm_wday, $tm_yday, + $tm_isdst ) + = @_; + return $tmob; +} + +sub localtime :prototype(;$) { populate CORE::localtime(@_ ? shift : time) } +sub ctime :prototype(;$) { scalar CORE::localtime(@_ ? shift : time) } + +__END__ + +=head1 NAME + +Time::localtime - by-name interface to Perl's built-in localtime() function + +=head1 SYNOPSIS + + use Time::localtime; + printf "Year is %d\n", localtime->year() + 1900; + + $now = ctime(); + + use Time::localtime; + use File::stat; + $date_string = ctime(stat($file)->mtime); + +=head1 DESCRIPTION + +This module's default exports override the core localtime() function, +replacing it with a version that returns "Time::tm" objects. +This object has methods that return the similarly named structure field +name from the C's tm structure from F; namely sec, min, hour, +mday, mon, year, wday, yday, and isdst. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as +variables named with a preceding C in front their method names. +Thus, C<$tm_obj-Emday()> corresponds to $tm_mday if you import +the fields. + +The ctime() function provides a way of getting at the +scalar sense of the original CORE::localtime() function. + +To access this functionality without the core overrides, +pass the C an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/src/main/perl/lib/Time/tm.pm b/src/main/perl/lib/Time/tm.pm new file mode 100644 index 000000000..4e22f1eb8 --- /dev/null +++ b/src/main/perl/lib/Time/tm.pm @@ -0,0 +1,30 @@ +package Time::tm 1.01; +use v5.38; + +use Class::Struct qw(struct); +struct('Time::tm' => [ + map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst } +]); + +__END__ + +=head1 NAME + +Time::tm - internal object used by Time::gmtime and Time::localtime + +=head1 SYNOPSIS + +Don't use this module directly. + +=head1 DESCRIPTION + +This module is used internally as a base class by Time::localtime And +Time::gmtime functions. It creates a Time::tm struct object which is +addressable just like's C's tm structure from F; namely with sec, +min, hour, mday, mon, year, wday, yday, and isdst. + +This class is an internal interface only. + +=head1 AUTHOR + +Tom Christiansen diff --git a/src/test/resources/unit/compile_warning_handler.t b/src/test/resources/unit/compile_warning_handler.t new file mode 100644 index 000000000..8f38a9a0f --- /dev/null +++ b/src/test/resources/unit/compile_warning_handler.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Test::More; + +our @captured; +BEGIN { + $SIG{__WARN__} = sub { push @captured, @_ }; +} + +use constant AUTOLOAD => 1; +my $sum = 1 + 'not numeric'; +like( + join('', @captured), + qr/isn't numeric in addition/, + 'warning-producing constant arithmetic reaches a compile-time handler', +); + +like( + join('', @captured), + qr/Constant name 'AUTOLOAD' is a Perl keyword/, + 'warnings::warn reaches a compile-time handler', +); + +is($sum, 1, 'non-numeric constant arithmetic retains its value'); +is(AUTOLOAD(), 1, 'keyword-named constant remains installed'); + +done_testing; diff --git a/src/test/resources/unit/cpan_requested_compat.t b/src/test/resources/unit/cpan_requested_compat.t new file mode 100644 index 000000000..02c972325 --- /dev/null +++ b/src/test/resources/unit/cpan_requested_compat.t @@ -0,0 +1,20 @@ +use strict; +use warnings; +use Test::More; + +use I18N::LangTags::List; +use version; + +is( + I18N::LangTags::List::name('en'), + 'English', + 'core I18N language-name table is available', +); + +{ + local $SIG{__WARN__} = sub { }; + my $overflow = version->new('v9223372036854775807'); + is("$overflow", 'v.Inf', 'overflowing dotted version component stringifies as v.Inf'); +} + +done_testing; diff --git a/src/test/resources/unit/time_localtime_core.t b/src/test/resources/unit/time_localtime_core.t new file mode 100644 index 000000000..6e8b7fc4a --- /dev/null +++ b/src/test/resources/unit/time_localtime_core.t @@ -0,0 +1,9 @@ +use strict; +use warnings; +use Test::More; +use Time::localtime; + +my $epoch = localtime(0); +is($epoch->sec, 0, 'Time::localtime exposes named fields'); + +done_testing; diff --git a/src/test/resources/unit/version_overflow_compare.t b/src/test/resources/unit/version_overflow_compare.t new file mode 100644 index 000000000..898e56006 --- /dev/null +++ b/src/test/resources/unit/version_overflow_compare.t @@ -0,0 +1,13 @@ +use strict; +use warnings; +use Test::More; +use version; + +local $SIG{__WARN__} = sub { }; +my $infinity = version->new('v9223372036854775807'); +my $finite = version->new('v999.0.0'); + +is($infinity <=> $infinity, 0, 'v.Inf compares equal to itself'); +ok($infinity > $finite, 'v.Inf compares greater than finite versions'); + +done_testing; From 08015e3631d4a0f46d990571b096d25b3bba45a7 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Tue, 28 Jul 2026 17:16:21 +0200 Subject: [PATCH 2/5] fix: replace CPAN patches with runtime parity Attribute Java-backed module frames to their Perl packages and preserve byte captures in warning-aware concatenation. Retire the obsolete Test::FailWarnings and DateTime::Format::CLDR compatibility artifacts, and correct the LRU fallback constructor for both function and method call forms. Document the runtime-first experiment and retain the Want and bundled LRU prototypes as follow-up work after their integration exposed unrelated global state coupling. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex --- dev/design/cpan-runtime-parity-experiment.md | 179 ++++++++++++++++++ .../runtime/operators/StringOperators.java | 53 +++--- .../runtimetypes/ExceptionFormatter.java | 14 ++ src/main/perl/lib/CPAN/Config.pm | 30 ++- .../CpanDistroprefs/DateTime-Format-CLDR.yml | 12 -- .../CpanDistroprefs/Test-FailWarnings.yml | 12 -- .../ByteSafePatternLiterals.patch | 16 -- .../CpanPatches/LRU-Cache-1.00/PurePerl.patch | 9 +- .../CallerOrigin.patch | 10 - .../unit/native_module_warning_caller.t | 34 ++++ .../unit/regex_byte_replacement_flag.t | 22 +++ 11 files changed, 303 insertions(+), 88 deletions(-) create mode 100644 dev/design/cpan-runtime-parity-experiment.md delete mode 100644 src/main/perl/lib/PerlOnJava/CpanDistroprefs/DateTime-Format-CLDR.yml delete mode 100644 src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-FailWarnings.yml delete mode 100644 src/main/perl/lib/PerlOnJava/CpanPatches/DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch delete mode 100644 src/main/perl/lib/PerlOnJava/CpanPatches/Test-FailWarnings-0.008/CallerOrigin.patch create mode 100644 src/test/resources/unit/native_module_warning_caller.t create mode 100644 src/test/resources/unit/regex_byte_replacement_flag.t diff --git a/dev/design/cpan-runtime-parity-experiment.md b/dev/design/cpan-runtime-parity-experiment.md new file mode 100644 index 000000000..e91d7336c --- /dev/null +++ b/dev/design/cpan-runtime-parity-experiment.md @@ -0,0 +1,179 @@ +# CPAN Runtime Parity Experiment + +## Objective + +Replace distribution-specific CPAN patches with reusable PerlOnJava runtime +semantics wherever the original distribution is expressing valid Perl +behavior. A patch is removed only after the unmodified upstream test suite and +new standard-Perl-validated unit tests pass on both PerlOnJava backends. + +## Current Compatibility Patches + +### Test::FailWarnings + +The removed patch skipped the synthetic `Warnings.java` frame while the module +walked `caller()`. Standard Perl attributes that frame to the `warnings` +package, allowing ordinary caller filters to identify it without knowing about +the Java implementation. + +Runtime target: + +- Java-backed Perl routines must invoke warning handlers with the same visible + caller stack as an ordinary Perl subroutine. +- Direct `warn`, `warnings::warn`, categorized warnings, anonymous handlers, + named handlers, JVM code, and interpreter code must agree. + +Success criterion: + +- Remove `Test-FailWarnings.yml` and `CallerOrigin.patch`. +- Run Test::FailWarnings 0.008 unmodified. + +Outcome: + +- `ExceptionFormatter` now derives the Perl package for Java-backed module + frames from the active `RuntimeCode`. +- The obsolete extracted preference and patch are retired on upgrade. +- The unmodified distribution passes all 8 tests. + +### DateTime::Format::CLDR + +The removed patch converted non-ASCII regex literals to explicit `\x{...}` +escapes. +Standard Perl preserves the byte/UTF-8 distinction while dynamically +constructing and compiling the pattern. + +Runtime target: + +- Regex interpolation must retain whether each pattern fragment is a byte + string or a character string. +- Backslash quoting a byte above `0x7f` must not create an invalid or + semantically different pattern. + +Success criterion: + +- Remove `DateTime-Format-CLDR.yml` and `ByteSafePatternLiterals.patch`. +- Run DateTime::Format::CLDR 1.19 unmodified, including all 13,000+ assertions. + +Outcome: + +- Warning-aware concatenation now preserves byte semantics for proxy operands + such as `$1`, matching the ordinary concatenation path and interpreter. +- The obsolete extracted preference and patch are retired on upgrade. +- The unmodified distribution passes 17 test files and 13,054 assertions. + +### Term::ANSIColor::Markup + +The patch replaces lvalue accessors with ordinary setters because +`Class::Accessor::Lvalue::Fast` depends on the XS-only `Want` module. It also +adds an undeclared `Test::Base` test prerequisite. + +Runtime target: + +- Determine the exact `Want` API and lvalue-subroutine behavior exercised by + Class::Accessor::Lvalue. +- Prefer a reusable native `Want` implementation over modifying the consumer. +- Treat genuinely missing upstream prerequisite metadata separately from + runtime parity. + +Success criterion: + +- Run Class::Accessor::Lvalue and Term::ANSIColor::Markup without changing + their runtime source. +- Retain metadata-only routing only if the upstream test prerequisite cannot + be discovered generically. + +Experiment result: + +- A native Want bridge over PerlOnJava's existing call-context stack was + prototyped and validated against standard Perl. +- Unmodified Class::Accessor::Lvalue::Fast passed 12/12 and unmodified + Term::ANSIColor::Markup passed 11/11 with that bridge. +- The prototype was not shipped in this change because eager or bundled + integration exposed an unrelated readonly-pad weak-reference regression. +- The existing source compatibility patch remains until Want can be integrated + without changing unrelated startup or compilation behavior. + +### LRU::Cache + +The distribution is XS-only. The current patch replaces it with a pure-Perl +implementation. + +Runtime target: + +- Evaluate a built-in native `LRU::Cache` module with the same object and + functional APIs. +- Distinguish normal module availability from the special request to test the + original XS distribution itself. + +Success criterion: + +- Ordinary `use LRU::Cache` needs no distribution source patch. +- Document whether `jcpan -t LRU::Cache` can reasonably bypass the upstream XS + build or must retain explicit compatibility routing. + +Experiment result: + +- XSLoader's bundled-shim fallback can run an unmodified upstream loader, but + packaging the fallback globally was coupled to the same regression observed + during the Want prototype. +- The distribution patch remains the scoped solution. +- The experiment found and fixed its constructor parity bug: both + `LRU::Cache::new($capacity)` and `LRU::Cache->new($capacity)` now work. +- The patched distribution passes 14 test files and 190 assertions. + +## Guardrails + +- Never modify upstream test files. +- Validate every new Perl unit test with standard Perl first. +- Test the JVM and interpreter backends independently. +- Capture all test output in `/tmp`. +- Wrap every `jperl`, `jcpan`, and `prove` invocation in `timeout`. +- Run full `make` before updating the PR. + +## Progress Tracking + +### Current Status: Runtime-first experiment complete (2026-07-28) + +### Completed Phases + +- [x] Baseline compatibility patches established (2026-07-28) + - All seven requested CPAN distributions pass. + - PR #873 passed Ubuntu and Windows CI. +- [x] Phase 1: Differential runtime boundaries (2026-07-28) + - Added standard-Perl-validated caller and byte-replacement unit tests. + - Identified Java-backed caller package attribution and warning-aware + concatenation as the reusable fixes. +- [x] Phase 2: Remove obsolete runtime-workaround patches (2026-07-28) + - Removed Test::FailWarnings caller filtering. + - Removed DateTime::Format::CLDR byte-pattern rewriting. + - Added upgrade cleanup for their extracted YAML and patch files. +- [x] Phase 3: Evaluate remaining source patches (2026-07-28) + - Validated native Want and bundled LRU prototypes. + - Kept them experimental after detecting unrelated global-state coupling. + - Fixed the existing LRU fallback's function-style constructor. + +### Next Steps + +1. Design lazy native-module registration that cannot perturb unrelated + compilation or readonly pad-constant identity. +2. Implement the remaining optree-dependent Want APIs (`BOOL`, `REF`, + `ASSIGN`, `rreturn`, and `lnoreturn`) before advertising full Want parity. +3. Revisit a bundled LRU fallback after native-module isolation is in place. +4. Consider a manifest-based cleanup mechanism for all retired generated CPAN + prefs and patches. + +### Open Questions + +- Should all Java-backed Perl frames use a formal native call-site abstraction + rather than the current active-code package lookup? +- How should optree ownership and native-module loading be isolated from + global readonly literal caches? +- Should bundled replacements satisfy `jcpan -t`, or only ordinary dependency + resolution and module loading? + +## Related Documents and Skills + +- `dev/design/caller_line_number_fix.md` +- `dev/design/utf8_flag_parity.md` +- `dev/design/regex_jruby_joni.md` +- `.agents/skills/debug-perlonjava/SKILL.md` diff --git a/src/main/java/org/perlonjava/runtime/operators/StringOperators.java b/src/main/java/org/perlonjava/runtime/operators/StringOperators.java index da7e7834f..284c35f3d 100644 --- a/src/main/java/org/perlonjava/runtime/operators/StringOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/StringOperators.java @@ -515,41 +515,36 @@ public static RuntimeScalar stringConcatWarnUninitialized(RuntimeScalar runtimeS return stringConcatBytes(aStr, bStr); } + // Match stringConcat(): the UTF-8 flag propagates only from an + // explicitly UTF-8 scalar. Special variables such as $1 are PROXY + // scalars whose toString() delegates to the current capture; treating + // every non-BYTE_STRING proxy as UTF-8 upgraded byte captures during + // s///e replacement evaluation. if (aResolved.type == RuntimeScalarType.STRING || bResolved.type == RuntimeScalarType.STRING) { return new RuntimeScalar(aStr + bStr); } - if (aResolved.type == BYTE_STRING || bResolved.type == BYTE_STRING) { - boolean aIsByte = aResolved.type == BYTE_STRING - || aResolved.type == RuntimeScalarType.UNDEF - || (aStr.isEmpty() && aResolved.type != RuntimeScalarType.STRING); - boolean bIsByte = bResolved.type == BYTE_STRING - || bResolved.type == RuntimeScalarType.UNDEF - || (bStr.isEmpty() && bResolved.type != RuntimeScalarType.STRING); - if (aIsByte && bIsByte) { - boolean safe = true; - for (int i = 0; safe && i < aStr.length(); i++) { - if (aStr.charAt(i) > 255) { - safe = false; - break; - } - } - for (int i = 0; safe && i < bStr.length(); i++) { - if (bStr.charAt(i) > 255) { - safe = false; - break; - } - } - if (safe) { - byte[] aBytes = aStr.getBytes(StandardCharsets.ISO_8859_1); - byte[] bBytes = bStr.getBytes(StandardCharsets.ISO_8859_1); - byte[] out = new byte[aBytes.length + bBytes.length]; - System.arraycopy(aBytes, 0, out, 0, aBytes.length); - System.arraycopy(bBytes, 0, out, aBytes.length, bBytes.length); - return new RuntimeScalar(out); - } + // No operand carries the UTF-8 flag. Preserve byte semantics whenever + // both Java strings can be represented as octets. + boolean safe = true; + for (int i = 0; safe && i < aStr.length(); i++) { + if (aStr.charAt(i) > 255) { + safe = false; } } + for (int i = 0; safe && i < bStr.length(); i++) { + if (bStr.charAt(i) > 255) { + safe = false; + } + } + if (safe) { + byte[] aBytes = aStr.getBytes(StandardCharsets.ISO_8859_1); + byte[] bBytes = bStr.getBytes(StandardCharsets.ISO_8859_1); + byte[] out = new byte[aBytes.length + bBytes.length]; + System.arraycopy(aBytes, 0, out, 0, aBytes.length); + System.arraycopy(bBytes, 0, out, aBytes.length, bBytes.length); + return new RuntimeScalar(out); + } return new RuntimeScalar(aStr + bStr); } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ExceptionFormatter.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ExceptionFormatter.java index 54c08eefc..ecb30f7a6 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ExceptionFormatter.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ExceptionFormatter.java @@ -263,6 +263,20 @@ private static StackTraceResult formatThrowable(Throwable t) { var entry = new ArrayList(); String pkgName = loc.packageName(); + // Java-backed Perl module methods do not have source-mapper + // metadata, so parseStackTraceElement() returns an empty + // package and caller() historically exposed them as main. + // The active RuntimeCode stack is aligned with the Perl + // frames collected here and retains the registered Perl + // package (for example, Warnings.java -> warnings). + if ((pkgName == null || pkgName.isEmpty()) + && element.getClassName().contains("org.perlonjava.runtime.perlmodule")) { + RuntimeCode nativeCode = RuntimeCode.getActiveCodeAt(stackTrace.size()); + if (nativeCode != null && nativeCode.packageName != null + && !nativeCode.packageName.isEmpty()) { + pkgName = nativeCode.packageName; + } + } entry.add(pkgName != null ? pkgName : "main"); entry.add(loc.sourceFileName()); entry.add(String.valueOf(loc.lineNumber())); diff --git a/src/main/perl/lib/CPAN/Config.pm b/src/main/perl/lib/CPAN/Config.pm index 4c7b9b600..e0919a1e3 100644 --- a/src/main/perl/lib/CPAN/Config.pm +++ b/src/main/perl/lib/CPAN/Config.pm @@ -119,10 +119,8 @@ sub _bootstrap_prefs { 'WWW-Suffit.yml' => 'PerlOnJava/CpanDistroprefs/WWW-Suffit.yml', 'WWW-Suffit-UserAgent.yml' => 'PerlOnJava/CpanDistroprefs/WWW-Suffit-UserAgent.yml', 'XML-FromPerl.yml' => 'PerlOnJava/CpanDistroprefs/XML-FromPerl.yml', - 'Test-FailWarnings.yml' => 'PerlOnJava/CpanDistroprefs/Test-FailWarnings.yml', 'Term-ANSIColor-Markup.yml' => 'PerlOnJava/CpanDistroprefs/Term-ANSIColor-Markup.yml', 'LRU-Cache.yml' => 'PerlOnJava/CpanDistroprefs/LRU-Cache.yml', - 'DateTime-Format-CLDR.yml' => 'PerlOnJava/CpanDistroprefs/DateTime-Format-CLDR.yml', ); $pref_install{'OpenAI-API.yml'} = $ENV{PERLONJAVA_OPENAI_LIVE_TESTING} ? 'PerlOnJava/CpanDistroprefs/OpenAI-API.live.yml' @@ -152,6 +150,20 @@ sub _bootstrap_prefs { File::Path::make_path($prefs_dir); } + # Bundled prefs are copied outside the JAR and survive upgrades. Retire + # entries whose compatibility workaround moved into the runtime, but only + # when the on-disk file still carries PerlOnJava's signature so user-owned + # CPAN preferences are never removed. + for my $file (qw( + Test-FailWarnings.yml + DateTime-Format-CLDR.yml + )) { + my $dest = File::Spec->catfile($prefs_dir, $file); + next unless -f $dest; + my $existing = $slurp->($dest); + unlink $dest if defined($existing) && $existing =~ /PerlOnJava/; + } + for my $file (sort keys %pref_install) { my $src_rel = $pref_install{$file}; my $src_path = $find_source->($src_rel); @@ -269,16 +281,22 @@ sub _bootstrap_patches { 'PerlOnJava/CpanPatches/Graph-0.9735/AdjacencyMap.pm.patch' ], [ 'Graph-0.9735/AdjacencyMap-Light.pm.patch', 'PerlOnJava/CpanPatches/Graph-0.9735/AdjacencyMap-Light.pm.patch' ], - [ 'Test-FailWarnings-0.008/CallerOrigin.patch', - 'PerlOnJava/CpanPatches/Test-FailWarnings-0.008/CallerOrigin.patch' ], [ 'Term-ANSIColor-Markup-0.06/PortableAccessors.patch', 'PerlOnJava/CpanPatches/Term-ANSIColor-Markup-0.06/PortableAccessors.patch' ], [ 'LRU-Cache-1.00/PurePerl.patch', 'PerlOnJava/CpanPatches/LRU-Cache-1.00/PurePerl.patch' ], - [ 'DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch', - 'PerlOnJava/CpanPatches/DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch' ], ); + # Like prefs, extracted patch files persist after an upgrade. These paths + # are owned by PerlOnJava and no current distropref references them. + for my $rel ( + 'Test-FailWarnings-0.008/CallerOrigin.patch', + 'DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch', + ) { + my $retired = File::Spec->catfile($patches_dir, $rel); + unlink $retired if -f $retired; + } + my $slurp = sub { my ($path) = @_; open my $fh, '<', $path or return undef; diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/DateTime-Format-CLDR.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/DateTime-Format-CLDR.yml deleted file mode 100644 index 2df6ab145..000000000 --- a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/DateTime-Format-CLDR.yml +++ /dev/null @@ -1,12 +0,0 @@ ---- -comment: | - PerlOnJava distroprefs for DateTime::Format::CLDR. - - Quote non-ASCII literal pattern bytes as explicit hexadecimal regex escapes. - This preserves both byte-string patterns from source files without `use - utf8` and decoded Unicode patterns when the dynamically assembled parser - regex is compiled on the JVM. -match: - distribution: "^MAROS/DateTime-Format-CLDR-" -patches: - - "DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch" diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-FailWarnings.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-FailWarnings.yml deleted file mode 100644 index d67e8440a..000000000 --- a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-FailWarnings.yml +++ /dev/null @@ -1,12 +0,0 @@ ---- -comment: | - PerlOnJava distroprefs for Test::FailWarnings. - - warnings::warn is implemented by a Java-backed core module, so warning - handlers see its synthetic Warnings.java dispatch frame before the actual - Perl caller. Teach Test::FailWarnings' source walker to ignore that internal - frame so -allow_from continues to match the originating package. -match: - distribution: "^DAGOLDEN/Test-FailWarnings-" -patches: - - "Test-FailWarnings-0.008/CallerOrigin.patch" diff --git a/src/main/perl/lib/PerlOnJava/CpanPatches/DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch b/src/main/perl/lib/PerlOnJava/CpanPatches/DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch deleted file mode 100644 index 58675f4c7..000000000 --- a/src/main/perl/lib/PerlOnJava/CpanPatches/DateTime-Format-CLDR-1.19/ByteSafePatternLiterals.patch +++ /dev/null @@ -1,16 +0,0 @@ ---- lib/DateTime/Format/CLDR.pm -+++ lib/DateTime/Format/CLDR.pm -@@ -957,7 +957,12 @@ - return $quote - if ref($quote) eq 'Regexp'; - -- $quote =~ s/([^[:alnum:][:space:]])/\\$1/g; -+ # Backslashing each byte of an undecoded UTF-8 literal creates invalid -+ # byte sequences between the slashes. Explicit code-point escapes work -+ # for both byte strings and decoded Unicode strings. -+ $quote =~ s/([^[:alnum:][:space:]])/ -+ ord($1) > 127 ? sprintf('\\x{%x}', ord($1)) : "\\$1" -+ /gex; - $quote =~ s/\s+/\\s+/g; - return $quote; - } diff --git a/src/main/perl/lib/PerlOnJava/CpanPatches/LRU-Cache-1.00/PurePerl.patch b/src/main/perl/lib/PerlOnJava/CpanPatches/LRU-Cache-1.00/PurePerl.patch index 5c5ee34a1..db27adfd0 100644 --- a/src/main/perl/lib/PerlOnJava/CpanPatches/LRU-Cache-1.00/PurePerl.patch +++ b/src/main/perl/lib/PerlOnJava/CpanPatches/LRU-Cache-1.00/PurePerl.patch @@ -1,6 +1,6 @@ --- lib/LRU/Cache.pm +++ lib/LRU/Cache.pm -@@ -2,8 +2,115 @@ +@@ -2,8 +2,118 @@ use strict; use warnings; our $VERSION = '1.00'; @@ -24,8 +24,11 @@ +} + +sub new { -+ my ($class, $capacity) = @_; -+ $class = __PACKAGE__ unless defined($class) && $class eq __PACKAGE__; ++ my ($invocant, $maybe_capacity) = @_; ++ my ($class, $capacity) = defined($maybe_capacity) ++ ? ($invocant, $maybe_capacity) ++ : (__PACKAGE__, $invocant); ++ + die "capacity must be a positive integer\n" + unless defined($capacity) && $capacity =~ /^\d+$/ && $capacity > 0; + diff --git a/src/main/perl/lib/PerlOnJava/CpanPatches/Test-FailWarnings-0.008/CallerOrigin.patch b/src/main/perl/lib/PerlOnJava/CpanPatches/Test-FailWarnings-0.008/CallerOrigin.patch deleted file mode 100644 index 1490b7b71..000000000 --- a/src/main/perl/lib/PerlOnJava/CpanPatches/Test-FailWarnings-0.008/CallerOrigin.patch +++ /dev/null @@ -1,10 +0,0 @@ ---- lib/Test/FailWarnings.pm -+++ lib/Test/FailWarnings.pm -@@ -62,6 +62,7 @@ - my ( $pkg, $filename, $line ) = caller( $i++ ); - return caller( $i - 2 ) unless defined $pkg; - next if $pkg =~ /^(?:Carp|warnings)/; -+ next if $filename =~ m{(?:^|/)Warnings\.java$}; - return ( $pkg, $filename, $line ); - } - } diff --git a/src/test/resources/unit/native_module_warning_caller.t b/src/test/resources/unit/native_module_warning_caller.t new file mode 100644 index 000000000..c020468da --- /dev/null +++ b/src/test/resources/unit/native_module_warning_caller.t @@ -0,0 +1,34 @@ +use strict; +use warnings; +use Test::More; + +package NativeWarningOrigin; +use warnings::register; + +sub emit_warning { + warnings::warn('native warning origin'); +} + +package main; + +my @source; +{ + local $SIG{__WARN__} = sub { + my $level = 0; + while (1) { + my @caller = caller($level); + $level = $level + 1; + last unless @caller; + next if $caller[0] =~ /^(?:Carp|warnings)$/; + @source = @caller[0, 1, 2]; + last; + } + }; + NativeWarningOrigin::emit_warning(); +} + +is($source[0], 'NativeWarningOrigin', 'warning handler sees the originating Perl package'); +like($source[1], qr/native_module_warning_caller\.t$/, 'warning handler sees the originating Perl file'); +ok($source[2] > 0, 'warning handler sees a real Perl source line'); + +done_testing; diff --git a/src/test/resources/unit/regex_byte_replacement_flag.t b/src/test/resources/unit/regex_byte_replacement_flag.t new file mode 100644 index 000000000..3dc932261 --- /dev/null +++ b/src/test/resources/unit/regex_byte_replacement_flag.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +use Encode qw(is_utf8); +use Test::More tests => 4; + +my $value = "¿≠"; +my @capture_flags; + +$value =~ s/([^[:alnum:][:space:]])/ + do { + push @capture_flags, is_utf8($1) ? 1 : 0; + "\\" . $1; + } +/gex; + +ok(!grep($_, @capture_flags), 'captures from a byte string remain bytes'); +ok(!is_utf8($value), 'code replacement does not upgrade the byte string'); + +my $pattern = qr/^$value$/; +ok(!is_utf8("$pattern"), 'compiled pattern retains byte semantics'); +ok("¿≠" =~ $pattern, 'byte pattern matches the original byte string'); From aed6c847a4c2cc122cfdecc62a8e8618af60338c Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 29 Jul 2026 11:01:47 +0200 Subject: [PATCH 3/5] fix: track ISA mutations for Test::Class parity Mark package ISA arrays as inheritance-sensitive and invalidate MRO caches at their mutation points. Dispatch anonymous CODE attributes in compile-time source order and preserve Perl caller lines through boolean short-circuit compilation on both backends. Remove and retire the Test::Class failure-ignore distropref after the unmodified upstream suite passes. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex --- dev/design/cpan-runtime-parity-experiment.md | 35 +++++++- .../backend/bytecode/BytecodeCompiler.java | 20 ++++- .../bytecode/CompileBinaryOperator.java | 38 ++++++++- .../perlonjava/backend/jvm/Dereference.java | 7 +- .../backend/jvm/EmitLogicalOperator.java | 18 ++++ .../backend/jvm/EmitSubroutine.java | 42 ++++++++-- .../perlonjava/backend/jvm/JavaClassInfo.java | 8 ++ .../analysis/ConstantFoldingVisitor.java | 47 +++++++++++ .../frontend/parser/SubroutineParser.java | 38 ++++++++- .../runtime/mro/InheritanceResolver.java | 19 +++++ .../runtime/perlmodule/Attributes.java | 32 +++++++ .../perlonjava/runtime/perlmodule/Mro.java | 20 +++-- .../runtime/runtimetypes/GlobalVariable.java | 16 +++- .../runtime/runtimetypes/RuntimeArray.java | 26 +++++- src/main/perl/lib/CPAN/Config.pm | 2 +- .../PerlOnJava/CpanDistroprefs/Test-Class.yml | 13 --- .../unit/anonymous_code_attribute_order.t | 25 ++++++ .../resources/unit/mro_get_isarev_updates.t | 83 +++++++++++++++++++ .../source_logical_expression_caller_line.t | 41 +++++++++ 19 files changed, 493 insertions(+), 37 deletions(-) delete mode 100644 src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-Class.yml create mode 100644 src/test/resources/unit/anonymous_code_attribute_order.t create mode 100644 src/test/resources/unit/mro_get_isarev_updates.t create mode 100644 src/test/resources/unit/source_logical_expression_caller_line.t diff --git a/dev/design/cpan-runtime-parity-experiment.md b/dev/design/cpan-runtime-parity-experiment.md index e91d7336c..2a5320c67 100644 --- a/dev/design/cpan-runtime-parity-experiment.md +++ b/dev/design/cpan-runtime-parity-experiment.md @@ -121,6 +121,32 @@ Experiment result: `LRU::Cache::new($capacity)` and `LRU::Cache->new($capacity)` now work. - The patched distribution passes 14 test files and 190 assertions. +### Test::Class + +The removed distropref ignored upstream test failures caused by three runtime +parity gaps: stale reverse inheritance after `@ISA` mutation, anonymous CODE +attributes dispatched after later named-sub attributes, and caller lines on +the right side of multi-line boolean expressions. + +Runtime outcome: + +- Package arrays named `@ISA` are marked as inheritance-sensitive. Structural + mutations increment a monotonic generation and invalidate method/MRO caches; + `mro::get_isarev` rebuilds only when that generation changes. +- Anonymous subs with non-builtin attributes receive a compile-time CODE + placeholder, so `MODIFY_CODE_ATTRIBUTES` runs in Perl source order. Both + backends attach the executable definition to that same CODE reference. +- Calls inside `&&`, `and`, `||`, and `or` report the outer logical + expression's first line through scoped compiler metadata. Constant folding + carries that metadata onto the surviving AST without changing runtime + execution. Defined-or (`//`) retains its distinct RHS-line behavior. +- `mro::get_linear_isa` hides the implicit `UNIVERSAL` fallback and its parents + when introspecting other classes, while preserving explicit introspection of + `UNIVERSAL` itself. +- The signed extracted Test::Class preference is retired on upgrade; user-owned + CPAN preferences are not removed. +- The unmodified Test::Class 0.52 suite passes 57 files and 191 assertions. + ## Guardrails - Never modify upstream test files. @@ -132,7 +158,7 @@ Experiment result: ## Progress Tracking -### Current Status: Runtime-first experiment complete (2026-07-28) +### Current Status: Test::Class runtime parity complete (2026-07-29) ### Completed Phases @@ -151,6 +177,13 @@ Experiment result: - Validated native Want and bundled LRU prototypes. - Kept them experimental after detecting unrelated global-state coupling. - Fixed the existing LRU fallback's function-style constructor. +- [x] Phase 4: Remove the Test::Class failure override (2026-07-29) + - Added mutation-aware `@ISA` generation tracking and reverse-MRO refresh. + - Moved anonymous CODE attribute dispatch to compile-time source order. + - Preserved Perl caller lines across boolean short-circuit compilation. + - Added standard-Perl-validated units for all three behaviors. + - Removed and retired `Test-Class.yml`. + - Verified unmodified Test::Class: 57 files, 191 tests. ### Next Steps diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index e1bd14f6d..6183140cc 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -80,6 +80,9 @@ public class BytecodeCompiler implements Visitor { // Token index tracking for error reporting private final TreeMap pcToTokenIndex = new TreeMap<>(); int currentTokenIndex = -1; // Track current token for error reporting + // Perl attributes calls inside boolean short-circuit expressions to the + // outermost expression's first line. + int callerLineTokenOverride = -1; // Callsite ID counter for /o modifier support (unique across all compilations) private static int nextCallsiteId = 1; // Track last result register for expression chaining @@ -5641,9 +5644,15 @@ private void visitAnonymousSubroutine(SubroutineNode node) { // No closures - just wrap the InterpretedCode RuntimeScalar codeScalar = new RuntimeScalar(subCode); subCode.__SUB__ = codeScalar; // Set __SUB__ for self-reference - // Dispatch MODIFY_CODE_ATTRIBUTES for anonymous subs with non-builtin attributes - if (subCode.attributes != null && !subCode.attributes.isEmpty() + RuntimeScalar compileTimeAttributeCodeRef = + node.getAnnotation("compileTimeAttributeCodeRef") instanceof RuntimeScalar ref + ? ref : null; + if (compileTimeAttributeCodeRef != null) { + codeScalar = Attributes.adoptCompileTimeCodeRef( + codeScalar, compileTimeAttributeCodeRef); + } else if (subCode.attributes != null && !subCode.attributes.isEmpty() && subCode.packageName != null) { + // Legacy fallback for ASTs created outside the parser. Attributes.runtimeDispatchModifyCodeAttributes(subCode.packageName, codeScalar); } int constIdx = addToConstantPool(codeScalar); @@ -5652,6 +5661,13 @@ private void visitAnonymousSubroutine(SubroutineNode node) { emit(constIdx); } else { // Has closures - emit CREATE_CLOSURE + RuntimeScalar compileTimeAttributeCodeRef = + node.getAnnotation("compileTimeAttributeCodeRef") instanceof RuntimeScalar ref + ? ref : null; + if (compileTimeAttributeCodeRef != null + && compileTimeAttributeCodeRef.value instanceof RuntimeCode prototype) { + prototype.isClosurePrototype = true; + } int templateIdx = addToConstantPool(subCode); emit(Opcodes.CREATE_CLOSURE); emitReg(codeReg); diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperator.java b/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperator.java index c34f91e99..72fc76a1d 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperator.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperator.java @@ -9,6 +9,23 @@ public class CompileBinaryOperator { static void visitBinaryOperator(BytecodeCompiler bytecodeCompiler, BinaryOperatorNode node) { + int savedCallerLineOverride = bytecodeCompiler.callerLineTokenOverride; + boolean booleanShortCircuit = node.operator.equals("&&") || node.operator.equals("and") + || node.operator.equals("||") || node.operator.equals("or"); + if (booleanShortCircuit && savedCallerLineOverride <= 0) { + bytecodeCompiler.callerLineTokenOverride = + node.left != null && node.left.getIndex() > 0 + ? node.left.getIndex() - 1 + : node.getIndex(); + } + try { + visitBinaryOperatorBody(bytecodeCompiler, node); + } finally { + bytecodeCompiler.callerLineTokenOverride = savedCallerLineOverride; + } + } + + private static void visitBinaryOperatorBody(BytecodeCompiler bytecodeCompiler, BinaryOperatorNode node) { // Track token index for error reporting bytecodeCompiler.currentTokenIndex = node.getIndex(); @@ -185,7 +202,8 @@ else if (node.right instanceof ListNode) { // Emit CALL_SUB opcode // Use emitWithToken so pcToTokenIndex maps the call instruction to the // coderef's token index (call-site line), not the closing ')' line. - int callSiteToken = node.left.getIndex(); + int callSiteToken = effectiveCallerLineToken( + bytecodeCompiler, node, node.left.getIndex()); if (callSiteToken > 0) { bytecodeCompiler.emitWithToken(Opcodes.CALL_SUB, callSiteToken); } else { @@ -256,7 +274,9 @@ else if (node.right instanceof BinaryOperatorNode rightCall) { // Emit CALL_METHOD. Perl reports ordinary method calls at // the expression start, but literal anon sub/block // arguments report the block/arg line. - int callSiteToken = methodCallerLineCallSiteToken(node, argsNode); + int callSiteToken = effectiveCallerLineToken( + bytecodeCompiler, node, + methodCallerLineCallSiteToken(node, argsNode)); if (callSiteToken > 0) { bytecodeCompiler.emitWithToken(Opcodes.CALL_METHOD, callSiteToken); } else { @@ -420,7 +440,8 @@ else if (node.right instanceof BinaryOperatorNode rightCall) { // Emit CALL_SUB or CALL_SUB_SHARE_ARGS opcode. Perl reports the // expression start for ordinary multi-line calls, but literal anon // sub/block arguments and &-prototype calls report the block/arg line. - int callSiteToken = callerLineCallSiteToken(node); + int callSiteToken = effectiveCallerLineToken( + bytecodeCompiler, node, callerLineCallSiteToken(node)); int rd = CompileBinaryOperatorHelper.compileBinaryOperatorSwitch( bytecodeCompiler, node, rs1, rs2, callSiteToken, shareCallerArgs); @@ -790,6 +811,17 @@ private static int callerLineCallSiteToken(BinaryOperatorNode node) { return expressionStartIndex(node); } + private static int effectiveCallerLineToken( + BytecodeCompiler bytecodeCompiler, Node node, int normalToken) { + Object annotated = node.getAnnotation("callerLineTokenOverride"); + if (annotated instanceof Integer token && token > 0) { + return token; + } + return bytecodeCompiler.callerLineTokenOverride > 0 + ? bytecodeCompiler.callerLineTokenOverride + : normalToken; + } + private static int expressionStartIndex(BinaryOperatorNode node) { if (node.left != null && node.left.getIndex() > 0) { return node.left.getIndex(); diff --git a/src/main/java/org/perlonjava/backend/jvm/Dereference.java b/src/main/java/org/perlonjava/backend/jvm/Dereference.java index afa92bc0d..4cc8b85de 100644 --- a/src/main/java/org/perlonjava/backend/jvm/Dereference.java +++ b/src/main/java/org/perlonjava/backend/jvm/Dereference.java @@ -973,7 +973,12 @@ static void handleArrowOperator(EmitterVisitor emitterVisitor, BinaryOperatorNod int callsiteId = nextMethodCallsiteId++; // Perl reports the method expression start for ordinary multi-line // calls, but literal anon sub/block arguments report the block line. - int callSiteIndex = node.left.getIndex(); + Object annotatedCallerLine = node.getAnnotation("callerLineTokenOverride"); + int callSiteIndex = annotatedCallerLine instanceof Integer token && token > 0 + ? token + : (emitterVisitor.ctx.javaClassInfo.callerLineTokenOverride > 0 + ? emitterVisitor.ctx.javaClassInfo.callerLineTokenOverride + : node.left.getIndex()); if (node.right instanceof BinaryOperatorNode callNode && "(".equals(callNode.operator) && firstMethodArgumentIsLiteralSub(callNode) diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitLogicalOperator.java b/src/main/java/org/perlonjava/backend/jvm/EmitLogicalOperator.java index 9e1086376..83103ff07 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitLogicalOperator.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitLogicalOperator.java @@ -197,6 +197,24 @@ private static Node scalarizeSingleElementSliceLvalue(Node left) { * @param getBoolean The method name to convert the result to a boolean. */ static void emitLogicalOperator(EmitterVisitor emitterVisitor, BinaryOperatorNode node, int compareOpcode, String getBoolean) { + int savedCallerLineOverride = emitterVisitor.ctx.javaClassInfo.callerLineTokenOverride; + if (!"getDefinedBoolean".equals(getBoolean) && savedCallerLineOverride <= 0) { + emitterVisitor.ctx.javaClassInfo.callerLineTokenOverride = + node.left != null && node.left.getIndex() > 0 + // Operand nodes point just after their final token. + // Stepping back keeps a newline-followed literal on + // the literal's line rather than the operator line. + ? node.left.getIndex() - 1 + : node.getIndex(); + } + try { + emitLogicalOperatorBody(emitterVisitor, node, compareOpcode, getBoolean); + } finally { + emitterVisitor.ctx.javaClassInfo.callerLineTokenOverride = savedCallerLineOverride; + } + } + + private static void emitLogicalOperatorBody(EmitterVisitor emitterVisitor, BinaryOperatorNode node, int compareOpcode, String getBoolean) { // Constant folding: if LHS is a compile-time constant, eliminate the branch entirely. // This matches Perl's behavior where e.g. `1 && expr` is folded to `expr` at compile time, // enabling patterns like `my $c = 1 && my $d = 42`. diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java b/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java index 867bf0f80..728a2df68 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java @@ -507,10 +507,37 @@ public static void emitSubroutine(EmitterContext ctx, SubroutineNode node) { "Ljava/util/List;"); } - // Dispatch MODIFY_CODE_ATTRIBUTES for anonymous subs with non-builtin attributes. - // Named subs have their dispatch in SubroutineParser.handleNamedSub at compile time. - // Anonymous subs need runtime dispatch because the code ref only exists at runtime. - if (node.name == null && node.attributes != null && !node.attributes.isEmpty()) { + RuntimeScalar compileTimeAttributeCodeRef = + node.getAnnotation("compileTimeAttributeCodeRef") instanceof RuntimeScalar ref + ? ref : null; + if (compileTimeAttributeCodeRef != null) { + String key = "compile_time_attr_" + + System.identityHashCode(compileTimeAttributeCodeRef); + RuntimeCode.interpretedSubs.put(key, compileTimeAttributeCodeRef); + + // Stack: [compiledRef] + mv.visitFieldInsn(Opcodes.GETSTATIC, + "org/perlonjava/runtime/runtimetypes/RuntimeCode", + "interpretedSubs", + "Ljava/util/HashMap;"); + mv.visitLdcInsn(key); + mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, + "java/util/HashMap", + "get", + "(Ljava/lang/Object;)Ljava/lang/Object;", + false); + mv.visitTypeInsn(Opcodes.CHECKCAST, + "org/perlonjava/runtime/runtimetypes/RuntimeScalar"); + // Stack: [compiledRef, compileTimeRef] + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/perlmodule/Attributes", + "adoptCompileTimeCodeRef", + "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;" + + "Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)" + + "Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", + false); + } else if (node.name == null && node.attributes != null && !node.attributes.isEmpty()) { + // Legacy fallback for ASTs created outside the parser. java.util.Set builtinAttrs = java.util.Set.of("lvalue", "method", "const"); boolean hasNonBuiltin = false; for (String attr : node.attributes) { @@ -815,7 +842,12 @@ static void handleApplyOperator(EmitterVisitor emitterVisitor, BinaryOperatorNod // Set debug line number to the call site. Perl reports the expression // start for ordinary multi-line calls, but literal anon sub/block // arguments and &-prototype calls report the block/arg line. - int callSiteIndex = callerLineCallSiteIndex(node); + Object annotatedCallerLine = node.getAnnotation("callerLineTokenOverride"); + int callSiteIndex = annotatedCallerLine instanceof Integer token && token > 0 + ? token + : (emitterVisitor.ctx.javaClassInfo.callerLineTokenOverride > 0 + ? emitterVisitor.ctx.javaClassInfo.callerLineTokenOverride + : callerLineCallSiteIndex(node)); if (callSiteIndex > 0) { ByteCodeSourceMapper.setDebugInfoLineNumber(emitterVisitor.ctx, callSiteIndex); } diff --git a/src/main/java/org/perlonjava/backend/jvm/JavaClassInfo.java b/src/main/java/org/perlonjava/backend/jvm/JavaClassInfo.java index 55d275440..92d39451c 100644 --- a/src/main/java/org/perlonjava/backend/jvm/JavaClassInfo.java +++ b/src/main/java/org/perlonjava/backend/jvm/JavaClassInfo.java @@ -16,6 +16,14 @@ */ public class JavaClassInfo { + /** + * Outermost boolean short-circuit expression token used for caller(). + * Perl attributes calls anywhere in an &&/and/||/or expression to the + * expression's first line. This state is shared by all context-specific + * emitter visitors for the current generated method. + */ + public int callerLineTokenOverride = -1; + /** * The name of the Java class. */ diff --git a/src/main/java/org/perlonjava/frontend/analysis/ConstantFoldingVisitor.java b/src/main/java/org/perlonjava/frontend/analysis/ConstantFoldingVisitor.java index c60378eee..a7dba9437 100644 --- a/src/main/java/org/perlonjava/frontend/analysis/ConstantFoldingVisitor.java +++ b/src/main/java/org/perlonjava/frontend/analysis/ConstantFoldingVisitor.java @@ -297,6 +297,8 @@ public void visit(BinaryOperatorNode node) { case "&&": case "and": // true && expr → expr; false && expr → false constant if (leftVal.getBoolean()) { + annotateCallerLine( + foldedRight, logicalExpressionStartIndex(node)); result = foldedRight; isConstant = isConstantNode(foldedRight); } else { @@ -314,6 +316,8 @@ public void visit(BinaryOperatorNode node) { result = foldedLeft; isConstant = true; } else { + annotateCallerLine( + foldedRight, logicalExpressionStartIndex(node)); result = foldedRight; isConstant = isConstantNode(foldedRight); } @@ -354,6 +358,49 @@ public void visit(BinaryOperatorNode node) { isConstant = false; } + private static int logicalExpressionStartIndex(BinaryOperatorNode node) { + return node.left != null && node.left.getIndex() > 0 + ? node.left.getIndex() - 1 + : node.getIndex(); + } + + /** + * Constant folding removes the logical node, so carry its caller-line + * metadata onto every surviving descendant that might emit a call. + */ + private static void annotateCallerLine(Node root, int tokenIndex) { + annotateCallerLine( + root, tokenIndex, + java.util.Collections.newSetFromMap(new java.util.IdentityHashMap<>())); + } + + private static void annotateCallerLine( + Node node, int tokenIndex, java.util.Set visited) { + if (node == null || !visited.add(node)) { + return; + } + node.setAnnotation("callerLineTokenOverride", tokenIndex); + for (java.lang.reflect.Field field : node.getClass().getFields()) { + if (java.lang.reflect.Modifier.isStatic(field.getModifiers())) { + continue; + } + try { + Object value = field.get(node); + if (value instanceof Node child) { + annotateCallerLine(child, tokenIndex, visited); + } else if (value instanceof Iterable iterable) { + for (Object item : iterable) { + if (item instanceof Node child) { + annotateCallerLine(child, tokenIndex, visited); + } + } + } + } catch (IllegalAccessException e) { + throw new IllegalStateException("Unable to annotate folded AST", e); + } + } + } + @Override public void visit(OperatorNode node) { if (node.operand == null) { diff --git a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java index 24c4234c6..b2d30d93f 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java @@ -1810,9 +1810,41 @@ private static SubroutineNode handleAnonSub(Parser parser, String subName, Strin // Throw an exception indicating a syntax error. throw new PerlCompilerException(parser.tokenIndex, "Syntax error", parser.ctx.errorUtil); } - // Finally, we return a new 'SubroutineNode' object with the parsed data: the name, prototype, attributes, block, - // `useTryCatch` flag, and token position. - return new SubroutineNode(subName, prototype, attributes, block, false, currentIndex); + // Perl creates anonymous CVs during compilation and dispatches their + // attributes immediately, in source order relative to named subs. Keep + // a compile-time CODE placeholder on the AST; the JVM/interpreter + // compiler attaches the executable body to it later. + SubroutineNode node = + new SubroutineNode(subName, prototype, attributes, block, false, currentIndex); + if (attributes != null && hasNonBuiltinCodeAttribute(attributes)) { + RuntimeCode placeholder = new RuntimeCode(prototype, new ArrayList<>(attributes)); + placeholder.packageName = parser.ctx.symbolTable.getCurrentPackage(); + if (parser.ctx.errorUtil != null) { + var loc = parser.ctx.errorUtil.getSourceLocationAccurate(currentIndex); + placeholder.cvStartFile = loc.fileName(); + placeholder.cvStartLine = loc.lineNumber(); + } + RuntimeScalar codeRef = new RuntimeScalar(placeholder); + placeholder.__SUB__ = codeRef; + callModifyCodeAttributes( + placeholder.packageName, codeRef, attributes, parser, currentIndex); + node.setAnnotation("compileTimeAttributeCodeRef", codeRef); + } + return node; + } + + private static boolean hasNonBuiltinCodeAttribute(List attributes) { + java.util.Set builtinAttrs = + java.util.Set.of("lvalue", "method", "const"); + for (String attr : attributes) { + String name = attr.startsWith("-") ? attr.substring(1) : attr; + int parenIdx = name.indexOf('('); + String baseName = parenIdx >= 0 ? name.substring(0, parenIdx) : name; + if (!builtinAttrs.contains(baseName) && !baseName.equals("prototype")) { + return true; + } + } + return false; } /** diff --git a/src/main/java/org/perlonjava/runtime/mro/InheritanceResolver.java b/src/main/java/org/perlonjava/runtime/mro/InheritanceResolver.java index e9d2bb47c..003c4e594 100644 --- a/src/main/java/org/perlonjava/runtime/mro/InheritanceResolver.java +++ b/src/main/java/org/perlonjava/runtime/mro/InheritanceResolver.java @@ -21,6 +21,9 @@ public class InheritanceResolver { private static final Map overloadContextCache = new HashMap<>(); // Track ISA array states for change detection private static final Map> isaStateCache = new HashMap<>(); + // Monotonic generation for reverse-inheritance consumers such as + // mro::get_isarev(). @ISA arrays notify us at their mutation point. + private static long isaGeneration; public static boolean autoloadEnabled = true; // Default MRO algorithm private static MROAlgorithm currentMRO = MROAlgorithm.DFS; @@ -184,6 +187,22 @@ public static void invalidateCache() { DestroyDispatch.invalidateCache(); } + /** + * Records a mutation to any package's {@code @ISA}. + * + *

Unlike ordinary arrays, {@code @ISA} changes Perl's method lookup + * graph. RuntimeArray marks package arrays ending in {@code ::ISA} and + * calls this hook for every structural mutation. + */ + public static void noteIsaMutation() { + isaGeneration++; + invalidateCache(); + } + + public static long getIsaGeneration() { + return isaGeneration; + } + /** * Drop method-resolution cache entries that depend on a given package sub's * leaf name (stash key {@code My::Pkg::foo} → {@code foo}), including diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Attributes.java b/src/main/java/org/perlonjava/runtime/perlmodule/Attributes.java index 57c105eaa..6d09a3978 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Attributes.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Attributes.java @@ -427,6 +427,38 @@ public static void runtimeDispatchModifyCodeAttributes(String packageName, Runti } } + /** + * Attach a runtime-compiled anonymous sub body to the CODE reference that + * already participated in compile-time attribute dispatch. + */ + public static RuntimeScalar adoptCompileTimeCodeRef( + RuntimeScalar compiledRef, RuntimeScalar compileTimeRef) { + if (compiledRef.type != CODE || compileTimeRef.type != CODE) { + return compiledRef; + } + RuntimeCode compiled = (RuntimeCode) compiledRef.value; + RuntimeCode placeholder = (RuntimeCode) compileTimeRef.value; + placeholder.adoptDefinitionFrom(compiled); + placeholder.__SUB__ = compileTimeRef; + + if (placeholder.codeObject instanceof RuntimeCode nested) { + nested.__SUB__ = compileTimeRef; + } + if (placeholder.codeObject != null) { + try { + var field = placeholder.codeObject.getClass().getDeclaredField("__SUB__"); + field.setAccessible(true); + field.set(placeholder.codeObject, compileTimeRef); + } catch (NoSuchFieldException ignored) { + // Java-backed/native Perl subs do not expose a generated __SUB__ field. + } catch (IllegalAccessException e) { + throw new PerlCompilerException( + "Unable to attach compile-time anonymous sub: " + e.getMessage()); + } + } + return compileTimeRef; + } + /** * Dispatch MODIFY_*_ATTRIBUTES at runtime for {@code my}/{@code state} variables. * diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Mro.java b/src/main/java/org/perlonjava/runtime/perlmodule/Mro.java index b516c2d0d..be774ef07 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Mro.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Mro.java @@ -20,6 +20,7 @@ public class Mro extends PerlModuleBase { // Reverse ISA cache (which classes inherit from a given class) private static final Map> isaRevCache = new HashMap<>(); + private static long isaRevGeneration = -1; /** * Constructor for Mro. @@ -165,9 +166,17 @@ public static RuntimeList get_linear_isa(RuntimeArray args, int ctx) { throw new PerlCompilerException("Invalid mro name: '" + mroType + "'"); } - // Remove UNIVERSAL from the list as per spec linearized = new ArrayList<>(linearized); - linearized.remove("UNIVERSAL"); + // UNIVERSAL and its parents participate in method dispatch, but + // Perl does not expose that implicit fallback through another + // class's mro::get_linear_isa(). Keep it when UNIVERSAL itself is + // the requested class. + if (!className.equals("UNIVERSAL")) { + int universalIndex = linearized.indexOf("UNIVERSAL"); + if (universalIndex >= 0) { + linearized = new ArrayList<>(linearized.subList(0, universalIndex)); + } + } } // Convert to RuntimeArray @@ -273,13 +282,13 @@ public static RuntimeList get_isarev(RuntimeArray args, int ctx) { String className = args.get(0).toString(); - // Build reverse ISA cache if empty - if (isaRevCache.isEmpty()) { + long currentGeneration = InheritanceResolver.getIsaGeneration(); + if (isaRevGeneration != currentGeneration) { buildIsaRevCache(); + isaRevGeneration = currentGeneration; } RuntimeArray result = new RuntimeArray(); - Set inheritors = isaRevCache.getOrDefault(className, new HashSet<>()); // Add all classes that inherit from this one, including indirectly Set allInheritors = new HashSet<>(); @@ -349,6 +358,7 @@ public static RuntimeList is_universal(RuntimeArray args, int ctx) { public static RuntimeList invalidate_all_method_caches(RuntimeArray args, int ctx) { InheritanceResolver.invalidateCache(); isaRevCache.clear(); + isaRevGeneration = -1; // Increment all package generations for (String pkg : new HashSet<>(packageGenerations.keySet())) { diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java index 351b82b4b..8934db500 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java @@ -388,7 +388,7 @@ public static void resetAllGlobals() { SpecialBlock.checkBlocks.elements.clear(); // Method resolution caches can grow across test scripts. - InheritanceResolver.invalidateCache(); + InheritanceResolver.noteIsaMutation(); // Debug/source mapping cache grows with every compilation; clear it between test scripts. ByteCodeSourceMapper.resetAll(); @@ -829,11 +829,15 @@ public static boolean hasGlobalPseudoConstant(String key) { * @return The RuntimeArray representing the global array. */ public static RuntimeArray getGlobalArray(String key) { + boolean isaArray = key.endsWith("::ISA"); if (!stashAliases.isEmpty()) { String resolvedKey = resolveAliasedFqn(key); if (resolvedKey != key) { RuntimeArray resolved = globalArrays.get(resolvedKey); if (resolved != null) { + if (isaArray || resolvedKey.endsWith("::ISA")) { + resolved.markIsaArray(); + } return resolved; } } @@ -875,6 +879,9 @@ public static RuntimeArray getGlobalArray(String key) { } else { markPackageGlobalRoot(var); } + if (isaArray) { + var.markIsaArray(); + } return var; } @@ -902,7 +909,12 @@ public static boolean existsGlobalArray(String key) { */ public static RuntimeArray removeGlobalArray(String key) { RuntimeArray removed = globalArrays.remove(key); - if (removed != null) invalidatePackageRootSnapshot(); + if (removed != null) { + invalidatePackageRootSnapshot(); + if (key.endsWith("::ISA")) { + InheritanceResolver.noteIsaMutation(); + } + } return removed; } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java index 85c370af7..ecc8f9b57 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java @@ -9,6 +9,7 @@ import java.util.Stack; import org.perlonjava.runtime.operators.WarnDie; +import org.perlonjava.runtime.mro.InheritanceResolver; import static org.perlonjava.runtime.runtimetypes.RuntimeScalarCache.*; import static org.perlonjava.runtime.runtimetypes.RuntimeScalarType.TIED_SCALAR; @@ -49,6 +50,9 @@ public class RuntimeArray extends RuntimeBase implements RuntimeScalarReference, public Set ownedAliasElements; // Iterator for traversing the hash elements private Integer eachIteratorIndex; + // Package arrays named @ISA participate in method resolution. All writes + // to their element list must invalidate MRO caches. + private boolean isaArray; // Constructor @@ -92,6 +96,7 @@ private RuntimeArrayElementList(RuntimeArray owner, int initialCapacity) { @Override public boolean add(RuntimeScalar value) { + owner.noteIsaMutation(); owner.notePackageRootMutation(null, value); if (value != null) value.markContainerOwner(owner); owner.markPackageRootedValue(value); @@ -100,6 +105,7 @@ public boolean add(RuntimeScalar value) { @Override public void add(int index, RuntimeScalar element) { + owner.noteIsaMutation(); owner.notePackageRootMutation(null, element); if (element != null) element.markContainerOwner(owner); owner.markPackageRootedValue(element); @@ -108,6 +114,7 @@ public void add(int index, RuntimeScalar element) { @Override public boolean addAll(java.util.Collection c) { + if (!c.isEmpty()) owner.noteIsaMutation(); owner.notePackageRootMutationIf(owner.hasRootEdge(c)); for (RuntimeScalar value : c) { if (value != null) value.markContainerOwner(owner); @@ -118,6 +125,7 @@ public boolean addAll(java.util.Collection c) { @Override public boolean addAll(int index, java.util.Collection c) { + if (!c.isEmpty()) owner.noteIsaMutation(); owner.notePackageRootMutationIf(owner.hasRootEdge(c)); for (RuntimeScalar value : c) { if (value != null) value.markContainerOwner(owner); @@ -129,6 +137,7 @@ public boolean addAll(int index, java.util.Collection c @Override public RuntimeScalar set(int index, RuntimeScalar element) { RuntimeScalar previous = super.get(index); + owner.noteIsaMutation(); owner.notePackageRootMutation(previous, element); if (element != null) element.markContainerOwner(owner); owner.markPackageRootedValue(element); @@ -138,6 +147,7 @@ public RuntimeScalar set(int index, RuntimeScalar element) { @Override public RuntimeScalar remove(int index) { RuntimeScalar previous = super.remove(index); + owner.noteIsaMutation(); owner.notePackageRootMutation(previous, null); return previous; } @@ -146,6 +156,7 @@ public RuntimeScalar remove(int index) { public boolean remove(Object o) { boolean removed = super.remove(o); if (removed && o instanceof RuntimeScalar scalar) { + owner.noteIsaMutation(); owner.notePackageRootMutation(scalar, null); } return removed; @@ -153,11 +164,24 @@ public boolean remove(Object o) { @Override public void clear() { - if (!isEmpty()) owner.notePackageRootClear(this); + if (!isEmpty()) { + owner.noteIsaMutation(); + owner.notePackageRootClear(this); + } super.clear(); } } + public void markIsaArray() { + isaArray = true; + } + + private void noteIsaMutation() { + if (isaArray) { + InheritanceResolver.noteIsaMutation(); + } + } + private static boolean rootEdge(RuntimeScalar value) { return value != null && (value.type & RuntimeScalarType.REFERENCE_BIT) != 0 diff --git a/src/main/perl/lib/CPAN/Config.pm b/src/main/perl/lib/CPAN/Config.pm index e0919a1e3..c5e1a22f7 100644 --- a/src/main/perl/lib/CPAN/Config.pm +++ b/src/main/perl/lib/CPAN/Config.pm @@ -47,7 +47,6 @@ sub _bootstrap_prefs { 'CGI-Widget-Tabs.yml' => 'PerlOnJava/CpanDistroprefs/CGI-Widget-Tabs.yml', 'Devel-Symdump.yml' => 'PerlOnJava/CpanDistroprefs/Devel-Symdump.yml', 'Pod-Parser.yml' => 'PerlOnJava/CpanDistroprefs/Pod-Parser.yml', - 'Test-Class.yml' => 'PerlOnJava/CpanDistroprefs/Test-Class.yml', 'ExtUtils-CBuilder.yml' => 'PerlOnJava/CpanDistroprefs/ExtUtils-CBuilder.yml', 'ExtUtils-ParseXS.yml' => 'PerlOnJava/CpanDistroprefs/ExtUtils-ParseXS.yml', 'Module-Build.yml' => 'PerlOnJava/CpanDistroprefs/Module-Build.yml', @@ -157,6 +156,7 @@ sub _bootstrap_prefs { for my $file (qw( Test-FailWarnings.yml DateTime-Format-CLDR.yml + Test-Class.yml )) { my $dest = File::Spec->catfile($prefs_dir, $file); next unless -f $dest; diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-Class.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-Class.yml deleted file mode 100644 index b2e2036e0..000000000 --- a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Test-Class.yml +++ /dev/null @@ -1,13 +0,0 @@ ---- -comment: | - PerlOnJava distroprefs for Test::Class. - - Test::Class is a pure-Perl test helper used by downstream CPAN test-only - dependencies such as Test::MockTime::HiRes. Its upstream suite exercises - Test::Builder diagnostic formatting and several attribute/CHECK edge cases - that differ under PerlOnJava, while the built module remains usable for the - downstream tests that require it. -match: - distribution: "^SZABGAB/Test-Class-" -test: - commandline: "PERLONJAVA_TEST_IGNORE_FAILURES" diff --git a/src/test/resources/unit/anonymous_code_attribute_order.t b/src/test/resources/unit/anonymous_code_attribute_order.t new file mode 100644 index 000000000..2b49f8615 --- /dev/null +++ b/src/test/resources/unit/anonymous_code_attribute_order.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +{ + package AttributeOrder; + + our @seen; + + sub MODIFY_CODE_ATTRIBUTES { + my ($package, $code, @attributes) = @_; + push @seen, $code; + return (); + } + + our $anonymous = sub : Ordered { 1 }; + sub named : Ordered { 2 } +} + +print "1..2\n"; +print $AttributeOrder::seen[0] == $AttributeOrder::anonymous + ? "ok 1 - anonymous CODE attributes are dispatched at compile time in source order\n" + : "not ok 1 - anonymous CODE attributes are dispatched at compile time in source order\n"; +print $AttributeOrder::seen[1] == \&AttributeOrder::named + ? "ok 2 - following named CODE attribute is dispatched second\n" + : "not ok 2 - following named CODE attribute is dispatched second\n"; diff --git a/src/test/resources/unit/mro_get_isarev_updates.t b/src/test/resources/unit/mro_get_isarev_updates.t new file mode 100644 index 000000000..6ca5074ae --- /dev/null +++ b/src/test/resources/unit/mro_get_isarev_updates.t @@ -0,0 +1,83 @@ +use strict; +use warnings; +use mro; + +my $test = 0; +sub check { + my ($pass, $name) = @_; + ++$test; + print(($pass ? 'ok' : 'not ok'), " $test - $name\n"); +} + +sub check_array { + my ($got, $expected, $name) = @_; + check( + @$got == @$expected + && join("\0", @$got) eq join("\0", @$expected), + $name, + ); +} + +print "1..6\n"; + +{ + package IsarevBase; + our $VERSION = 1; +} + +check_array( + mro::get_isarev('IsarevBase'), + [], + 'initial reverse inheritance lookup is empty', +); + +eval q{ + package IsarevChild; + use base qw(IsarevBase); + 1; +} or die $@; + +check_array( + mro::get_isarev('IsarevBase'), + ['IsarevChild'], + 'reverse inheritance lookup sees a class added after the cache was read', +); + +eval q{ + package IsarevGrandchild; + use parent -norequire, qw(IsarevChild); + 1; +} or die $@; + +check_array( + [sort @{mro::get_isarev('IsarevBase')}], + [qw(IsarevChild IsarevGrandchild)], + 'reverse inheritance lookup includes newly added indirect subclasses', +); + +{ + package IsarevUniversalParent; + sub marker { 1 } + + package IsarevLinearChild; + our @ISA = ('IsarevBase'); +} + +{ + local @UNIVERSAL::ISA = ('IsarevUniversalParent'); + + check_array( + mro::get_linear_isa('IsarevLinearChild'), + [qw(IsarevLinearChild IsarevBase)], + 'implicit UNIVERSAL parents are hidden from another class linearization', + ); + check_array( + mro::get_linear_isa('UNIVERSAL'), + [qw(UNIVERSAL IsarevUniversalParent)], + 'UNIVERSAL exposes its own explicit parents', + ); + check( + IsarevLinearChild->can('marker'), + 'UNIVERSAL parent remains available to method lookup', + ); +} diff --git a/src/test/resources/unit/source_logical_expression_caller_line.t b/src/test/resources/unit/source_logical_expression_caller_line.t new file mode 100644 index 000000000..adf65f094 --- /dev/null +++ b/src/test/resources/unit/source_logical_expression_caller_line.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +my $test = 0; +sub check { + my ($got, $expected, $name) = @_; + ++$test; + print(($got == $expected ? "ok" : "not ok"), " $test - $name\n"); + print("# got $got, expected $expected\n") if $got != $expected; +} + +sub caller_line { + return (caller)[2]; +} + +print "1..5\n"; + +my $or_line; +my $or_start = __LINE__ + 1; +0 + || ($or_line = caller_line()); +check($or_line, $or_start, 'or RHS uses expression start line'); + +my $and_line; +my $and_start = __LINE__ + 1; +1 + && ($and_line = caller_line()); +check($and_line, $and_start, 'and RHS uses expression start line'); + +my ($nested_left, $nested_right, $nested_sum); +my $nested_start = __LINE__ + 1; +0 + || ($nested_sum = ($nested_left = caller_line()) + + ($nested_right = caller_line())); +check($nested_left, $nested_start, 'nested first call uses outer expression start line'); +check($nested_right, $nested_start, 'nested second call uses outer expression start line'); + +my $defined_or_line; +undef + // ($defined_or_line = caller_line()); +check($defined_or_line, __LINE__ - 1, 'defined-or retains its RHS call line'); From 4392a3f024cbfdb366b8757ee29b098513f2333c Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 29 Jul 2026 11:11:13 +0200 Subject: [PATCH 4/5] fix: unwrap parenthesized interpreter lvalues Compile one-element parenthesized increment and decrement operands as their underlying lvalues instead of RuntimeList values. This fixes Test2::Hub's parenthesized hash-count increment and allows Test::More contexts to complete under the interpreter. Restore the MRO parity regression to Test::More and add focused pre/post increment and decrement coverage. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex --- dev/design/cpan-runtime-parity-experiment.md | 8 ++++- .../backend/bytecode/CompileOperator.java | 12 ++++--- .../resources/unit/mro_get_isarev_updates.t | 33 +++++-------------- .../source_parenthesized_increment_lvalue.t | 23 +++++++++++++ 4 files changed, 47 insertions(+), 29 deletions(-) create mode 100644 src/test/resources/unit/source_parenthesized_increment_lvalue.t diff --git a/dev/design/cpan-runtime-parity-experiment.md b/dev/design/cpan-runtime-parity-experiment.md index 2a5320c67..8543f9711 100644 --- a/dev/design/cpan-runtime-parity-experiment.md +++ b/dev/design/cpan-runtime-parity-experiment.md @@ -140,6 +140,10 @@ Runtime outcome: expression's first line through scoped compiler metadata. Constant folding carries that metadata onto the surviving AST without changing runtime execution. Defined-or (`//`) retains its distinct RHS-line behavior. +- The interpreter unwraps one-element parenthesized lvalues before compiling + increment/decrement operations. This fixes Test2::Hub's + `++($self->{+COUNT})` pattern and lets the MRO regression use Test::More on + both backends. - `mro::get_linear_isa` hides the implicit `UNIVERSAL` fallback and its parents when introspecting other classes, while preserving explicit introspection of `UNIVERSAL` itself. @@ -181,7 +185,9 @@ Runtime outcome: - Added mutation-aware `@ISA` generation tracking and reverse-MRO refresh. - Moved anonymous CODE attribute dispatch to compile-time source order. - Preserved Perl caller lines across boolean short-circuit compilation. - - Added standard-Perl-validated units for all three behaviors. + - Fixed interpreter increment/decrement of parenthesized lvalues used by + Test2::Hub. + - Added standard-Perl-validated units for all runtime behaviors. - Removed and retired `Test-Class.yml`. - Verified unmodified Test::Class: 57 files, 191 tests. diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java index 96e5e44bf..eac7b8708 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java @@ -696,12 +696,16 @@ private static void visitFileTestOp(BytecodeCompiler bc, OperatorNode node, Stri private static void visitIncrDecr(BytecodeCompiler bc, OperatorNode node, String op) { boolean isPostfix = op.endsWith("postfix"); boolean isIncrement = op.startsWith("++"); - if (node.operand == null) { + Node operand = node.operand; + while (operand instanceof ListNode list && list.elements.size() == 1) { + operand = list.elements.getFirst(); + } + if (operand == null) { bc.throwCompilerException("Increment/decrement operator requires operand"); return; } - if (node.operand instanceof IdentifierNode) { - String varName = ((IdentifierNode) node.operand).name; + if (operand instanceof IdentifierNode) { + String varName = ((IdentifierNode) operand).name; if (bc.hasVariable(varName)) { int varReg = bc.getVariableRegister(varName); if (isPostfix) { @@ -718,7 +722,7 @@ private static void visitIncrDecr(BytecodeCompiler bc, OperatorNode node, String return; } } - bc.compileNode(node.operand, -1, RuntimeContextType.LVALUE); + bc.compileNode(operand, -1, RuntimeContextType.LVALUE); int operandReg = bc.lastResultReg; if (isPostfix) { int resultReg = bc.allocateRegister(); diff --git a/src/test/resources/unit/mro_get_isarev_updates.t b/src/test/resources/unit/mro_get_isarev_updates.t index 6ca5074ae..c14872d4f 100644 --- a/src/test/resources/unit/mro_get_isarev_updates.t +++ b/src/test/resources/unit/mro_get_isarev_updates.t @@ -1,31 +1,14 @@ use strict; use warnings; +use Test::More; use mro; -my $test = 0; -sub check { - my ($pass, $name) = @_; - ++$test; - print(($pass ? 'ok' : 'not ok'), " $test - $name\n"); -} - -sub check_array { - my ($got, $expected, $name) = @_; - check( - @$got == @$expected - && join("\0", @$got) eq join("\0", @$expected), - $name, - ); -} - -print "1..6\n"; - { package IsarevBase; our $VERSION = 1; } -check_array( +is_deeply( mro::get_isarev('IsarevBase'), [], 'initial reverse inheritance lookup is empty', @@ -37,7 +20,7 @@ eval q{ 1; } or die $@; -check_array( +is_deeply( mro::get_isarev('IsarevBase'), ['IsarevChild'], 'reverse inheritance lookup sees a class added after the cache was read', @@ -49,7 +32,7 @@ eval q{ 1; } or die $@; -check_array( +is_deeply( [sort @{mro::get_isarev('IsarevBase')}], [qw(IsarevChild IsarevGrandchild)], 'reverse inheritance lookup includes newly added indirect subclasses', @@ -66,18 +49,20 @@ check_array( { local @UNIVERSAL::ISA = ('IsarevUniversalParent'); - check_array( + is_deeply( mro::get_linear_isa('IsarevLinearChild'), [qw(IsarevLinearChild IsarevBase)], 'implicit UNIVERSAL parents are hidden from another class linearization', ); - check_array( + is_deeply( mro::get_linear_isa('UNIVERSAL'), [qw(UNIVERSAL IsarevUniversalParent)], 'UNIVERSAL exposes its own explicit parents', ); - check( + ok( IsarevLinearChild->can('marker'), 'UNIVERSAL parent remains available to method lookup', ); } + +done_testing; diff --git a/src/test/resources/unit/source_parenthesized_increment_lvalue.t b/src/test/resources/unit/source_parenthesized_increment_lvalue.t new file mode 100644 index 000000000..1e1f8f065 --- /dev/null +++ b/src/test/resources/unit/source_parenthesized_increment_lvalue.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +my $test = 0; +sub check { + my ($got, $expected, $name) = @_; + ++$test; + my $pass = $got == $expected; + print(($pass ? 'ok' : 'not ok'), " $test - $name\n"); + print("# got $got, expected $expected\n") unless $pass; +} + +print "1..6\n"; + +my $hash = {count => 0}; +check(++($hash->{count}), 1, 'parenthesized hash lvalue pre-increment returns new value'); +check($hash->{count}, 1, 'parenthesized hash lvalue pre-increment updates entry'); +check(($hash->{count})++, 1, 'parenthesized hash lvalue post-increment returns old value'); +check($hash->{count}, 2, 'parenthesized hash lvalue post-increment updates entry'); + +my @array = (4); +check(--($array[0]), 3, 'parenthesized array lvalue pre-decrement returns new value'); +check($array[0], 3, 'parenthesized array lvalue pre-decrement updates element'); From c9f6a59a8178aeee81041fa0bb57f43c2676bfe2 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 29 Jul 2026 12:00:54 +0200 Subject: [PATCH 5/5] fix: defer const attributes until CODE definitions exist Preserve built-in effects applied by custom anonymous CODE attribute handlers and finalize const values only after the executable body and closure captures are available. Add a standard-Perl-validated unit test and document the parity behavior. Generated with [Codex](https://openai.com/codex/) Co-Authored-By: Codex --- dev/design/cpan-runtime-parity-experiment.md | 6 ++ .../backend/bytecode/BytecodeCompiler.java | 1 + .../backend/bytecode/InterpretedCode.java | 2 + .../bytecode/OpcodeHandlerExtended.java | 4 +- .../frontend/parser/SubroutineParser.java | 2 + .../runtime/perlmodule/Attributes.java | 95 ++++++++++++++++--- .../runtime/runtimetypes/RuntimeCode.java | 11 +++ .../unit/source_anonymous_const_attribute.t | 30 ++++++ 8 files changed, 136 insertions(+), 15 deletions(-) create mode 100644 src/test/resources/unit/source_anonymous_const_attribute.t diff --git a/dev/design/cpan-runtime-parity-experiment.md b/dev/design/cpan-runtime-parity-experiment.md index 8543f9711..884b430e9 100644 --- a/dev/design/cpan-runtime-parity-experiment.md +++ b/dev/design/cpan-runtime-parity-experiment.md @@ -136,6 +136,10 @@ Runtime outcome: - Anonymous subs with non-builtin attributes receive a compile-time CODE placeholder, so `MODIFY_CODE_ATTRIBUTES` runs in Perl source order. Both backends attach the executable definition to that same CODE reference. +- Built-in attributes applied by a custom handler to that placeholder are + carried to the executable CODE. In particular, `:const` evaluation is + deferred until the body and any closure captures exist, matching + `op/attrs.t` without warning or source patching. - Calls inside `&&`, `and`, `||`, and `or` report the outer logical expression's first line through scoped compiler metadata. Constant folding carries that metadata onto the surviving AST without changing runtime @@ -187,6 +191,8 @@ Runtime outcome: - Preserved Perl caller lines across boolean short-circuit compilation. - Fixed interpreter increment/decrement of parenthesized lvalues used by Test2::Hub. + - Deferred custom-handler `:const` evaluation until anonymous CODE + definitions and captures are complete, fixing the `op/attrs.t` regression. - Added standard-Perl-validated units for all runtime behaviors. - Removed and retired `Test-Class.yml`. - Verified unmodified Test::Class: 57 files, 191 tests. diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index 6183140cc..ea765f7a0 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -5667,6 +5667,7 @@ private void visitAnonymousSubroutine(SubroutineNode node) { if (compileTimeAttributeCodeRef != null && compileTimeAttributeCodeRef.value instanceof RuntimeCode prototype) { prototype.isClosurePrototype = true; + Attributes.transferCompileTimeAttributes(subCode, prototype); } int templateIdx = addToConstantPool(subCode); emit(Opcodes.CREATE_CLOSURE); diff --git a/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java b/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java index 834fc2f37..f01aac32d 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java +++ b/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java @@ -437,6 +437,8 @@ public InterpretedCode withCapturedVars(RuntimeBase[] capturedVars) { copy.subName = this.subName; copy.packageName = this.packageName; copy.isTryExpressionWrapper = this.isTryExpressionWrapper; + copy.attributesDispatchedAtCompileTime = this.attributesDispatchedAtCompileTime; + copy.deferredConstAttribute = this.deferredConstAttribute; // Preserve compiler-set fields that are not passed through the constructor copy.gotoLabelPcs = this.gotoLabelPcs; copy.usesLocalization = this.usesLocalization; diff --git a/src/main/java/org/perlonjava/backend/bytecode/OpcodeHandlerExtended.java b/src/main/java/org/perlonjava/backend/bytecode/OpcodeHandlerExtended.java index 92901b5b1..8a50f91d5 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/OpcodeHandlerExtended.java +++ b/src/main/java/org/perlonjava/backend/bytecode/OpcodeHandlerExtended.java @@ -973,7 +973,9 @@ public static int executeCreateClosure(int[] bytecode, int pc, RuntimeBase[] reg // Dispatch MODIFY_CODE_ATTRIBUTES for anonymous subs with non-builtin attributes // Pass isClosure=true since CREATE_CLOSURE always creates a closure - if (closureCode.attributes != null && !closureCode.attributes.isEmpty() + if (closureCode.attributesDispatchedAtCompileTime) { + Attributes.finalizeCompileTimeAttributes(closureCode); + } else if (closureCode.attributes != null && !closureCode.attributes.isEmpty() && closureCode.packageName != null) { Attributes.runtimeDispatchModifyCodeAttributes(closureCode.packageName, codeRef, true); } diff --git a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java index b2d30d93f..484aa7a9d 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java @@ -1819,6 +1819,8 @@ private static SubroutineNode handleAnonSub(Parser parser, String subName, Strin if (attributes != null && hasNonBuiltinCodeAttribute(attributes)) { RuntimeCode placeholder = new RuntimeCode(prototype, new ArrayList<>(attributes)); placeholder.packageName = parser.ctx.symbolTable.getCurrentPackage(); + placeholder.definitionPending = true; + placeholder.attributesDispatchedAtCompileTime = true; if (parser.ctx.errorUtil != null) { var loc = parser.ctx.errorUtil.getSourceLocationAccurate(currentIndex); placeholder.cvStartFile = loc.fileName(); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Attributes.java b/src/main/java/org/perlonjava/runtime/perlmodule/Attributes.java index 6d09a3978..c6acbe4e5 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Attributes.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Attributes.java @@ -202,21 +202,15 @@ private static int applyCodeAttribute(RuntimeScalar svref, String attrName, bool } // const: invoke and store result if callable, else warn "useless" if ("const".equals(attrName) && !hadAttr) { + if (code.definitionPending) { + // Perl lets an attribute handler apply :const + // to an anonymous closure prototype before its + // executable body and captures are finalized. + code.deferredConstAttribute = true; + return ATTR_APPLIED; + } if (hasCallableBody) { - // Const folding: call the sub with no args and store the result - // Deep-copy: the result may contain aliases to mutable variables - // (e.g. sub :const { $_ } — the result aliases $_, which may change later) - RuntimeArray emptyArgs = new RuntimeArray(); - RuntimeList result = code.apply(emptyArgs, RuntimeContextType.LIST); - RuntimeList frozen = new RuntimeList(); - for (RuntimeBase elem : result.elements) { - if (elem instanceof RuntimeScalar rs) { - frozen.elements.add(new RuntimeScalar(rs)); - } else { - frozen.elements.add(elem); - } - } - code.constantValue = frozen; + cacheConstantValue(code); return ATTR_APPLIED; } // No callable body — const is useless @@ -438,7 +432,21 @@ public static RuntimeScalar adoptCompileTimeCodeRef( } RuntimeCode compiled = (RuntimeCode) compiledRef.value; RuntimeCode placeholder = (RuntimeCode) compileTimeRef.value; + List compileTimeAttributes = placeholder.attributes == null + ? List.of() : new ArrayList<>(placeholder.attributes); + boolean deferredConst = placeholder.deferredConstAttribute; + if (compiled instanceof org.perlonjava.backend.bytecode.InterpretedCode) { + transferCompileTimeBuiltinAttributes( + compiled, compileTimeAttributes, deferredConst); + compiled.__SUB__ = compileTimeRef; + compileTimeRef.value = compiled; + finalizeCompileTimeAttributes(compiled); + return compileTimeRef; + } placeholder.adoptDefinitionFrom(compiled); + transferCompileTimeBuiltinAttributes( + placeholder, compileTimeAttributes, deferredConst); + finalizeCompileTimeAttributes(placeholder); placeholder.__SUB__ = compileTimeRef; if (placeholder.codeObject instanceof RuntimeCode nested) { @@ -459,6 +467,65 @@ public static RuntimeScalar adoptCompileTimeCodeRef( return compileTimeRef; } + /** + * Transfer built-in effects applied by a compile-time attribute handler to + * an interpreter closure template. Non-built-in source attributes are not + * installed as built-in CV flags. + */ + public static void transferCompileTimeAttributes( + RuntimeCode target, RuntimeCode compileTimePrototype) { + List compileTimeAttributes = compileTimePrototype.attributes == null + ? List.of() : new ArrayList<>(compileTimePrototype.attributes); + transferCompileTimeBuiltinAttributes( + target, compileTimeAttributes, + compileTimePrototype.deferredConstAttribute); + } + + private static void transferCompileTimeBuiltinAttributes( + RuntimeCode target, List compileTimeAttributes, + boolean deferredConst) { + Set builtinAttrs = Set.of("lvalue", "method", "const"); + if (target.attributes == null) { + target.attributes = new ArrayList<>(); + } + target.attributes.removeIf(attr -> builtinAttrs.contains(attr)); + for (String attr : compileTimeAttributes) { + if (builtinAttrs.contains(attr) && !target.attributes.contains(attr)) { + target.attributes.add(attr); + } + } + target.definitionPending = false; + target.attributesDispatchedAtCompileTime = true; + target.deferredConstAttribute = deferredConst; + } + + /** + * Finalize deferred built-in attributes after a closure has captured its + * runtime environment. + */ + public static void finalizeCompileTimeAttributes(RuntimeCode code) { + if (code.deferredConstAttribute) { + code.deferredConstAttribute = false; + cacheConstantValue(code); + } + } + + private static void cacheConstantValue(RuntimeCode code) { + // Deep-copy because a const body may return an alias to a mutable + // variable (for example sub :const { $_ }). + RuntimeArray emptyArgs = new RuntimeArray(); + RuntimeList result = code.apply(emptyArgs, RuntimeContextType.LIST); + RuntimeList frozen = new RuntimeList(); + for (RuntimeBase elem : result.elements) { + if (elem instanceof RuntimeScalar rs) { + frozen.elements.add(new RuntimeScalar(rs)); + } else { + frozen.elements.add(elem); + } + } + code.constantValue = frozen; + } + /** * Dispatch MODIFY_*_ATTRIBUTES at runtime for {@code my}/{@code state} variables. * diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 133c13c7d..25ae31aa7 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -707,6 +707,12 @@ private RuntimeList detachTryExpressionLvalueResult(RuntimeList result, int call // In Perl 5, MODIFY_CODE_ATTRIBUTES receives the closure prototype for closures. // Calling a closure prototype should die with "Closure prototype called". public boolean isClosurePrototype = false; + // Anonymous CODE attributes are dispatched before backend compilation. + // These flags carry built-in effects until the executable definition and + // (for closures) captured environment are available. + public boolean definitionPending = false; + public boolean attributesDispatchedAtCompileTime = false; + public boolean deferredConstAttribute = false; // Flag to indicate this code is a map/grep block - non-local return should propagate through it public boolean isMapGrepBlock = false; // Flag to indicate this code is an eval BLOCK - non-local return should propagate through it @@ -1041,6 +1047,8 @@ public RuntimeCode cloneForClosure() { clone.isDeclared = this.isDeclared; clone.constantValue = this.constantValue; clone.compilerSupplier = this.compilerSupplier; + clone.attributesDispatchedAtCompileTime = this.attributesDispatchedAtCompileTime; + clone.deferredConstAttribute = this.deferredConstAttribute; // isClosurePrototype stays false for the clone (it's callable) return clone; } @@ -1547,6 +1555,9 @@ public void adoptDefinitionFrom(RuntimeCode codeFrom) { this.isBuiltin = codeFrom.isBuiltin; this.isDeclared = codeFrom.isDeclared; this.isClosurePrototype = codeFrom.isClosurePrototype; + this.definitionPending = codeFrom.definitionPending; + this.attributesDispatchedAtCompileTime = codeFrom.attributesDispatchedAtCompileTime; + this.deferredConstAttribute = codeFrom.deferredConstAttribute; this.isMapGrepBlock = codeFrom.isMapGrepBlock; this.isEvalBlock = codeFrom.isEvalBlock; this.explicitlyRenamed = codeFrom.explicitlyRenamed; diff --git a/src/test/resources/unit/source_anonymous_const_attribute.t b/src/test/resources/unit/source_anonymous_const_attribute.t new file mode 100644 index 000000000..bd7a7e1f3 --- /dev/null +++ b/src/test/resources/unit/source_anonymous_const_attribute.t @@ -0,0 +1,30 @@ +use strict; +use warnings; +use attributes (); + +my $test = 0; +sub check { + my ($pass, $name) = @_; + ++$test; + print(($pass ? 'ok' : 'not ok'), " $test - $name\n"); +} + +print "1..4\n"; + +{ + package AnonymousConstAttribute; + sub MODIFY_CODE_ATTRIBUTES { + attributes->import(shift, shift, lc shift) if $_[2]; + return (); + } +} + +my $warning = ''; +local $SIG{__WARN__} = sub { $warning .= shift }; +$_ = 32487; +my $sub = eval 'package AnonymousConstAttribute; +sub : Const { $_ }'; +check($@ eq '', 'custom const attribute compiles'); +check($warning eq '', 'const on pending anonymous definition does not warn'); +check(ref($sub) eq 'CODE', 'custom const attribute returns a coderef'); +undef $_; +check(&$sub == 32487, 'deferred const value is frozen after definition');