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;