feat: add multi-engine regex flavour support
This commit is contained in:
753
public/engines/perl/regex_tools_bridge.pl
Normal file
753
public/engines/perl/regex_tools_bridge.pl
Normal file
@@ -0,0 +1,753 @@
|
||||
package RegexTools;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use Cpanel::JSON::XS ();
|
||||
no re 'eval';
|
||||
|
||||
our $BRIDGE_ABI_VERSION = 1;
|
||||
our $REQUEST_PATH = '/tmp/regex-tools-request.json';
|
||||
our $RESPONSE_PATH = '/tmp/regex-tools-response.json';
|
||||
our $OUTPUT_PATH = '/tmp/regex-tools-output.bin';
|
||||
|
||||
my $JSON = Cpanel::JSON::XS->new->utf8->canonical;
|
||||
my $TRUE = Cpanel::JSON::XS::true;
|
||||
my $FALSE = Cpanel::JSON::XS::false;
|
||||
|
||||
my $MAXIMUM_PATTERN_CHARACTERS = 64 * 1024;
|
||||
my $MAXIMUM_SUBJECT_BYTES = 16 * 1024 * 1024;
|
||||
my $MAXIMUM_REPLACEMENT_CHARACTERS = 64 * 1024;
|
||||
my $MAXIMUM_MATCHES = 10_000;
|
||||
my $MAXIMUM_CAPTURE_ROWS = 100_000;
|
||||
my $MAXIMUM_CAPTURE_GROUPS = 1_000;
|
||||
my $MAXIMUM_OUTPUT_BYTES = 64 * 1024 * 1024;
|
||||
my $MAXIMUM_ERROR_CHARACTERS = 1_024;
|
||||
my $OUTPUT_CHUNK_CHARACTERS = 4_096;
|
||||
my $MAXIMUM_REQUEST_BYTES = 6 * (
|
||||
$MAXIMUM_SUBJECT_BYTES
|
||||
+ $MAXIMUM_PATTERN_CHARACTERS
|
||||
+ $MAXIMUM_REPLACEMENT_CHARACTERS
|
||||
) + 16 * 1024;
|
||||
my $MAXIMUM_RESPONSE_BYTES = 8 * 1024 * 1024;
|
||||
|
||||
sub _bounded_message {
|
||||
my ($value) = @_;
|
||||
$value = defined($value) ? "$value" : 'Unknown Perl bridge error';
|
||||
$value =~ s/\s+at \Q@{[$0]}\E line \d+\.?\s*\z//;
|
||||
return length($value) <= $MAXIMUM_ERROR_CHARACTERS
|
||||
? $value
|
||||
: substr($value, 0, $MAXIMUM_ERROR_CHARACTERS - 1) . "\x{2026}";
|
||||
}
|
||||
|
||||
sub _utf8_bytes {
|
||||
my ($value) = @_;
|
||||
my $encoded = $value;
|
||||
utf8::encode($encoded);
|
||||
return $encoded;
|
||||
}
|
||||
|
||||
sub _failure {
|
||||
my ($phase, $code, $message) = @_;
|
||||
return {
|
||||
abi => $BRIDGE_ABI_VERSION,
|
||||
ok => $FALSE,
|
||||
phase => $phase,
|
||||
code => $code,
|
||||
message => _bounded_message($message),
|
||||
};
|
||||
}
|
||||
|
||||
sub _is_plain_hash {
|
||||
my ($value) = @_;
|
||||
return ref($value) eq 'HASH';
|
||||
}
|
||||
|
||||
sub _has_exact_keys {
|
||||
my ($value, @expected) = @_;
|
||||
return 0 if !_is_plain_hash($value);
|
||||
return join("\0", sort keys %$value)
|
||||
eq join("\0", sort @expected);
|
||||
}
|
||||
|
||||
sub _is_integer_in_range {
|
||||
my ($value, $minimum, $maximum) = @_;
|
||||
return defined($value)
|
||||
&& !ref($value)
|
||||
&& "$value" =~ /\A(?:0|[1-9][0-9]*)\z/
|
||||
&& $value >= $minimum
|
||||
&& $value <= $maximum;
|
||||
}
|
||||
|
||||
sub _read_request {
|
||||
open my $input, '<:raw', $REQUEST_PATH
|
||||
or die "Unable to open the fixed bridge request file: $!";
|
||||
local $/;
|
||||
my $encoded = <$input>;
|
||||
close $input or die "Unable to close the fixed bridge request file: $!";
|
||||
die 'The fixed bridge request exceeds its byte limit.'
|
||||
if !defined($encoded) || length($encoded) > $MAXIMUM_REQUEST_BYTES;
|
||||
return $JSON->decode($encoded);
|
||||
}
|
||||
|
||||
sub _write_response {
|
||||
my ($response) = @_;
|
||||
my $encoded = $JSON->encode($response);
|
||||
die 'The fixed bridge response exceeds its byte limit.'
|
||||
if length($encoded) > $MAXIMUM_RESPONSE_BYTES;
|
||||
open my $output, '>:raw', $RESPONSE_PATH
|
||||
or die "Unable to open the fixed bridge response file: $!";
|
||||
print {$output} $encoded
|
||||
or die "Unable to write the fixed bridge response file: $!";
|
||||
close $output
|
||||
or die "Unable to close the fixed bridge response file: $!";
|
||||
}
|
||||
|
||||
sub _contains_code_assertion {
|
||||
my ($pattern) = @_;
|
||||
my $escaped = 0;
|
||||
my $character_class = 0;
|
||||
my $quoted = 0;
|
||||
for (my $index = 0; $index < length($pattern); $index++) {
|
||||
my $current = substr($pattern, $index, 1);
|
||||
if ($quoted) {
|
||||
if ($current eq '\\'
|
||||
&& substr($pattern, $index + 1, 1) eq 'E') {
|
||||
$quoted = 0;
|
||||
$index++;
|
||||
}
|
||||
next;
|
||||
}
|
||||
if ($escaped) {
|
||||
$escaped = 0;
|
||||
next;
|
||||
}
|
||||
if ($current eq '\\') {
|
||||
if (substr($pattern, $index + 1, 1) eq 'Q') {
|
||||
$quoted = 1;
|
||||
$index++;
|
||||
}
|
||||
else {
|
||||
$escaped = 1;
|
||||
}
|
||||
next;
|
||||
}
|
||||
if ($current eq '[' && !$character_class) {
|
||||
$character_class = 1;
|
||||
next;
|
||||
}
|
||||
if ($current eq ']' && $character_class) {
|
||||
$character_class = 0;
|
||||
next;
|
||||
}
|
||||
next if $character_class;
|
||||
return 1 if substr($pattern, $index, 3) eq '(?{';
|
||||
return 1 if substr($pattern, $index, 4) eq '(??{';
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _validate_flags {
|
||||
my ($flags) = @_;
|
||||
return 'Flags must be a string.' if !defined($flags) || ref($flags);
|
||||
my %seen;
|
||||
for my $flag (split //, $flags) {
|
||||
return 'The request contains an unsupported or duplicate Perl flag.'
|
||||
if $flag !~ /\A[gimsxnadlu]\z/ || $seen{$flag}++;
|
||||
}
|
||||
my $character_rules = grep { $seen{$_} } qw(a d l u);
|
||||
return 'Perl character-set flags a, d, l and u are mutually exclusive.'
|
||||
if $character_rules > 1;
|
||||
return;
|
||||
}
|
||||
|
||||
sub _validate_request {
|
||||
my ($request) = @_;
|
||||
return _failure('bridge', 'invalid-request', 'The request must be a JSON object.')
|
||||
if !_is_plain_hash($request);
|
||||
return _failure('bridge', 'abi-mismatch', 'The bridge ABI version is unsupported.')
|
||||
if !defined($request->{abi})
|
||||
|| ref($request->{abi})
|
||||
|| $request->{abi} != $BRIDGE_ABI_VERSION;
|
||||
if (defined($request->{operation})
|
||||
&& !ref($request->{operation})
|
||||
&& $request->{operation} eq 'identity') {
|
||||
return _failure(
|
||||
'bridge',
|
||||
'invalid-request',
|
||||
'The identity request contains missing or unexpected fields.',
|
||||
) if !_has_exact_keys($request, qw(abi operation));
|
||||
return;
|
||||
}
|
||||
return _failure('bridge', 'invalid-operation', 'The bridge operation is unsupported.')
|
||||
if !defined($request->{operation})
|
||||
|| ref($request->{operation})
|
||||
|| ($request->{operation} ne 'execute'
|
||||
&& $request->{operation} ne 'replace');
|
||||
my @request_fields = qw(
|
||||
abi
|
||||
flags
|
||||
maximumCaptureRows
|
||||
maximumMatches
|
||||
operation
|
||||
options
|
||||
pattern
|
||||
scanAll
|
||||
subject
|
||||
);
|
||||
push @request_fields, qw(maximumOutputBytes replacement)
|
||||
if $request->{operation} eq 'replace';
|
||||
return _failure(
|
||||
'bridge',
|
||||
'invalid-request',
|
||||
'The request contains missing or unexpected fields.',
|
||||
) if !_has_exact_keys($request, @request_fields);
|
||||
return _failure('bridge', 'invalid-request', 'Pattern and subject must be strings.')
|
||||
if !defined($request->{pattern})
|
||||
|| ref($request->{pattern})
|
||||
|| !defined($request->{subject})
|
||||
|| ref($request->{subject});
|
||||
return _failure('bridge', 'pattern-limit', 'The pattern exceeds the bridge limit.')
|
||||
if length($request->{pattern}) > $MAXIMUM_PATTERN_CHARACTERS;
|
||||
return _failure('bridge', 'subject-limit', 'The subject exceeds the bridge limit.')
|
||||
if length(_utf8_bytes($request->{subject})) > $MAXIMUM_SUBJECT_BYTES;
|
||||
return _failure('bridge', 'unsupported-option', 'Perl does not accept engine options.')
|
||||
if !_is_plain_hash($request->{options})
|
||||
|| keys(%{$request->{options}});
|
||||
my $flag_error = _validate_flags($request->{flags});
|
||||
return _failure('bridge', 'unsupported-flag', $flag_error) if $flag_error;
|
||||
return _failure(
|
||||
'bridge',
|
||||
'result-limit',
|
||||
'The requested result bounds are outside the bridge contract.',
|
||||
) if !_is_integer_in_range(
|
||||
$request->{maximumMatches},
|
||||
1,
|
||||
$MAXIMUM_MATCHES,
|
||||
) || !_is_integer_in_range(
|
||||
$request->{maximumCaptureRows},
|
||||
1,
|
||||
$MAXIMUM_CAPTURE_ROWS,
|
||||
);
|
||||
return _failure(
|
||||
'compile',
|
||||
'code-assertion-disabled',
|
||||
'Perl code assertions (?{...}) and (??{...}) are disabled.',
|
||||
) if _contains_code_assertion($request->{pattern});
|
||||
if ($request->{operation} eq 'execute') {
|
||||
return _failure(
|
||||
'bridge',
|
||||
'invalid-request',
|
||||
'Execution requests cannot contain replacement fields.',
|
||||
) if exists($request->{replacement})
|
||||
|| exists($request->{maximumOutputBytes});
|
||||
return;
|
||||
}
|
||||
return _failure(
|
||||
'bridge',
|
||||
'invalid-request',
|
||||
'Replacement requests require a string template and output bound.',
|
||||
) if !defined($request->{replacement})
|
||||
|| ref($request->{replacement})
|
||||
|| !_is_integer_in_range(
|
||||
$request->{maximumOutputBytes},
|
||||
1,
|
||||
$MAXIMUM_OUTPUT_BYTES,
|
||||
);
|
||||
return _failure(
|
||||
'bridge',
|
||||
'replacement-limit',
|
||||
'The replacement template exceeds the bridge limit.',
|
||||
) if length($request->{replacement}) > $MAXIMUM_REPLACEMENT_CHARACTERS;
|
||||
return;
|
||||
}
|
||||
|
||||
sub _compile_pattern {
|
||||
my ($pattern, $flags) = @_;
|
||||
my $modifiers = join '', grep { index($flags, $_) >= 0 }
|
||||
qw(i m s x n a d l u);
|
||||
my $wrapped = length($modifiers)
|
||||
? "(?$modifiers:$pattern)"
|
||||
: "(?:$pattern)";
|
||||
my $compiled;
|
||||
my $error;
|
||||
{
|
||||
local $SIG{__WARN__} = sub { };
|
||||
local $@;
|
||||
$compiled = eval { qr/$wrapped/ };
|
||||
$error = $@;
|
||||
}
|
||||
return ($compiled, $error);
|
||||
}
|
||||
|
||||
sub _capture_group_count {
|
||||
my ($compiled) = @_;
|
||||
my $probe = qr/(?:$compiled)|()/;
|
||||
'' =~ $probe;
|
||||
return $#- - 1;
|
||||
}
|
||||
|
||||
sub _snapshot_match {
|
||||
my ($group_count, $starts, $ends) = @_;
|
||||
my @captures;
|
||||
for my $group (1 .. $group_count) {
|
||||
push @captures, defined($starts->[$group])
|
||||
&& $starts->[$group] >= 0
|
||||
? [0 + $starts->[$group], 0 + $ends->[$group]]
|
||||
: undef;
|
||||
}
|
||||
return {
|
||||
span => [0 + $starts->[0], 0 + $ends->[0]],
|
||||
captures => \@captures,
|
||||
};
|
||||
}
|
||||
|
||||
sub _push_literal_token {
|
||||
my ($tokens, $literal) = @_;
|
||||
return if !length($$literal);
|
||||
push @$tokens, ['literal', $$literal];
|
||||
$$literal = '';
|
||||
}
|
||||
|
||||
sub _tokenize_replacement {
|
||||
my ($template, $group_count) = @_;
|
||||
my @tokens;
|
||||
my $literal = '';
|
||||
my $cursor = 0;
|
||||
while ($cursor < length($template)) {
|
||||
my $current = substr($template, $cursor, 1);
|
||||
if ($current ne '$') {
|
||||
$literal .= $current;
|
||||
$cursor++;
|
||||
next;
|
||||
}
|
||||
my $next = substr($template, $cursor + 1, 1);
|
||||
if ($next eq '$') {
|
||||
_push_literal_token(\@tokens, \$literal);
|
||||
push @tokens, ['literal', '$'];
|
||||
$cursor += 2;
|
||||
next;
|
||||
}
|
||||
if (substr($template, $cursor + 1) =~ /\A([0-9]+)/) {
|
||||
my $digits = $1;
|
||||
my $canonical = $digits;
|
||||
$canonical =~ s/\A0+(?=[0-9])//;
|
||||
my $number = length($canonical) <= length("$group_count")
|
||||
&& $canonical <= $group_count
|
||||
? 0 + $canonical
|
||||
: undef;
|
||||
_push_literal_token(\@tokens, \$literal);
|
||||
push @tokens, ['capture', $number];
|
||||
$cursor += 1 + length($digits);
|
||||
next;
|
||||
}
|
||||
if (substr($template, $cursor + 1)
|
||||
=~ /\A\{([A-Za-z_][A-Za-z0-9_]*)\}/) {
|
||||
my $name = $1;
|
||||
_push_literal_token(\@tokens, \$literal);
|
||||
push @tokens, ['named', $name];
|
||||
$cursor += 3 + length($name);
|
||||
next;
|
||||
}
|
||||
$literal .= '$';
|
||||
$cursor++;
|
||||
}
|
||||
_push_literal_token(\@tokens, \$literal);
|
||||
return \@tokens;
|
||||
}
|
||||
|
||||
sub _write_encoded {
|
||||
my ($state, $encoded) = @_;
|
||||
return if !length($encoded);
|
||||
print {$state->{handle}} $encoded
|
||||
or die "Unable to write the fixed bridge output file: $!";
|
||||
$state->{bytes} += length($encoded);
|
||||
}
|
||||
|
||||
sub _append_piece {
|
||||
my ($state, $value) = @_;
|
||||
return 0 if $state->{truncated};
|
||||
return 1 if !length($value);
|
||||
my $encoded = _utf8_bytes($value);
|
||||
my $remaining = $state->{maximum} - $state->{bytes};
|
||||
if (length($encoded) <= $remaining) {
|
||||
_write_encoded($state, $encoded);
|
||||
return 1;
|
||||
}
|
||||
my ($low, $high) = (0, length($value));
|
||||
while ($low < $high) {
|
||||
my $middle = int(($low + $high + 1) / 2);
|
||||
my $prefix_bytes = length(_utf8_bytes(substr($value, 0, $middle)));
|
||||
if ($prefix_bytes <= $remaining) {
|
||||
$low = $middle;
|
||||
}
|
||||
else {
|
||||
$high = $middle - 1;
|
||||
}
|
||||
}
|
||||
_write_encoded($state, _utf8_bytes(substr($value, 0, $low)))
|
||||
if $low > 0;
|
||||
$state->{truncated} = $TRUE;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _append_text {
|
||||
my ($state, $value) = @_;
|
||||
return 0 if $state->{truncated};
|
||||
my $cursor = 0;
|
||||
while ($cursor < length($value)) {
|
||||
my $length = length($value) - $cursor;
|
||||
$length = $OUTPUT_CHUNK_CHARACTERS
|
||||
if $length > $OUTPUT_CHUNK_CHARACTERS;
|
||||
return 0
|
||||
if !_append_piece($state, substr($value, $cursor, $length));
|
||||
$cursor += $length;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _append_span {
|
||||
my ($state, $subject, $start, $end) = @_;
|
||||
return 0 if $state->{truncated};
|
||||
my $cursor = $start;
|
||||
while ($cursor < $end) {
|
||||
my $length = $end - $cursor;
|
||||
$length = $OUTPUT_CHUNK_CHARACTERS
|
||||
if $length > $OUTPUT_CHUNK_CHARACTERS;
|
||||
return 0
|
||||
if !_append_piece($state, substr($subject, $cursor, $length));
|
||||
$cursor += $length;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _resolve_named_spans {
|
||||
my ($tokens, $subject, $starts, $ends, $named_values) = @_;
|
||||
my %resolved;
|
||||
for my $token (@$tokens) {
|
||||
my ($kind, $name) = @$token;
|
||||
next if $kind ne 'named'
|
||||
|| exists($resolved{$name})
|
||||
|| !exists($named_values->{$name})
|
||||
|| !defined($named_values->{$name});
|
||||
my $captured = $named_values->{$name};
|
||||
for my $group (1 .. $#$ends) {
|
||||
next if !defined($starts->[$group])
|
||||
|| $starts->[$group] < 0
|
||||
|| $ends->[$group] - $starts->[$group] != length($captured)
|
||||
|| index($subject, $captured, $starts->[$group])
|
||||
!= $starts->[$group];
|
||||
$resolved{$name} = [
|
||||
0 + $starts->[$group],
|
||||
0 + $ends->[$group],
|
||||
];
|
||||
last;
|
||||
}
|
||||
die "Unable to resolve native span for named capture $name."
|
||||
if !exists($resolved{$name});
|
||||
}
|
||||
return \%resolved;
|
||||
}
|
||||
|
||||
sub _append_replacement_tokens {
|
||||
my ($state, $tokens, $subject, $starts, $ends, $named_spans) = @_;
|
||||
for my $token (@$tokens) {
|
||||
return 0 if $state->{truncated};
|
||||
my ($kind, $value) = @$token;
|
||||
if ($kind eq 'literal') {
|
||||
_append_text($state, $value);
|
||||
}
|
||||
elsif ($kind eq 'capture') {
|
||||
_append_span(
|
||||
$state,
|
||||
$subject,
|
||||
$starts->[$value],
|
||||
$ends->[$value],
|
||||
) if defined($value)
|
||||
&& defined($starts->[$value])
|
||||
&& $starts->[$value] >= 0;
|
||||
}
|
||||
elsif ($kind eq 'named') {
|
||||
_append_span(
|
||||
$state,
|
||||
$subject,
|
||||
$named_spans->{$value}->[0],
|
||||
$named_spans->{$value}->[1],
|
||||
) if exists($named_spans->{$value});
|
||||
}
|
||||
else {
|
||||
die 'The fixed replacement tokenizer produced an invalid token.';
|
||||
}
|
||||
}
|
||||
return !$state->{truncated};
|
||||
}
|
||||
|
||||
sub _open_output {
|
||||
my ($maximum, $path) = @_;
|
||||
open my $handle, '>:raw', $path
|
||||
or die "Unable to open the fixed bridge output file: $!";
|
||||
return {
|
||||
handle => $handle,
|
||||
bytes => 0,
|
||||
maximum => 0 + $maximum,
|
||||
truncated => $FALSE,
|
||||
};
|
||||
}
|
||||
|
||||
sub _close_output {
|
||||
my ($state) = @_;
|
||||
close $state->{handle}
|
||||
or die "Unable to close the fixed bridge output file: $!";
|
||||
delete $state->{handle};
|
||||
}
|
||||
|
||||
sub _run_regex {
|
||||
my ($request) = @_;
|
||||
my ($compiled, $compile_error) = _compile_pattern(
|
||||
$request->{pattern},
|
||||
$request->{flags},
|
||||
);
|
||||
return _failure('compile', 'compile-error', $compile_error)
|
||||
if !defined($compiled);
|
||||
my $group_count = _capture_group_count($compiled);
|
||||
return _failure(
|
||||
'compile',
|
||||
'capture-group-limit',
|
||||
"The pattern declares $group_count capture groups; "
|
||||
. "the bridge limit is $MAXIMUM_CAPTURE_GROUPS.",
|
||||
) if $group_count > $MAXIMUM_CAPTURE_GROUPS;
|
||||
|
||||
my $rows_per_match = $group_count > 0 ? $group_count : 1;
|
||||
my $allowed_matches = $request->{maximumMatches};
|
||||
my $row_bound = int($request->{maximumCaptureRows} / $rows_per_match);
|
||||
$allowed_matches = $row_bound if $row_bound < $allowed_matches;
|
||||
|
||||
my $subject = $request->{subject};
|
||||
my $global = index($request->{flags}, 'g') >= 0;
|
||||
my $replacement_tokens = $request->{operation} eq 'replace'
|
||||
? _tokenize_replacement($request->{replacement}, $group_count)
|
||||
: undef;
|
||||
my @matches;
|
||||
my $results_truncated = $FALSE;
|
||||
my $replacement_state = defined($replacement_tokens)
|
||||
? _open_output($request->{maximumOutputBytes}, $OUTPUT_PATH)
|
||||
: undef;
|
||||
$replacement_state->{cursor} = 0 if defined($replacement_state);
|
||||
|
||||
pos($subject) = 0;
|
||||
while ($subject =~ /$compiled/g) {
|
||||
my @starts = @-;
|
||||
my @ends = @+;
|
||||
if (@matches >= $allowed_matches) {
|
||||
$results_truncated = $TRUE;
|
||||
last;
|
||||
}
|
||||
push @matches, _snapshot_match(
|
||||
$group_count,
|
||||
\@starts,
|
||||
\@ends,
|
||||
);
|
||||
|
||||
if (defined($replacement_state)) {
|
||||
_append_span(
|
||||
$replacement_state,
|
||||
$subject,
|
||||
$replacement_state->{cursor},
|
||||
$starts[0],
|
||||
);
|
||||
if (!$replacement_state->{truncated}) {
|
||||
my $named_spans = _resolve_named_spans(
|
||||
$replacement_tokens,
|
||||
$subject,
|
||||
\@starts,
|
||||
\@ends,
|
||||
\%+,
|
||||
);
|
||||
_append_replacement_tokens(
|
||||
$replacement_state,
|
||||
$replacement_tokens,
|
||||
$subject,
|
||||
\@starts,
|
||||
\@ends,
|
||||
$named_spans,
|
||||
);
|
||||
}
|
||||
$replacement_state->{cursor} = $ends[0];
|
||||
if ($replacement_state->{truncated}) {
|
||||
$results_truncated = $TRUE;
|
||||
last;
|
||||
}
|
||||
}
|
||||
last if !$global;
|
||||
}
|
||||
|
||||
my $response = {
|
||||
abi => $BRIDGE_ABI_VERSION,
|
||||
ok => $TRUE,
|
||||
groupCount => 0 + $group_count,
|
||||
groupNames => [],
|
||||
matches => \@matches,
|
||||
resultsTruncated => $results_truncated,
|
||||
};
|
||||
if (defined($replacement_state)) {
|
||||
_append_span(
|
||||
$replacement_state,
|
||||
$subject,
|
||||
$replacement_state->{cursor},
|
||||
length($subject),
|
||||
);
|
||||
_close_output($replacement_state);
|
||||
$response->{outputBytes} = 0 + $replacement_state->{bytes};
|
||||
$response->{outputTruncated} = $replacement_state->{truncated};
|
||||
}
|
||||
return $response;
|
||||
}
|
||||
|
||||
sub _render_self_test_replacement {
|
||||
my ($compiled, $subject, $template, $maximum) = @_;
|
||||
my $group_count = _capture_group_count($compiled);
|
||||
my $tokens = _tokenize_replacement($template, $group_count);
|
||||
return if $subject !~ /$compiled/;
|
||||
my @starts = @-;
|
||||
my @ends = @+;
|
||||
my $named_spans = _resolve_named_spans(
|
||||
$tokens,
|
||||
$subject,
|
||||
\@starts,
|
||||
\@ends,
|
||||
\%+,
|
||||
);
|
||||
my $encoded = '';
|
||||
my $state = _open_output($maximum, \$encoded);
|
||||
_append_span($state, $subject, 0, $starts[0]);
|
||||
_append_replacement_tokens(
|
||||
$state,
|
||||
$tokens,
|
||||
$subject,
|
||||
\@starts,
|
||||
\@ends,
|
||||
$named_spans,
|
||||
);
|
||||
_append_span($state, $subject, $ends[0], length($subject));
|
||||
_close_output($state);
|
||||
my $decoded = $encoded;
|
||||
return if !utf8::decode($decoded);
|
||||
return ($decoded, 0 + $state->{bytes}, $state->{truncated});
|
||||
}
|
||||
|
||||
sub _self_test {
|
||||
return $FALSE if "$^V" ne 'v5.28.1';
|
||||
my ($compiled, $error) = _compile_pattern(
|
||||
'(?<word>\x{1F600}+)',
|
||||
'u',
|
||||
);
|
||||
return $FALSE if $error || !defined($compiled);
|
||||
my $subject = "x\x{1F600}\x{1F600}";
|
||||
return $FALSE if $subject !~ /$compiled/;
|
||||
return $FALSE if $-[0] != 1 || $+[0] != 3;
|
||||
return $FALSE if $+{word} ne "\x{1F600}\x{1F600}";
|
||||
my ($named, $named_bytes, $named_truncated) =
|
||||
_render_self_test_replacement(
|
||||
$compiled,
|
||||
$subject,
|
||||
'<${word}>',
|
||||
1_024,
|
||||
);
|
||||
return $FALSE if !defined($named)
|
||||
|| $named ne "x<\x{1F600}\x{1F600}>"
|
||||
|| $named_bytes != 11
|
||||
|| $named_truncated;
|
||||
my $native_named = $subject;
|
||||
$native_named =~ s/$compiled/<$+{word}>/;
|
||||
return $FALSE if $named ne $native_named;
|
||||
my $numbered_compiled = qr/(a)(b)/;
|
||||
my ($numbered, $numbered_bytes, $numbered_truncated) =
|
||||
_render_self_test_replacement(
|
||||
$numbered_compiled,
|
||||
'ab',
|
||||
'$1-$$',
|
||||
1_024,
|
||||
);
|
||||
my $native_numbered = 'ab';
|
||||
$native_numbered =~ s/$numbered_compiled/$1-\$/;
|
||||
return $FALSE if !defined($numbered)
|
||||
|| $numbered ne $native_numbered
|
||||
|| $numbered_bytes != 3
|
||||
|| $numbered_truncated;
|
||||
my ($greedy, $greedy_bytes, $greedy_truncated) =
|
||||
_render_self_test_replacement(
|
||||
qr/(a)(b)/,
|
||||
'ab',
|
||||
'$12/$1/$$/${missing}/$',
|
||||
1_024,
|
||||
);
|
||||
return $FALSE if !defined($greedy)
|
||||
|| $greedy ne '/a/$//$'
|
||||
|| $greedy_bytes != 7
|
||||
|| $greedy_truncated;
|
||||
my ($bounded, $bounded_bytes, $bounded_truncated) =
|
||||
_render_self_test_replacement(
|
||||
$compiled,
|
||||
$subject,
|
||||
'<${word}>',
|
||||
5,
|
||||
);
|
||||
return $FALSE if !defined($bounded)
|
||||
|| $bounded ne 'x<'
|
||||
|| $bounded_bytes != 2
|
||||
|| !$bounded_truncated;
|
||||
return $TRUE;
|
||||
}
|
||||
|
||||
sub _identity {
|
||||
return {
|
||||
abi => $BRIDGE_ABI_VERSION,
|
||||
ok => $TRUE,
|
||||
identity => {
|
||||
bridge => 'regex-tools-webperl-json',
|
||||
bridgeVersion => $BRIDGE_ABI_VERSION,
|
||||
engine => 'Perl regular expressions',
|
||||
engineVersion => '5.28.1',
|
||||
perlVersion => "$^V",
|
||||
webPerlVersion => '0.09-beta',
|
||||
offsetUnit => 'code-point',
|
||||
replacementGrammar => 'literal + $$ + $n + ${name}',
|
||||
replacementTransport => 'fixed MEMFS binary output file',
|
||||
replacementParityOracle => 'fixed native s/// fixtures',
|
||||
legacy => $TRUE,
|
||||
beta => $TRUE,
|
||||
selfTest => _self_test(),
|
||||
},
|
||||
};
|
||||
}
|
||||
|
||||
sub run_request {
|
||||
my $response;
|
||||
my $ok = eval {
|
||||
my $request = _read_request();
|
||||
my $validation_failure = _validate_request($request);
|
||||
$response = $validation_failure
|
||||
|| ($request->{operation} eq 'identity'
|
||||
? _identity()
|
||||
: _run_regex($request));
|
||||
1;
|
||||
};
|
||||
if (!$ok) {
|
||||
$response = _failure(
|
||||
'bridge',
|
||||
'bridge-error',
|
||||
$@ || 'Unknown fixed Perl bridge failure',
|
||||
);
|
||||
}
|
||||
eval { _write_response($response); 1 } or do {
|
||||
my $fallback = _failure(
|
||||
'bridge',
|
||||
'serialization-error',
|
||||
$@ || 'The fixed Perl bridge could not serialize its response.',
|
||||
);
|
||||
_write_response($fallback);
|
||||
};
|
||||
return 'ok';
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user