diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000000..8c0c9b8b3f --- /dev/null +++ b/.gitattributes @@ -0,0 +1,3 @@ +/dev/unicode/17.0.0/** -text +/src/main/java/org/perlonjava/runtime/regex/PerlUnicodeBlockData.java text eol=lf +/src/main/java/org/perlonjava/runtime/regex/PerlUnicodeNumericValueData.java text eol=lf diff --git a/dev/design/phase36-regex-differential-20260817.md b/dev/design/phase36-regex-differential-20260817.md new file mode 100644 index 0000000000..e4b47f09cc --- /dev/null +++ b/dev/design/phase36-regex-differential-20260817.md @@ -0,0 +1,185 @@ +# Phase 36 Forced-Backend Regex Differential — 2026-08-17 + +## Scope + +This report records the 80-file `perl5_t/t/re` corpus with the temporary Java +and Joni matcher selector on both PerlOnJava execution backends. The corpus +uses the clean pre-PR-1002 binary built from commit `ba85bdc05`; its SHA-256 is: + +```text +04be3d3d52348dbda4de1ff187df5cd9d788a274ab14bbb5170bafe879cd12cf +``` + +The historical comparison is PR 958's captured runner log: + +```text +../PerlOnJava/logs/test_20260815_080000_958.log +``` + +That log contains all 80 regex files and records 50,273/94,771 passing +assertions. Complete logs, runner JSON, and normalized comparison JSON remain +outside Git under `/tmp/phase36-regex-*`. + +PR 1002 merged and PR 1005's package-localization fix was prepared after this +binary was frozen. In particular, PR 1005 closes `pat_advanced.t` tests +922–933. Those changes are intentionally not mixed into this same-commit +matrix; a later verification rerun must use one rebuilt current-master binary +for all four legs. + +## Method + +Each matrix leg inherits one matcher selection and, for interpreter legs, +global interpreter selection. `perl_test_runner.pl` owns a hard timeout and +process group for every `jperl` child. Full output is captured to a log and the +runner writes per-file JSON. The displayed 300-second value is the base limit; +the runner's configured heavy-file overrides raise `pat_psycho*` and other +designated heavy fixtures to 600 seconds. + +```text +JPERL_REGEX_BACKEND=java perl dev/tools/perl_test_runner.pl \ + --timeout 300 --jobs 5 --output /tmp/phase36-regex-java-jvm.json perl5_t/t/re + +JPERL_REGEX_BACKEND=joni perl dev/tools/perl_test_runner.pl \ + --timeout 300 --jobs 5 --output /tmp/phase36-regex-joni-jvm.json perl5_t/t/re + +JPERL_REGEX_BACKEND=java JPERL_INTERPRETER=1 \ + perl dev/tools/perl_test_runner.pl --timeout 300 --jobs 6 \ + --output /tmp/phase36-regex-java-interpreter.json perl5_t/t/re + +JPERL_REGEX_BACKEND=joni JPERL_INTERPRETER=1 \ + perl dev/tools/perl_test_runner.pl --timeout 300 --jobs 6 \ + --output /tmp/phase36-regex-joni-interpreter.json perl5_t/t/re +``` + +The comparison gate now reports execution errors, incomplete files, and +zero-TAP results explicitly. `--expected-files 80 --fail-on-invalid` rejects an +incomplete corpus independently of the existing per-file pass-count regression +gate. + +## Matrix Summary + +| Matcher | Execution backend | Passing / planned | Delta vs PR 958 | Timeouts | Status | +|---|---|---:|---:|---:|---| +| Java | JVM | 49,923 / 94,823 | -350 / +52 | 0 | complete | +| Joni | JVM | 32,479 / 77,612 | -17,794 / -17,159 | 10 | complete | +| Java | interpreter | 50,021 / 94,823 | -252 / +52 | 0 | complete | +| Joni | interpreter | 32,483 / 77,612 | -17,790 / -17,159 | 10 | complete | + +## Complete Java/JVM Comparison + +The forced-Java/JVM leg covered all 80 files. It has four per-file pass-count +regressions against PR 958: + +| File | PR 958 | Candidate | Delta | Initial classification | +|---|---:|---:|---:|---| +| `pat.t` | 1099/1302 | 239/1302 | -860 | shared source-provenance abort | +| `pat_thr.t` | 1099/1302 | 239/1302 | -860 | same direct failure in thread wrapper | +| `reg_mesg.t` | 1692/2525 | 1664/2521 | -28 | diagnostics and plan change | +| `regexp_normal.t` | 2193/2210 | 2175/2210 | -18 | matcher semantics | + +`pat{,_thr}.t` stops immediately after test 239 with: + +```text +Eval-group not allowed at runtime, use re 'eval' +``` + +This is not an optimizer/debug transcript difference or a Java/Joni routing +difference. The forced-Joni leg stops at the same point. The failing literal +uses single-quote regex delimiters, `m'a(?{ ... })b'`; initial reduction shows +that this parse path produces a plain pattern string and loses trusted literal +callback provenance before matcher selection. + +The net aggregate loss masks substantial progress since PR 958. In particular, +`pat_re_eval{,_thr}.t` improves from 0/555 to 423/555 each, +`pat_advanced{,_thr}.t` improves from 1376/1687 to 1511/1687 each, +`reg_eval_scope.t` reaches 49/49, and `rxcode.t` reaches 40/42. + +## Complete Joni/JVM Comparison + +The forced-Joni leg covers all 80 files but falls to 32,479/77,612: 17,794 +fewer passing assertions and 17,159 fewer planned assertions than PR 958. It +contains 27 per-file pass-count regressions, 33 execution issues, and 29 +zero-TAP files. Ten files reach their runner-owned bounds with zero TAP: + +- 300 seconds: `regex_sets_compat.t`, `regexp.t`, `regexp_noamp.t`, + `regexp_notrie.t`, `regexp_qr.t`, `regexp_qr_embed.t`, and + `regexp_trielist.t`. +- 600 seconds: `pat_psycho.t`, `pat_psycho_thr.t`, and + `regexp_qr_embed_thr.t`. + +The cluster is matcher-specific: the same files complete in the forced-Java +leg. Reduction must determine whether each stall occurs during Joni compile or +search before any broad implementation change. + +Completed Joni/JVM files also expose semantic gaps independent of timeout: + +- `pat{,_thr}.t`: 239/1302 each, sharing the matcher-independent literal + callback provenance abort described above. +- `pat_advanced{,_thr}.t`: 1271/1687 each, versus forced Java 1511/1687. +- `reg_mesg.t`: 1364/2486, versus forced Java 1664/2521. +- `reg_posixcc.t`: 2052/2560, versus forced Java 2560/2560. +- `regexp_normal.t`: 2175/2210 on both matcher selections. +- `regexp_unicode_prop.t`: 1039/1110; its thread wrapper is 1040/1110. + +`speed.t` exits incomplete at 1/59 after 451 seconds and `speed_thr.t` exits +incomplete at 1/59 after 301 seconds. These are internal-watchdog/incomplete +results rather than runner timeouts, but still lose 25 passing assertions per +file against PR 958. + +## Complete Java JVM/Interpreter Comparison + +The forced-Java interpreter leg covers all 80 files at 50,021/94,823. It has +the same zero runner timeouts and planned count as forced-Java/JVM, while +gaining 98 passing assertions in aggregate. That aggregate gain is entirely +driven by `alpha_assertions.t` (2188/2320 on JVM and 2293/2320 on interpreter, ++105); four interpreter-specific losses remain: + +| File | JVM | Interpreter | Delta | +|---|---:|---:|---:| +| `reg_eval_scope.t` | 49/49 | 45/49 | -4 | +| `pat_advanced.t` | 1511/1687 | 1510/1687 | -1 | +| `pat_advanced_thr.t` | 1511/1687 | 1510/1687 | -1 | +| `qr.t` | 4/4 | 3/4 | -1 | + +Against PR 958, the interpreter leg has five pass-count regressions: the same +four Java/JVM corpus regressions plus `qr.t` at -1. These execution-backend +differences are shared runtime/compiler parity gaps, not Java-vs-Joni matcher +differences. + +## Complete Joni JVM/Interpreter Comparison + +The forced-Joni interpreter leg covers all 80 files at 32,483/77,612. Its ten +timeouts, 33 execution issues, 29 zero-TAP files, and planned count are +identical to Joni/JVM. It gains four passing assertions in aggregate, again +masking execution-backend differences: + +| File | JVM | Interpreter | Delta | +|---|---:|---:|---:| +| `reg_eval_scope.t` | 49/49 | 45/49 | -4 | +| `qr.t` | 4/4 | 3/4 | -1 | +| `alpha_assertions.t` | 2099/2320 | 2108/2320 | +9 | + +On the interpreter execution backend, selecting Joni instead of Java changes +50,021/94,823 to 32,483/77,612: 17,538 fewer passing and 17,211 fewer planned +assertions, with 29 regressing and three improving files. The loss categories +match the JVM engine differential, so the primary blocker is matcher selection +rather than execution-backend compilation. + +## Classification and Follow-up + +- Source policy: fix the matcher-independent single-quote literal callback + provenance abort after this report PR, with a focused standard-Perl oracle. +- Matcher semantics: separate the shared `regexp_normal.t` loss from + Joni-only `pat_advanced.t` and POSIX/property losses. +- Diagnostics: treat `reg_mesg.t` independently from matching behavior. +- Timeout behavior: reduce the Joni timeout cluster under individual hard + timeouts; do not hide it through Java fallback. +- Optimizer/debug transcript: none of the regressions above are currently + classified as transcript-only exclusions. + +The Phase 1 exit criterion is not met. Joni fails to retain every assertion +that passes under Java, introduces ten matcher-specific timeouts on both +execution backends, and exposes independent semantic and diagnostic losses. +The four relevant pairwise comparisons (Java/Joni within each execution +backend and JVM/interpreter within each matcher selection) are complete and +retained under `/tmp/phase36-compare-*`. diff --git a/dev/design/phase36-regex-parity.md b/dev/design/phase36-regex-parity.md index 654cf51cbe..b0d0e523d7 100644 --- a/dev/design/phase36-regex-parity.md +++ b/dev/design/phase36-regex-parity.md @@ -165,7 +165,18 @@ allocate callback state or callback frames. suite whose regex capability policy is removed. 5. Run warning-free `make`, Joni upstream tests, packaging and license checks, and the thread release matrix. -6. Rebase each focused delivery slice onto current master. Require green Ubuntu +6. Rewrite `dev/implementation/regex.md` to describe the final as-implemented + matcher architecture and ownership boundaries, and update + `docs/design/joni-callout-fork.md` to match the shipped fork API, namespace, + packaging, callback/unwind contract, and Unicode responsibilities. Review + both documents for a clear reader path, consistent terminology, and removal + of superseded proposals or predictions. Audit the remaining regex/Joni + design documents: delete only content that is wholly redundant and retains + no useful rationale; otherwise replace historical implementation plans with + concise summaries that preserve decisions and point to the canonical + implementation and fork documents. Preserve copyright and authorship + notices in every retained or consolidated third-party description. +7. Rebase each focused delivery slice onto current master. Require green Ubuntu and Windows CI before merging and beginning the next slice. Exit criteria: all semantic gates pass, no previously passing file regresses, @@ -222,7 +233,208 @@ compatibility contract. ## Progress Tracking -### Current Status: Joni default; Phase 4 semantic gate complete at 550/555 +### Current Status: Phases 0, 2, and 4 complete; Phases 1 and 3 corpus gates active + +The unified `integration/phase36-regex-parity` branch was assembled on +2026-08-18 from all 35 ready Phase 36 PRs, with one squashed review-unit commit +per PR. Duplicate #1007 ancestry from #1010, duplicate #1008/#1009/#1012 +ancestry from #1016, and temporary integration merge commits were excluded. +The final stacked implementation matches PR #1040 plus the independent #1006, +#1007, and #1010 changes. The exact source head `3e6076a67` passed warning-free +`make` in 6m46s, including direct Joni, packaging, and all five unit shards. +Unified draft PR #1042 is open against `master`; Ubuntu and Windows CI and the +final forced-backend differential remain pending. + +The unified history includes the completed callback/runtime slices, lossless +generated Unicode fixtures, explicit `Is_*` property/value +normalization, fatal Joni syntax diagnostics, native GCB semantics, and the +first 524 lines of retired Java-only preprocessor code. Every source slice has +a warning-free combined `make` checkpoint. PR #1027 adds native sentence +boundaries; PR #1028 adds independently validated alpha assertion aliases and +native word boundaries. PR #1029 integrates corrected global zero-width `/g` +progression and pinned Perl 5.44 Unicode 17.0 Age properties. PR #1030 adds +binary `ASCII_Hex_Digit` values, pinned General_Category sets, and exact native +line boundaries. PR #1031 adds pinned Canonical_Combining_Class sets and valid +empty-property rendering. PR #1032 integrates native numeric escapes through +U+10FFFF; PR #1033 adds pinned Bidi_Class sets; PR #1034 integrates native +vertical-whitespace escapes; PR #1035 adds Decomposition_Type and PR #1036 +adds East_Asian_Width, PR #1037 adds Numeric_Value, and PR #1038 adds +Joining_Group, and PR #1039 adds Block. The current WIP integrates +Script/Script_Extensions; independently validated break-property values, +generic and specialized binary-property data, residual enumerated-property +families, and the first preprocessor dead-state deletion are ready for focused +integration. + +Lexical `use bytes` now compiles non-ASCII substitution patterns with a +single-byte Joni encoding while preserving upgraded, byte-backed, and compiled +`qr//` source provenance. The focused oracle passes 12/12 on system Perl, JVM, +and interpreter, and the exact upstream marker-stage reducer improves from 2/4 +to 4/4 on both execution backends. Generated chunks 05–10 consequently execute +239,843 genuine boundary assertions rather than matching literal UTF-8 marker +text. JVM and interpreter have exact per-file parity at 2,192/239,843 with every +plan complete, exit 0, and no child timeout at the pre-GCB baseline. The runner +classifies zero-pass files as `error`, but their recorded plans, actual counts, +and process exits are complete. + +Native Joni GCB assertions now implement GB1–GB13 and GB999, including Indic +conjunct and emoji-ZWJ context, and `\X` consumes repeated GB9c conjuncts. The +focused 29-assertion oracle passes on system Perl, JVM, and interpreter. +Authoritative chunk 05 improves by 6,324 assertions from 2,192/14,953 to +8,516/14,976 identically on JVM and interpreter: its complete GCB/`\X` section +passes, leaving only the 6,460 sentence-boundary assertions in that chunk. + +Native Joni sentence assertions now implement SB1–SB11 and SB998 with a +reproducibly generated Perl 5.44 Unicode 17.0 `Sentence_Break` table. The +23-assertion focused oracle passes on system Perl, JVM, and interpreter, direct +Joni coverage exercises the same engine path, and authoritative chunk 05 passes +14,976/14,976 identically on JVM and interpreter. This closes all 6,460 +remaining sentence assertions without coupling the Joni fork to ICU or the +PerlOnJava runtime. + +The most recent exact property chunks 01–04 remain 98,092/167,501 on both +execution backends. Native Joni word assertions implement WB1–WB16 and WB999 +from repository-pinned Perl 5.44 Unicode 17.0 Word_Break and +Extended_Pictographic data. The 33-assertion focused oracle passes on system +Perl, JVM, and interpreter, direct Joni exercises the same path, and generated +chunk 10 passes 19,510/19,510 identically on both execution backends. Combined +with the complete boundary chunk 05 and unchanged chunks 06–09, current +generated evidence was 132,578/407,367 before the current property slice. A resource-contended +current-head refresh did not reproduce a complete exact JVM/interpreter pair, +so it does not replace that accepted baseline. + +`Age` now uses exact introduction-version sets and `In`/`Present_In` use +cumulative sets generated from the repository-pinned Perl 5.44 Unicode 17.0 +`DAge.txt`; `Unassigned`/`NA`, colon delimiters, wildcard-value spellings, and +Perl loose version aliases are covered without inheriting the host ICU Unicode +version. The focused oracle passes 14/14 on system Perl, JVM, and interpreter. +Stable chunk 01 validation improves from 30,194 to 30,705 passing assertions +identically on JVM and interpreter, with no numbered regression. This raises +current generated evidence by 511 to 133,089/407,367. + +`General_Category`/`gc`/`Category` assignments now resolve all atomic and +aggregate values from repository-pinned Perl 5.44 Unicode 17.0 data. Short, +long, `Is_`, colon, wildcard, and loose value aliases are generated +reproducibly without the host ICU category table. The focused oracle passes +18/18 on system Perl, JVM, and interpreter; Age remains 14/14 and invalid +property diagnostics remain 39/39. Chunk 01 improves by another 606 assertions +to 31,311/41,843 identically on both execution backends with no numbered +regression, raising property-plus-completed-sentence/word evidence to +133,695/407,367 before line integration. + +Native Joni line assertions now implement Unicode 17 UAX #14 from pinned Perl +5.44 Line_Break, General_Category, East_Asian_Width, and emoji data. The +84-assertion focused oracle passes on both execution backends and chunks 06–09 +pass 205,380/205,380 each on JVM and interpreter. Protected sentence and word +chunks remain exact, making the complete generated boundary corpus +239,866/239,866 and current generated evidence 339,075/407,367. + +`Canonical_Combining_Class`/`ccc` assignments now resolve every pinned Unicode +17 value and alias, including ordered `Not_Reordered` defaults for unassigned +code points and reserved valid values whose sets are empty. Empty properties +render as valid match-none/match-all classes rather than invalid `[]` syntax. +The focused oracle passes 24/24 on system Perl, JVM, and interpreter. Chunk 01 +passes 33,516/41,843 identically on both execution backends: 2,195 CCC +assertions and 10 already-native line preamble assertions improve over the +31,311 baseline with zero numbered regressions. Current generated evidence is +341,280/407,367. + +`Bidi_Class`/`bc` assignments now resolve all 23 values from a complete pinned +Unicode 17 partition. Ordered missing defaults, short/long and loose aliases, +directional controls, noncharacters, and unknown-value rejection are covered. +The focused oracle passes 99/99 on system Perl, JVM, and interpreter; the +combined Unicode/property/boundary smoke is 345/345 per backend. Chunk 01 gains +736 assertions to 34,252/41,843 identically on both execution backends with no +numbered regression, raising current generated evidence to 342,016/407,367. + +Native Joni `\v` now matches Perl's seven vertical-whitespace code points and +`\V` matches their complement, both directly and inside character classes, +without changing non-Perl Joni syntax behavior. The focused oracle passes +92/92 on system Perl, JVM, and interpreter. Unchanged `reg_posixcc.t` improves +from 2,052/2,560 to 2,560/2,560 on both execution backends with zero numbered +regressions, closing its entire 508-assertion Joni gap. + +`Decomposition_Type`/`dt` assignments now resolve all 18 atomic values plus +Perl's composite `Non_Canonical` value from a complete pinned Unicode 17 +partition. Short/long and loose aliases, ordered `None` defaults, the exact +case-sensitive `Is` assignment prefix, and invalid-value rejection are covered. +The focused oracle passes 45/45 on system Perl, JVM, and interpreter. Chunk 01 +gains 640 assertions to 34,892/41,843 identically on both execution backends +with zero numbered regressions, raising current generated evidence to +342,656/407,367. + +`East_Asian_Width`/`ea` assignments now resolve all six values from a complete +pinned Unicode 17 partition, including the ordered CJK `Wide` and general +`Neutral` missing defaults. Short/long and loose aliases are covered, and +surrogate range endpoints render as explicit Joni hex escapes rather than +lossy literal surrogates. The focused oracle passes 31/31 on system Perl, JVM, +and interpreter; protected boundary smoke remains 169/169 per backend. Chunk +01 gains 216 assertions to 35,108/41,843 identically on both execution backends +with zero numbered regressions, raising current generated evidence to +342,872/407,367. + +`Numeric_Value`/`nv` assignments now resolve all 144 exact rational values and +the `NaN` complement from pinned Perl 5.44 Unicode 17 data. Integer, decimal, +exponent, reduced-rational, loose, wildcard, and exact case-sensitive `Is` +forms follow Perl's generated keyword aliases and binary-NV canonicalization, +including four-significant-digit decimal spellings without heuristic tolerance. +The focused oracle passes 50/50 +on system Perl, JVM, and interpreter; protected boundary smoke remains 169/169 +per backend. Chunks 02–03 gain 13,976 assertions with zero numbered regressions +and exact JVM/interpreter success sets, raising current generated evidence to +356,848/407,367. + +`Joining_Group`/`jg` assignments now resolve all 106 values from a complete +pinned Unicode 17 partition. Loose aliases, the ordered `No_Joining_Group` +default, the alternate `Hamza_On_Heh_Goal` wildcard name, canonical and +squeezed wildcard values, exact case-sensitive `Is` policy, and wildcard +diagnostics follow Perl 5.44. The focused oracle passes 49/49 on system Perl, +JVM, and interpreter; protected boundary smoke remains 169/169 per backend. +Chunks 01–04 gain 4,290 assertions with no pass-count regression and exact +JVM/interpreter success sets, raising current generated evidence to +361,138/407,367. + +`Block`/`blk` assignments and `In...`/single-`Is...` shortcuts now resolve all +347 values, including `No_Block`, from a complete pinned Unicode 17 partition. +Official compact aliases, loose forms, `#...#` wildcards, Script and +General_Category/binary precedence, ordered gaps, noncharacters, and exact +compound `Is` policy follow Perl 5.44. The 36-assertion oracle passes standard +Perl; JVM and interpreter pass all 35 Block-specific assertions while retaining +one pre-existing TODO for unresolved deferred `In...` user-property timing. +The two focused precedence reducers pass 12/12 on all runtimes, protected +boundary smoke remains 169/169 per backend, and chunks 01–04 gain 8,324 +assertions with zero numbered regressions and exact backend identity. Current +generated evidence is 369,462/407,367. + +`Script`/`sc` and `Script_Extensions`/`scx` assignments now resolve all 176 +values from pinned Unicode 17 partitions and Script_Extensions overrides. +Explicit `sc` retains strict Script semantics while Perl's bare Script-value +shortcuts use Script_Extensions; the composite `Katakana_Or_Hiragana`/`Hrkt` +pseudo-value is rejected from bare and exact assignments and excluded from +wildcard unions as required by Perl. Loose aliases, `Qaac`/`Qaai`, +wildcards, exact `Is` assignment policy, precedence over Block shortcuts, and +positive or complemented properties inside ordinary character classes are +covered. The 95-assertion oracle passes system Perl, JVM, and interpreter; the +focused precedence, class-negation, and bare-scx reducers pass 7/7, 8/8, and +10/10 respectively on all three runtimes. Protected boundary smoke remains +169/169 per backend. Chunks 01–04 gain 8,140 assertions with zero numbered +regressions and exact JVM/interpreter counts, raising current generated +evidence to 377,602/407,367. + +Joni now accepts Perl's top-level, scoped, combined, and negative inline `p` +syntax as matcher-neutral policy. PerlOnJava publishes that policy while +ordinary and substitution callbacks execute, without misclassifying escaped or +character-class text. The focused 15-assertion oracle passes on system Perl, +JVM, and interpreter, and unchanged `reg_pmod.t` reaches 88/88 on both +execution backends. Regex source scanning also consumes each `\c` operand +before interpolation, so `\c@` cannot be mistaken for `@-`; the focused +4-assertion oracle passes on all three runtimes and unchanged `subst.t` reaches +250/281 on JVM and interpreter. + +The matcher adapter now carries Joni's search start and Perl `\G` position as +independent cursors, including Unicode offset conversion. The focused +12-assertion oracle passes on system Perl, JVM, and interpreter; unchanged +`subst.t` reaches 275/281 on both execution backends with tests 165-188 +restored. The temporary Java backend retains its start-at-`pos` approximation. Executable callback source and literal trailing `/x` comments survive canonical regex-object stringification on both execution backends. Recursive Joni call @@ -250,6 +462,41 @@ one-level failed callback state. The focused `pat_re_eval.t` gate executes all 555 assertions with 550 semantic assertions passing on both execution backends; the remaining five inspect Perl's optimizer/debug transcript. +The last completed forced-backend differential's forced-Java/JVM leg covers all +80 files at +49,923/94,823 versus PR 958's 50,273/94,771. The apparent aggregate regression +is dominated by `pat{,_thr}.t` aborting after test 239 on a runtime eval-group +policy error; that source-policy slice is assigned independently. The completed +forced-Joni/JVM leg is 32,479/77,612, with ten bounded timeout files. Its +largest completed losses against forced Java are `reg_posixcc.t` (-508), +`reg_mesg.t` (-300), both `pat_advanced` variants (-240 each), +`alpha_assertions.t` (-89), and `regex_sets.t` (-84). The completed +forced-Java/interpreter leg covers all 80 files at 50,021/94,823 with no runner +timeouts, 98 more passing assertions than forced-Java/JVM, and an identical +plan. The completed forced-Joni/interpreter leg is 32,483/77,612 with the same +ten timeouts and planned count as Joni/JVM. The final same-binary report is +complete in `dev/design/phase36-regex-differential-20260817.md`; Phase 1's exit +criterion is not met because Joni loses Java-passing assertions and introduces +matcher-specific timeouts on both execution backends. + +The post-PR-#1028 plus `/g` combined forced-Joni refresh executes all 80 files +at 74,603/331,826 on JVM and 74,607/331,826 on interpreter. Four generated +property chunks time out after producing partial TAP and require the narrow +600-second rerun; chunks 05 and 10 are exact while chunks 06–09 expose only the +assigned line-boundary gap. Six regressions versus the preceding Joni result +reduced to two fatal roots. Binary `ASCII_Hex_Digit=True` routing is now closed: +the focused Perl boolean-value oracle passes 16/16 on system Perl, JVM, and +interpreter, and `pat.t` is restored from its zero-TAP abort to the independently +tracked test-239 runtime-eval gate. Native Joni numeric parsing now treats bare +high octal escapes as UTF-8 code points and accepts underscored braced hex and +octal escapes through U+10FFFF. The focused standard-Perl oracle has 14 ordinary +passes plus four explicitly classified TODOs on both execution backends; +`pat_rt_report{,_thr}` advances from 5 executed assertions to 73/72, and +`pat_advanced.t` reaches its later independent `Titlecase` property blocker. +Strict-regex source policy and Perl code points above U+10FFFF remain explicit +frontend/representation debt, so the forced-Java underscore compatibility pass +is retained for now. + ### Completed Phases - [x] Phase 0: Reproducible differential baseline (2026-08-17) @@ -265,17 +512,197 @@ the remaining five inspect Perl's optimizer/debug transcript. - [x] Added the temporary backend selector and made Joni the default. - [x] Routed ordinary matching, substitution, and split through the selected backend without per-operation fallback. - - [ ] Re-run the complete forced-backend matrix and prove the exit criterion. -- [ ] Phase 2: Conditions and backtracking-visible state (in progress) + - [x] Completed the forced-Java/JVM 80-file leg and identified the + `pat{,_thr}.t` test-239 source-policy abort as the leading regression. + - [x] Completed the four-leg forced-backend matrix and published its + classification. The exit criterion is explicitly not met; timeout and + semantic remediation remain Phase 1 work. + - [x] Reduced the forced-Joni zero-pass surface to seven shared causes: + catastrophic backtracking, quadratic matcher reconstruction, absent + generated Unicode fixtures, regex-set preprocessing, unsupported compiler + introspection, regexp-object propagation, and three assertion-level + environment/runtime failures. + - [x] Moved immutable Joni UTF-8 input and offset maps out of the scalar + `/g` hot loop. The focused million-match oracle completes in 1.07 seconds + on JVM and 1.41 seconds on interpreter (PR #1008), with exact map and + supplementary-character capture-boundary coverage. + - [x] Separated Joni's search-start and `\G` cursors for ordinary matching + and substitution, including Unicode subjects and code replacements. The + focused oracle passes 12/12 and unchanged `subst.t` passes 275/281 on JVM + and interpreter. + - [x] Added a provenance-aware single-byte Joni pattern/input path for + non-ASCII substitutions under lexical `use bytes`. Upgraded, byte-backed, + and compiled byte-backed patterns pass 12/12 on all runtimes, and the + generated Unicode marker stage passes 4/4 on JVM and interpreter. + - [x] Closed `/g` same-position retry and capture semantics after a zero-width + first alternative (`0703725c8`, integrated as `402102446`). The focused + oracle passes 23/23, the raw omniholder reducer improves from 7/10 to 10/10 + in all six Java/Joni × JVM/interpreter modes, and DBIx::Simple remains 69/69. + - [x] Reran the combined forced-Joni 80-file corpus on JVM and interpreter, + published the complete file-by-file comparison, and reduced its six actual + regressions to two fatal roots with narrow owners and rerun gates. +- [x] Phase 2: Conditions and backtracking-visible state (2026-08-17) - [x] Implemented executable callback conditions, control verbs including `(*MARK:NAME)`, and callback-visible recursive capture state in Joni. - [x] Closed runtime callback capture ownership at final scope teardown. - [x] Closed failed-path `$^N` and `$+` restoration through recursive callback unwind. -- [ ] Phase 3: Unicode and pattern syntax completion (in progress) + - [x] Added direct active-localization lookup for runtime control variables; + dynamic `PRUNE`, `SKIP`, and `COMMIT` update package `$REGERROR` without + mutating non-localized `$REGERROR`/`$REGMARK` variables on either backend. + - [x] Propagated `PRUNE`, `SKIP`, `COMMIT`, and `THEN` cuts and search-control + requests from nested `(??{...})` matcher programs. A 9-assertion + standard-Perl oracle passes on JVM and interpreter, and `pat_advanced.t` + test 891 now observes 3 callback executions instead of 9. + - [x] Refreshed the package alias stored for a reused `our` symbol when a + later declaration changes package. The focused package oracle passes on + system Perl, JVM, and interpreter, and `pat_advanced.t` tests 922-933 pass + on both execution backends without a regex-adapter workaround. + - [x] Exposed the actual match subject as callback `$_`, the provisional + callout offset through `pos`, and the in-progress match span through `$&` + plus the pre-match and post-match variables. Callback-bearing substitution + recompilation now preserves trusted callout markers. The 24-assertion + upstream `pos inside (?{})` block + passes on system Perl, JVM, and interpreter; `subst_amp.t` remains 13/13 + on both execution backends. + - [x] Removed the obsolete nested `(*ACCEPT)` and callback-`pos` workarounds + from `pat.t.patch` and resynchronized those original Perl 5.44 assertions. + - [x] Verified reference stringification (5/5) and + `${^LAST_SUCCESSFUL_PATTERN}` dynamic scope and reuse (25/25) on system + Perl, JVM, and interpreter; removed both obsolete `pat.t.patch` wrappers + and resynchronized the original assertions. + - [x] Preserved callback-bearing compiled regexes through one- and multi-item + array interpolation, including Perl's deferred dot-overload composition + with surrounding dynamic callbacks. The focused oracle passes 28/28 on + system Perl, JVM, and interpreter. + - [x] Removed the final `pat.t.patch` hunk, deleted the patch and its importer + configuration, and resynchronized the unmodified Perl 5.44 `pat.t`. +- [ ] Phase 3: Unicode and pattern syntax completion (focused gates complete; + generated full-corpus remediation active) - [x] Added Perl escape syntax, Unicode-property resolution, scoped ASCII folds, possessive intervals, and bounded lookbehind support to Joni. - - [ ] Complete the remaining Unicode aliases and diagnostic parity inventory. + - [x] Converted public regex `pos` values between Perl logical-character + offsets and Java matcher offsets for scalar `/g`, `\G`, fast scanners, and + substitution callbacks. The 11-assertion supplementary-character oracle + passes on system Perl, JVM, and interpreter. + - [x] Restricted user-defined property dispatch to Perl's exact `Is`/`In` + naming convention and made unknown-property diagnostics fatal even in + compatibility warning mode. The focused oracle passes 39/39 on system + Perl, JVM, and interpreter; `regexp_unicode_prop.t` gains 15 assertions. + - [x] Matched user-property definition validation, deterministic recursion + chains, callback-death wrapping, and direct package-name policy. + The focused oracle passes 12/12 on system Perl, JVM, and interpreter; + unchanged upstream coverage gains two assertions. + - [x] Preserved deferred user-property package provenance through implicit + Unicode-flag copies and later literal reuse. The focused oracle passes 8/8 + on system Perl, JVM, and interpreter; `regexp_unicode_prop.t` gains nine + assertions to 1,065/1,110 on both execution backends. + - [x] Accepted inline `p` directly in Joni while retaining match-variable + policy in PerlOnJava, including provisional callback state. The focused + oracle passes 15/15 and unchanged `reg_pmod.t` passes 88/88 on JVM and + interpreter. + - [x] Preserved `\c` control operands through regex source interpolation. + The focused oracle passes 4/4 and unchanged `subst.t` gains test 154 on + both execution backends. + - [x] Completed the built-in Unicode aliases exercised by + `regexp_unicode_prop.t` while preserving deferred user-property precedence. + The focused alias oracle passes 16/16 on system Perl, JVM, and interpreter; + unchanged `regexp_unicode_prop.t` passes 1,110/1,110 on both execution + backends. + - [x] Added a lossless, idempotent importer for Perl's generated TestProp + corpus. The focused importer test passes 66/66, two real generations are + byte-identical, system Perl executes 503,197 TAP, and JVM/interpreter both + execute 290,912 TAP with exact semantic parity and no timeout. + - [x] Classified all 115,144 failures newly exposed by the lossless generated + `uniprops*.t` corpus, including the cross-cutting invalid boundary-harness + evidence in chunks 05–10. + - [x] Normalized explicit `Is_*` property/value assignments and the colon + delimiter (PR #1019), gaining exactly 44,944 generated assertions on both + execution backends without changing any plan. + - [x] Rejected 40 invalid Perl inline option/group-name forms in forked Joni + with exact JVM/interpreter `reg_mesg.t` parity, reducing residual Joni-only + acceptance differences from 198 to 158 (`028602adc`). + - [x] Integrated native Python-style named captures and backreferences plus + removal of their frontend conversion (`afbe2bc34`, integrated as + `cc489bee8`). The 20-case oracle passes on both execution backends with exact + malformed/unknown diagnostics. + - [x] Integrated native braced-octal parsing and missing-close/empty + diagnostics plus fatal unterminated braced-hex diagnostics (`55433291a`, + `913e2b583`) with exact JVM/interpreter `reg_mesg.t` parity. + - [x] Integrated native bare high-octal and underscored braced hex/octal + parsing through U+10FFFF (`f849c2ef9`, integrated as `eb907a10b`). The + focused gate has 14 ordinary passes plus four classified TODOs on both + backends and restores `pat_advanced`/`pat_rt_report` startup. + - [x] Integrated native Joni alpha assertion aliases `pla`, `plb`, `nla`, + `nlb`, and `atomic` (`a6255fbff`, integrated as `49d7d9648`). The focused + 25-case oracle passes on both execution backends and the generated alpha + corpus gains 98 passing assertions per backend with zero regressions. + - [x] Fixed byte-mode substitution of upgraded marker regexes so chunks 05–10 + exercise real boundary subjects with exact JVM/interpreter plans. + - [x] Implemented native Joni GCB assertions for GB1–GB13 and GB999 and aligned + `\X` with repeated GB9c Indic conjunct behavior. The focused oracle passes + 29/29 and generated chunk 05 reaches 8,516/14,976 on both execution backends. + - [x] Implemented native Joni sentence assertions for SB1–SB11 and SB998 from + a reproducible Perl 5.44 Unicode 17.0 table. The focused oracle passes 23/23 + and generated chunk 05 passes 14,976/14,976 on both execution backends. + - [x] Implemented native Joni word assertions for WB1–WB16 and WB999 from + reproducible Perl 5.44 Unicode 17.0 Word_Break and Extended_Pictographic + tables. The focused oracle passes 33/33 and generated chunk 10 passes + 19,510/19,510 on both execution backends. + - [x] Generated exact `Age` and cumulative `In`/`Present_In` sets from pinned + Perl 5.44 Unicode 17.0 data, including loose version, wildcard, and + unassigned aliases. The focused oracle passes 14/14 and chunk 01 gains 511 + assertions with no numbered regression. + - [x] Routed Perl boolean values for the built-in `ASCII_Hex_Digit`/`AHex` + property through the frontend set resolver. All eight true/false aliases + pass 16/16 on system Perl, JVM, and interpreter, restoring `pat.t` startup. + - [x] Generated pinned Unicode 17.0 General_Category atomic and aggregate + sets with Perl property/value aliases. The focused oracle passes 18/18 and + chunk 01 gains 606 assertions on both backends with zero regressions. + - [x] Implemented native Joni line assertions from reproducible pinned Unicode + 17.0 data. The focused oracle passes 84/84 and chunks 06–09 pass + 205,380/205,380 on both execution backends while sentence/word stay exact. + - [x] Generated pinned Unicode 17.0 Canonical_Combining_Class sets with loose + aliases, ordered missing defaults, reserved empty values, and valid + empty/full rendering. The focused oracle passes 24/24 and chunk 01 reaches + 33,516/41,843 on both backends with zero numbered regressions. + - [x] Generated and integrated a complete pinned Unicode 17.0 Bidi_Class + partition with loose aliases and ordered missing defaults. The focused + oracle passes 99/99 and chunk 01 gains 736 assertions to 34,252/41,843 on + both backends with zero numbered regressions. + - [x] Generated and integrated a complete pinned Unicode 17.0 + Decomposition_Type partition, including Perl's composite `Non_Canonical` + value and exact `Is` prefix policy. The focused oracle passes 45/45 and + chunk 01 gains 640 assertions to 34,892/41,843 on both backends with zero + numbered regressions. + - [x] Generated and integrated a complete pinned Unicode 17.0 + East_Asian_Width partition with all ordered missing defaults and lossless + surrogate-range rendering. The focused oracle passes 31/31 and chunk 01 + gains 216 assertions to 35,108/41,843 on both backends with zero numbered + regressions. + - [x] Generated and integrated pinned Perl 5.44 Unicode 17.0 Numeric_Value + sets for all 144 rationals plus NaN, including exact rational reduction, + generated decimal keyword aliases, loose forms, and wildcard policy. The + focused oracle passes 50/50; chunks 02–03 gain 13,976 assertions with zero + numbered regressions and exact backend identity. + - [x] Generated and integrated a complete pinned Unicode 17.0 Joining_Group + partition with loose aliases, ordered defaults, alternate wildcard names, + and exact `Is`/wildcard rejection policy. The focused oracle passes 49/49; + chunks 01–04 gain 4,290 assertions with exact backend identity. + - [x] Generated and integrated a complete pinned Unicode 17.0 Block + partition with official aliases, ordered `No_Block` gaps, wildcard policy, + and Script/category/binary precedence. Chunks 01–04 gain 8,324 assertions + with zero numbered regressions and exact backend identity. + - [x] Generated and integrated complete pinned Unicode 17.0 Script and + Script_Extensions sets, including Perl's bare-scx policy, strict explicit + Script assignments, composite-value rejection and wildcard exclusion, + aliases, precedence, and ordinary character-class complements. The focused oracle + passes 95/95; chunks 01–04 gain 8,140 assertions with zero numbered + regressions and exact backend counts. + - [x] Integrated native Perl `\v`/`\V` dispatch inside and outside character + classes (`1eff1db97`, integrated as `6328935cd`). The focused oracle passes + 92/92 and unchanged `reg_posixcc.t` passes 2,560/2,560 on both backends. + - [ ] Close the remaining property failures before marking Phase 3 complete. - [x] Phase 4: Runtime source and diagnostics (2026-08-17; semantic gate complete at 550/555) - [x] Preserved mixed executable-source provenance, nested dynamic callback @@ -286,26 +713,69 @@ the remaining five inspect Perl's optimizer/debug transcript. the final owning regex scope exits (test 307). - [x] Resolved failed-path `$^N`/`$+` tests 85-86 on JVM and interpreter. - [x] Classified tests 444-448 as optimizer/debug-transcript exclusions. + - [x] Decoded byte-backed eval source according to lexical `use utf8`, + including pragmas activated inside the source, while preserving `no utf8` + byte semantics and fatal malformed-UTF-8 diagnostics. The focused oracle + passes 7/7 on system Perl, JVM, interpreter, and the direct JVM eval + compiler. + - [x] Kept Joni syntax/value exceptions fatal for ordinary user-source + compilation while preserving executable-source validation deferral. The + focused oracle passes 7/7 and unchanged forced-Joni `reg_mesg.t` gains 259 + raw passing assertions; 197 parser-acceptance differences remain classified. - [ ] Phase 5: Remove the Java matching backend + - [x] Retired the unreachable top-level `(*PRUNE)` text rewrite after native + Joni control-verb gates passed under default and forced-Java policy + (`5760874e4`; 316 preprocessor lines removed). + - [x] Removed the disabled invalid-brace pass and its exclusive helpers + (`4be6a48e3`; 208 preprocessor lines removed), retaining active Perl/Joni + quantifier diagnostics as explicit focused hard/TODO gates. + - [x] Removed the Java-only terminated-whitespace possessification pass + (`c5343aca2`; 80 preprocessor lines removed) after greedy backtracking and + 20,000-character gates passed default and forced-Java policy on both + execution backends. + - [x] Validated removal of the Java-only terminated lazy-negated-class + possessification pass (`625ea97a2`; 252 preprocessor lines removed) with + leftmost-capture and 20,000-character gates in all four backend modes. + - [x] Retired the Java-only DBIx omniholder alternative reorder + (`18e71a532`; 50 lines removed) after exact substitution and bundled + DBIx::Simple gates passed. The independent raw `/g` 7/10 progression gap is + now closed at 10/10 by the shared matcher-adapter fix above. - [ ] Phase 6: Integration and release ### Next Steps -1. Capture forced-Java and forced-Joni results for the full 80-file direct regex - corpus, compare both against PR 958, and classify any newly exposed gaps. -2. Run the applicable `pat_advanced.t` control-verb and condition sections, - then close Phase 2 if their direct and interpreter results agree. -3. Map each remaining `pat.t.patch` hunk to its semantic blocker. As each blocker - closes, remove its hunk and rerun the targeted importer so validation uses - the original Perl 5.44 assertions. -4. Capture the clean-branch JVM and interpreter 80-file baselines and compare - both to PR 958 with the regression exit gate. -5. Inventory the remaining uncommon Unicode aliases and invalid-property - diagnostics against Perl 5.44's bundled tables, then move the next - matcher-semantic preprocessor slice into Joni. -6. Keep the warning-free whole-unit-suite gate green with Joni as the default; - use explicit Java mode only to classify corpus regressions before Phase 5 - removes the legacy backend and selector. +1. Keep unified draft PR #1042 open until final validation completes. Preserve + its 35 source PR commits and use a merge commit after the forced-backend + differential and Ubuntu/Windows CI pass. +2. Preserve the now-complete native Joni boundary corpus at 239,866/239,866: + sentence chunk 05, line chunks 06–09, and word chunk 10 must remain exact on + JVM and interpreter while property and parser work continues. +3. Integrate the independently generated break-property value slice, then the + generic and specialized binary-property families and residual enumerated + families currently advancing in parallel. + Preserve pinned Perl 5.44 + acceptance and rejection semantics rather than inheriting host ICU breadth. + Keep native `\v`/`\V` exact at 2,560/2,560 in `reg_posixcc.t`. +4. Rerun generated property chunks 01–04 on both backends with the classified + 600-second bound and retain complete TAP/JSON. After the two fatal roots and + native line boundaries integrate, refresh the complete forced-Joni 80-file + corpus and apply the no-regression gate against Phase 0 and PR 958. +5. Audit every `RegexPreprocessor` rule against the final ownership boundary. + Move matcher semantics into Joni, retain only source-policy scanning, delete + Java-only rewrites and compiled-pattern variants, and remove the temporary + Java backend selector after the performance gate passes. +6. Reconcile `docs/reference/feature-matrix.md` with the final corpus; update + `dev/implementation/regex.md` and `docs/design/joni-callout-fork.md` to the + as-implemented architecture and review both for clarity and structure. + Audit redundant regex/Joni documents, deleting only wholly redundant text + and summarizing historically useful rationale with links to the canonical + documents. Replace stale Unicode limitations, add any still-missing regex + features, and link each limitation to a reducer or explicit optimizer/debug + exclusion. +7. Run unchanged CPAN consumers, the direct/thread release matrix, packaging + and license checks, and require green Ubuntu and Windows CI on the unified + PR. Merge it with a merge commit so the focused history remains available + and the complete integration can be reverted with `git revert -m 1`. ### Open Questions and Blockers @@ -314,11 +784,15 @@ the remaining five inspect Perl's optimizer/debug transcript. - Resource-sensitive baselines must wait for unrelated Java builds to finish. - The interpreter does not reliably expose the lexical package through `InterpreterState.currentPackage` while a regex executes. Localized - `$REGMARK`/`$REGERROR` slots are therefore discovered by their active - `GlobalRuntimeScalar` identities; a future regex call-site metadata field can - make nested simultaneous localizations exact without scanning active globals. + `$REGMARK`/`$REGERROR` slots are therefore enumerated from active dynamic + `GlobalRuntimeScalar` bindings rather than inferred from the current package + or scanned from dormant globals. - Shared parser or `eval` failures are fixed in focused slices when they block a regex semantic test, rather than being approximated inside the matcher. +- Starting a forced-Joni global match exactly on a supplementary character + also requires PR #1008's high-surrogate offset-map correction. The public + `pos` conversion is independently complete; add that exact-start assertion + when #1008 integrates. ## Related Documents and Skills diff --git a/dev/import-perl5/README.md b/dev/import-perl5/README.md index f8942caa08..b9309fee68 100644 --- a/dev/import-perl5/README.md +++ b/dev/import-perl5/README.md @@ -37,6 +37,22 @@ perl dev/import-perl5/sync.pl --only File-DosGlob Substring match against each row’s `source:` and `target:` fields. Prefer this after adding a single module so unrelated trees under `src/main/perl/lib/` are not overwritten. Run `perl dev/import-perl5/sync.pl --help` for details. +### Refresh the pinned Unicode generator snapshot + +The six tracked payloads under `dev/unicode/17.0.0/` are ordinary manifest +imports from the pinned `perl5/lib/unicore` checkout. Refresh only that complete +group with its unique target prefix: + +```bash +perl dev/import-perl5/sync.pl --only dev/unicode/17.0.0 +``` + +The command updates `version`, the three alias/block files, and the two +`extracted/` property files. Their repository-authored `README.md` is not an +import target and remains untouched. Review source/target hashes and regenerate +the affected checked-in Java data after intentionally advancing the pinned Perl +or Unicode baseline. + ### Add a New Module ```bash @@ -66,6 +82,8 @@ Main synchronization script that imports files from perl5/ based on config.yaml. **Features:** - Copies individual files or entire directories +- Refreshes the minimal tracked Unicode generator snapshot through explicit manifest rows +- Generates pinned-source test artifacts such as `unicore/TestProp.pl` - Applies patches automatically - Creates necessary directories - Validates sources exist @@ -80,6 +98,34 @@ perl dev/import-perl5/sync.pl --help Protected targets (`protected: true` in YAML) are always excluded from bulk directory rsync using the **full** config list, even when `--only` is used. +#### Generated Unicode property fixture + +The upstream `uniprops01.t` through `uniprops10.t` wrappers load +`perl5_t/lib/unicore/TestProp.pl`. Perl does not commit that file: its build +generates it from `perl5/lib/unicore/mktables` and the pinned Unicode database. +PerlOnJava therefore generates a losslessly split fixture explicitly: + +```bash +perl dev/import-perl5/sync.pl --only TestProp.pl +``` + +Generation runs in a temporary copy of `perl5/lib/unicore`, so it does not +modify the pinned source tree. The importer retains every canonical assertion, +splits the ten existing `TESTCHUNK` sections into ignored `TestProp-01.pl` +through `TestProp-10.pl` files, and installs a small `TestProp.pl` dispatcher. +Each unchanged upstream wrapper consequently parses only its selected section +instead of parsing the complete 12 MB corpus before applying its chunk guard. +Running the dispatcher without `TESTCHUNK` still evaluates all sections in +canonical order. + +The dispatcher embeds the canonical SHA-256 and per-chunk call counts. The +dispatcher and all chunks remain ignored with the rest of `perl5_t/` and are +not included in the JAR or distribution. A clean checkout obtains them by +running the command above (a full unfiltered sync also runs this row). Unrelated +filtered syncs neither generate nor remove them. Missing Unicode inputs or an +incompatible host Perl make the sync fail with an actionable diagnostic rather +than silently leaving the ten wrappers unavailable. + ### add_module.pl Interactive tool to add new modules to the sync configuration. diff --git a/dev/import-perl5/config.yaml b/dev/import-perl5/config.yaml index 6e6cabde7b..86c60e4871 100644 --- a/dev/import-perl5/config.yaml +++ b/dev/import-perl5/config.yaml @@ -3,7 +3,8 @@ # Each entry specifies: # source: Path relative to project root (typically perl5/...) # target: Path relative to project root where file/dir should be copied -# type: 'file' (default) or 'directory' for bulk directory copies +# type: 'file' (default), 'directory' for bulk copies, or a documented +# generated type handled by sync.pl (currently TestProp.pl only) # patch: Optional patch file (relative to dev/import-perl5/patches/) # protected: Optional boolean (true/false) - if true, existing file won't be overwritten # @@ -94,9 +95,39 @@ imports: target: perl5_t/Porting type: directory - # NOTE: perl5_t/lib directory should exist (for opendir tests) but remain empty - # to avoid module loading conflicts. PerlOnJava uses src/main/perl/lib instead. - # The sync.pl script will create an empty perl5_t/lib directory if needed. + # Minimal pinned Unicode 17.0 generator inputs. Keep these as explicit file + # imports so clean checkouts can reproduce the checked-in Java data without + # importing the complete perl5/lib/unicore tree. + - source: perl5/lib/unicore/version + target: dev/unicode/17.0.0/version + type: file + + - source: perl5/lib/unicore/Blocks.txt + target: dev/unicode/17.0.0/Blocks.txt + type: file + + - source: perl5/lib/unicore/PropertyAliases.txt + target: dev/unicode/17.0.0/PropertyAliases.txt + type: file + + - source: perl5/lib/unicore/PropValueAliases.txt + target: dev/unicode/17.0.0/PropValueAliases.txt + type: file + + - source: perl5/lib/unicore/extracted/DDecompositionType.txt + target: dev/unicode/17.0.0/extracted/DDecompositionType.txt + type: file + + - source: perl5/lib/unicore/extracted/DNumValues.txt + target: dev/unicode/17.0.0/extracted/DNumValues.txt + type: file + + # perl5_t/lib otherwise remains empty to avoid module loading conflicts. + # TestProp.pl is generated from the pinned Unicode inputs because upstream + # does not store this build artifact in the perl5 source tree. + - source: perl5/lib/unicore/mktables + target: perl5_t/lib/unicore/TestProp.pl + type: generated_unicode_testprop # Bulk import all core test files from perl5/t/ to perl5_t/t/ # This creates a complete Perl 5 test environment under perl5_t/ @@ -111,7 +142,6 @@ imports: - source: perl5/t/re/pat.t target: perl5_t/t/re/pat.t - patch: pat.t.patch - source: perl5/t/porting/manifest.t target: perl5_t/t/porting/manifest.t diff --git a/dev/import-perl5/patches/pat.t.patch b/dev/import-perl5/patches/pat.t.patch deleted file mode 100644 index 9baeff974e..0000000000 --- a/dev/import-perl5/patches/pat.t.patch +++ /dev/null @@ -1,109 +0,0 @@ ---- perl5/t/re/pat.t 2025-10-13 09:35:44 -+++ t/re/pat.t 2025-10-22 09:57:03 -@@ -714,7 +714,7 @@ - $_ = "aced"; - #12 3 4 5 - /((a?(*ACCEPT)())())()/ -- or die "Failed to match"; -+ or warn "Failed to match"; - is($1,"a",$message . "buffer 1 is defined with expected value"); - is($2,"a",$message . "buffer 2 is defined with expected value"); - ok(!defined($3),$message . "buffer 3 is not defined"); -@@ -723,7 +723,7 @@ - ok(!defined($6),$message . "buffer 6 is not defined"); - $message= 'NO ACCEPT and CLOSE - '; - /((a?())())()/ -- or die "Failed to match"; -+ or warn "Failed to match"; - is($1,"a",$message . "buffer 1 is defined with expected value"); - is($2,"a",$message . "buffer 2 is defined with expected value"); - is($3,"", $message . "buffer 3 is defined with expected value"); -@@ -733,7 +733,7 @@ - #12 3 4 5 - $message = 'ACCEPT and CLOSE - '; - /((a?(*ACCEPT)(c))(e))(d)/ -- or die "Failed to match"; -+ or warn "Failed to match"; - is($1,"a",$message . "buffer 1 is defined with expected value"); - is($2,"a",$message . "buffer 2 is defined with expected value"); - ok(!defined($3),$message . "buffer 3 is not defined"); -@@ -742,7 +742,7 @@ - ok(!defined($6),$message . "buffer 6 is not defined"); - $message= 'NO ACCEPT and CLOSE - '; - /((a?(c))(e))(d)/ -- or die "Failed to match"; -+ or warn "Failed to match"; - is($1,"ace", $message . "buffer 1 is defined with expected value"); - is($2,"ac", $message . "buffer 2 is defined with expected value"); - is($3,"c", $message . "buffer 3 is defined with expected value"); -@@ -897,7 +897,7 @@ - } - - -- { -+ eval { - my $message = 'pos inside (?{ })'; - my $str = 'abcde'; - our ($foo, $bar); -@@ -959,7 +959,7 @@ - "'abcd' 'e|' 'abcde' " . - "'abcde|' 'ab' 'cde' " . - "'abcde|' 'abc' 'de'", $message); -- } -+ } or fail("pos inside (?{ }) - not implemented"); - - { - my $message = '\G anchor checks'; -@@ -1183,11 +1183,11 @@ - sub new {bless []} - - my $message = "Ref stringification"; -- ::ok(do { \my $v} =~ /^SCALAR/, "Scalar ref stringification") or diag($message); -- ::ok(do {\\my $v} =~ /^REF/, "Ref ref stringification") or diag($message); -- ::ok([] =~ /^ARRAY/, "Array ref stringification") or diag($message); -- ::ok({} =~ /^HASH/, "Hash ref stringification") or diag($message); -- ::ok('S' -> new =~ /^Object S/, "Object stringification") or diag($message); -+ ::ok(do { \my $v} =~ /^SCALAR/, "Scalar ref stringification") or ::diag($message); -+ ::ok(do {\\my $v} =~ /^REF/, "Ref ref stringification") or ::diag($message); -+ ::ok([] =~ /^ARRAY/, "Array ref stringification") or ::diag($message); -+ ::ok({} =~ /^HASH/, "Hash ref stringification") or ::diag($message); -+ ::ok('S' -> new =~ /^Object S/, "Object stringification") or ::diag($message); - } - - { -@@ -2461,7 +2461,7 @@ - "GH Issue #18865 'XaaXbbXb' - test optimization"); - } - } -- { -+ eval { - # Test that ${^LAST_SUCCESSFUL_PATTERN} works as expected. - # It should match like the empty pattern does, and it should be dynamic - # in the same was as $1 is dynamic. -@@ -2511,7 +2511,7 @@ - ok($str =~ s/bar//,"matched bar"); - ok($str =~ s/$copy/PQR/, 'replaced $copy with PQR'); - is($str, "PQR", 'final string should be PQR'); -- } -+ } or fail('${^LAST_SUCCESSFUL_PATTERN} - not implemented'); - - - # Various tests for regexes with code blocks interpolated from an -@@ -2521,7 +2521,7 @@ - # "eval"', or would assert fail, or crash, or produce unpredictable - # results. - -- { -+ eval { - local $" = '-'; # separator when interpolating arrays - - my $pat; -@@ -2625,7 +2625,7 @@ - unlike "", $pat, "code in array 16 not 1"; - unlike "XAB-B-=EC", $pat, "code in array 16 not 2"; - -- } -+ } or fail("(??{}) code blocks in arrays - not implemented"); - - { - # github #21661 diff --git a/dev/import-perl5/sync.pl b/dev/import-perl5/sync.pl index c91b7a3785..7e459af9dc 100755 --- a/dev/import-perl5/sync.pl +++ b/dev/import-perl5/sync.pl @@ -16,7 +16,9 @@ use File::Path qw(make_path); use File::Copy qw(copy); use File::Spec; -use Cwd qw(abs_path); +use File::Temp qw(tempdir tempfile); +use Cwd qw(abs_path getcwd); +use Digest::SHA qw(sha256_hex); # Simple YAML parser for our specific needs sub parse_yaml { @@ -140,6 +142,249 @@ sub copy_directory { return 1; } +# Split the canonical generated corpus without dropping or reordering a byte of +# any TESTCHUNK section. The small dispatcher retains the canonical lexical +# helper scope and evals only the selected section. Leading newlines in each +# chunk preserve canonical caller line numbers in TAP diagnostics. +sub split_unicode_testprop { + my ($canonical) = @_; + my @markers; + while ($canonical + =~ /^if \(!\$::TESTCHUNK or \$::TESTCHUNK == (\d+)\) \{\s*$/mg) + { + push @markers, { number => 0 + $1, start => $-[0] }; + } + unless (join(',', map { $_->{number} } @markers) eq join(',', 1 .. 10)) { + die "Generated TestProp.pl has unexpected TESTCHUNK order: " + . (@markers ? join(',', map { $_->{number} } @markers) : '(none)') + . "\n"; + } + + pos($canonical) = $markers[-1]{start}; + my $finished_start; + if ($canonical =~ /^Finished\(\);\s*$/mg) { + $finished_start = $-[0]; + } + die "Generated TestProp.pl is missing Finished() after TESTCHUNK 10\n" + unless defined $finished_start; + + my $preamble = substr($canonical, 0, $markers[0]{start}); + my $finish = substr($canonical, $finished_start); + my @sections; + for my $index (0 .. $#markers) { + my $end = $index == $#markers + ? $finished_start + : $markers[$index + 1]{start}; + my $section = substr($canonical, $markers[$index]{start}, + $end - $markers[$index]{start}); + my $line_offset = substr($canonical, 0, $markers[$index]{start}) + =~ tr/\n//; + my %counts; + $counts{$1}++ while $section + =~ /^\s+(Expect|Error|Test_GCB|Test_SB|Test_LB|Test_WB)\(/mg; + push @sections, { + number => $markers[$index]{number}, + source => $section, + padded => ("\n" x $line_offset) . $section, + line_offset => $line_offset, + counts => \%counts, + }; + } + + my $reconstructed = $preamble . join('', map { $_->{source} } @sections) + . $finish; + die "Internal TestProp.pl split changed canonical content\n" + unless $reconstructed eq $canonical; + + my $canonical_sha = sha256_hex($canonical); + my @manifest = ( + "\n# PerlOnJava lossless TESTCHUNK dispatcher\n", + "# Canonical pinned mktables SHA-256: $canonical_sha\n", + ); + for my $section (@sections) { + my @counts = map { "$_=$section->{counts}{$_}" } + sort keys %{$section->{counts}}; + push @manifest, "# TESTCHUNK $section->{number}: " + . join(', ', @counts) . "\n"; + } + push @manifest, <<'DISPATCHER'; +my $__poj_testprop_dir = __FILE__; +$__poj_testprop_dir =~ s{[^/\\]+\z}{}; +my @__poj_testprop_chunks = !$::TESTCHUNK + ? (1 .. 10) + : ($::TESTCHUNK >= 1 && $::TESTCHUNK <= 10 ? ($::TESTCHUNK) : ()); +for my $__poj_testprop_chunk (@__poj_testprop_chunks) { + my $__poj_testprop_path = sprintf '%sTestProp-%02d.pl', + $__poj_testprop_dir, $__poj_testprop_chunk; + open my $__poj_testprop_fh, '<', $__poj_testprop_path + or die "Cannot load $__poj_testprop_path: $!\n"; + local $/; + my $__poj_testprop_source = <$__poj_testprop_fh>; + close $__poj_testprop_fh + or die "Cannot close $__poj_testprop_path: $!\n"; + my $__poj_testprop_completed = eval($__poj_testprop_source . "\n; 1;"); + my $__poj_testprop_error = $@; + unless ($__poj_testprop_completed) { + $__poj_testprop_error = "section eval returned false without an error\n" + unless length $__poj_testprop_error; + die "Cannot evaluate $__poj_testprop_path: $__poj_testprop_error"; + } +} +DISPATCHER + my $dispatcher = $preamble . join('', @manifest) . $finish; + return ($dispatcher, \@sections, $canonical_sha); +} + +# Generate the Unicode property test fixture from a pristine copy of the +# pinned source data. Upstream deliberately does not commit TestProp.pl; its +# normal build creates it with lib/unicore/mktables -maketest. +sub generate_unicode_testprop { + my ($generator_relative, $target, $project_root) = @_; + my $generator = File::Spec->catfile($project_root, $generator_relative); + my $unicode_source = dirname($generator); + my @required = ( + $generator, + File::Spec->catfile($unicode_source, 'version'), + File::Spec->catfile($unicode_source, 'UnicodeData.txt'), + ); + for my $required (@required) { + unless (-f $required) { + warn " ERROR: Cannot generate Unicode TestProp.pl; missing pinned " + . "generation prerequisite: $required\n" + . " Restore perl5/lib/unicore from the pinned perl5 source " + . "before running this sync.\n\n"; + return 0; + } + } + + my $temporary = tempdir('perlonjava-testprop-XXXXXX', TMPDIR => 1, CLEANUP => 1); + my $temporary_unicode = File::Spec->catdir($temporary, 'unicore'); + make_path($temporary_unicode) or do { + warn " ERROR: Cannot create temporary Unicode generation directory: $!\n\n"; + return 0; + }; + unless (copy_directory($unicode_source, $temporary_unicode, + $project_root, [], [])) { + warn " ERROR: Cannot copy pinned Unicode data for TestProp.pl generation.\n\n"; + return 0; + } + + my $generated = File::Spec->catfile($temporary_unicode, 'TestProp.pl'); + my $original_dir = getcwd(); + unless (chdir $project_root) { + warn " ERROR: Cannot enter project root for TestProp.pl generation: $!\n\n"; + return 0; + } + print " Generating with pinned Unicode data: $generator_relative\n"; + my $result = system($^X, $generator_relative, + '-C', $temporary_unicode, + '-T', $generated, + '-q'); + my $generation_error = $!; + unless (chdir $original_dir) { + die "sync.pl: cannot restore working directory '$original_dir': $!\n"; + } + if ($result != 0) { + my $exit = $result == -1 + ? "could not start: $generation_error" + : ($result & 127) + ? "terminated by signal " . ($result & 127) + : "exit code " . ($result >> 8); + warn " ERROR: Unicode TestProp.pl generation failed ($exit).\n" + . " Ensure the pinned perl5/lib/unicore data is complete and the " + . "host Perl can run mktables.\n\n"; + return 0; + } + unless (-s $generated) { + warn " ERROR: Unicode generator completed without producing TestProp.pl.\n\n"; + return 0; + } + + open my $generated_fh, '<', $generated or do { + warn " ERROR: Cannot inspect generated TestProp.pl: $!\n\n"; + return 0; + }; + local $/; + my $contents = <$generated_fh>; + close $generated_fh; + my ($dispatcher, $sections, $canonical_sha); + eval { + ($dispatcher, $sections, $canonical_sha) + = split_unicode_testprop($contents); + 1; + } or do { + my $error = $@ || 'unknown split error'; + chomp $error; + warn " ERROR: Cannot split generated TestProp.pl: $error\n\n"; + return 0; + }; + + my $target_dir = dirname($target); + unless (-d $target_dir) { + make_path($target_dir) or do { + warn " ERROR: Cannot create generated fixture directory: $!\n\n"; + return 0; + }; + } + my @outputs; + my ($volume, $directories, $base) = File::Spec->splitpath($target); + $base =~ s/\.pl\z//; + for my $section (@$sections) { + my $chunk_base = sprintf '%s-%02d.pl', $base, $section->{number}; + my $chunk_target = File::Spec->catpath($volume, $directories, + $chunk_base); + push @outputs, [$chunk_target, $section->{padded}]; + } + # Publish the dispatcher last so readers never see it before all ten chunk + # names exist. Stage every output completely before replacing any member of + # the current family; a write failure therefore leaves that family intact. + push @outputs, [$target, $dispatcher]; + my @staged; + for my $output (@outputs) { + my ($path, $source) = @$output; + my ($output_fh, $staged_path); + eval { + ($output_fh, $staged_path) = tempfile( + '.TestProp-sync-XXXXXX', DIR => $target_dir, UNLINK => 0 + ); + 1; + } or do { + my $error = $@ || 'unknown temporary-file error'; + chomp $error; + warn " ERROR: Cannot stage generated fixture $path: $error\n\n"; + unlink $_->[0] for @staged; + return 0; + }; + print {$output_fh} $source or do { + warn " ERROR: Cannot stage generated fixture $path: $!\n\n"; + close $output_fh; + unlink $staged_path; + unlink $_->[0] for @staged; + return 0; + }; + close $output_fh or do { + warn " ERROR: Cannot close staged generated fixture $path: $!\n\n"; + unlink $staged_path; + unlink $_->[0] for @staged; + return 0; + }; + push @staged, [$staged_path, $path]; + } + while (my $staged = shift @staged) { + my ($staged_path, $path) = @$staged; + unless (rename $staged_path, $path) { + warn " ERROR: Cannot publish generated fixture $path: $!\n\n"; + unlink $staged_path; + unlink $_->[0] for @staged; + return 0; + } + } + print " Installed lossless generated fixture dispatcher and 10 chunks: " + . File::Spec->abs2rel($target, $project_root) + . " (canonical SHA-256 $canonical_sha)\n"; + return 1; +} + sub usage { print <<'USAGE'; PerlOnJava perl5 import sync — see dev/import-perl5/config.yaml @@ -264,7 +509,13 @@ sub main { print "Processing: $import->{source}\n"; # Check if source exists - if ($type eq 'directory') { + if ($type eq 'generated_unicode_testprop') { + unless (generate_unicode_testprop($import->{source}, $target, $project_root)) { + $error_count++; + next; + } + } + elsif ($type eq 'directory') { unless (-d $source) { warn " ERROR: Source directory not found: $source\n\n"; $error_count++; @@ -342,7 +593,8 @@ sub main { $success_count++; } - # Create empty perl5_t/lib directory (needed for opendir tests but must stay empty) + # Create perl5_t/lib for opendir tests. It remains empty except for + # explicitly configured generated test fixtures such as unicore/TestProp.pl. my $lib_dir = File::Spec->catdir($project_root, 'perl5_t', 'lib'); unless (-d $lib_dir) { print "Creating empty perl5_t/lib directory...\n"; @@ -362,4 +614,6 @@ sub main { } } -main(); +main() unless caller; + +1; diff --git a/dev/import-perl5/t/generated_unicode_testprop.t b/dev/import-perl5/t/generated_unicode_testprop.t new file mode 100644 index 0000000000..a2284a9047 --- /dev/null +++ b/dev/import-perl5/t/generated_unicode_testprop.t @@ -0,0 +1,203 @@ +use strict; +use warnings; +use Test::More; +use File::Path qw(make_path); +use File::Spec; +use File::Temp qw(tempdir); +use Digest::SHA qw(sha256_hex); + +my $sync = File::Spec->catfile('dev', 'import-perl5', 'sync.pl'); +do "./$sync" or die "Could not load $sync: $@ $!"; + +my $root = tempdir(CLEANUP => 1); +my $unicode = File::Spec->catdir($root, 'perl5', 'lib', 'unicore'); +make_path($unicode); + +my $generator_relative = File::Spec->catfile('perl5', 'lib', 'unicore', 'mktables'); +my $generator = File::Spec->catfile($root, $generator_relative); +open my $generator_fh, '>', $generator or die "Cannot create fake generator: $!"; +print {$generator_fh} <<'GENERATOR'; +use strict; +use warnings; +use File::Spec; +my ($directory, $target); +while (@ARGV) { + my $argument = shift; + $directory = shift if $argument eq '-C'; + $target = shift if $argument eq '-T'; +} +die "missing generation arguments\n" unless defined $directory && defined $target; +open my $output, '>', $target or die "Cannot create $target: $!"; +print {$output} <<'PREAMBLE'; +# generated fixture +my $helper_lexical = 1; +sub Expect { $main::testprop_expects += $helper_lexical } +sub Error { $main::testprop_errors += $helper_lexical } +sub Test_GCB { $main::testprop_breaks += $helper_lexical } +sub Test_SB { $main::testprop_breaks += $helper_lexical } +sub Test_LB { $main::testprop_breaks += $helper_lexical } +sub Test_WB { $main::testprop_breaks += $helper_lexical } +sub Finished { $main::testprop_finished++ } +PREAMBLE +for my $chunk (1 .. 10) { + print {$output} "if (!\$::TESTCHUNK or \$::TESTCHUNK == $chunk) {\n"; + print {$output} " \$main::testprop_chunks .= '$chunk,';\n"; + if ($chunk <= 4) { + for my $index (1 .. 600) { + my $suffix = " # chunk-$chunk-expect-$index"; + $suffix .= " regression-$index" + if $chunk == 1 && $index <= 16; + print {$output} " Expect();$suffix\n"; + } + print {$output} " Error(); # chunk-$chunk-error-$_\n" for 1 .. 300; + } + elsif ($chunk == 5) { + print {$output} " Test_GCB();\n" for 1 .. 120; + print {$output} " Test_SB();\n" for 1 .. 80; + } + elsif ($chunk <= 9) { + print {$output} " Test_LB();\n" for 1 .. 80; + } + else { + print {$output} " Test_WB();\n" for 1 .. 80; + } + print {$output} "}\n"; +} +print {$output} "Finished();\n"; +close $output; +GENERATOR +close $generator_fh; + +for my $required (qw(version UnicodeData.txt)) { + my $path = File::Spec->catfile($unicode, $required); + open my $fh, '>', $path or die "Cannot create $path: $!"; + print {$fh} $required eq 'version' ? "17.0.0\n" : "0041;LATIN CAPITAL LETTER A\n"; + close $fh; +} + +my $target = File::Spec->catfile($root, 'perl5_t', 'lib', 'unicore', 'TestProp.pl'); +my @family = ($target, map { + File::Spec->catfile($root, 'perl5_t', 'lib', 'unicore', + sprintf('TestProp-%02d.pl', $_)) +} 1 .. 10); + +sub slurp { + my ($path) = @_; + open my $fh, '<', $path or die "Cannot read $path: $!"; + local $/; + my $contents = <$fh>; + close $fh; + return $contents; +} + +ok(generate_unicode_testprop($generator_relative, $target, $root), + 'generated import succeeds from pinned inputs'); +ok(-s $_, "generated fixture is installed: $_") for @family; +my %first_family = map { $_ => slurp($_) } @family; +my $first = $first_family{$target}; +like($first, qr/^# Canonical pinned mktables SHA-256: ([0-9a-f]{64})$/m, + 'dispatcher records its canonical generated-input hash'); +my ($recorded_canonical_sha) = $first + =~ /^# Canonical pinned mktables SHA-256: ([0-9a-f]{64})$/m; +my @reconstructed_sections; +for my $chunk (1 .. 10) { + like($first, qr/^# TESTCHUNK $chunk: /m, + "dispatcher records TESTCHUNK $chunk counts"); + my $path = $family[$chunk]; + my $source = $first_family{$path}; + my $marker = "if (!\$::TESTCHUNK or \$::TESTCHUNK == $chunk) {"; + my $start = index($source, $marker); + cmp_ok($start, '>=', 0, "chunk $chunk contains its canonical marker"); + is(index($source, 'TESTCHUNK == ', $start + length $marker), -1, + "chunk $chunk contains no later TESTCHUNK section"); + push @reconstructed_sections, substr($source, $start); +} +my ($canonical_preamble) = split /\n# PerlOnJava lossless TESTCHUNK dispatcher\n/, + $first, 2; +my $reconstructed = $canonical_preamble + . join('', @reconstructed_sections) . "Finished();\n"; +is(sha256_hex($reconstructed), $recorded_canonical_sha, + 'dispatcher and chunks reconstruct the canonical generated hash'); +my @expects = $reconstructed =~ /^\s+Expect\(/mg; +my @errors = $reconstructed =~ /^\s+Error\(/mg; +is(scalar @expects, 4 * 600, 'all canonical Expect calls are retained'); +is(scalar @errors, 4 * 300, 'all canonical Error calls are retained'); +like($reconstructed, qr/# chunk-2-expect-1$/m, + 'first ordered Expect call is retained'); +like($reconstructed, qr/# chunk-2-expect-600$/m, + 'last ordered Expect call is retained'); +like($reconstructed, qr/# chunk-2-error-1$/m, + 'first ordered Error call is retained'); +like($reconstructed, qr/# chunk-2-error-300$/m, + 'last ordered Error call is retained'); + +{ + local $::TESTCHUNK = 2; + local $::testprop_chunks = ''; + local $::testprop_expects = 0; + local $::testprop_errors = 0; + local $::testprop_breaks = 0; + local $::testprop_finished = 0; + my $loaded = do $target; + ok(defined $loaded, 'dispatcher executes one selected generated chunk') + or diag "dispatcher error: $@ $!"; + is($::testprop_chunks, '2,', 'dispatcher loads exactly the selected chunk'); + is($::testprop_expects, 600, + 'selected chunk eval sees canonical lexical helper scope'); + is($::testprop_errors, 300, 'selected chunk retains every Error call'); + is($::testprop_finished, 1, 'selected dispatch calls canonical Finished once'); +} +{ + local $::TESTCHUNK = 0; + local $::testprop_chunks = ''; + local $::testprop_expects = 0; + local $::testprop_errors = 0; + local $::testprop_breaks = 0; + local $::testprop_finished = 0; + my $loaded = do $target; + ok(defined $loaded, 'dispatcher executes all chunks when none is selected') + or diag "dispatcher error: $@ $!"; + is($::testprop_chunks, '1,2,3,4,5,6,7,8,9,10,', + 'unselected dispatch preserves canonical chunk order'); + is($::testprop_expects, 4 * 600, 'all-chunk dispatch retains all Expect calls'); + is($::testprop_errors, 4 * 300, 'all-chunk dispatch retains all Error calls'); + is($::testprop_breaks, 120 + 80 + 4 * 80 + 80, + 'all-chunk dispatch retains all boundary calls'); + is($::testprop_finished, 1, 'all-chunk dispatch calls canonical Finished once'); +} + +open my $damage_fh, '>', $target or die "Cannot alter $target: $!"; +print {$damage_fh} "damaged\n"; +close $damage_fh; +open my $chunk_damage_fh, '>', $family[7] + or die "Cannot alter $family[7]: $!"; +print {$chunk_damage_fh} "damaged chunk\n"; +close $chunk_damage_fh; +ok(generate_unicode_testprop($generator_relative, $target, $root), + 'repeated generation succeeds'); +my %second_family = map { $_ => slurp($_) } @family; +is_deeply(\%second_family, \%first_family, + 'repeated generation installs a byte-identical dispatcher and chunks'); + +unlink File::Spec->catfile($unicode, 'version') + or die "Cannot remove fake version prerequisite: $!"; +my $warning = ''; +{ + local $SIG{__WARN__} = sub { $warning .= join '', @_ }; + ok(!generate_unicode_testprop($generator_relative, $target, $root), + 'missing generation prerequisite fails'); +} +like($warning, qr/missing pinned generation prerequisite.*version/s, + 'missing prerequisite diagnostic names the absent input'); + +my $bad_order = join '', + "if (!\$::TESTCHUNK or \$::TESTCHUNK == 2) {\n}\n", + "if (!\$::TESTCHUNK or \$::TESTCHUNK == 1) {\n}\n", + (map { "if (!\$::TESTCHUNK or \$::TESTCHUNK == $_) {\n}\n" } 3 .. 10), + "Finished();\n"; +my $order_error = ''; +eval { split_unicode_testprop($bad_order); 1 } or $order_error = $@; +like($order_error, qr/unexpected TESTCHUNK order: 2,1,3,4,5,6,7,8,9,10/, + 'splitting rejects dropped or reordered canonical sections'); + +done_testing; diff --git a/dev/tools/README.md b/dev/tools/README.md index 7a494a1098..835e318061 100644 --- a/dev/tools/README.md +++ b/dev/tools/README.md @@ -43,10 +43,13 @@ parallelism without making their watchdogs contend with `pat*`. The baseline may be either runner JSON or a captured historical runner log. Use `--fail-on-regression` for release gates and `--output` to retain a -machine-readable per-file comparison: +machine-readable per-file comparison. Corpus gates can additionally use +`--fail-on-invalid --expected-files N` to reject missing files, execution +errors, timeouts, incomplete runs, and zero-TAP results: ```bash -perl dev/tools/compare_test_results.pl --fail-on-regression \ +perl dev/tools/compare_test_results.pl --fail-on-regression --fail-on-invalid \ + --expected-files 80 \ --path-prefix perl5_t/t/re \ --output /tmp/regex-comparison.json \ ../PerlOnJava/logs/test_20260815_080000_958.log /tmp/regex.json diff --git a/dev/tools/compare_test_logs.pl b/dev/tools/compare_test_logs.pl index ad927640a8..40cfd61a50 100755 --- a/dev/tools/compare_test_logs.pl +++ b/dev/tools/compare_test_logs.pl @@ -18,6 +18,9 @@ =head1 SYNOPSIS --show-regressions Show files with regressions (default: yes) --show-unchanged Show files with no change (default: no) --summary-only Only show summary statistics + --normalize-pr958-artifacts + Normalize two exact, independently reconstructed + PR 958 transcript artifacts; raw counts are printed --sort-by FIELD Sort by: name, diff, before, after (default: diff) --help Show this help message @@ -47,6 +50,18 @@ =head1 EXAMPLES my $sort_by = 'diff'; my $help = 0; my $show_flakes = 0; # Set --show-flakes to include known-flake files in regression list +my $normalize_pr958_artifacts = 0; +my @artifact_normalizations; + +# These are exact transcript signatures, not a file-level whitelist. They are +# applied only when explicitly requested and only when file, pass count, and +# total all match the independently reconstructed PR 958 artifacts. +my %PR958_ARTIFACTS = ( + 'op/do.t|94|99' => [68, 71, + 'PR 958 duplicated its first 28 TAP assertions; canonical unique run'], + 'japh/abigail.t|110|130' => [109, 130, + 'PR 958 logged one irreproducible extra pass; exact reconstruction'], +); # Known-flake whitelist: tests whose pass count varies under the parallel # perl_test_runner due to environmental factors (TTY allocation, file @@ -102,6 +117,7 @@ =head1 EXAMPLES 'summary-only' => \$summary_only, 'sort-by=s' => \$sort_by, 'show-flakes!' => \$show_flakes, + 'normalize-pr958-artifacts!' => \$normalize_pr958_artifacts, 'help|h' => \$help, ) or die "Error in command line arguments\n"; @@ -118,6 +134,9 @@ =head1 EXAMPLES --show-regressions Show files with regressions (default: yes) --show-unchanged Show files with no change (default: no) --summary-only Only show summary statistics + --normalize-pr958-artifacts + Normalize exact PR 958 transcript signatures and show + both raw and normalized counts --sort-by FIELD Sort by: name, diff, before, after (default: diff) --help Show this help message @@ -133,7 +152,7 @@ =head1 EXAMPLES # Parse a log file and extract test results sub parse_log { - my $file = shift; + my ($file, $side) = @_; my %results; open my $fh, '<', $file or die "Cannot open $file: $!\n"; @@ -147,6 +166,22 @@ sub parse_log { # New logs: perl5_t/t/uni/variables.t -> t/uni/variables.t -> uni/variables.t $test =~ s{^perl5_t/}{}; $test =~ s{^t/}{}; + my ($raw_passed, $raw_total) = ($passed, $total); + if ($normalize_pr958_artifacts) { + my $artifact = $PR958_ARTIFACTS{"$test|$passed|$total"}; + if ($artifact) { + ($passed, $total) = @{$artifact}[0, 1]; + push @artifact_normalizations, { + side => $side, + test => $test, + raw_passed => $raw_passed, + raw_total => $raw_total, + passed => $passed, + total => $total, + reason => $artifact->[2], + }; + } + } $results{$test} = { passed => $passed, total => $total, @@ -160,8 +195,8 @@ sub parse_log { # Parse both logs print "Parsing logs...\n"; -my %old_results = parse_log($old_log); -my %new_results = parse_log($new_log); +my %old_results = parse_log($old_log, 'old'); +my %new_results = parse_log($new_log, 'new'); # Calculate statistics my @changes; @@ -279,6 +314,16 @@ sub parse_log { print "Old log: $old_log\n"; print "New log: $new_log\n"; print "\n"; +if (@artifact_normalizations) { + print "PR 958 exact artifact normalization (raw -> normalized):\n"; + for my $item (@artifact_normalizations) { + printf " %-3s %-24s %d/%d -> %d/%d # %s\n", + $item->{side}, $item->{test}, + $item->{raw_passed}, $item->{raw_total}, + $item->{passed}, $item->{total}, $item->{reason}; + } + print "\n"; +} printf "Total tests in old log: %6d tests, %6d passing (%5.2f%%)\n", $stats{total_old_tests}, $stats{total_old_passed}, $stats{total_old_tests} ? 100 * $stats{total_old_passed} / $stats{total_old_tests} : 0; diff --git a/dev/tools/compare_test_results.pl b/dev/tools/compare_test_results.pl index c6653732ea..cd911a302b 100644 --- a/dev/tools/compare_test_results.pl +++ b/dev/tools/compare_test_results.pl @@ -7,11 +7,15 @@ use Encode qw(FB_DEFAULT decode); my $fail_on_regression = 0; +my $fail_on_invalid = 0; +my $expected_files; my $output_file; my $path_prefix; my $help = 0; GetOptions( 'fail-on-regression!' => \$fail_on_regression, + 'fail-on-invalid!' => \$fail_on_invalid, + 'expected-files=i' => \$expected_files, 'output=s' => \$output_file, 'path-prefix=s' => \$path_prefix, 'help' => \$help, @@ -30,12 +34,14 @@ $candidate = filter_results($candidate, $path_prefix); } my $comparison = compare_results($baseline, $candidate); +$comparison->{expected_files} = $expected_files if defined $expected_files; print_report($baseline_file, $candidate_file, $comparison); save_report($output_file, $baseline_file, $candidate_file, $comparison) if defined $output_file; exit 1 if $fail_on_regression && @{$comparison->{regressions}}; +exit 1 if $fail_on_invalid && has_invalid_candidate($comparison, $expected_files); exit 0; sub usage { @@ -48,6 +54,9 @@ sub usage { Options: --fail-on-regression Exit nonzero when any candidate file loses passing tests + --fail-on-invalid Exit nonzero for missing files, execution failures, + zero-TAP results, or an --expected-files mismatch + --expected-files NUM Require exactly NUM candidate files --output FILE Save the normalized comparison as JSON --path-prefix PATH Compare only files below this canonical path --help Show this help @@ -118,7 +127,8 @@ sub filter_results { sub compare_results { my ($baseline, $candidate) = @_; - my (@regressions, @improvements, @plan_changes, @missing, @added); + my (@regressions, @improvements, @plan_changes, @missing, @added, + @execution_issues, @zero_tap); my ($baseline_ok, $candidate_ok, $baseline_total, $candidate_total) = (0, 0, 0, 0); $baseline_ok += $_->{ok} for values %$baseline; @@ -127,6 +137,19 @@ sub compare_results { $candidate_total += $_->{total} for values %$candidate; my %all = map { $_ => 1 } (keys %$baseline, keys %$candidate); + for my $file (sort keys %$candidate) { + my $result = $candidate->{$file}; + push @execution_issues, { + file => $file, + status => $result->{status}, + ok => $result->{ok}, + total => $result->{total}, + } if $result->{status} =~ /\A(?:error|timeout|incomplete)\z/; + push @zero_tap, { + file => $file, + status => $result->{status}, + } if $result->{total} == 0; + } for my $file (sort keys %all) { my ($before, $after) = ($baseline->{$file}, $candidate->{$file}); if (!$after) { @@ -165,6 +188,8 @@ sub compare_results { plan_changes => \@plan_changes, missing_files => \@missing, added_files => \@added, + execution_issues => \@execution_issues, + zero_tap => \@zero_tap, }; } @@ -175,10 +200,16 @@ sub print_report { print "Candidate: $candidate_file\n"; printf "Passing assertions: %d/%d -> %d/%d (%+d passing, %+d planned)\n", @{$summary}{qw(baseline_ok baseline_total candidate_ok candidate_total delta_ok delta_total)}; - printf "Files: %d -> %d; regressions=%d improvements=%d missing=%d added=%d\n", + printf "Files: %d -> %d; regressions=%d improvements=%d missing=%d added=%d execution-issues=%d zero-TAP=%d\n", $summary->{baseline_files}, $summary->{candidate_files}, scalar(@{$comparison->{regressions}}), scalar(@{$comparison->{improvements}}), - scalar(@{$comparison->{missing_files}}), scalar(@{$comparison->{added_files}}); + scalar(@{$comparison->{missing_files}}), scalar(@{$comparison->{added_files}}), + scalar(@{$comparison->{execution_issues}}), scalar(@{$comparison->{zero_tap}}); + if (defined $comparison->{expected_files} + && $summary->{candidate_files} != $comparison->{expected_files}) { + printf "EXPECTED FILE COUNT MISMATCH: expected %d, found %d\n", + $comparison->{expected_files}, $summary->{candidate_files}; + } print_entries('REGRESSIONS', $comparison->{regressions}); print_entries('IMPROVEMENTS', $comparison->{improvements}); @@ -191,6 +222,26 @@ sub print_report { print "\nADDED FILES\n"; print " $_->{file}\n" for @{$comparison->{added_files}}; } + if (@{$comparison->{execution_issues}}) { + print "\nEXECUTION ISSUES\n"; + printf " %s: status=%s %d/%d\n", + @{$_}{qw(file status ok total)} for @{$comparison->{execution_issues}}; + } + if (@{$comparison->{zero_tap}}) { + print "\nZERO TAP\n"; + printf " %s: status=%s\n", @{$_}{qw(file status)} + for @{$comparison->{zero_tap}}; + } +} + +sub has_invalid_candidate { + my ($comparison, $required_files) = @_; + return 1 if @{$comparison->{missing_files}}; + return 1 if @{$comparison->{execution_issues}}; + return 1 if @{$comparison->{zero_tap}}; + return 1 if defined($required_files) + && $comparison->{summary}{candidate_files} != $required_files; + return 0; } sub print_entries { diff --git a/dev/tools/generate_joni_boundary_data.pl b/dev/tools/generate_joni_boundary_data.pl new file mode 100644 index 0000000000..9cf1c38d3f --- /dev/null +++ b/dev/tools/generate_joni_boundary_data.pl @@ -0,0 +1,114 @@ +#!/usr/bin/env perl +use strict; +use warnings; + +my $unicode_root = 'perl5/lib/unicore'; +my $expected_unicode_version = '17.0.0'; +open my $version_fh, '<', "$unicode_root/version" or die "Can't read Unicode version: $!\n"; +chomp(my $unicode_version = <$version_fh>); +close $version_fh; +die "Expected Unicode $expected_unicode_version, found $unicode_version\n" + unless $unicode_version eq $expected_unicode_version; + +open my $property_fh, '<', "$unicode_root/auxiliary/SentenceBreakProperty.txt" + or die "Can't read Sentence_Break data: $!\n"; +my @ranges; +while (<$property_fh>) { + next unless /^([0-9A-F]+)(?:\.\.([0-9A-F]+))?\s*;\s*([A-Za-z_]+)/; + push @ranges, [hex($1), defined($2) ? hex($2) : hex($1), $3]; +} +close $property_fh; +@ranges = sort { $a->[0] <=> $b->[0] } @ranges; + +my (@starts, @values); +my $cursor = 0; +for my $range (@ranges) { + my ($start, $end, $property) = @$range; + die "Overlapping Sentence_Break ranges at U+", sprintf('%04X', $start), "\n" + if $start < $cursor; + if ($start > $cursor) { + push @starts, $cursor; + push @values, 'Other'; + } + push @starts, $start; + push @values, $property; + $cursor = $end + 1; +} +if ($cursor <= 0x10ffff) { + push @starts, $cursor; + push @values, 'Other'; +} + +my @classes = qw( + Other ATerm Close CR Extend Format LF Lower Numeric OLetter SContinue Sep Sp STerm Upper +); +my %class_id; +@class_id{@classes} = (0 .. $#classes); + +for my $value (@values) { + die "Unknown Sentence_Break value '$value'\n" unless exists $class_id{$value}; +} + +print <<'HEADER'; +/* + * Permission is hereby granted, free of charge, to any person obtaining a copy of + * this software and associated documentation files (the "Software"), to deal in + * the Software without restriction, including without limitation the rights to + * use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies + * of the Software, and to permit persons to whom the Software is furnished to do + * so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in all + * copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ +package org.joni; + +// Generated by dev/tools/generate_joni_boundary_data.pl. Do not edit manually. +final class SentenceBreakData { +HEADER + +print " static final String UNICODE_VERSION = \"$unicode_version\";\n"; +for my $i (0 .. $#classes) { + my $constant = uc($classes[$i]); + print " static final byte $constant = $i;\n"; +} + +print "\n private static final int[] STARTS = {\n"; +for (my $i = 0; $i < @starts; $i += 10) { + my $end = $i + 9 < $#starts ? $i + 9 : $#starts; + print " ", join(', ', map { sprintf '0x%X', $starts[$_] } $i .. $end), ",\n"; +} +print " };\n\n private static final byte[] VALUES = {\n"; +for (my $i = 0; $i < @values; $i += 16) { + my $end = $i + 15 < $#values ? $i + 15 : $#values; + print " ", join(', ', map { uc($values[$_]) } $i .. $end), ",\n"; +} +print <<'FOOTER'; + }; + + static byte propertyOf(int codePoint) { + int low = 0; + int high = STARTS.length - 1; + while (low <= high) { + int middle = (low + high) >>> 1; + if (STARTS[middle] <= codePoint) { + low = middle + 1; + } else { + high = middle - 1; + } + } + return VALUES[Math.max(0, high)]; + } + + private SentenceBreakData() { + } +} +FOOTER diff --git a/dev/tools/generate_joni_line_break_data.pl b/dev/tools/generate_joni_line_break_data.pl new file mode 100644 index 0000000000..ef79dd1022 --- /dev/null +++ b/dev/tools/generate_joni_line_break_data.pl @@ -0,0 +1,233 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Digest::SHA qw(sha256_hex); +use File::Spec; +use FindBin; + +my $expected_version = '17.0.0'; +my $unicore = File::Spec->catdir($FindBin::Bin, '..', '..', 'perl5', 'lib', 'unicore'); +my %sources = ( + Line_Break => [File::Spec->catfile($unicore, 'LineBreak.txt'), + 'e6a18fa91f8f6a6f8e534b1d3f128c21ada45bfe152eb6b1bcc5e15fd8ac92e6'], + General_Category => [File::Spec->catfile($unicore, 'UnicodeData.txt'), + '2e1efc1dcb59c575eedf5ccae60f95229f706ee6d031835247d843c11d96470c'], + East_Asian_Width => [File::Spec->catfile($unicore, 'EastAsianWidth.txt'), + 'ea7ce50f3444a050333448dffef1cadd9325af55cbb764b4a2280faf52170a33'], + Extended_Pictographic => [File::Spec->catfile($unicore, 'emoji', 'emoji.txt'), + '2cb2bb9455cda83e8481541ecf5b6dfda66a3bb89efa3fa7c5297eccf607b72b'], +); + +sub source_text { + my ($property) = @_; + my ($path, $expected_hash) = @{$sources{$property}}; + open my $input, '<:raw', $path or die "Cannot read $path: $!\n"; + local $/; + my $text = <$input>; + close $input or die "Cannot close $path: $!\n"; + my $actual_hash = sha256_hex($text); + die "$path SHA-256 mismatch: expected $expected_hash, found $actual_hash\n" + unless $actual_hash eq $expected_hash; + return ($path, $text); +} + +sub range_from_text { + my ($range) = @_; + my ($first, $last) = split /\.\./, $range; + return (hex($first), hex(defined $last ? $last : $first)); +} + +sub parse_property_file { + my ($property, $version_pattern, $wanted_value, $default) = @_; + my ($path, $text) = source_text($property); + die "$path is not pinned Unicode $expected_version data\n" + unless $text =~ $version_pattern; + my (@ranges, @missing); + for my $line (split /\n/, $text) { + if ($line =~ /^#\s*\@missing:\s*([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*;\s*([A-Za-z0-9_]+)/) { + my ($range, $value) = ($1, $2); + my ($first, $last) = range_from_text($range); + push @missing, [$first, $last, $value]; + next; + } + next unless $line =~ /^([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*;\s*([A-Za-z0-9_]+)/; + my ($range, $value) = ($1, $2); + next if defined $wanted_value && $value ne $wanted_value; + my ($first, $last) = range_from_text($range); + push @ranges, [$first, $last, defined $wanted_value ? 'Y' : $value]; + } + return {ranges => \@ranges, missing => \@missing, default => $default}; +} + +sub parse_general_category { + my ($path, $text) = source_text('General_Category'); + my (@ranges, $pending); + for my $line (split /\n/, $text) { + my @fields = split /;/, $line, -1; + next unless @fields >= 3; + my ($code, $name, $category) = (hex($fields[0]), $fields[1], $fields[2]); + if ($name =~ /, First>$/) { + $pending = [$code, $category]; + } elsif ($name =~ /, Last>$/) { + die "Unmatched UnicodeData Last range at $fields[0]\n" + unless $pending && $pending->[1] eq $category; + push @ranges, [$pending->[0], $code, $category]; + undef $pending; + } else { + push @ranges, [$code, $code, $category]; + } + } + die "Unclosed UnicodeData First range\n" if $pending; + return {ranges => \@ranges, missing => [], default => 'Cn'}; +} + +my @classes = qw( + AI AK AL AP AS B2 BA BB BK CB CJ CL CM CP CR EB EM EX GL H2 H3 HH HL HY + ID IN IS JL JT JV LF NL NS NU OP PO PR QU RI SA SG SP SY VF VI WJ XX ZW ZWJ +); +my %class_id; +@class_id{@classes} = (0 .. $#classes); + +my %maps = ( + Line_Break => parse_property_file('Line_Break', qr/^# LineBreak-\Q$expected_version\E\.txt/m, undef, 'XX'), + General_Category => parse_general_category(), + East_Asian_Width => parse_property_file('East_Asian_Width', qr/^# EastAsianWidth-\Q$expected_version\E\.txt/m, undef, 'N'), + Extended_Pictographic => parse_property_file('Extended_Pictographic', qr/^# Version: 17\.0$/m, + 'Extended_Pictographic', 'N'), +); + +my %starts = (0 => 1); +for my $map (values %maps) { + for my $range (@{$map->{ranges}}, @{$map->{missing}}) { + $starts{$range->[0]} = 1; + $starts{$range->[1] + 1} = 1 if $range->[1] < 0x10ffff; + } +} +my @starts = sort { $a <=> $b } keys %starts; + +sub value_at { + my ($map, $code) = @_; + my $ranges = $map->{ranges}; + my ($low, $high) = (0, $#$ranges); + while ($low <= $high) { + my $middle = ($low + $high) >> 1; + if ($ranges->[$middle][0] <= $code) { + $low = $middle + 1; + } else { + $high = $middle - 1; + } + } + return $ranges->[$high][2] if $high >= 0 && $code <= $ranges->[$high][1]; + my $value = $map->{default}; + for my $range (@{$map->{missing}}) { + $value = $range->[2] if $range->[0] <= $code && $code <= $range->[1]; + } + return $value; +} + +my @values; +for my $code (@starts) { + my $lb = value_at($maps{Line_Break}, $code); + my $gc = value_at($maps{General_Category}, $code); + my $ea = value_at($maps{East_Asian_Width}, $code); + my $ep = value_at($maps{Extended_Pictographic}, $code); + + $lb = 'AL' if $lb eq 'AI' || $lb eq 'SG' || $lb eq 'XX'; + $lb = $gc eq 'Mn' || $gc eq 'Mc' ? 'CM' : 'AL' if $lb eq 'SA'; + $lb = 'NS' if $lb eq 'CJ'; + die "Unknown Line_Break value '$lb'\n" unless exists $class_id{$lb}; + + my $packed = $class_id{$lb}; + $packed |= 1 << 6 if $gc eq 'Pi'; + $packed |= 1 << 7 if $gc eq 'Pf'; + $packed |= 1 << 8 if $ea eq 'F' || $ea eq 'W' || $ea eq 'H'; + $packed |= 1 << 9 if $ep eq 'Y' && $gc eq 'Cn'; + push @values, $packed; +} + +# Coalesce adjacent union intervals whose packed value is identical. +my (@coalesced_starts, @coalesced_values); +for my $i (0 .. $#starts) { + next if @coalesced_values && $values[$i] == $coalesced_values[-1]; + push @coalesced_starts, $starts[$i]; + push @coalesced_values, $values[$i]; +} + +print <<'HEADER'; +/* + * Permission is hereby granted, free of charge, to any person obtaining a copy of + * this software and associated documentation files (the "Software"), to deal in + * the Software without restriction, including without limitation the rights to + * use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies + * of the Software, and to permit persons to whom the Software is furnished to do + * so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in all + * copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ +package org.joni; + +// Generated by dev/tools/generate_joni_line_break_data.pl. Do not edit manually. +final class LineBreakData { +HEADER + +print " static final String UNICODE_VERSION = \"$expected_version\";\n"; +for my $class (@classes) { + print " static final short $class = $class_id{$class};\n"; +} +print <<'FLAGS'; + static final short CLASS_MASK = 0x3f; + static final short INITIAL_PUNCTUATION = 1 << 6; + static final short FINAL_PUNCTUATION = 1 << 7; + static final short EAST_ASIAN = 1 << 8; + static final short UNASSIGNED_EXTENDED_PICTOGRAPHIC = 1 << 9; + +FLAGS + +print " private static final int[] STARTS = {\n"; +for (my $i = 0; $i < @coalesced_starts; $i += 10) { + my $end = $i + 9 < $#coalesced_starts ? $i + 9 : $#coalesced_starts; + print " ", join(', ', map { sprintf '0x%X', $coalesced_starts[$_] } $i .. $end), ",\n"; +} +print " };\n\n private static final short[] VALUES = {\n"; +for (my $i = 0; $i < @coalesced_values; $i += 16) { + my $end = $i + 15 < $#coalesced_values ? $i + 15 : $#coalesced_values; + print " ", join(', ', @coalesced_values[$i .. $end]), ",\n"; +} +print <<'FOOTER'; + }; + + static short propertyOf(int codePoint) { + int low = 0; + int high = STARTS.length - 1; + while (low <= high) { + int middle = (low + high) >>> 1; + if (STARTS[middle] <= codePoint) { + low = middle + 1; + } else { + high = middle - 1; + } + } + return VALUES[Math.max(0, high)]; + } + + static short lineClass(short property) { + return (short)(property & CLASS_MASK); + } + + static boolean has(short property, short flag) { + return (property & flag) != 0; + } + + private LineBreakData() { + } +} +FOOTER diff --git a/dev/tools/generate_joni_word_break_data.pl b/dev/tools/generate_joni_word_break_data.pl new file mode 100644 index 0000000000..62c52c411c --- /dev/null +++ b/dev/tools/generate_joni_word_break_data.pl @@ -0,0 +1,153 @@ +#!/usr/bin/env perl +use strict; +use warnings; + +my $unicode_root = 'perl5/lib/unicore'; +my $expected_unicode_version = '17.0.0'; +open my $version_fh, '<', "$unicode_root/version" or die "Can't read Unicode version: $!\n"; +chomp(my $unicode_version = <$version_fh>); +close $version_fh; +die "Expected Unicode $expected_unicode_version, found $unicode_version\n" + unless $unicode_version eq $expected_unicode_version; + +sub read_property_ranges { + my ($path, $wanted_property) = @_; + open my $fh, '<', $path or die "Can't read $path: $!\n"; + my @ranges; + while (<$fh>) { + next unless /^([0-9A-F]+)(?:\.\.([0-9A-F]+))?\s*;\s*([A-Za-z_]+)/; + my ($start, $end, $property) = (hex($1), defined($2) ? hex($2) : hex($1), $3); + next if defined($wanted_property) && $property ne $wanted_property; + push @ranges, [$start, $end, $property]; + } + close $fh; + return sort { $a->[0] <=> $b->[0] } @ranges; +} + +my @word_ranges = read_property_ranges("$unicode_root/auxiliary/WordBreakProperty.txt"); +my (@starts, @values); +my $cursor = 0; +for my $range (@word_ranges) { + my ($start, $end, $property) = @$range; + die "Overlapping Word_Break ranges at U+", sprintf('%04X', $start), "\n" + if $start < $cursor; + if ($start > $cursor) { + push @starts, $cursor; + push @values, 'Other'; + } + push @starts, $start; + push @values, $property; + $cursor = $end + 1; +} +if ($cursor <= 0x10ffff) { + push @starts, $cursor; + push @values, 'Other'; +} + +my @pictographic_ranges = read_property_ranges( + "$unicode_root/emoji/emoji.txt", 'Extended_Pictographic'); + +my @classes = qw( + Other ALetter CR Double_Quote Extend ExtendNumLet Format Hebrew_Letter + Katakana LF MidLetter MidNum MidNumLet Newline Numeric Regional_Indicator + Single_Quote WSegSpace ZWJ +); +my %class_id; +@class_id{@classes} = (0 .. $#classes); + +for my $value (@values) { + die "Unknown Word_Break value '$value'\n" unless exists $class_id{$value}; +} + +sub constant_name { + my ($name) = @_; + $name =~ s/([a-z])([A-Z])/$1_$2/g; + return uc $name; +} + +print <<'HEADER'; +/* + * Permission is hereby granted, free of charge, to any person obtaining a copy of + * this software and associated documentation files (the "Software"), to deal in + * the Software without restriction, including without limitation the rights to + * use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies + * of the Software, and to permit persons to whom the Software is furnished to do + * so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in all + * copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ +package org.joni; + +// Generated by dev/tools/generate_joni_word_break_data.pl. Do not edit manually. +final class WordBreakData { +HEADER + +print " static final String UNICODE_VERSION = \"$unicode_version\";\n"; +for my $i (0 .. $#classes) { + print " static final byte ", constant_name($classes[$i]), " = $i;\n"; +} + +print "\n private static final int[] STARTS = {\n"; +for (my $i = 0; $i < @starts; $i += 10) { + my $end = $i + 9 < $#starts ? $i + 9 : $#starts; + print " ", join(', ', map { sprintf '0x%X', $starts[$_] } $i .. $end), ",\n"; +} +print " };\n\n private static final byte[] VALUES = {\n"; +for (my $i = 0; $i < @values; $i += 16) { + my $end = $i + 15 < $#values ? $i + 15 : $#values; + print " ", join(', ', map { constant_name($values[$_]) } $i .. $end), ",\n"; +} +print " };\n\n private static final int[] EXTENDED_PICTOGRAPHIC_RANGES = {\n"; +my @pictographic_pairs = map { ($_->[0], $_->[1]) } @pictographic_ranges; +for (my $i = 0; $i < @pictographic_pairs; $i += 8) { + my $end = $i + 7 < $#pictographic_pairs ? $i + 7 : $#pictographic_pairs; + print " ", join(', ', map { sprintf '0x%X', $pictographic_pairs[$_] } $i .. $end), ",\n"; +} +print <<'FOOTER'; + }; + + static byte propertyOf(int codePoint) { + int low = 0; + int high = STARTS.length - 1; + while (low <= high) { + int middle = (low + high) >>> 1; + if (STARTS[middle] <= codePoint) { + low = middle + 1; + } else { + high = middle - 1; + } + } + return VALUES[Math.max(0, high)]; + } + + static boolean isExtendedPictographic(int codePoint) { + int low = 0; + int high = EXTENDED_PICTOGRAPHIC_RANGES.length / 2 - 1; + while (low <= high) { + int middle = (low + high) >>> 1; + int start = EXTENDED_PICTOGRAPHIC_RANGES[middle * 2]; + int rangeEnd = EXTENDED_PICTOGRAPHIC_RANGES[middle * 2 + 1]; + if (codePoint < start) { + high = middle - 1; + } else if (codePoint > rangeEnd) { + low = middle + 1; + } else { + return true; + } + } + return false; + } + + private WordBreakData() { + } +} +FOOTER diff --git a/dev/tools/generate_perl_unicode_age_data.pl b/dev/tools/generate_perl_unicode_age_data.pl new file mode 100644 index 0000000000..0aeaea23b2 --- /dev/null +++ b/dev/tools/generate_perl_unicode_age_data.pl @@ -0,0 +1,117 @@ +#!/usr/bin/env perl +use strict; +use warnings; + +my $unicode_root = 'perl5/lib/unicore'; +my $expected_unicode_version = '17.0.0'; + +open my $version_fh, '<', "$unicode_root/version" + or die "Can't read Unicode version: $!\n"; +chomp(my $unicode_version = <$version_fh>); +close $version_fh; +die "Expected Unicode $expected_unicode_version, found $unicode_version\n" + unless $unicode_version eq $expected_unicode_version; + +open my $age_fh, '<', "$unicode_root/DAge.txt" + or die "Can't read Age data: $!\n"; +my (@versions, %version_index, @ranges); +while (<$age_fh>) { + next unless /^([0-9A-F]+)(?:\.\.([0-9A-F]+))?\s*;\s*([0-9]+\.[0-9]+)/; + my ($start, $end, $version) = (hex($1), defined($2) ? hex($2) : hex($1), $3); + if (!exists $version_index{$version}) { + $version_index{$version} = scalar @versions; + push @versions, $version; + } + if (@ranges && $ranges[-1][2] == $version_index{$version} + && $ranges[-1][1] + 1 == $start) { + $ranges[-1][1] = $end; + } else { + push @ranges, [$start, $end, $version_index{$version}]; + } +} +close $age_fh; + +die "Age data does not end at Unicode 17.0\n" + unless @versions && $versions[-1] eq '17.0'; + +print <<'HEADER'; +/* + * Generated from Perl 5.44's Unicode Character Database. Do not edit manually. + * + * Unicode data source copyright: + * © 2025 Unicode®, Inc. + * Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in + * the U.S. and other countries. + * For terms of use and license, see https://www.unicode.org/terms_of_use.html + */ +package org.perlonjava.runtime.regex; + +import com.ibm.icu.text.UnicodeSet; + +final class PerlUnicodeAgeData { +HEADER + +print " static final String UNICODE_VERSION = \"$unicode_version\";\n"; +print " private static final String[] VERSIONS = {\n "; +print join(', ', map { qq{"$_"} } @versions); +print "\n };\n\n"; +print " private static final int[] RANGES = {\n"; +for (my $i = 0; $i < @ranges; $i += 4) { + my $end = $i + 3 < $#ranges ? $i + 3 : $#ranges; + print " ", join(', ', map { + sprintf '0x%X, 0x%X, %d', @{$ranges[$_]}[0, 1, 2] + } $i .. $end), ",\n"; +} +print <<'FOOTER'; + }; + + private static final UnicodeSet[] EXACT_SETS = buildExactSets(); + private static final UnicodeSet[] CUMULATIVE_SETS = buildCumulativeSets(); + private static final UnicodeSet UNASSIGNED = new UnicodeSet(0, 0x10ffff) + .removeAll(CUMULATIVE_SETS[CUMULATIVE_SETS.length - 1]).freeze(); + + static UnicodeSet exactSet(String version) { + int versionIndex = versionIndex(version); + return versionIndex < 0 ? null : EXACT_SETS[versionIndex]; + } + + static UnicodeSet cumulativeSet(String version) { + int versionIndex = versionIndex(version); + return versionIndex < 0 ? null : CUMULATIVE_SETS[versionIndex]; + } + + static UnicodeSet unassignedSet() { + return UNASSIGNED; + } + + private static UnicodeSet[] buildExactSets() { + UnicodeSet[] sets = new UnicodeSet[VERSIONS.length]; + for (int i = 0; i < sets.length; i++) sets[i] = new UnicodeSet(); + for (int i = 0; i < RANGES.length; i += 3) { + sets[RANGES[i + 2]].add(RANGES[i], RANGES[i + 1]); + } + for (UnicodeSet set : sets) set.freeze(); + return sets; + } + + private static UnicodeSet[] buildCumulativeSets() { + UnicodeSet[] sets = new UnicodeSet[VERSIONS.length]; + UnicodeSet running = new UnicodeSet(); + for (int i = 0; i < sets.length; i++) { + running.addAll(EXACT_SETS[i]); + sets[i] = new UnicodeSet(running).freeze(); + } + return sets; + } + + private static int versionIndex(String version) { + for (int i = 0; i < VERSIONS.length; i++) { + if (VERSIONS[i].equals(version)) return i; + } + return -1; + } + + private PerlUnicodeAgeData() { + } +} +FOOTER diff --git a/dev/tools/generate_perl_unicode_bidi_class_data.pl b/dev/tools/generate_perl_unicode_bidi_class_data.pl new file mode 100755 index 0000000000..cc4bf5d6be --- /dev/null +++ b/dev/tools/generate_perl_unicode_bidi_class_data.pl @@ -0,0 +1,266 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Digest::SHA qw(sha256_hex); +use File::Spec; +use FindBin; + +my $expected_version = '17.0.0'; +my $root = File::Spec->catdir($FindBin::Bin, '..', '..'); +my $unicore = File::Spec->catdir($root, 'perl5', 'lib', 'unicore'); +my @sources = ( + { + name => 'DerivedBidiClass-17.0.0.txt', + path => File::Spec->catfile($unicore, 'extracted', 'DBidiClass.txt'), + hash => '4867b4b7f0731ed1bfcd34cc6251211ff1542541fce0734b6fbda139ee80b3a4', + version => qr/^# DerivedBidiClass-\Q$expected_version\E\.txt$/m, + }, + { + name => 'PropertyValueAliases-17.0.0.txt', + path => File::Spec->catfile($unicore, 'PropValueAliases.txt'), + hash => '670d2bebb48649c04fabfbf033308073dcff47946324a8033237254c048b3b01', + version => qr/^# PropertyValueAliases-\Q$expected_version\E\.txt$/m, + }, + { + name => 'PropertyAliases-17.0.0.txt', + path => File::Spec->catfile($unicore, 'PropertyAliases.txt'), + hash => '4441f573caf952ffece1d7c892e7715bd7136dfc26f96eb6f268bf1e474715fb', + version => qr/^# PropertyAliases-\Q$expected_version\E\.txt$/m, + }, +); + +sub read_source { + my ($source) = @_; + open my $input, '<:raw', $source->{path} + or die "Cannot read $source->{path}: $!\n"; + local $/; + my $text = <$input>; + close $input or die "Cannot close $source->{path}: $!\n"; + my $actual_hash = sha256_hex($text); + die "$source->{path} SHA-256 mismatch: expected $source->{hash}, found $actual_hash\n" + unless $actual_hash eq $source->{hash}; + die "$source->{path} is not pinned Unicode $expected_version data\n" + unless $text =~ $source->{version}; + $source->{text} = $text; +} + +sub trim { + my ($text) = @_; + $text =~ s/^\s+|\s+$//g; + return $text; +} + +sub loose_name { + my ($name) = @_; + $name = lc $name; + $name =~ s/[\s_-]+//g; + return $name; +} + +sub parse_range { + my ($text) = @_; + my ($start, $end) = split /\.\./, $text; + return (hex($start), hex(defined $end ? $end : $start)); +} + +read_source($_) for @sources; + +my $version_path = File::Spec->catfile($unicore, 'version'); +open my $version_input, '<', $version_path or die "Cannot read $version_path: $!\n"; +chomp(my $unicode_version = <$version_input>); +close $version_input or die "Cannot close $version_path: $!\n"; +die "Expected Unicode $expected_version, found $unicode_version\n" + unless $unicode_version eq $expected_version; + +my (@short_values, @long_values, %alias_index); +for my $line (split /\n/, $sources[1]{text}) { + next if $line =~ /^\s*#/; + $line =~ s/#.*$//; + my @fields = map { trim($_) } split /;/, $line; + next unless @fields >= 3 && $fields[0] eq 'bc'; + my $index = scalar @short_values; + push @short_values, $fields[1]; + push @long_values, $fields[2]; + for my $alias (@fields[1 .. $#fields]) { + next unless length $alias; + my $loose = loose_name($alias); + die "Bidi_Class alias collision for '$alias'\n" + if exists $alias_index{$loose} && $alias_index{$loose} != $index; + $alias_index{$loose} = $index; + } +} +die "Expected 23 Bidi_Class values, found " . scalar(@short_values) . "\n" + unless @short_values == 23; + +my %property_aliases; +for my $line (split /\n/, $sources[2]{text}) { + next if $line =~ /^\s*#/; + $line =~ s/#.*$//; + my @fields = map { trim($_) } split /;/, $line; + next unless @fields >= 2 && ($fields[0] eq 'bc' || $fields[1] eq 'Bidi_Class'); + $property_aliases{loose_name($_)} = 1 for grep { length } @fields; +} +die "Pinned property aliases do not define bc and Bidi_Class\n" + unless $property_aliases{bc} && $property_aliases{bidiclass}; + +my (@missing, @explicit); +for my $line (split /\n/, $sources[0]{text}) { + if ($line =~ /^#\s*\@missing:\s*([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*;\s*([A-Za-z_]+)/) { + my ($range, $value) = ($1, $2); + my ($start, $end) = parse_range($range); + my $index = $alias_index{loose_name($value)}; + die "Unknown \@missing Bidi_Class value '$value'\n" unless defined $index; + push @missing, [$start, $end, $index]; + next; + } + next unless $line =~ /^([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*;\s*([A-Za-z_]+)/; + my ($range, $value) = ($1, $2); + my ($start, $end) = parse_range($range); + my $index = $alias_index{loose_name($value)}; + die "Unknown explicit Bidi_Class value '$value'\n" unless defined $index; + push @explicit, [$start, $end, $index]; +} +die "Bidi_Class data has no ranges or defaults\n" unless @explicit && @missing; + +my $default_index = $alias_index{loose_name('Left_To_Right')}; +my @code_value = ($default_index) x 0x110000; +for my $range (@missing) { + my ($code, $end, $index) = @$range; + $code_value[$code++] = $index while $code <= $end; +} +for my $range (@explicit) { + my ($code, $end, $index) = @$range; + $code_value[$code++] = $index while $code <= $end; +} + +my @ranges; +my ($range_start, $range_value) = (0, $code_value[0]); +for my $code (1 .. 0x10ffff) { + next if $code_value[$code] == $range_value; + push @ranges, [$range_start, $code - 1, $range_value]; + ($range_start, $range_value) = ($code, $code_value[$code]); +} +push @ranges, [$range_start, 0x10ffff, $range_value]; + +print <<'HEADER'; +/* + * Generated from Perl 5.44's pinned Unicode Character Database. Do not edit manually. + * +HEADER +for my $source (@sources) { + print " * Source: $source->{name}\n"; + for my $line (split /\n/, $source->{text}) { + next unless $line =~ /^# (?:©|Unicode and|the U\.S\.|For terms of use and license)/; + $line =~ s/^# / * /; + print "$line\n"; + } + print " *\n"; +} +print <<'HEADER_END'; + */ +package org.perlonjava.runtime.regex; + +import com.ibm.icu.text.UnicodeSet; + +final class PerlUnicodeBidiClassData { +HEADER_END + +print " static final String UNICODE_VERSION = \"$unicode_version\";\n"; +print " static final String DBIDI_CLASS_SHA256 = \"$sources[0]{hash}\";\n"; +print " static final String PROP_VALUE_ALIASES_SHA256 = \"$sources[1]{hash}\";\n"; +print " static final String PROPERTY_ALIASES_SHA256 = \"$sources[2]{hash}\";\n\n"; + +print " private static final String[] SHORT_VALUES = {\n "; +print join(', ', map { qq{"$_"} } @short_values); +print "\n };\n"; +print " private static final String[] LONG_VALUES = {\n "; +print join(', ', map { qq{"$_"} } @long_values); +print "\n };\n"; + +my @aliases = sort keys %alias_index; +print " private static final String[] VALUE_ALIASES = {\n "; +print join(', ', map { qq{"$_"} } @aliases); +print "\n };\n"; +print " private static final byte[] VALUE_ALIAS_INDEX = {\n "; +print join(', ', map { $alias_index{$_} } @aliases); +print "\n };\n"; + +my @property_aliases = sort keys %property_aliases; +print " private static final String[] PROPERTY_ALIASES = {\n "; +print join(', ', map { qq{"$_"} } @property_aliases); +print "\n };\n\n"; + +print " private static final int[] RANGES = {\n"; +for (my $i = 0; $i < @ranges; $i += 4) { + my $end = $i + 3 < $#ranges ? $i + 3 : $#ranges; + print " ", join(', ', map { + sprintf '0x%X, 0x%X, %d', @{$ranges[$_]}[0, 1, 2] + } $i .. $end), ",\n"; +} +print <<'FOOTER'; + }; + + private static final UnicodeSet[] VALUE_SETS = buildValueSets(); + + static boolean isPropertyAlias(String alias) { + String loose = looseName(alias); + if (loose == null) return false; + for (String candidate : PROPERTY_ALIASES) { + if (candidate.equals(loose)) return true; + } + return false; + } + + static UnicodeSet valueSet(String alias) { + int index = valueIndex(alias); + return index < 0 ? null : VALUE_SETS[index]; + } + + static String shortValue(String alias) { + int index = valueIndex(alias); + return index < 0 ? null : SHORT_VALUES[index]; + } + + static String canonicalValue(String alias) { + int index = valueIndex(alias); + return index < 0 ? null : LONG_VALUES[index]; + } + + static String[] canonicalValues() { + return LONG_VALUES.clone(); + } + + private static int valueIndex(String alias) { + String loose = looseName(alias); + if (loose == null) return -1; + for (int i = 0; i < VALUE_ALIASES.length; i++) { + if (VALUE_ALIASES[i].equals(loose)) return VALUE_ALIAS_INDEX[i]; + } + return -1; + } + + private static String looseName(String name) { + if (name == null) return null; + StringBuilder loose = new StringBuilder(name.length()); + for (int i = 0; i < name.length(); i++) { + char character = name.charAt(i); + if (character == '_' || character == '-' || Character.isWhitespace(character)) continue; + loose.append(Character.toLowerCase(character)); + } + return loose.toString(); + } + + private static UnicodeSet[] buildValueSets() { + UnicodeSet[] sets = new UnicodeSet[LONG_VALUES.length]; + for (int i = 0; i < sets.length; i++) sets[i] = new UnicodeSet(); + for (int i = 0; i < RANGES.length; i += 3) { + sets[RANGES[i + 2]].add(RANGES[i], RANGES[i + 1]); + } + for (UnicodeSet set : sets) set.freeze(); + return sets; + } + + private PerlUnicodeBidiClassData() { + } +} +FOOTER diff --git a/dev/tools/generate_perl_unicode_block_data.pl b/dev/tools/generate_perl_unicode_block_data.pl new file mode 100644 index 0000000000..f92f652fe5 --- /dev/null +++ b/dev/tools/generate_perl_unicode_block_data.pl @@ -0,0 +1,351 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Digest::SHA qw(sha256_hex); +use File::Spec; +use FindBin; + +binmode STDOUT, ':raw'; + +my $expected_version = '17.0.0'; +my @required_sources = qw(version Blocks.txt PropertyAliases.txt PropValueAliases.txt); +my $local_unicore = File::Spec->catdir($FindBin::Bin, '..', '..', 'perl5', 'lib', 'unicore'); +my $vendored_unicore = File::Spec->catdir($FindBin::Bin, '..', 'unicode', $expected_version); + +sub missing_sources { + my ($root) = @_; + return grep { !-f File::Spec->catfile($root, $_) } @required_sources; +} + +my @local_missing = missing_sources($local_unicore); +my @vendored_missing = missing_sources($vendored_unicore); +my $unicore = !@local_missing ? $local_unicore + : !@vendored_missing ? $vendored_unicore + : die "No complete Unicode $expected_version source tree: local missing " + . join(', ', @local_missing) . '; vendored missing ' + . join(', ', @vendored_missing) . "\n"; +my %sources = ( + Version => [File::Spec->catfile($unicore, 'version'), + '8c30575264b2772c7a69c5bb6069a28f0e0a7a0df735871bde2d99ee674316ac'], + Blocks => [File::Spec->catfile($unicore, 'Blocks.txt'), + 'c0edefaf1a19771e830a82735472716af6bf3c3975f6c2a23ffbe2580fbbcb15'], + Property_Aliases => [File::Spec->catfile($unicore, 'PropertyAliases.txt'), + '4441f573caf952ffece1d7c892e7715bd7136dfc26f96eb6f268bf1e474715fb'], + Property_Value_Aliases => [File::Spec->catfile($unicore, 'PropValueAliases.txt'), + '670d2bebb48649c04fabfbf033308073dcff47946324a8033237254c048b3b01'], +); + +sub source_text { + my ($name) = @_; + my ($path, $expected_hash) = @{$sources{$name}}; + open my $input, '<:raw', $path or die "Cannot read $path: $!\n"; + local $/; + my $text = <$input>; + close $input or die "Cannot close $path: $!\n"; + my $actual_hash = sha256_hex($text); + die "$path SHA-256 mismatch: expected $expected_hash, found $actual_hash\n" + unless $actual_hash eq $expected_hash; + return ($path, $text); +} + +sub trim { + my ($text) = @_; + $text =~ s/^\s+|\s+$//g; + return $text; +} + +sub loose { + my ($text) = @_; + $text = lc $text; + $text =~ s/[\x09-\x0d _-]+//g; + return $text; +} + +sub range_from_text { + my ($range) = @_; + my ($first, $last) = split /\.\./, $range; + return (hex($first), hex(defined $last ? $last : $first)); +} + +sub verify_unicode_notice { + my ($path, $text) = @_; + die "$path does not preserve the Unicode copyright notice\n" + unless $text =~ /^# © 2025 Unicode®, Inc\.$/m; + die "$path does not preserve the Unicode trademark notice\n" + unless $text =~ /^# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc\. in the U\.S\. and other countries\.$/m; + die "$path does not preserve the Unicode terms notice\n" + unless $text =~ m{^# For terms of use and license, see https://www\.unicode\.org/terms_of_use\.html$}m; +} + +my ($version_path, $version_text) = source_text('Version'); +$version_text =~ s/\s+\z//; +die "Expected Unicode $expected_version, found '$version_text' in $version_path\n" + unless $version_text eq $expected_version; + +my ($property_path, $property_text) = source_text('Property_Aliases'); +die "$property_path is not pinned Unicode $expected_version data\n" + unless $property_text =~ /^# PropertyAliases-\Q$expected_version\E\.txt$/m; +verify_unicode_notice($property_path, $property_text); +my @property_aliases; +for my $line (split /\n/, $property_text) { + $line =~ s/#.*//; + my @fields = map { trim($_) } split /;/, $line, -1; + next unless @fields >= 2 && $fields[0] eq 'blk'; + @property_aliases = grep { length } @fields; +} +die "Unexpected Block aliases in $property_path: @property_aliases\n" + unless join("\0", @property_aliases) eq join("\0", 'blk', 'Block'); + +my ($value_path, $value_text) = source_text('Property_Value_Aliases'); +die "$value_path is not pinned Unicode $expected_version data\n" + unless $value_text =~ /^# PropertyValueAliases-\Q$expected_version\E\.txt$/m; +verify_unicode_notice($value_path, $value_text); +my (@value_rows, %row_for_long, %row_for_alias); +my $in_block_values = 0; +for my $line (split /\n/, $value_text) { + if ($line =~ /^# Block \(blk\)$/) { + $in_block_values = 1; + next; + } + last if $in_block_values && $line =~ /^# /; + next unless $in_block_values && $line =~ /^blk\s*;/; + $line =~ s/#.*//; + my @fields = map { trim($_) } split /;/, $line, -1; + shift @fields; + @fields = grep { length } @fields; + die "Block value record lacks short/long aliases: '$line'\n" unless @fields >= 2; + my $row = scalar @value_rows; + push @value_rows, \@fields; + my $long_key = loose($fields[1]); + die "Duplicate Block long alias '$fields[1]'\n" if exists $row_for_long{$long_key}; + $row_for_long{$long_key} = $row; + for my $alias (@fields) { + my $key = loose($alias); + die "Block alias '$alias' collides across values\n" + if exists $row_for_alias{$key} && $row_for_alias{$key} != $row; + $row_for_alias{$key} = $row; + } +} +die "Expected 347 Block value records, found " . scalar(@value_rows) . "\n" + unless @value_rows == 347; +my %exact_aliases; +my $alias_field_count = 0; +for my $row (@value_rows) { + $alias_field_count += @$row; + $exact_aliases{$_} = 1 for @$row; +} +die "Expected 700 Block alias fields, found $alias_field_count\n" + unless $alias_field_count == 700; +die "Expected 496 exact Block aliases, found " . scalar(keys %exact_aliases) . "\n" + unless keys(%exact_aliases) == 496; +die "Expected 495 loose Block aliases, found " . scalar(keys %row_for_alias) . "\n" + unless keys(%row_for_alias) == 495; +my $no_block_row = $row_for_long{loose('No_Block')}; +die "Missing No_Block aliases\n" unless defined $no_block_row; + +my ($blocks_path, $blocks_text) = source_text('Blocks'); +die "$blocks_path is not pinned Unicode $expected_version data\n" + unless $blocks_text =~ /^# Blocks-\Q$expected_version\E\.txt$/m; +verify_unicode_notice($blocks_path, $blocks_text); +my (@missing, @explicit); +for my $line (split /\n/, $blocks_text) { + if ($line =~ /^\#\s*\@missing:\s*([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*; + \s*([^#]+?)\s*$/x) { + my ($first, $last) = range_from_text($1); + push @missing, [$first, $last, trim($2)]; + next; + } + next if $line =~ /^\s*(?:#|$)/; + die "Malformed Blocks record '$line'\n" + unless $line =~ /^([0-9A-F]+\.\.[0-9A-F]+)\s*;\s*([^#]+?)\s*$/; + my ($first, $last) = range_from_text($1); + push @explicit, [$first, $last, trim($2)]; +} +die "Expected one ordered Block \@missing rule\n" + unless @missing == 1 && $missing[0][0] == 0 && $missing[0][1] == 0x10ffff + && loose($missing[0][2]) eq loose('No_Block'); +die "Expected 346 explicit Block ranges, found " . scalar(@explicit) . "\n" + unless @explicit == 346; + +my @value_names = ('No_Block'); +my %value_id_for_row = ($no_block_row => 0); +my $explicit_count = 0; +for my $index (0 .. $#explicit) { + my ($first, $last, $source_name) = @{$explicit[$index]}; + die sprintf("Invalid Block range U+%04X..U+%04X\n", $first, $last) + if $first < 0 || $last > 0x10ffff || $first > $last; + die sprintf("Block range is not aligned to hex columns: U+%04X..U+%04X\n", $first, $last) + if ($first & 0xf) != 0 || ($last & 0xf) != 0xf; + die sprintf("Overlapping or out-of-order Block range at U+%04X\n", $first) + if $index > 0 && $first <= $explicit[$index - 1][1]; + my $row = $row_for_long{loose($source_name)}; + die "Block '$source_name' has no long value alias\n" unless defined $row; + die "Block '$source_name' is represented by more than one range\n" + if exists $value_id_for_row{$row}; + my $value_id = scalar @value_names; + $value_id_for_row{$row} = $value_id; + push @value_names, $value_rows[$row][1]; + $explicit[$index][2] = $value_id; + $explicit_count += $last - $first + 1; +} +die "Expected 347 reachable Block values, found " . scalar(@value_names) . "\n" + unless @value_names == 347 && keys(%value_id_for_row) == 347; +die "Expected 303,808 named-Block code points, found $explicit_count\n" + unless $explicit_count == 303_808; + +my @partition; +my $cursor = 0; +for my $range (@explicit) { + push @partition, [$cursor, $range->[0] - 1, 0] if $cursor < $range->[0]; + push @partition, [@$range]; + $cursor = $range->[1] + 1; +} +push @partition, [$cursor, 0x10ffff, 0] if $cursor <= 0x10ffff; +die "Expected 397 complete Block intervals, found " . scalar(@partition) . "\n" + unless @partition == 397; +my ($partition_count, $no_block_count, $no_block_ranges) = (0, 0, 0); +for my $index (0 .. $#partition) { + my ($first, $last, $value_id) = @{$partition[$index]}; + die "Block partition is not contiguous\n" + if ($index == 0 && $first != 0) + || ($index > 0 && $first != $partition[$index - 1][1] + 1); + die "Block partition value is out of bounds\n" + if $value_id < 0 || $value_id >= @value_names; + my $count = $last - $first + 1; + $partition_count += $count; + if ($value_id == 0) { + $no_block_count += $count; + $no_block_ranges++; + } +} +die "Block partition does not end at U+10FFFF\n" + unless $partition[-1][1] == 0x10ffff; +die "Block partition does not cover the Unicode scalar universe\n" + unless $partition_count == 0x110000; +die "Expected 51 No_Block ranges and 810,304 code points\n" + unless $no_block_ranges == 51 && $no_block_count == 810_304; + +my %alias_value_id; +for my $key (keys %row_for_alias) { + my $value_id = $value_id_for_row{$row_for_alias{$key}}; + die "Block alias '$key' has no reachable value\n" unless defined $value_id; + $alias_value_id{$key} = $value_id; +} +my @alias_keys = sort keys %alias_value_id; + +print <<'HEADER'; +package org.perlonjava.runtime.regex; + +import com.ibm.icu.text.UnicodeSet; +import java.util.Arrays; + +/* + * Generated from Perl 5.44's pinned Unicode Character Database by + * dev/tools/generate_perl_unicode_block_data.pl. Do not edit manually. + * + * Unicode data source copyright: + * © 2025 Unicode®, Inc. + * Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in + * the U.S. and other countries. + * For terms of use and license, see https://www.unicode.org/terms_of_use.html + */ +final class PerlUnicodeBlockData { +HEADER + +print " static final String UNICODE_VERSION = \"$expected_version\";\n"; +print " static final short INVALID = -1;\n"; +print " static final short NO_BLOCK = 0;\n\n"; +print " private static final String[] VALUE_NAMES = {\n"; +for (my $i = 0; $i < @value_names; $i += 6) { + my $end = $i + 5 < $#value_names ? $i + 5 : $#value_names; + print " ", join(', ', map { qq{\"$value_names[$_]\"} } $i .. $end), ",\n"; +} +print " };\n\n private static final int[] RANGES = {\n"; +for (my $i = 0; $i < @partition; $i += 3) { + my $end = $i + 2 < $#partition ? $i + 2 : $#partition; + my @items = map { sprintf("0x%X, 0x%X, %d,", @$_) } + @partition[$i .. $end]; + print " ", join(' ', @items), "\n"; +} +print " };\n\n private static final String[] ALIAS_KEYS = {\n"; +for (my $i = 0; $i < @alias_keys; $i += 6) { + my $end = $i + 5 < $#alias_keys ? $i + 5 : $#alias_keys; + print " ", join(', ', map { qq{\"$alias_keys[$_]\"} } $i .. $end), ",\n"; +} +print " };\n\n private static final short[] ALIAS_VALUE_IDS = {\n"; +for (my $i = 0; $i < @alias_keys; $i += 20) { + my $end = $i + 19 < $#alias_keys ? $i + 19 : $#alias_keys; + print " ", join(', ', map { $alias_value_id{$alias_keys[$_]} } $i .. $end), ",\n"; +} +print <<'FOOTER'; + }; + + private static final UnicodeSet[] SETS = buildSets(); + + static int valueCount() { + return VALUE_NAMES.length; + } + + static int aliasCount() { + return ALIAS_KEYS.length; + } + + static int rangeCount() { + return RANGES.length / 3; + } + + static String canonicalValue(int valueId) { + return VALUE_NAMES[valueId]; + } + + static UnicodeSet set(int valueId) { + return SETS[valueId]; + } + + static UnicodeSet set(String valueAlias) { + short valueId = value(valueAlias); + return valueId == INVALID ? null : SETS[valueId]; + } + + static short value(String valueAlias) { + String key = loose(valueAlias); + int index = Arrays.binarySearch(ALIAS_KEYS, key); + return index < 0 ? INVALID : ALIAS_VALUE_IDS[index]; + } + + static boolean isPropertyAlias(String alias) { + boolean hasIsPrefix = alias != null && alias.startsWith("Is"); + String normalized = loose(hasIsPrefix ? alias.substring(2) : alias); + return normalized.equals("blk") || normalized.equals("block"); + } + + private static UnicodeSet[] buildSets() { + UnicodeSet[] sets = new UnicodeSet[VALUE_NAMES.length]; + for (int valueId = 0; valueId < sets.length; valueId++) { + sets[valueId] = new UnicodeSet(); + } + for (int offset = 0; offset < RANGES.length; offset += 3) { + sets[RANGES[offset + 2]].add(RANGES[offset], RANGES[offset + 1]); + } + for (int valueId = 0; valueId < sets.length; valueId++) { + sets[valueId].freeze(); + } + return sets; + } + + private static String loose(String alias) { + if (alias == null) return ""; + StringBuilder normalized = new StringBuilder(alias.length()); + for (int i = 0; i < alias.length(); i++) { + char character = alias.charAt(i); + if (character == '_' || character == '-' || character == ' ' + || (character >= '\t' && character <= '\r')) continue; + normalized.append(Character.toLowerCase(character)); + } + return normalized.toString(); + } + + private PerlUnicodeBlockData() { + } +} +FOOTER diff --git a/dev/tools/generate_perl_unicode_combining_class_data.pl b/dev/tools/generate_perl_unicode_combining_class_data.pl new file mode 100644 index 0000000000..397c7c5f58 --- /dev/null +++ b/dev/tools/generate_perl_unicode_combining_class_data.pl @@ -0,0 +1,214 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Digest::SHA qw(sha256_hex); + +my $unicode_root = 'perl5/lib/unicore'; +my $expected_unicode_version = '17.0.0'; +my %expected_hash = ( + 'extracted/DCombiningClass.txt' => + '191463abfbd202703c6fd6776a92a23ac44ec65e0476a7f95aa91ca492cef29b', + 'PropValueAliases.txt' => + '670d2bebb48649c04fabfbf033308073dcff47946324a8033237254c048b3b01', +); + +open my $version_fh, '<', "$unicode_root/version" + or die "Can't read Unicode version: $!\n"; +chomp(my $unicode_version = <$version_fh>); +close $version_fh; +die "Expected Unicode $expected_unicode_version, found $unicode_version\n" + unless $unicode_version eq $expected_unicode_version; + +sub read_pinned_file { + my ($relative) = @_; + my $path = "$unicode_root/$relative"; + open my $fh, '<:raw', $path or die "Can't read $path: $!\n"; + local $/; + my $text = <$fh>; + close $fh; + my $actual = sha256_hex($text); + die "$path SHA-256 mismatch: expected $expected_hash{$relative}, found $actual\n" + unless $actual eq $expected_hash{$relative}; + return $text; +} + +sub normalized_alias { + my ($alias) = @_; + $alias = lc $alias; + $alias =~ s/[\s_+\-]//g; + $alias =~ s/^0+(?=\d)// if $alias =~ /^\d+$/; + return $alias; +} + +my $class_text = read_pinned_file('extracted/DCombiningClass.txt'); +die "Combining class data is not Unicode $expected_unicode_version\n" + unless $class_text =~ /^# DerivedCombiningClass-\Q$expected_unicode_version\E\.txt/m; + +my (@values, %value_index, @ranges); +for my $line (split /\n/, $class_text) { + next unless $line =~ /^([0-9A-F]+)(?:\.\.([0-9A-F]+))?\s*;\s*([0-9]+)/; + my ($start, $end, $value) = + (hex($1), defined($2) ? hex($2) : hex($1), int($3)); + if (!exists $value_index{$value}) { + $value_index{$value} = scalar @values; + push @values, $value; + } + my $index = $value_index{$value}; + if (@ranges && $ranges[-1][2] == $index && $ranges[-1][1] + 1 == $start) { + $ranges[-1][1] = $end; + } else { + push @ranges, [$start, $end, $index]; + } +} +die "No Canonical_Combining_Class ranges found\n" unless @ranges; +die "Unexpected Canonical_Combining_Class default\n" + unless $class_text =~ /^# \@missing:\s*0000\.\.10FFFF;\s*Not_Reordered\s*$/m; + +my $alias_text = read_pinned_file('PropValueAliases.txt'); +die "Property value aliases are not Unicode $expected_unicode_version\n" + unless $alias_text =~ /^# PropertyValueAliases-\Q$expected_unicode_version\E\.txt/m; +my %aliases; +for my $line (split /\n/, $alias_text) { + $line =~ s/\s*#.*$//; + next unless $line =~ /\S/; + my @fields = map { + my $field = $_; + $field =~ s/^\s+|\s+$//g; + $field; + } split /;/, $line; + next unless @fields >= 4 && lc($fields[0]) eq 'ccc'; + my $canonical = int($fields[1]); + if (!exists $value_index{$canonical}) { + $value_index{$canonical} = scalar @values; + push @values, $canonical; + } + for my $alias (@fields[1 .. $#fields]) { + next unless length $alias; + my $normalized = normalized_alias($alias); + if (exists $aliases{$normalized} && $aliases{$normalized} != $canonical) { + die "Conflicting combining-class alias $alias\n"; + } + $aliases{$normalized} = $canonical; + } +} +for my $value (@values) { + $aliases{normalized_alias($value)} //= $value; +} + +print <<'HEADER'; +/* + * Generated from Perl 5.44's Unicode Character Database. Do not edit manually. + * + * Unicode data source copyright: + * © 2025 Unicode®, Inc. + * Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in + * the U.S. and other countries. + * For terms of use and license, see https://www.unicode.org/terms_of_use.html + */ +package org.perlonjava.runtime.regex; + +import com.ibm.icu.text.UnicodeSet; + +import java.util.HashMap; +import java.util.Map; + +final class PerlUnicodeCombiningClassData { +HEADER + +print " static final String UNICODE_VERSION = \"$unicode_version\";\n"; +print " private static final int DEFAULT_VALUE_INDEX = $value_index{0};\n"; +print " private static final int[] VALUES = {\n "; +print join(', ', @values); +print "\n };\n\n"; + +my $range_chunk_size = 400; +my $range_chunk_count = int((@ranges + $range_chunk_size - 1) / $range_chunk_size); +for my $chunk (0 .. $range_chunk_count - 1) { + my $first = $chunk * $range_chunk_size; + my $last = $first + $range_chunk_size - 1; + $last = $#ranges if $last > $#ranges; + print " private static int[] rangeChunk$chunk() {\n"; + print " return new int[] {\n"; + for (my $i = $first; $i <= $last; $i += 4) { + my $end = $i + 3 < $last ? $i + 3 : $last; + print " ", join(', ', map { + sprintf '0x%X, 0x%X, %d', @{$ranges[$_]}[0, 1, 2] + } $i .. $end), ",\n"; + } + print " };\n"; + print " }\n\n"; +} +print " private static final int[][] RANGE_CHUNKS = {\n "; +print join(', ', map { "rangeChunk$_()" } 0 .. $range_chunk_count - 1); +print "\n };\n\n"; + +print " private static final String[] ALIASES = {\n"; +my @alias_names = sort keys %aliases; +for (my $i = 0; $i < @alias_names; $i += 4) { + my $end = $i + 3 < $#alias_names ? $i + 3 : $#alias_names; + print " ", join(', ', map { + my $name = $alias_names[$_]; + qq{"$name", "} . $aliases{$name} . qq{"} + } $i .. $end), ",\n"; +} +print <<'FOOTER'; + }; + + private static final UnicodeSet[] SETS = buildSets(); + private static final Map ALIAS_INDEX = buildAliasIndex(); + + static UnicodeSet resolve(String value) { + Integer index = ALIAS_INDEX.get(normalizeValue(value)); + return index == null ? null : SETS[index]; + } + + private static UnicodeSet[] buildSets() { + UnicodeSet[] sets = new UnicodeSet[VALUES.length]; + for (int i = 0; i < sets.length; i++) sets[i] = new UnicodeSet(); + UnicodeSet covered = new UnicodeSet(); + for (int[] ranges : RANGE_CHUNKS) { + for (int i = 0; i < ranges.length; i += 3) { + sets[ranges[i + 2]].add(ranges[i], ranges[i + 1]); + covered.add(ranges[i], ranges[i + 1]); + } + } + sets[DEFAULT_VALUE_INDEX].addAll( + new UnicodeSet(0, 0x10FFFF).removeAll(covered)); + for (UnicodeSet set : sets) set.freeze(); + return sets; + } + + private static Map buildAliasIndex() { + Map valueIndexes = new HashMap<>(); + for (int i = 0; i < VALUES.length; i++) valueIndexes.put(VALUES[i], i); + Map indexes = new HashMap<>(); + for (int i = 0; i < ALIASES.length; i += 2) { + indexes.put(ALIASES[i], valueIndexes.get(Integer.parseInt(ALIASES[i + 1]))); + } + return Map.copyOf(indexes); + } + + private static String normalizeValue(String value) { + String normalized = value.trim(); + if (normalized.startsWith(":\\A") && normalized.endsWith("\\z:") + && normalized.length() > 6) { + normalized = normalized.substring(3, normalized.length() - 3); + } + StringBuilder loose = new StringBuilder(normalized.length()); + boolean numeric = true; + for (int i = 0; i < normalized.length(); i++) { + char ch = normalized.charAt(i); + if (Character.isWhitespace(ch) || ch == '-' || ch == '_' || ch == '+') continue; + if (!Character.isDigit(ch)) numeric = false; + loose.append(Character.toLowerCase(ch)); + } + if (!numeric) return loose.toString(); + int first = 0; + while (first + 1 < loose.length() && loose.charAt(first) == '0') first++; + return loose.substring(first); + } + + private PerlUnicodeCombiningClassData() { + } +} +FOOTER diff --git a/dev/tools/generate_perl_unicode_decomposition_type_data.pl b/dev/tools/generate_perl_unicode_decomposition_type_data.pl new file mode 100644 index 0000000000..ce03f179c8 --- /dev/null +++ b/dev/tools/generate_perl_unicode_decomposition_type_data.pl @@ -0,0 +1,359 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Digest::SHA qw(sha256_hex); +use File::Spec; +use FindBin; + +binmode STDOUT, ':raw'; + +my $expected_version = '17.0.0'; +my @required_sources = ( + 'version', File::Spec->catfile('extracted', 'DDecompositionType.txt'), + 'PropertyAliases.txt', 'PropValueAliases.txt', +); +my $local_unicore = File::Spec->catdir($FindBin::Bin, '..', '..', 'perl5', 'lib', 'unicore'); +my $vendored_unicore = File::Spec->catdir($FindBin::Bin, '..', 'unicode', $expected_version); + +sub missing_sources { + my ($root) = @_; + return grep { !-f File::Spec->catfile($root, $_) } @required_sources; +} + +my @local_missing = missing_sources($local_unicore); +my @vendored_missing = missing_sources($vendored_unicore); +my $unicore = !@local_missing ? $local_unicore + : !@vendored_missing ? $vendored_unicore + : die "No complete Unicode $expected_version source tree: local missing " + . join(', ', @local_missing) . '; vendored missing ' + . join(', ', @vendored_missing) . "\n"; +my %sources = ( + Version => [File::Spec->catfile($unicore, 'version'), + '8c30575264b2772c7a69c5bb6069a28f0e0a7a0df735871bde2d99ee674316ac'], + Decomposition_Type => [File::Spec->catfile($unicore, 'extracted', 'DDecompositionType.txt'), + 'f44e5ceaf40edc1fe06ea0404e8bebc7d356dcc38aac076543b6874008a06e3e'], + Property_Aliases => [File::Spec->catfile($unicore, 'PropertyAliases.txt'), + '4441f573caf952ffece1d7c892e7715bd7136dfc26f96eb6f268bf1e474715fb'], + Property_Value_Aliases => [File::Spec->catfile($unicore, 'PropValueAliases.txt'), + '670d2bebb48649c04fabfbf033308073dcff47946324a8033237254c048b3b01'], +); + +sub source_text { + my ($name) = @_; + my ($path, $expected_hash) = @{$sources{$name}}; + open my $input, '<:raw', $path or die "Cannot read $path: $!\n"; + local $/; + my $text = <$input>; + close $input or die "Cannot close $path: $!\n"; + my $actual_hash = sha256_hex($text); + die "$path SHA-256 mismatch: expected $expected_hash, found $actual_hash\n" + unless $actual_hash eq $expected_hash; + return ($path, $text); +} + +sub trim { + my ($text) = @_; + $text =~ s/^\s+|\s+$//g; + return $text; +} + +sub loose { + my ($text) = @_; + $text = lc $text; + $text =~ s/[\s_-]+//g; + return $text; +} + +sub range_from_text { + my ($range) = @_; + my ($first, $last) = split /\.\./, $range; + return (hex($first), hex(defined $last ? $last : $first)); +} + +sub verify_unicode_notice { + my ($path, $text) = @_; + die "$path does not preserve the Unicode copyright notice\n" + unless $text =~ /^# © 2025 Unicode®, Inc\.$/m; + die "$path does not preserve the Unicode terms notice\n" + unless $text =~ m{^# For terms of use and license, see https://www\.unicode\.org/terms_of_use\.html$}m; +} + +my ($version_path, $version_text) = source_text('Version'); +$version_text =~ s/\s+\z//; +die "Expected Unicode $expected_version, found '$version_text' in $version_path\n" + unless $version_text eq $expected_version; + +my ($data_path, $data_text) = source_text('Decomposition_Type'); +die "$data_path is not pinned Unicode $expected_version data\n" + unless $data_text =~ /^# DerivedDecompositionType-\Q$expected_version\E\.txt$/m; +verify_unicode_notice($data_path, $data_text); + +my (@ranges, @missing); +for my $line (split /\n/, $data_text) { + if ($line =~ /^#\s*\@missing:\s*([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*;\s*([A-Za-z0-9_]+)/) { + my ($first, $last) = range_from_text($1); + push @missing, [$first, $last, $2]; + next; + } + next unless $line =~ /^([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*;\s*([A-Za-z0-9_]+)/; + my ($first, $last) = range_from_text($1); + push @ranges, [$first, $last, $2]; +} +die "No Decomposition_Type ranges found in $data_path\n" unless @ranges; +die "No ordered \@missing rules found in $data_path\n" unless @missing; +@ranges = sort { $a->[0] <=> $b->[0] } @ranges; +for my $index (1 .. $#ranges) { + die sprintf("Overlapping Decomposition_Type ranges at U+%04X\n", $ranges[$index][0]) + if $ranges[$index][0] <= $ranges[$index - 1][1]; +} + +my ($property_path, $property_text) = source_text('Property_Aliases'); +die "$property_path is not pinned Unicode $expected_version data\n" + unless $property_text =~ /^# PropertyAliases-\Q$expected_version\E\.txt$/m; +verify_unicode_notice($property_path, $property_text); +my @property_aliases; +for my $line (split /\n/, $property_text) { + $line =~ s/#.*//; + my @fields = map { trim($_) } split /;/, $line, -1; + next unless @fields >= 2 && $fields[0] eq 'dt'; + @property_aliases = grep { length } @fields; +} +die "Missing dt aliases in $property_path\n" unless @property_aliases; + +my ($value_path, $value_text) = source_text('Property_Value_Aliases'); +die "$value_path is not pinned Unicode $expected_version data\n" + unless $value_text =~ /^# PropertyValueAliases-\Q$expected_version\E\.txt$/m; +verify_unicode_notice($value_path, $value_text); +my (@values, %value_index, %value_aliases); +for my $line (split /\n/, $value_text) { + $line =~ s/#.*//; + my @fields = map { trim($_) } split /;/, $line, -1; + next unless @fields >= 3 && $fields[0] eq 'dt'; + my ($short, $canonical, @extra) = @fields[1 .. $#fields]; + if (!exists $value_index{$canonical}) { + $value_index{$canonical} = scalar @values; + push @values, $canonical; + } + my $id = $value_index{$canonical}; + for my $alias (grep { length } ($short, $canonical, @extra)) { + my $normalized = loose($alias); + die "Conflicting Decomposition_Type alias '$alias'\n" + if exists $value_aliases{$normalized} && $value_aliases{$normalized} != $id; + $value_aliases{$normalized} = $id; + } +} +die "Expected 18 Decomposition_Type values, found " . scalar(@values) . "\n" + unless @values == 18; + +# Perl adds one valid union value beyond the Unicode property-value aliases. +# perl5/lib/unicore/mktables names it Non_Canon / Non_Canonical and defines it +# as the union of every non-canonical decomposition type. +my $non_canonical_id = scalar @values; +push @values, 'Non_Canonical'; +$value_index{Non_Canonical} = $non_canonical_id; +$value_aliases{loose('Non_Canon')} = $non_canonical_id; +$value_aliases{loose('Non_Canonical')} = $non_canonical_id; + +for my $range (@ranges, @missing) { + die "Unknown Decomposition_Type value '$range->[2]'\n" + unless exists $value_index{$range->[2]}; +} + +my %starts = (0 => 1); +for my $range (@ranges, @missing) { + die "Invalid Unicode range U+" . sprintf('%X', $range->[0]) . "..U+" + . sprintf('%X', $range->[1]) . "\n" + if $range->[0] < 0 || $range->[1] > 0x10ffff || $range->[0] > $range->[1]; + $starts{$range->[0]} = 1; + $starts{$range->[1] + 1} = 1 if $range->[1] < 0x10ffff; +} +my @starts = sort { $a <=> $b } keys %starts; + +sub value_at { + my ($code, $explicit, $defaults) = @_; + my $value; + # UAX #44 applies @missing rules in source order; a later matching rule wins. + for my $range (@$defaults) { + $value = $range->[2] if $range->[0] <= $code && $code <= $range->[1]; + } + my ($low, $high) = (0, $#$explicit); + while ($low <= $high) { + my $middle = ($low + $high) >> 1; + if ($explicit->[$middle][0] <= $code) { + $low = $middle + 1; + } else { + $high = $middle - 1; + } + } + $value = $explicit->[$high][2] + if $high >= 0 && $code <= $explicit->[$high][1]; + die sprintf("No Decomposition_Type value covers U+%04X\n", $code) + unless defined $value; + return $value; +} + +# Guard the ordering contract even though Unicode 17 currently has one rule. +my @ordered_missing_probe = ( + [0x0000, 0x10ffff, 'None'], + [0x1000, 0x10ff, 'Compat'], + [0x1080, 0x10af, 'Wide'], +); +my @explicit_probe = ([0x10a0, 0x10a0, 'Canonical']); +my @probe_codes = (0x0fff, 0x1000, 0x107f, 0x1080, 0x109f, 0x10a0, 0x10af, 0x10b0, 0x1100); +my @probe_expected = qw(None Compat Compat Wide Wide Canonical Wide Compat None); +for my $index (0 .. $#probe_codes) { + die "Ordered \@missing rule self-check failed\n" + unless value_at($probe_codes[$index], \@explicit_probe, \@ordered_missing_probe) + eq $probe_expected[$index]; +} + +my (@coalesced_starts, @coalesced_values); +for my $code (@starts) { + my $id = $value_index{value_at($code, \@ranges, \@missing)}; + next if @coalesced_values && $id == $coalesced_values[-1]; + push @coalesced_starts, $code; + push @coalesced_values, $id; +} +die "Generated partition does not begin at U+0000\n" + unless @coalesced_starts && $coalesced_starts[0] == 0; + +my %constant_for; +for my $value (@values) { + my $constant = uc $value; + $constant =~ s/[^A-Z0-9]+/_/g; + $constant_for{$value} = $constant; +} + +print <<'HEADER'; +package org.perlonjava.runtime.regex; + +/* + * Generated from Perl 5.44's pinned Unicode Character Database by + * dev/tools/generate_perl_unicode_decomposition_type_data.pl. Do not edit manually. + * + * Unicode data source copyright: + * © 2025 Unicode®, Inc. + * Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in + * the U.S. and other countries. + * For terms of use and license, see https://www.unicode.org/terms_of_use.html + */ +final class PerlUnicodeDecompositionTypeData { +HEADER + +print " static final String UNICODE_VERSION = \"$expected_version\";\n"; +for my $value (@values) { + print " static final byte $constant_for{$value} = $value_index{$value};\n"; +} +print " static final byte INVALID = -1;\n\n"; +print " private static final String[] CANONICAL_NAMES = {\n "; +print join(', ', map { qq{"$_"} } @values); +print "\n };\n\n"; +print " private static final int[] STARTS = {\n"; +for (my $i = 0; $i < @coalesced_starts; $i += 10) { + my $end = $i + 9 < $#coalesced_starts ? $i + 9 : $#coalesced_starts; + print " ", join(', ', map { sprintf '0x%X', $coalesced_starts[$_] } $i .. $end), ",\n"; +} +print " };\n\n private static final byte[] VALUES = {\n"; +for (my $i = 0; $i < @coalesced_values; $i += 18) { + my $end = $i + 17 < $#coalesced_values ? $i + 17 : $#coalesced_values; + print " ", join(', ', @coalesced_values[$i .. $end]), ",\n"; +} +print <<'METHODS'; + }; + + static byte propertyOf(int codePoint) { + if (codePoint < 0 || codePoint > 0x10ffff) { + throw new IllegalArgumentException("Not a Unicode code point: " + codePoint); + } + int low = 0; + int high = STARTS.length - 1; + while (low <= high) { + int middle = (low + high) >>> 1; + if (STARTS[middle] <= codePoint) { + low = middle + 1; + } else { + high = middle - 1; + } + } + return VALUES[high]; + } + + static int rangeCount() { + return STARTS.length; + } + + static int rangeStart(int index) { + return STARTS[index]; + } + + static int rangeEnd(int index) { + return index + 1 < STARTS.length ? STARTS[index + 1] - 1 : 0x10ffff; + } + + static byte rangeValue(int index) { + return VALUES[index]; + } + + static boolean isPropertyAlias(String alias) { + boolean hasIsPrefix = alias != null && alias.startsWith("Is"); + String normalized = loose(hasIsPrefix ? alias.substring(2) : alias); + switch (normalized) { +METHODS +for my $alias (sort { loose($a) cmp loose($b) } @property_aliases) { + print ' case "', loose($alias), "\":\n"; +} +print <<'PROPERTY_FOOTER'; + return true; + default: + return false; + } + } + + static byte valueForAlias(String alias) { + String normalized = loose(alias); + switch (normalized) { +PROPERTY_FOOTER +my %aliases_by_id; +for my $alias (sort keys %value_aliases) { + push @{$aliases_by_id{$value_aliases{$alias}}}, $alias; +} +for my $id (0 .. $#values) { + for my $alias (@{$aliases_by_id{$id}}) { + print " case \"$alias\":\n"; + } + print " return $constant_for{$values[$id]};\n"; +} +print <<'FOOTER'; + default: + return INVALID; + } + } + + static String canonicalValueName(byte value) { + return value >= 0 && value < CANONICAL_NAMES.length + ? CANONICAL_NAMES[value] : null; + } + + static boolean matches(byte property, byte requested) { + if (requested == NON_CANONICAL) { + return property != CANONICAL && property != NONE; + } + return property == requested; + } + + private static String loose(String alias) { + if (alias == null) return ""; + StringBuilder normalized = new StringBuilder(alias.length()); + for (int i = 0; i < alias.length(); i++) { + char character = alias.charAt(i); + if (character == '_' || character == '-' || character == ' ' + || (character >= '\t' && character <= '\r')) continue; + normalized.append(Character.toLowerCase(character)); + } + return normalized.toString(); + } + + private PerlUnicodeDecompositionTypeData() { + } +} +FOOTER diff --git a/dev/tools/generate_perl_unicode_east_asian_width_data.pl b/dev/tools/generate_perl_unicode_east_asian_width_data.pl new file mode 100644 index 0000000000..d2fd0137d7 --- /dev/null +++ b/dev/tools/generate_perl_unicode_east_asian_width_data.pl @@ -0,0 +1,266 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Digest::SHA qw(sha256_hex); +use File::Spec; +use FindBin; + +my $expected_version = '17.0.0'; +my $root = File::Spec->catdir($FindBin::Bin, '..', '..'); +my $unicore = File::Spec->catdir($root, 'perl5', 'lib', 'unicore'); +my @sources = ( + { + name => 'DerivedEastAsianWidth-17.0.0.txt', + path => File::Spec->catfile($unicore, 'extracted', 'DEastAsianWidth.txt'), + hash => '0b5523a2217cb318d20b329a05d31eec5af5686ba09d263b85bb75a28989a3a8', + version => qr/^# DerivedEastAsianWidth-\Q$expected_version\E\.txt$/m, + }, + { + name => 'PropertyValueAliases-17.0.0.txt', + path => File::Spec->catfile($unicore, 'PropValueAliases.txt'), + hash => '670d2bebb48649c04fabfbf033308073dcff47946324a8033237254c048b3b01', + version => qr/^# PropertyValueAliases-\Q$expected_version\E\.txt$/m, + }, + { + name => 'PropertyAliases-17.0.0.txt', + path => File::Spec->catfile($unicore, 'PropertyAliases.txt'), + hash => '4441f573caf952ffece1d7c892e7715bd7136dfc26f96eb6f268bf1e474715fb', + version => qr/^# PropertyAliases-\Q$expected_version\E\.txt$/m, + }, +); + +sub read_source { + my ($source) = @_; + open my $input, '<:raw', $source->{path} + or die "Cannot read $source->{path}: $!\n"; + local $/; + my $text = <$input>; + close $input or die "Cannot close $source->{path}: $!\n"; + my $actual_hash = sha256_hex($text); + die "$source->{path} SHA-256 mismatch: expected $source->{hash}, found $actual_hash\n" + unless $actual_hash eq $source->{hash}; + die "$source->{path} is not pinned Unicode $expected_version data\n" + unless $text =~ $source->{version}; + $source->{text} = $text; +} + +sub trim { + my ($text) = @_; + $text =~ s/^\s+|\s+$//g; + return $text; +} + +sub loose_name { + my ($name) = @_; + $name = lc $name; + $name =~ s/[\s_-]+//g; + return $name; +} + +sub parse_range { + my ($text) = @_; + my ($start, $end) = split /\.\./, $text; + return (hex($start), hex(defined $end ? $end : $start)); +} + +read_source($_) for @sources; + +my $version_path = File::Spec->catfile($unicore, 'version'); +open my $version_input, '<', $version_path or die "Cannot read $version_path: $!\n"; +chomp(my $unicode_version = <$version_input>); +close $version_input or die "Cannot close $version_path: $!\n"; +die "Expected Unicode $expected_version, found $unicode_version\n" + unless $unicode_version eq $expected_version; + +my (@short_values, @long_values, %alias_index); +for my $line (split /\n/, $sources[1]{text}) { + next if $line =~ /^\s*#/; + $line =~ s/#.*$//; + my @fields = map { trim($_) } split /;/, $line; + next unless @fields >= 3 && $fields[0] eq 'ea'; + my $index = scalar @short_values; + push @short_values, $fields[1]; + push @long_values, $fields[2]; + for my $alias (@fields[1 .. $#fields]) { + next unless length $alias; + my $loose = loose_name($alias); + die "East_Asian_Width alias collision for '$alias'\n" + if exists $alias_index{$loose} && $alias_index{$loose} != $index; + $alias_index{$loose} = $index; + } +} +die "Expected 6 East_Asian_Width values, found " . scalar(@short_values) . "\n" + unless @short_values == 6; + +my %property_aliases; +for my $line (split /\n/, $sources[2]{text}) { + next if $line =~ /^\s*#/; + $line =~ s/#.*$//; + my @fields = map { trim($_) } split /;/, $line; + next unless @fields >= 2 && ($fields[0] eq 'ea' || $fields[1] eq 'East_Asian_Width'); + $property_aliases{loose_name($_)} = 1 for grep { length } @fields; +} +die "Pinned property aliases do not define ea and East_Asian_Width\n" + unless $property_aliases{ea} && $property_aliases{eastasianwidth}; + +my (@missing, @explicit); +for my $line (split /\n/, $sources[0]{text}) { + if ($line =~ /^#\s*\@missing:\s*([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*;\s*([A-Za-z_]+)/) { + my ($range, $value) = ($1, $2); + my ($start, $end) = parse_range($range); + my $index = $alias_index{loose_name($value)}; + die "Unknown \@missing East_Asian_Width value '$value'\n" unless defined $index; + push @missing, [$start, $end, $index]; + next; + } + next unless $line =~ /^([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*;\s*([A-Za-z_]+)/; + my ($range, $value) = ($1, $2); + my ($start, $end) = parse_range($range); + my $index = $alias_index{loose_name($value)}; + die "Unknown explicit East_Asian_Width value '$value'\n" unless defined $index; + push @explicit, [$start, $end, $index]; +} +die "East_Asian_Width data has no ranges or defaults\n" unless @explicit && @missing; + +my $default_index = $alias_index{loose_name('Neutral')}; +my @code_value = ($default_index) x 0x110000; +for my $range (@missing) { + my ($code, $end, $index) = @$range; + $code_value[$code++] = $index while $code <= $end; +} +for my $range (@explicit) { + my ($code, $end, $index) = @$range; + $code_value[$code++] = $index while $code <= $end; +} + +my @ranges; +my ($range_start, $range_value) = (0, $code_value[0]); +for my $code (1 .. 0x10ffff) { + next if $code_value[$code] == $range_value; + push @ranges, [$range_start, $code - 1, $range_value]; + ($range_start, $range_value) = ($code, $code_value[$code]); +} +push @ranges, [$range_start, 0x10ffff, $range_value]; + +print <<'HEADER'; +/* + * Generated from Perl 5.44's pinned Unicode Character Database. Do not edit manually. + * +HEADER +for my $source (@sources) { + print " * Source: $source->{name}\n"; + for my $line (split /\n/, $source->{text}) { + next unless $line =~ /^# (?:©|Unicode and|the U\.S\.|For terms of use and license)/; + $line =~ s/^# / * /; + print "$line\n"; + } + print " *\n"; +} +print <<'HEADER_END'; + */ +package org.perlonjava.runtime.regex; + +import com.ibm.icu.text.UnicodeSet; + +final class PerlUnicodeEastAsianWidthData { +HEADER_END + +print " static final String UNICODE_VERSION = \"$unicode_version\";\n"; +print " static final String DEAST_ASIAN_WIDTH_SHA256 = \"$sources[0]{hash}\";\n"; +print " static final String PROP_VALUE_ALIASES_SHA256 = \"$sources[1]{hash}\";\n"; +print " static final String PROPERTY_ALIASES_SHA256 = \"$sources[2]{hash}\";\n\n"; + +print " private static final String[] SHORT_VALUES = {\n "; +print join(', ', map { qq{"$_"} } @short_values); +print "\n };\n"; +print " private static final String[] LONG_VALUES = {\n "; +print join(', ', map { qq{"$_"} } @long_values); +print "\n };\n"; + +my @aliases = sort keys %alias_index; +print " private static final String[] VALUE_ALIASES = {\n "; +print join(', ', map { qq{"$_"} } @aliases); +print "\n };\n"; +print " private static final byte[] VALUE_ALIAS_INDEX = {\n "; +print join(', ', map { $alias_index{$_} } @aliases); +print "\n };\n"; + +my @property_aliases = sort keys %property_aliases; +print " private static final String[] PROPERTY_ALIASES = {\n "; +print join(', ', map { qq{"$_"} } @property_aliases); +print "\n };\n\n"; + +print " private static final int[] RANGES = {\n"; +for (my $i = 0; $i < @ranges; $i += 4) { + my $end = $i + 3 < $#ranges ? $i + 3 : $#ranges; + print " ", join(', ', map { + sprintf '0x%X, 0x%X, %d', @{$ranges[$_]}[0, 1, 2] + } $i .. $end), ",\n"; +} +print <<'FOOTER'; + }; + + private static final UnicodeSet[] VALUE_SETS = buildValueSets(); + + static boolean isPropertyAlias(String alias) { + String loose = looseName(alias); + if (loose == null) return false; + for (String candidate : PROPERTY_ALIASES) { + if (candidate.equals(loose)) return true; + } + return false; + } + + static UnicodeSet valueSet(String alias) { + int index = valueIndex(alias); + return index < 0 ? null : VALUE_SETS[index]; + } + + static String shortValue(String alias) { + int index = valueIndex(alias); + return index < 0 ? null : SHORT_VALUES[index]; + } + + static String canonicalValue(String alias) { + int index = valueIndex(alias); + return index < 0 ? null : LONG_VALUES[index]; + } + + static String[] canonicalValues() { + return LONG_VALUES.clone(); + } + + private static int valueIndex(String alias) { + String loose = looseName(alias); + if (loose == null) return -1; + for (int i = 0; i < VALUE_ALIASES.length; i++) { + if (VALUE_ALIASES[i].equals(loose)) return VALUE_ALIAS_INDEX[i]; + } + return -1; + } + + private static String looseName(String name) { + if (name == null) return null; + StringBuilder loose = new StringBuilder(name.length()); + for (int i = 0; i < name.length(); i++) { + char character = name.charAt(i); + if (character == '_' || character == '-' || Character.isWhitespace(character)) continue; + loose.append(Character.toLowerCase(character)); + } + return loose.toString(); + } + + private static UnicodeSet[] buildValueSets() { + UnicodeSet[] sets = new UnicodeSet[LONG_VALUES.length]; + for (int i = 0; i < sets.length; i++) sets[i] = new UnicodeSet(); + for (int i = 0; i < RANGES.length; i += 3) { + sets[RANGES[i + 2]].add(RANGES[i], RANGES[i + 1]); + } + for (UnicodeSet set : sets) set.freeze(); + return sets; + } + + private PerlUnicodeEastAsianWidthData() { + } +} +FOOTER diff --git a/dev/tools/generate_perl_unicode_general_category_data.pl b/dev/tools/generate_perl_unicode_general_category_data.pl new file mode 100644 index 0000000000..1de28460ae --- /dev/null +++ b/dev/tools/generate_perl_unicode_general_category_data.pl @@ -0,0 +1,226 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Digest::SHA qw(sha256_hex); + +my $unicode_root = 'perl5/lib/unicore'; +my $expected_unicode_version = '17.0.0'; +my %expected_hash = ( + 'extracted/DGeneralCategory.txt' => + 'd62e5bab70ca74f099343f71224fa051cb1fdd61a1ab45c0488c44cfc0b6102e', + 'PropValueAliases.txt' => + '670d2bebb48649c04fabfbf033308073dcff47946324a8033237254c048b3b01', +); + +open my $version_fh, '<', "$unicode_root/version" + or die "Can't read Unicode version: $!\n"; +chomp(my $unicode_version = <$version_fh>); +close $version_fh; +die "Expected Unicode $expected_unicode_version, found $unicode_version\n" + unless $unicode_version eq $expected_unicode_version; + +sub read_pinned_file { + my ($relative) = @_; + my $path = "$unicode_root/$relative"; + open my $fh, '<:raw', $path or die "Can't read $path: $!\n"; + local $/; + my $text = <$fh>; + close $fh; + my $actual = sha256_hex($text); + die "$path SHA-256 mismatch: expected $expected_hash{$relative}, found $actual\n" + unless $actual eq $expected_hash{$relative}; + return $text; +} + +sub loose_name { + my ($name) = @_; + $name = lc $name; + $name =~ s/[\s_-]//g; + return $name; +} + +my $category_text = read_pinned_file('extracted/DGeneralCategory.txt'); +die "General_Category data is not Unicode $expected_unicode_version\n" + unless $category_text =~ /^# DerivedGeneralCategory-\Q$expected_unicode_version\E\.txt/m; + +my (@values, %value_index, @ranges); +for my $line (split /\n/, $category_text) { + next unless $line =~ /^([0-9A-F]+)(?:\.\.([0-9A-F]+))?\s*;\s*([A-Za-z]+)/; + my ($start, $end, $value) = + (hex($1), defined($2) ? hex($2) : hex($1), $3); + if (!exists $value_index{$value}) { + $value_index{$value} = scalar @values; + push @values, $value; + } + my $index = $value_index{$value}; + if (@ranges && $ranges[-1][2] == $index && $ranges[-1][1] + 1 == $start) { + $ranges[-1][1] = $end; + } else { + push @ranges, [$start, $end, $index]; + } +} +die "No General_Category ranges found\n" unless @ranges; + +# DerivedGeneralCategory contains the 30 atomic values. Perl also exposes the +# Unicode aggregate aliases from PropertyValueAliases.txt; materialize their +# unions from the same pinned atomic ranges so no host Unicode table is used. +my %composite = ( + C => [qw(Cc Cf Cn Co Cs)], + L => [qw(Ll Lm Lo Lt Lu)], + LC => [qw(Ll Lt Lu)], + M => [qw(Mc Me Mn)], + N => [qw(Nd Nl No)], + P => [qw(Pc Pd Pe Pf Pi Po Ps)], + S => [qw(Sc Sk Sm So)], + Z => [qw(Zl Zp Zs)], +); +my @atomic_ranges = @ranges; +for my $value (qw(C L LC M N P S Z)) { + $value_index{$value} = scalar @values; + push @values, $value; + my %member = map { + die "Composite $value references unknown category $_\n" + unless exists $value_index{$_}; + $value_index{$_} => 1; + } @{$composite{$value}}; + push @ranges, map { + [$_->[0], $_->[1], $value_index{$value}] + } grep { $member{$_->[2]} } @atomic_ranges; +} + +my $alias_text = read_pinned_file('PropValueAliases.txt'); +die "Property value aliases are not Unicode $expected_unicode_version\n" + unless $alias_text =~ /^# PropertyValueAliases-\Q$expected_unicode_version\E\.txt/m; + +my %aliases; +for my $line (split /\n/, $alias_text) { + $line =~ s/\s*#.*$//; + next unless $line =~ /\S/; + my @fields = map { + my $field = $_; + $field =~ s/^\s+|\s+$//g; + $field; + } split /;/, $line; + next unless @fields >= 3 && lc($fields[0]) eq 'gc'; + my $canonical = $fields[1]; + die "General_Category alias has unknown value $canonical\n" + unless exists $value_index{$canonical}; + for my $alias (@fields[1 .. $#fields]) { + next unless length $alias; + my $loose = loose_name($alias); + if (exists $aliases{$loose} && $aliases{$loose} ne $canonical) { + die "Conflicting General_Category alias $alias\n"; + } + $aliases{$loose} = $canonical; + } +} +for my $value (@values) { + $aliases{loose_name($value)} //= $value; +} + +print <<'HEADER'; +/* + * Generated from Perl 5.44's Unicode Character Database. Do not edit manually. + * + * Unicode data source copyright: + * © 2025 Unicode®, Inc. + * Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in + * the U.S. and other countries. + * For terms of use and license, see https://www.unicode.org/terms_of_use.html + */ +package org.perlonjava.runtime.regex; + +import com.ibm.icu.text.UnicodeSet; + +import java.util.HashMap; +import java.util.Map; + +final class PerlUnicodeGeneralCategoryData { +HEADER + +print " static final String UNICODE_VERSION = \"$unicode_version\";\n"; +print " private static final String[] VALUES = {\n "; +print join(', ', map { qq{"$_"} } @values); +print "\n };\n\n"; +my $range_chunk_size = 400; +my $range_chunk_count = int((@ranges + $range_chunk_size - 1) / $range_chunk_size); +for my $chunk (0 .. $range_chunk_count - 1) { + my $first = $chunk * $range_chunk_size; + my $last = $first + $range_chunk_size - 1; + $last = $#ranges if $last > $#ranges; + print " private static int[] rangeChunk$chunk() {\n"; + print " return new int[] {\n"; + for (my $i = $first; $i <= $last; $i += 4) { + my $end = $i + 3 < $last ? $i + 3 : $last; + print " ", join(', ', map { + sprintf '0x%X, 0x%X, %d', @{$ranges[$_]}[0, 1, 2] + } $i .. $end), ",\n"; + } + print " };\n"; + print " }\n\n"; +} +print " private static final int[][] RANGE_CHUNKS = {\n "; +print join(', ', map { "rangeChunk$_()" } 0 .. $range_chunk_count - 1); +print "\n };\n\n"; +print " private static final String[] ALIASES = {\n"; +my @alias_names = sort keys %aliases; +for (my $i = 0; $i < @alias_names; $i += 4) { + my $end = $i + 3 < $#alias_names ? $i + 3 : $#alias_names; + print " ", join(', ', map { + my $name = $alias_names[$_]; + qq{"$name", "} . $aliases{$name} . qq{"} + } $i .. $end), ",\n"; +} +print <<'FOOTER'; + }; + + private static final UnicodeSet[] SETS = buildSets(); + private static final Map ALIAS_INDEX = buildAliasIndex(); + + static UnicodeSet resolve(String value) { + Integer index = ALIAS_INDEX.get(normalizeValue(value)); + return index == null ? null : SETS[index]; + } + + private static UnicodeSet[] buildSets() { + UnicodeSet[] sets = new UnicodeSet[VALUES.length]; + for (int i = 0; i < sets.length; i++) sets[i] = new UnicodeSet(); + for (int[] ranges : RANGE_CHUNKS) { + for (int i = 0; i < ranges.length; i += 3) { + sets[ranges[i + 2]].add(ranges[i], ranges[i + 1]); + } + } + for (UnicodeSet set : sets) set.freeze(); + return sets; + } + + private static Map buildAliasIndex() { + Map valueIndexes = new HashMap<>(); + for (int i = 0; i < VALUES.length; i++) valueIndexes.put(VALUES[i], i); + Map indexes = new HashMap<>(); + for (int i = 0; i < ALIASES.length; i += 2) { + indexes.put(ALIASES[i], valueIndexes.get(ALIASES[i + 1])); + } + return Map.copyOf(indexes); + } + + private static String normalizeValue(String value) { + String normalized = value.trim(); + if (normalized.startsWith(":\\A") && normalized.endsWith("\\z:") + && normalized.length() > 6) { + normalized = normalized.substring(3, normalized.length() - 3); + } + StringBuilder loose = new StringBuilder(normalized.length()); + for (int i = 0; i < normalized.length(); i++) { + char ch = normalized.charAt(i); + if (!Character.isWhitespace(ch) && ch != '-' && ch != '_') { + loose.append(Character.toLowerCase(ch)); + } + } + return loose.toString(); + } + + private PerlUnicodeGeneralCategoryData() { + } +} +FOOTER diff --git a/dev/tools/generate_perl_unicode_joining_group_data.pl b/dev/tools/generate_perl_unicode_joining_group_data.pl new file mode 100644 index 0000000000..6cbe596d42 --- /dev/null +++ b/dev/tools/generate_perl_unicode_joining_group_data.pl @@ -0,0 +1,279 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Digest::SHA qw(sha256_hex); +use File::Spec; +use FindBin; + +my $expected_version = '17.0.0'; +my $root = File::Spec->catdir($FindBin::Bin, '..', '..'); +my $unicore = File::Spec->catdir($root, 'perl5', 'lib', 'unicore'); +my @sources = ( + { + name => 'DerivedJoiningGroup-17.0.0.txt', + path => File::Spec->catfile($unicore, 'extracted', 'DJoinGroup.txt'), + hash => 'bb67e0c00b88acfa5be633967b66b23326844a86e49c6fde7b57960d3af66cae', + version => qr/^# DerivedJoiningGroup-\Q$expected_version\E\.txt$/m, + }, + { + name => 'PropertyValueAliases-17.0.0.txt', + path => File::Spec->catfile($unicore, 'PropValueAliases.txt'), + hash => '670d2bebb48649c04fabfbf033308073dcff47946324a8033237254c048b3b01', + version => qr/^# PropertyValueAliases-\Q$expected_version\E\.txt$/m, + }, + { + name => 'PropertyAliases-17.0.0.txt', + path => File::Spec->catfile($unicore, 'PropertyAliases.txt'), + hash => '4441f573caf952ffece1d7c892e7715bd7136dfc26f96eb6f268bf1e474715fb', + version => qr/^# PropertyAliases-\Q$expected_version\E\.txt$/m, + }, +); + +sub read_source { + my ($source) = @_; + open my $input, '<:raw', $source->{path} + or die "Cannot read $source->{path}: $!\n"; + local $/; + my $text = <$input>; + close $input or die "Cannot close $source->{path}: $!\n"; + my $actual_hash = sha256_hex($text); + die "$source->{path} SHA-256 mismatch: expected $source->{hash}, found $actual_hash\n" + unless $actual_hash eq $source->{hash}; + die "$source->{path} is not pinned Unicode $expected_version data\n" + unless $text =~ $source->{version}; + $source->{text} = $text; +} + +sub trim { + my ($text) = @_; + $text =~ s/^\s+|\s+$//g; + return $text; +} + +sub loose_name { + my ($name) = @_; + $name = lc $name; + $name =~ s/[\s_-]+//g; + return $name; +} + +sub parse_range { + my ($text) = @_; + my ($start, $end) = split /\.\./, $text; + return (hex($start), hex(defined $end ? $end : $start)); +} + +read_source($_) for @sources; + +my $version_path = File::Spec->catfile($unicore, 'version'); +open my $version_input, '<', $version_path or die "Cannot read $version_path: $!\n"; +chomp(my $unicode_version = <$version_input>); +close $version_input or die "Cannot close $version_path: $!\n"; +die "Expected Unicode $expected_version, found $unicode_version\n" + unless $unicode_version eq $expected_version; + +my (@short_values, @long_values, %alias_index, %wildcard_value_index); +for my $line (split /\n/, $sources[1]{text}) { + next if $line =~ /^\s*#/; + $line =~ s/#.*$//; + my @fields = map { trim($_) } split /;/, $line; + next unless @fields >= 3 && $fields[0] eq 'jg'; + my $index = scalar @short_values; + push @short_values, $fields[1]; + push @long_values, $fields[2]; + for my $alias (@fields[1 .. $#fields]) { + next unless length $alias; + my $loose = loose_name($alias); + die "Joining_Group alias collision for '$alias'\n" + if exists $alias_index{$loose} && $alias_index{$loose} != $index; + $alias_index{$loose} = $index; + die "Joining_Group wildcard alias collision for '$alias'\n" + if exists $wildcard_value_index{$alias} + && $wildcard_value_index{$alias} != $index; + $wildcard_value_index{$alias} = $index; + } +} +die "Expected 106 Joining_Group values, found " . scalar(@short_values) . "\n" + unless @short_values == 106; + +my %property_aliases; +for my $line (split /\n/, $sources[2]{text}) { + next if $line =~ /^\s*#/; + $line =~ s/#.*$//; + my @fields = map { trim($_) } split /;/, $line; + next unless @fields >= 2 && ($fields[0] eq 'jg' || $fields[1] eq 'Joining_Group'); + $property_aliases{loose_name($_)} = 1 for grep { length } @fields; +} +die "Pinned property aliases do not define jg and Joining_Group\n" + unless $property_aliases{jg} && $property_aliases{joininggroup}; + +my (@missing, @explicit); +for my $line (split /\n/, $sources[0]{text}) { + if ($line =~ /^#\s*\@missing:\s*([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*;\s*([A-Za-z_]+)/) { + my ($range, $value) = ($1, $2); + my ($start, $end) = parse_range($range); + my $index = $alias_index{loose_name($value)}; + die "Unknown \@missing Joining_Group value '$value'\n" unless defined $index; + push @missing, [$start, $end, $index]; + next; + } + next unless $line =~ /^([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*;\s*([A-Za-z_]+)/; + my ($range, $value) = ($1, $2); + my ($start, $end) = parse_range($range); + my $index = $alias_index{loose_name($value)}; + die "Unknown explicit Joining_Group value '$value'\n" unless defined $index; + push @explicit, [$start, $end, $index]; +} +die "Joining_Group data has no ranges or defaults\n" unless @explicit && @missing; + +my $default_index = $alias_index{loose_name('No_Joining_Group')}; +my @code_value = ($default_index) x 0x110000; +for my $range (@missing) { + my ($code, $end, $index) = @$range; + $code_value[$code++] = $index while $code <= $end; +} +for my $range (@explicit) { + my ($code, $end, $index) = @$range; + $code_value[$code++] = $index while $code <= $end; +} + +my @ranges; +my ($range_start, $range_value) = (0, $code_value[0]); +for my $code (1 .. 0x10ffff) { + next if $code_value[$code] == $range_value; + push @ranges, [$range_start, $code - 1, $range_value]; + ($range_start, $range_value) = ($code, $code_value[$code]); +} +push @ranges, [$range_start, 0x10ffff, $range_value]; + +print <<'HEADER'; +/* + * Generated from Perl 5.44's pinned Unicode Character Database. Do not edit manually. + * +HEADER +for my $source (@sources) { + print " * Source: $source->{name}\n"; + for my $line (split /\n/, $source->{text}) { + next unless $line =~ /^# (?:©|Unicode and|the U\.S\.|For terms of use and license)/; + $line =~ s/^# / * /; + print "$line\n"; + } + print " *\n"; +} +print <<'HEADER_END'; + */ +package org.perlonjava.runtime.regex; + +import com.ibm.icu.text.UnicodeSet; + +final class PerlUnicodeJoiningGroupData { +HEADER_END + +print " static final String UNICODE_VERSION = \"$unicode_version\";\n"; +print " static final String DJOIN_GROUP_SHA256 = \"$sources[0]{hash}\";\n"; +print " static final String PROP_VALUE_ALIASES_SHA256 = \"$sources[1]{hash}\";\n"; +print " static final String PROPERTY_ALIASES_SHA256 = \"$sources[2]{hash}\";\n\n"; + +print " private static final String[] SHORT_VALUES = {\n "; +print join(', ', map { qq{"$_"} } @short_values); +print "\n };\n"; +print " private static final String[] LONG_VALUES = {\n "; +print join(', ', map { qq{"$_"} } @long_values); +print "\n };\n"; + +my @aliases = sort keys %alias_index; +print " private static final String[] VALUE_ALIASES = {\n "; +print join(', ', map { qq{"$_"} } @aliases); +print "\n };\n"; +print " private static final byte[] VALUE_ALIAS_INDEX = {\n "; +print join(', ', map { $alias_index{$_} } @aliases); +print "\n };\n"; + +my @wildcard_values = sort keys %wildcard_value_index; +print " private static final String[] WILDCARD_VALUES = {\n "; +print join(', ', map { qq{\"$_\"} } @wildcard_values); +print "\n };\n"; + +my @property_aliases = sort keys %property_aliases; +print " private static final String[] PROPERTY_ALIASES = {\n "; +print join(', ', map { qq{"$_"} } @property_aliases); +print "\n };\n\n"; + +print " private static final int[] RANGES = {\n"; +for (my $i = 0; $i < @ranges; $i += 4) { + my $end = $i + 3 < $#ranges ? $i + 3 : $#ranges; + print " ", join(', ', map { + sprintf '0x%X, 0x%X, %d', @{$ranges[$_]}[0, 1, 2] + } $i .. $end), ",\n"; +} +print <<'FOOTER'; + }; + + private static final UnicodeSet[] VALUE_SETS = buildValueSets(); + + static boolean isPropertyAlias(String alias) { + String loose = looseName(alias); + if (loose == null) return false; + for (String candidate : PROPERTY_ALIASES) { + if (candidate.equals(loose)) return true; + } + return false; + } + + static UnicodeSet valueSet(String alias) { + int index = valueIndex(alias); + return index < 0 ? null : VALUE_SETS[index]; + } + + static String shortValue(String alias) { + int index = valueIndex(alias); + return index < 0 ? null : SHORT_VALUES[index]; + } + + static String canonicalValue(String alias) { + int index = valueIndex(alias); + return index < 0 ? null : LONG_VALUES[index]; + } + + static String[] canonicalValues() { + return LONG_VALUES.clone(); + } + + static String[] wildcardValues() { + return WILDCARD_VALUES.clone(); + } + + private static int valueIndex(String alias) { + String loose = looseName(alias); + if (loose == null) return -1; + for (int i = 0; i < VALUE_ALIASES.length; i++) { + if (VALUE_ALIASES[i].equals(loose)) return VALUE_ALIAS_INDEX[i]; + } + return -1; + } + + private static String looseName(String name) { + if (name == null) return null; + StringBuilder loose = new StringBuilder(name.length()); + for (int i = 0; i < name.length(); i++) { + char character = name.charAt(i); + if (character == '_' || character == '-' || Character.isWhitespace(character)) continue; + loose.append(Character.toLowerCase(character)); + } + return loose.toString(); + } + + private static UnicodeSet[] buildValueSets() { + UnicodeSet[] sets = new UnicodeSet[LONG_VALUES.length]; + for (int i = 0; i < sets.length; i++) sets[i] = new UnicodeSet(); + for (int i = 0; i < RANGES.length; i += 3) { + sets[RANGES[i + 2]].add(RANGES[i], RANGES[i + 1]); + } + for (UnicodeSet set : sets) set.freeze(); + return sets; + } + + private PerlUnicodeJoiningGroupData() { + } +} +FOOTER diff --git a/dev/tools/generate_perl_unicode_numeric_value_data.pl b/dev/tools/generate_perl_unicode_numeric_value_data.pl new file mode 100644 index 0000000000..c35c37f9e7 --- /dev/null +++ b/dev/tools/generate_perl_unicode_numeric_value_data.pl @@ -0,0 +1,427 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Config; +use Digest::SHA qw(sha256_hex); +use File::Spec; +use FindBin; + +binmode STDOUT, ':raw'; + +my $expected_version = '17.0.0'; +my @required_sources = ( + 'version', File::Spec->catfile('extracted', 'DNumValues.txt'), + 'PropertyAliases.txt', 'PropValueAliases.txt', +); +my $local_unicore = File::Spec->catdir($FindBin::Bin, '..', '..', 'perl5', 'lib', 'unicore'); +my $vendored_unicore = File::Spec->catdir($FindBin::Bin, '..', 'unicode', $expected_version); + +sub missing_sources { + my ($root) = @_; + return grep { !-f File::Spec->catfile($root, $_) } @required_sources; +} + +my @local_missing = missing_sources($local_unicore); +my @vendored_missing = missing_sources($vendored_unicore); +my $unicore = !@local_missing ? $local_unicore + : !@vendored_missing ? $vendored_unicore + : die "No complete Unicode $expected_version source tree: local missing " + . join(', ', @local_missing) . '; vendored missing ' + . join(', ', @vendored_missing) . "\n"; +my %sources = ( + Version => [File::Spec->catfile($unicore, 'version'), + '8c30575264b2772c7a69c5bb6069a28f0e0a7a0df735871bde2d99ee674316ac'], + Numeric_Value => [File::Spec->catfile($unicore, 'extracted', 'DNumValues.txt'), + '139b976bdc288be01c80f018523da769cf2845109b5a7f0f8a432db64bfedcfa'], + Property_Aliases => [File::Spec->catfile($unicore, 'PropertyAliases.txt'), + '4441f573caf952ffece1d7c892e7715bd7136dfc26f96eb6f268bf1e474715fb'], + Property_Value_Aliases => [File::Spec->catfile($unicore, 'PropValueAliases.txt'), + '670d2bebb48649c04fabfbf033308073dcff47946324a8033237254c048b3b01'], +); + +die "Numeric_Value generation requires 64-bit Perl integers\n" + unless $Config{ivsize} >= 8; + +sub source_text { + my ($name) = @_; + my ($path, $expected_hash) = @{$sources{$name}}; + open my $input, '<:raw', $path or die "Cannot read $path: $!\n"; + local $/; + my $text = <$input>; + close $input or die "Cannot close $path: $!\n"; + my $actual_hash = sha256_hex($text); + die "$path SHA-256 mismatch: expected $expected_hash, found $actual_hash\n" + unless $actual_hash eq $expected_hash; + return ($path, $text); +} + +sub trim { + my ($text) = @_; + $text =~ s/^\s+|\s+$//g; + return $text; +} + +sub loose { + my ($text) = @_; + $text = lc $text; + $text =~ s/[\x09-\x0d _-]+//g; + return $text; +} + +sub range_from_text { + my ($range) = @_; + my ($first, $last) = split /\.\./, $range; + return (hex($first), hex(defined $last ? $last : $first)); +} + +sub verify_unicode_notice { + my ($path, $text) = @_; + die "$path does not preserve the Unicode copyright notice\n" + unless $text =~ /^# © 2025 Unicode®, Inc\.$/m; + die "$path does not preserve the Unicode terms notice\n" + unless $text =~ m{^# For terms of use and license, see https://www\.unicode\.org/terms_of_use\.html$}m; +} + +sub gcd { + my ($left, $right) = @_; + $left = -$left if $left < 0; + while ($right != 0) { + ($left, $right) = ($right, $left % $right); + } + return $left; +} + +my ($version_path, $version_text) = source_text('Version'); +$version_text =~ s/\s+\z//; +die "Expected Unicode $expected_version, found '$version_text' in $version_path\n" + unless $version_text eq $expected_version; + +my ($property_path, $property_text) = source_text('Property_Aliases'); +die "$property_path is not pinned Unicode $expected_version data\n" + unless $property_text =~ /^# PropertyAliases-\Q$expected_version\E\.txt$/m; +verify_unicode_notice($property_path, $property_text); +my @property_aliases; +for my $line (split /\n/, $property_text) { + $line =~ s/#.*//; + my @fields = map { trim($_) } split /;/, $line, -1; + next unless @fields >= 2 && $fields[0] eq 'nv'; + @property_aliases = grep { length } @fields; +} +die "Missing nv aliases in $property_path\n" unless @property_aliases; +die "Unexpected nv aliases in $property_path: @property_aliases\n" + unless join("\0", @property_aliases) eq join("\0", 'nv', 'Numeric_Value'); + +my ($value_path, $value_text) = source_text('Property_Value_Aliases'); +die "$value_path is not pinned Unicode $expected_version data\n" + unless $value_text =~ /^# PropertyValueAliases-\Q$expected_version\E\.txt$/m; +verify_unicode_notice($value_path, $value_text); +my @missing; +for my $line (split /\n/, $value_text) { + if ($line =~ /^\#\s*\@missing:\s*([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*; + \s*Numeric_Value\s*;\s*([A-Za-z0-9_]+)/x) { + my ($first, $last) = range_from_text($1); + push @missing, [$first, $last, $2]; + } +} +die "Expected one Numeric_Value \@missing rule\n" + unless @missing == 1 && $missing[0][0] == 0 && $missing[0][1] == 0x10ffff + && $missing[0][2] eq 'NaN'; + +my ($data_path, $data_text) = source_text('Numeric_Value'); +die "$data_path is not pinned Unicode $expected_version data\n" + unless $data_text =~ /^# DerivedNumericValues-\Q$expected_version\E\.txt$/m; +verify_unicode_notice($data_path, $data_text); + +my (@ranges, @values, %value_index, %decimal_value, %source_counts); +my ($record_count, $range_record_count, $explicit_count) = (0, 0, 0); +for my $line (split /\n/, $data_text) { + next if $line =~ /^\s*(?:#|$)/; + die "Malformed Numeric_Value record '$line'\n" + unless $line =~ /^([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*; + \s*([^;]+?)\s*;\s*;\s*(-?\d+(?:\/\d+)?)\s*(?:\#.*)?$/x; + my ($range_text, $decimal, $canonical) = ($1, trim($2), $3); + my ($first, $last) = range_from_text($range_text); + my ($numerator, $denominator) = $canonical =~ m{^(-?\d+)(?:/(\d+))?$}; + $denominator = 1 unless defined $denominator; + die "Invalid rational '$canonical'\n" + if $denominator <= 0 || gcd($numerator, $denominator) != 1; + die "Numeric value does not fit signed long: '$canonical'\n" + if $numerator < -9_223_372_036_854_775_807 + || $numerator > 9_223_372_036_854_775_807; + die "Conflicting decimal spelling '$decimal'\n" + if exists $decimal_value{$decimal} && $decimal_value{$decimal} ne $canonical; + $decimal_value{$decimal} = $canonical; + + if (!exists $value_index{$canonical}) { + $value_index{$canonical} = scalar @values; + my $perl_decimal_alias = sprintf '%.3e', $numerator / $denominator; + push @values, [ + $canonical, 0 + $numerator, 0 + $denominator, $perl_decimal_alias + ]; + } + push @ranges, [$first, $last, $value_index{$canonical}]; + $record_count++; + $range_record_count++ if $range_text =~ /\.\./; + $explicit_count += $last - $first + 1; + $source_counts{$canonical} += $last - $first + 1; +} + +die "Expected 1,980 Numeric_Value records, found $record_count\n" + unless $record_count == 1_980; +die "Expected 25 source range records, found $range_record_count\n" + unless $range_record_count == 25; +die "Expected 2,023 numeric code points, found $explicit_count\n" + unless $explicit_count == 2_023; +die "Expected 144 distinct numeric values, found " . scalar(@values) . "\n" + unless @values == 144; +die "Expected 144 distinct decimal spellings, found " . scalar(keys %decimal_value) . "\n" + unless keys(%decimal_value) == 144; +my %decimal_canonical = map { $decimal_value{$_} => 1 } keys %decimal_value; +die "Decimal spellings do not map one-to-one to the 144 exact values\n" + unless keys(%decimal_canonical) == 144; +my %perl_decimal_for = map { $_->[0] => $_->[3] } @values; +for my $expected ( + ['1/12', '8.333e-02'], ['1/64', '1.562e-02'], + ['1/7', '1.429e-01'], ['1/6', '1.667e-01'], ['3/64', '4.688e-02'], +) { + die "Unexpected Perl decimal alias for $expected->[0]: " + . ($perl_decimal_for{$expected->[0]} // '') . "\n" + unless ($perl_decimal_for{$expected->[0]} // '') eq $expected->[1]; +} + +@ranges = sort { $a->[0] <=> $b->[0] } @ranges; +for my $index (0 .. $#ranges) { + my $range = $ranges[$index]; + die sprintf("Invalid Numeric_Value range U+%04X..U+%04X\n", @$range[0, 1]) + if $range->[0] < 0 || $range->[1] > 0x10ffff || $range->[0] > $range->[1]; + die sprintf("Overlapping Numeric_Value ranges at U+%04X\n", $range->[0]) + if $index > 0 && $range->[0] <= $ranges[$index - 1][1]; +} + +my @coalesced; +for my $range (@ranges) { + if (@coalesced && $coalesced[-1][2] == $range->[2] + && $coalesced[-1][1] + 1 == $range->[0]) { + $coalesced[-1][1] = $range->[1]; + } else { + push @coalesced, [@$range]; + } +} +die "Expected 1,979 coalesced numeric ranges, found " . scalar(@coalesced) . "\n" + unless @coalesced == 1_979; +die "Expected 1,112,089 NaN code points\n" + unless 0x110000 - $explicit_count == 1_112_089; + +my @ranges_by_value = map { [] } @values; +for my $range (@coalesced) { + push @{$ranges_by_value[$range->[2]]}, [$range->[0], $range->[1]]; +} +for my $index (0 .. $#values) { + my $count = 0; + $count += $_->[1] - $_->[0] + 1 for @{$ranges_by_value[$index]}; + die "Cardinality changed for numeric value '$values[$index][0]'\n" + unless $count == $source_counts{$values[$index][0]}; +} + +my (@range_offsets, @range_endpoints); +for my $ranges_for_value (@ranges_by_value) { + push @range_offsets, scalar(@range_endpoints) / 2; + push @range_endpoints, @$_ for @$ranges_for_value; +} +push @range_offsets, scalar(@range_endpoints) / 2; + +print <<'HEADER'; +package org.perlonjava.runtime.regex; + +import com.ibm.icu.text.UnicodeSet; +import java.math.BigDecimal; +import java.math.MathContext; +import java.math.RoundingMode; + +/* + * Generated from Perl 5.44's pinned Unicode Character Database by + * dev/tools/generate_perl_unicode_numeric_value_data.pl. Do not edit manually. + * + * Unicode data source copyright: + * © 2025 Unicode®, Inc. + * Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in + * the U.S. and other countries. + * For terms of use and license, see https://www.unicode.org/terms_of_use.html + */ +final class PerlUnicodeNumericValueData { +HEADER + +print " static final String UNICODE_VERSION = \"$expected_version\";\n"; +print " static final short INVALID = -1;\n\n"; +print " private static final String[] CANONICAL_VALUES = {\n "; +print join(', ', map { qq{"$_->[0]"} } @values); +print "\n };\n\n"; +print " private static final String[] DECIMAL_ALIASES = {\n "; +print join(', ', map { qq{"$_->[3]"} } @values); +print "\n };\n\n"; +print " private static final long[] NUMERATORS = {\n "; +print join(', ', map { "$_->[1]L" } @values); +print "\n };\n\n"; +print " private static final short[] DENOMINATORS = {\n "; +print join(', ', map { $_->[2] } @values); +print "\n };\n\n"; +print " private static final int[] RANGE_OFFSETS = {\n"; +for (my $i = 0; $i < @range_offsets; $i += 16) { + my $end = $i + 15 < $#range_offsets ? $i + 15 : $#range_offsets; + print " ", join(', ', @range_offsets[$i .. $end]), ",\n"; +} +print " };\n\n private static final int[] RANGE_ENDPOINTS = {\n"; +for (my $i = 0; $i < @range_endpoints; $i += 10) { + my $end = $i + 9 < $#range_endpoints ? $i + 9 : $#range_endpoints; + print " ", join(', ', map { sprintf '0x%X', $range_endpoints[$_] } $i .. $end), ",\n"; +} +print <<'FOOTER'; + }; + + private static final MathContext PERL_NUMERIC_CONTEXT = + new MathContext(4, RoundingMode.HALF_EVEN); + private static final UnicodeSet[] SETS = buildSets(); + private static final BigDecimal[] DECIMALS = buildDecimals(); + private static final BigDecimal[] ALTERNATE_DECIMALS = buildAlternateDecimals(); + private static final UnicodeSet ASSIGNED = buildAssignedSet(); + private static final UnicodeSet NAN = new UnicodeSet(0, 0x10ffff) + .removeAll(ASSIGNED).freeze(); + + static int valueCount() { + return CANONICAL_VALUES.length; + } + + static String canonicalValue(int index) { + return CANONICAL_VALUES[index]; + } + + static long numerator(int index) { + return NUMERATORS[index]; + } + + static short valueForDecimal(BigDecimal decimal) { + double binaryValue = decimal.doubleValue(); + if (!Double.isFinite(binaryValue)) return INVALID; + BigDecimal canonical = new BigDecimal(binaryValue).round(PERL_NUMERIC_CONTEXT); + for (short index = 0; index < DECIMALS.length; index++) { + if (DENOMINATORS[index] != 1 + && (DECIMALS[index].compareTo(canonical) == 0 + || ALTERNATE_DECIMALS[index].compareTo(canonical) == 0)) { + return index; + } + } + return INVALID; + } + + static int denominator(int index) { + return DENOMINATORS[index]; + } + + static UnicodeSet set(int index) { + return SETS[index]; + } + + static UnicodeSet nanSet() { + return NAN; + } + + static UnicodeSet assignedSet() { + return ASSIGNED; + } + + static short valueForRational(long numerator, long denominator) { + if (denominator == 0 || numerator == Long.MIN_VALUE || denominator == Long.MIN_VALUE) { + return INVALID; + } + if (denominator < 0) { + numerator = -numerator; + denominator = -denominator; + } + long divisor = gcd(numerator, denominator); + numerator /= divisor; + denominator /= divisor; + for (short index = 0; index < CANONICAL_VALUES.length; index++) { + if (NUMERATORS[index] == numerator && DENOMINATORS[index] == denominator) { + return index; + } + } + return INVALID; + } + + static boolean isPropertyAlias(String alias) { + boolean hasIsPrefix = alias != null && alias.startsWith("Is"); + String normalized = loose(hasIsPrefix ? alias.substring(2) : alias); + switch (normalized) { + case "numericvalue": + case "nv": + return true; + default: + return false; + } + } + + private static UnicodeSet[] buildSets() { + UnicodeSet[] sets = new UnicodeSet[CANONICAL_VALUES.length]; + for (int value = 0; value < sets.length; value++) { + UnicodeSet set = new UnicodeSet(); + for (int range = RANGE_OFFSETS[value]; range < RANGE_OFFSETS[value + 1]; range++) { + set.add(RANGE_ENDPOINTS[range * 2], RANGE_ENDPOINTS[range * 2 + 1]); + } + sets[value] = set.freeze(); + } + return sets; + } + + private static BigDecimal[] buildDecimals() { + BigDecimal[] decimals = new BigDecimal[DECIMAL_ALIASES.length]; + for (int index = 0; index < decimals.length; index++) { + decimals[index] = new BigDecimal(DECIMAL_ALIASES[index]); + if (index > 0 && decimals[index - 1].compareTo(decimals[index]) >= 0) { + throw new IllegalStateException("Numeric_Value decimals are not sorted"); + } + } + return decimals; + } + + private static BigDecimal[] buildAlternateDecimals() { + MathContext alternateContext = new MathContext(4, RoundingMode.HALF_UP); + BigDecimal[] decimals = new BigDecimal[NUMERATORS.length]; + for (int index = 0; index < decimals.length; index++) { + decimals[index] = BigDecimal.valueOf(NUMERATORS[index]) + .divide(BigDecimal.valueOf(DENOMINATORS[index]), alternateContext); + } + return decimals; + } + + private static UnicodeSet buildAssignedSet() { + UnicodeSet assigned = new UnicodeSet(); + for (UnicodeSet set : SETS) assigned.addAll(set); + return assigned.freeze(); + } + + private static long gcd(long left, long right) { + left = Math.abs(left); + while (right != 0) { + long remainder = left % right; + left = right; + right = remainder; + } + return left; + } + + private static String loose(String alias) { + if (alias == null) return ""; + StringBuilder normalized = new StringBuilder(alias.length()); + for (int i = 0; i < alias.length(); i++) { + char character = alias.charAt(i); + if (character == '_' || character == '-' || character == ' ' + || (character >= '\t' && character <= '\r')) continue; + normalized.append(Character.toLowerCase(character)); + } + return normalized.toString(); + } + + private PerlUnicodeNumericValueData() { + } +} +FOOTER diff --git a/dev/tools/generate_perl_unicode_script_data.pl b/dev/tools/generate_perl_unicode_script_data.pl new file mode 100644 index 0000000000..d3286951d2 --- /dev/null +++ b/dev/tools/generate_perl_unicode_script_data.pl @@ -0,0 +1,376 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Digest::SHA qw(sha256_hex); +use File::Spec; +use FindBin; + +my $expected_version = '17.0.0'; +my $root = File::Spec->catdir($FindBin::Bin, '..', '..'); +my $unicore = File::Spec->catdir($root, 'perl5', 'lib', 'unicore'); +my @sources = ( + { + name => 'Scripts-17.0.0.txt', + path => File::Spec->catfile($unicore, 'Scripts.txt'), + hash => '9f5e50d3abaee7d6ce09480f325c706f485ae3240912527e651954d2d6b035bf', + version => qr/^# Scripts-\Q$expected_version\E\.txt$/m, + }, + { + name => 'ScriptExtensions-17.0.0.txt', + path => File::Spec->catfile($unicore, 'ScriptExtensions.txt'), + hash => 'ec2107e58825a1586acee8e0911ce18260394ac8b87e535ca325f1ccbeb06bc6', + version => qr/^# ScriptExtensions-\Q$expected_version\E\.txt$/m, + }, + { + name => 'PropertyValueAliases-17.0.0.txt', + path => File::Spec->catfile($unicore, 'PropValueAliases.txt'), + hash => '670d2bebb48649c04fabfbf033308073dcff47946324a8033237254c048b3b01', + version => qr/^# PropertyValueAliases-\Q$expected_version\E\.txt$/m, + }, + { + name => 'PropertyAliases-17.0.0.txt', + path => File::Spec->catfile($unicore, 'PropertyAliases.txt'), + hash => '4441f573caf952ffece1d7c892e7715bd7136dfc26f96eb6f268bf1e474715fb', + version => qr/^# PropertyAliases-\Q$expected_version\E\.txt$/m, + }, +); + +sub read_source { + my ($source) = @_; + open my $input, '<:raw', $source->{path} + or die "Cannot read $source->{path}: $!\n"; + local $/; + my $text = <$input>; + close $input or die "Cannot close $source->{path}: $!\n"; + my $actual_hash = sha256_hex($text); + die "$source->{path} SHA-256 mismatch: expected $source->{hash}, found $actual_hash\n" + unless $actual_hash eq $source->{hash}; + die "$source->{path} is not pinned Unicode $expected_version data\n" + unless $text =~ $source->{version}; + $source->{text} = $text; +} + +sub trim { + my ($text) = @_; + $text =~ s/^\s+|\s+$//g; + return $text; +} + +sub loose_name { + my ($name) = @_; + $name = lc $name; + $name =~ s/[\s_-]+//g; + return $name; +} + +sub parse_range { + my ($text) = @_; + my ($start, $end) = split /\.\./, $text; + return (hex($start), hex(defined $end ? $end : $start)); +} + +read_source($_) for @sources; + +my $version_path = File::Spec->catfile($unicore, 'version'); +open my $version_input, '<', $version_path or die "Cannot read $version_path: $!\n"; +chomp(my $unicode_version = <$version_input>); +close $version_input or die "Cannot close $version_path: $!\n"; +die "Expected Unicode $expected_version, found $unicode_version\n" + unless $unicode_version eq $expected_version; + +my (@short_values, @long_values, %alias_index, %wildcard_value_index); +for my $line (split /\n/, $sources[2]{text}) { + next if $line =~ /^\s*#/; + $line =~ s/#.*$//; + my @fields = map { trim($_) } split /;/, $line; + next unless @fields >= 3 && $fields[0] eq 'sc'; + my $index = scalar @short_values; + push @short_values, $fields[1]; + push @long_values, $fields[2]; + for my $alias (@fields[1 .. $#fields]) { + next unless length $alias; + my $loose = loose_name($alias); + die "Script alias collision for '$alias'\n" + if exists $alias_index{$loose} && $alias_index{$loose} != $index; + $alias_index{$loose} = $index; + die "Script wildcard alias collision for '$alias'\n" + if exists $wildcard_value_index{$alias} + && $wildcard_value_index{$alias} != $index; + $wildcard_value_index{$alias} = $index; + } +} +die "Expected 176 Script values, found " . scalar(@short_values) . "\n" + unless @short_values == 176; + +my (%script_property_aliases, %script_extensions_property_aliases); +for my $line (split /\n/, $sources[3]{text}) { + next if $line =~ /^\s*#/; + $line =~ s/#.*$//; + my @fields = map { trim($_) } split /;/, $line; + next unless @fields >= 2; + if ($fields[0] eq 'sc' || $fields[1] eq 'Script') { + $script_property_aliases{loose_name($_)} = 1 for grep { length } @fields; + } + if ($fields[0] eq 'scx' || $fields[1] eq 'Script_Extensions') { + $script_extensions_property_aliases{loose_name($_)} = 1 + for grep { length } @fields; + } +} +die "Pinned property aliases do not define sc and Script\n" + unless $script_property_aliases{sc} && $script_property_aliases{script}; +die "Pinned property aliases do not define scx and Script_Extensions\n" + unless $script_extensions_property_aliases{scx} + && $script_extensions_property_aliases{scriptextensions}; + +my (@script_missing, @script_explicit); +for my $line (split /\n/, $sources[0]{text}) { + if ($line =~ /^#\s*\@missing:\s*([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*;\s*([A-Za-z_]+)/) { + my ($range, $value) = ($1, $2); + my ($start, $end) = parse_range($range); + my $index = $alias_index{loose_name($value)}; + die "Unknown \@missing Script value '$value'\n" unless defined $index; + push @script_missing, [$start, $end, $index]; + next; + } + next unless $line =~ /^([0-9A-F]+(?:\.\.[0-9A-F]+)?)\s*;\s*([A-Za-z_]+)/; + my ($range, $value) = ($1, $2); + my ($start, $end) = parse_range($range); + my $index = $alias_index{loose_name($value)}; + die "Unknown explicit Script value '$value'\n" unless defined $index; + push @script_explicit, [$start, $end, $index]; +} +die "Script data has no ranges or defaults\n" + unless @script_explicit && @script_missing; + +my $unknown_index = $alias_index{loose_name('Unknown')}; +my @script_code_value = ($unknown_index) x 0x110000; +for my $range (@script_missing) { + my ($code, $end, $index) = @$range; + $script_code_value[$code++] = $index while $code <= $end; +} +for my $range (@script_explicit) { + my ($code, $end, $index) = @$range; + $script_code_value[$code++] = $index while $code <= $end; +} + +my @script_ranges; +my ($range_start, $range_value) = (0, $script_code_value[0]); +for my $code (1 .. 0x10ffff) { + next if $script_code_value[$code] == $range_value; + push @script_ranges, [$range_start, $code - 1, $range_value]; + ($range_start, $range_value) = ($code, $script_code_value[$code]); +} +push @script_ranges, [$range_start, 0x10ffff, $range_value]; + +my (@script_extensions_ranges, @script_extensions_values); +my @script_extensions_explicit = (0) x 0x110000; +my $saw_script_fallback = 0; +for my $line (split /\n/, $sources[1]{text}) { + if ($line =~ /^#\s*\@missing:\s*0000\.\.10FFFF\s*;\s*