Oregami
Repositories/oxedyne/fe2o3

oxedyne/fe2o3/fe2o3_text/tests/regex_oracle/oracle.pl

4.7 KiB, 1 run

created by r1870400018:60340, which is this file's identity for as long as the history lasts, whatever it is later renamed to

download · who wrote it · its history

1#!/usr/bin/env perl
2# Runs corpus.txt through Perl's regular expression engine and writes expected.txt, the answers
3# tests/regex.rs holds fe2o3_text's engine to.
4#
5# Perl is the oracle for what a match is -- leftmost-first backtracking, captures, classes, Unicode
6# properties. Where Perl and the Rust `regex` crate differ in *policy* rather than in matching,
7# this script carries the Rust policy itself, written independently of fe2o3_text:
8#
9# - a search from a position sees the text before it as context (`^`, `\b`), done here by
10# consuming that text inside the pattern rather than by Perl's `pos`, whose rules for empty
11# matches are its own;
12# - iteration passes over an empty match where the previous match ended, and searches again one
13# character on;
14# - `split` yields the pieces between matches; `$name`, `${name}` and `$$` expand as the crate
15# documents.
16#
17# Run from this directory: perl oracle.pl < corpus.txt > expected.txt
18use strict;
19use warnings;
20use utf8;
21use Encode qw(encode_utf8);
22
23binmode STDIN, ':encoding(UTF-8)';
24binmode STDOUT, ':encoding(UTF-8)';
25
26# Escapes a field for expected.txt: backslash, tab, newline and carriage return.
27sub esc {
28 my $s = shift;
29 $s =~ s/\\/\\\\/g;
30 $s =~ s/\t/\\t/g;
31 $s =~ s/\n/\\n/g;
32 $s =~ s/\r/\\r/g;
33 return $s;
34}
35
36# Decodes a corpus haystack.
37sub unhay {
38 my $s = shift;
39 $s =~ s/\\x\{([0-9A-Fa-f]+)\}/chr(hex($1))/ge;
40 $s =~ s/\\n/\n/g;
41 $s =~ s/\\t/\t/g;
42 return $s;
43}
44
45# The leftmost match at or after character $p, as [[start, end] or undef per group] in characters,
46# with the named groups' texts.
47sub search {
48 my ($re, $s, $p) = @_;
49 return undef unless $s =~ /\A(?s:.{$p})(?s:.*?)\K$re/;
50 my @g;
51 for my $i (0 .. $#+) {
52 push @g, defined $-[$i] ? [$-[$i], $+[$i]] : undef;
53 }
54 my %named;
55 for my $k (keys %-) {
56 $named{$k} = $-{$k}[0];
57 }
58 return { g => \@g, n => \%named };
59}
60
61# Every match, by the iteration rule of the Rust `regex` crate.
62sub matches {
63 my ($re, $s) = @_;
64 my $len = length $s;
65 my ($at, $last) = (0, undef);
66 my @out;
67 while ($at <= $len) {
68 my $m = search($re, $s, $at);
69 last unless $m;
70 my ($b, $e) = @{ $m->{g}[0] };
71 if ($b == $e && defined $last && $e == $last) {
72 last if $at + 1 > $len;
73 $m = search($re, $s, $at + 1);
74 last unless $m;
75 }
76 push @out, $m;
77 $at = $m->{g}[0][1];
78 $last = $at;
79 }
80 return @out;
81}
82
83# Expands a replacement template for one match, as the `regex` crate's `Captures::expand` does.
84sub expand {
85 my ($tpl, $s, $m) = @_;
86 my $out = '';
87 my $text = sub {
88 my $name = shift;
89 if ($name =~ /^[0-9]+$/) {
90 my $g = $m->{g}[$name];
91 return defined $g ? substr($s, $g->[0], $g->[1] - $g->[0]) : '';
92 }
93 my $v = $m->{n}{$name};
94 return defined $v ? $v : '';
95 };
96 while (length $tpl) {
97 if ($tpl =~ s/^\$\$//) {
98 $out .= '$';
99 } elsif ($tpl =~ s/^\$\{([^}]+)\}//) {
100 $out .= $text->($1);
101 } elsif ($tpl =~ s/^\$([0-9A-Za-z_]+)//) {
102 $out .= $text->($1);
103 } else {
104 $tpl =~ s/^(.)//s;
105 $out .= $1;
106 }
107 }
108 return $out;
109}
110
111my ($pat, $perl, $tpl);
112my $cases = 0;
113while (my $line = <STDIN>) {
114 chomp $line;
115 next if $line =~ /^#/ || $line !~ /\S/;
116 my ($tag, $body) = $line =~ /^(\w) (.*)$/ or die "unreadable corpus line: $line\n";
117 if ($tag eq 'P') {
118 ($pat, $perl, $tpl) = ($body, $body, undef);
119 } elsif ($tag eq 'Q') {
120 $perl = $body;
121 } elsif ($tag eq 'R') {
122 $tpl = $body;
123 } elsif ($tag eq 'H') {
124 my $s = unhay($body);
125 die "a '\$' pattern over a haystack ending in a newline: $pat\n"
126 if $perl =~ /\$/ && $s =~ /\n\z/;
127 my $re = eval { qr/$perl/ } or die "Perl will not compile '$perl': $@";
128 my $len = length $s;
129 # Byte offset of each character, and of the end.
130 my @off = (0);
131 for my $i (1 .. $len) {
132 push @off, $off[-1] + length(encode_utf8(substr($s, $i - 1, 1)));
133 }
134 my $spans = sub {
135 my $m = shift;
136 return join ' ', map { defined $_ ? "$off[$_->[0]],$off[$_->[1]]" : '-' } @{ $m->{g} };
137 };
138 print "P\t", esc($pat), "\nH\t", esc($s), "\n";
139 # The search from every character position.
140 for my $p (0 .. $len) {
141 my $m = search($re, $s, $p);
142 print "A\t$off[$p]\t", ($m ? $spans->($m) : 'none'), "\n";
143 }
144 my @ms = matches($re, $s);
145 print "M\t", $spans->($_), "\n" for @ms;
146 # Split pieces, each escaped, separated by U+001F.
147 my ($last, @pieces) = (0);
148 for my $m (@ms) {
149 push @pieces, substr($s, $last, $m->{g}[0][0] - $last);
150 $last = $m->{g}[0][1];
151 }
152 push @pieces, substr($s, $last);
153 print "S\t", join("\x1F", map { esc($_) } @pieces), "\n";
154 if (defined $tpl) {
155 my ($out, $l) = ('', 0);
156 for my $m (@ms) {
157 $out .= substr($s, $l, $m->{g}[0][0] - $l) . expand($tpl, $s, $m);
158 $l = $m->{g}[0][1];
159 }
160 $out .= substr($s, $l);
161 print "R\t", esc($tpl), "\t", esc($out), "\n";
162 }
163 print "E\n";
164 $cases++;
165 }
166}
167print STDERR "$cases cases\n";