package NotFork::Method::Fragment_patch;

# Copyright 2021 The LumoSQL Authors, see LICENSES/MIT
#
# SPDX-License-Identifier: MIT
# SPDX-FileCopyrightText: 2020 The LumoSQL Authors
# SPDX-ArtifactOfProjectName: not-forking
# SPDX-FileType: Code
# SPDX-FileComment: Original by Claudio Calvelli, 2021
# SPDX-FileComment: Internal hunk applier added 2026, see
#                   doc/fragment_patch-specification.md

# Handle a "fragment_patch" modification file; this is similar to a normal
# patch but considers the source file built of fragments (normally functions
# or some other easily identifiable feature) and applies patches to all
# fragments separately; this makes it easier to adjust to upstream changes,
# for example if the function being patched is the only thing in the whole
# source which hasn't changed, the normal "patch" may not find it, this
# one will.
#
# The hunk-apply step no longer shells out to patch(1).  apply() splits the
# target file into before/fragment/after using the recipe's regex anchors
# (unchanged), then applies the recipe's unified-diff hunks to "fragment" with
# a deterministic in-tree applier (see doc/fragment_patch-specification.md):
# each hunk's old-image is matched against "fragment" by exact line content
# (trailing newline included), and its new-image is spliced in.  There is no
# fuzz, no offset search, and no whitespace munging; output depends only on the
# fragment bytes and the hunk bytes.  A hunk that does not match dies with a
# diagnostic in not-fork terms (recipe, fragment, anchor) including a near-miss.

use strict;
use Carp;
use Fcntl ':seek';
use NotFork::Method::patch_common;
use File::Temp;
use Exporter;

our @ISA = qw(NotFork::Method::patch_common Exporter);
our @EXPORT = ();
our @EXPORT_OK = qw(quote unquote);

sub new {
    @_ == 4 or croak "Usage: Notfork::Method::Fragment_patch->new(NAME, SRCDIR, OPTIONS)";
    my ($class, $name, $srcdir, $options) = @_;
    bless {
	name      => $name,
	srcdir    => $srcdir,
	fragments => [],
	files     => [],
	NotFork::Method::patch_common::_init($options),
    }, $class;
}

# this is called after NotFork::Get has read the first part of a modification
# file; we scan it to determine a list of files to patch and fragments within
# each file
sub load_data {
    @_ == 3 or croak "Usage: FRAGMENT_PATCH->load_data(FILENAME, FILEHANDLE)";
    my ($obj, $fn, $fh) = @_;
    my %files = ();
    NAME: while (defined (my $name = <$fh>)) {
	chomp $name;
	$name =~ s/^\s+//;
	$name =~ s/\s+$//;
	$name = unquote($name);
	$files{$name} = undef;
	while (1) {
	    my @data;
	    for my $what (qw(start end)) {
		my $data = <$fh>;
		defined $data or die "$fn: Missing $what\n";
		chomp $data;
		$data =~ s/^\s+//;
		$data =~ s/\s+$//;
		my $value;
		if ($what eq 'start' && $data eq '-----') {
		    next NAME;
		} elsif ($data eq $what) {
		    $data = undef;
		} elsif ($data =~ /^\//) {
		    if ($what eq 'start') {
			$data =~ s/\/\s+(\S+)$//
			    or die "$fn: Invalid line ($what): $data\n";
			$value = unquote($1);
		    } else {
			$data =~ s/\/$//
			    or die "$fn: Invalid line ($what): $data\n";
		    }
		    $data =~ s/^\///;
		    $data = qr/$data/;
		} else {
		    die "$fn: Invalid line ($what): $data\n";
		}
		push @data, $data, $value;
	    }
	    my $pos = tell $fh;
	    defined $pos or die "$fn: $!\n";
	    my $end_pos = $pos;
	    while (<$fh>) {
		chomp;
		$_ eq '---' and last;
		$end_pos = tell $fh;
		defined $end_pos or die "$fn: $!\n";
	    }
	    push @{$obj->{fragments}}, [$name, $fn, $pos, $end_pos, @data];
	}
    }
    push @{$obj->{files}}, sort keys %files;
    $obj;
}

# this is called to apply a patch; we copy the file from the original
# (VCS dir) into a cache directory then apply the patch there
# we could make this more efficient by ordering the fragments
# and not splitting/joining the file for each fragment; maybe in
# a future version
sub apply {
    @_ == 8 or croak "Usage: FRAGMENT_PATCH->apply(VCS_DIR, VCS_OBJ, SUBTREE, REPLACE_CALLBACK, EDIT_CALLBACK, VERSION, ID)";
    my ($obj, $vcs, $vcs_obj, $subtree, $r_call, $e_call, $version, $commit_id) = @_;
    for my $lp (@{$obj->{fragments}}) {
	my ($name, $fn, $pos, $end_pos, $pattern, $value, $end_pattern) = @$lp;
	# extract the hunk body (the bytes between the end-anchor line and the
	# '---' terminator, which load_data recorded as [$pos .. $end_pos]).
	open my $fh, '<', $fn or die "$fn: $!\n";
	seek $fh, $pos, SEEK_SET or die "$fn: $!\n";
	my $body = '';
	my $diff = $end_pos - $pos;
	my $buffer;
	while ($diff > 0) {
	    my $todo = $diff;
	    $todo > 4096 and $todo = 4096;
	    my $got = read $fh, $buffer, $todo;
	    defined $got or die "$fn: $!\n";
	    $got or last;
	    $diff -= $got;
	    $body .= $buffer;
	}
	close $fh;
	# split the target file into before / fragment / after using the
	# recipe's regex anchors (unchanged behaviour).  Each line keeps the
	# trailing newline it has on disk (if any).
	my $copy = $e_call->($name);
	open my $of, '<', "$copy/$name" or die "$name: $!\n";
	my (@before, @fragment, @after);
	if (defined $pattern) {
	    my $ok = 0;
	    while (<$of>) {
		if ($_ =~ $pattern && (! defined $value || $value eq $1)) {
		    push @fragment, $_;
		    $ok = 1;
		    last;
		}
		push @before, $_;
	    }
	    $ok or die "$name: Fragment not found ($value)\n";
	}
	while (<$of>) {
	    if (defined $end_pattern && $_ =~ $end_pattern) {
		push @after, $_;
		last;
	    }
	    push @fragment, $_;
	}
	while (<$of>) {
	    push @after, $_;
	}
	close $of;
	# diagnostic context: speak in not-fork terms (section 8)
	my %ctx = (
	    recipe       => $fn,
	    file         => $name,
	    start_anchor => (defined $pattern ? "$pattern" : 'start'),
	    start_value  => $value,
	    end_anchor   => (defined $end_pattern ? "$end_pattern" : 'end'),
	);
	# apply the hunks to the fragment in memory (replaces patch(1))
	my $frag_recs  = _split_lines(join('', @fragment));
	my $hunks      = _parse_hunks($body, \%ctx);
	my $out_recs   = _apply_hunks($frag_recs, $hunks, \%ctx);
	my $new_frag   = _join_lines($out_recs);
	# rebuild the file: before + modified fragment + after
	open my $nf, '>', "$copy/$name" or die "$copy/$name: $!\n";
	print $nf @before              or die "$copy/$name: $!\n";
	print $nf $new_frag            or die "$copy/$name: $!\n";
	print $nf @after               or die "$copy/$name: $!\n";
	close $nf or die "$copy/$name: $!\n";
	# tell callback we've finished
	$r_call->($name, "$copy/$name");
    }
}

# fragment_patch applies its hunks itself and no longer needs patch(1).
# Override the inherited patch_common::check_prereq (which requires
# patch/gpatch) so this method declares no external-program prerequisite.
# The plain "patch" method keeps patch_common::check_prereq unchanged.
sub check_prereq {
    @_ == 2 or croak "Usage: FRAGMENT_PATCH->check_prereq(RESULT)";
    my ($obj, $result) = @_;
    # no external prerequisites: the applier is pure Perl
    $obj;
}

# ===========================================================================
# Deterministic in-tree hunk applier.
# See doc/fragment_patch-specification.md (the matching contract).
# ===========================================================================

# A "line record" is { text => STRING (no trailing newline), nl => BOOL }.

# split a raw string into line records, tracking trailing-newline presence (s6)
sub _split_lines {
    my ($raw) = @_;
    my @out;
    while (length $raw) {
	if ($raw =~ s/^([^\n]*)\n//) {
	    push @out, { text => $1, nl => 1 };
	} else {
	    push @out, { text => $raw, nl => 0 };
	    last;
	}
    }
    return \@out;
}

# reassemble line records into a raw string
sub _join_lines {
    my ($lines) = @_;
    my $out = '';
    for my $l (@$lines) {
	$out .= $l->{text};
	$out .= "\n" if $l->{nl};
    }
    return $out;
}

# byte equality including trailing-newline presence (s4.1)
sub _line_eq {
    my ($a, $b) = @_;
    return $a->{text} eq $b->{text} && $a->{nl} == $b->{nl};
}

# parse the hunk body into a list of hunks (s2).
# each hunk: { header => STRING, old => [recs], new => [recs] }
sub _parse_hunks {
    my ($body, $ctx) = @_;
    $ctx ||= {};
    my $body_lines = _split_lines($body);
    my @hunks;
    my $cur;
    my $last_side;   # 'old' | 'new' | 'both' - target for a backslash directive (s6)
    my $finish = sub { push @hunks, $cur if $cur; $cur = undef; };

    for my $rec (@$body_lines) {
	my $line   = $rec->{text};
	my $had_nl = $rec->{nl};

	if ($line =~ /^\@\@ /) {
	    $finish->();
	    $line =~ /^\@\@ -\d+(?:,\d+)? \+\d+(?:,\d+)? \@\@/
		or _applier_die($ctx, "malformed hunk header: $line");
	    $cur = { header => $line, old => [], new => [] };
	    $last_side = undef;
	    next;
	}

	unless (defined $cur) {
	    next if $line eq '';   # tolerate blank lines before the first header
	    _applier_die($ctx, "hunk body line before any \@\@ header: $line");
	}

	# newline directive (s6): the preceding emitted line had no trailing newline
	if ($line =~ /^\\/) {
	    defined $last_side
		or _applier_die($ctx, "newline directive with no preceding line");
	    if ($last_side eq 'old' || $last_side eq 'both') {
		$cur->{old}[-1]{nl} = 0 if @{$cur->{old}};
	    }
	    if ($last_side eq 'new' || $last_side eq 'both') {
		$cur->{new}[-1]{nl} = 0 if @{$cur->{new}};
	    }
	    next;
	}

	# blank context: a line that is exactly empty / was a bare newline (s2.3)
	if ($line eq '') {
	    push @{$cur->{old}}, { text => '', nl => $had_nl };
	    push @{$cur->{new}}, { text => '', nl => $had_nl };
	    $last_side = 'both';
	    next;
	}

	my $first = substr($line, 0, 1);
	if ($first eq ' ') {
	    my $content = substr($line, 1);
	    push @{$cur->{old}}, { text => $content, nl => $had_nl };
	    push @{$cur->{new}}, { text => $content, nl => $had_nl };
	    $last_side = 'both';
	} elsif ($first eq '+') {
	    push @{$cur->{new}}, { text => substr($line, 1), nl => $had_nl };
	    $last_side = 'new';
	} elsif ($first eq '-') {
	    push @{$cur->{old}}, { text => substr($line, 1), nl => $had_nl };
	    $last_side = 'old';
	} else {
	    _applier_die($ctx, "malformed hunk body line (first byte '"
			       . $first . "'): $line");
	}
    }
    $finish->();
    return \@hunks;
}

# apply hunks to the fragment (s4, s5). dies on no-match / ambiguity / empty.
sub _apply_hunks {
    my ($frag, $hunks, $ctx) = @_;
    $ctx ||= {};
    my @out;
    my $pos = 0;   # forward-monotonic cursor (s4.2)

    for my $h (@$hunks) {
	my @old = @{$h->{old}};
	@old or _applier_die($ctx,
	    "hunk has empty old-image (additions only), nothing to match "
	    . "against; header as written: $h->{header}");

	# old-image longer than the whole fragment: the hunk's context spills
	# past an anchor boundary (typically the trailing context line is the
	# end-anchor line, which lives in "after", not "fragment").  This is a
	# structural recipe issue, independent of upstream drift; patch(1)
	# previously hid it by fuzzing the unmatchable context line away.
	if (@old > @$frag) {
	    _applier_die($ctx,
		"no match for hunk (header as written: $h->{header}): its "
		. "old-image is " . scalar(@old) . " lines but the anchored "
		. "fragment is only " . scalar(@$frag) . " line"
		. (@$frag == 1 ? '' : 's') . ".  The hunk's context extends "
		. "past an anchor boundary (a context line likely coincides "
		. "with the end-anchor); regenerate the recipe so the hunk "
		. "stays within the fragment.");
	}

	my @at;
	for (my $i = $pos; $i + @old <= @$frag; $i++) {
	    my $ok = 1;
	    for my $j (0 .. $#old) {
		if (!_line_eq($frag->[$i + $j], $old[$j])) { $ok = 0; last }
	    }
	    push @at, $i if $ok;
	}

	if (@at == 0) {
	    my $miss = _near_miss($frag, \@old, $pos);
	    _applier_die($ctx,
		"no match for hunk (header as written: $h->{header}) within "
		. "the anchored fragment.\n" . $miss);
	}
	if (@at > 1) {
	    my @lines = map { $_ + 1 } @at;
	    _applier_die($ctx,
		"ambiguous match for hunk (header as written: $h->{header}): "
		. "old-image matches at fragment lines " . join(', ', @lines)
		. "; the hunk is under-specified, add more context.");
	}

	my $at = $at[0];
	push @out, @{$frag}[$pos .. $at - 1] if $at > $pos;
	push @out, map { { %$_ } } @{$h->{new}};
	$pos = $at + @old;
    }
    push @out, @{$frag}[$pos .. $#$frag] if $pos <= $#$frag;
    return \@out;
}

# near-miss diagnostic (s8): closest same-length window by line edit distance.
# builds the message only; never affects whether/where a hunk applies.
# in list context returns ($message, $distance).
sub _near_miss {
    my ($frag, $old, $pos) = @_;
    my $n = scalar @$old;
    my ($best_d, $best_i);
    my $hi = @$frag - $n;
    for (my $i = $pos; $i <= $hi; $i++) {
	my $d = 0;
	for my $j (0 .. $n - 1) {
	    $d++ unless _line_eq($frag->[$i + $j], $old->[$j]);
	}
	if (!defined $best_d || $d < $best_d) {
	    $best_d = $d; $best_i = $i;
	    last if $d == 0;
	}
    }
    if (!defined $best_i) {
	my $m = "  (fragment shorter than the hunk's old-image; "
	      . "no comparable window)";
	return wantarray ? ($m, undef) : $m;
    }
    my @lines = ("  closest near-miss at fragment line " . ($best_i + 1)
		 . " (line-distance $best_d):");
    for my $j (0 .. $n - 1) {
	my $exp = $old->[$j];
	my $fnd = $frag->[$best_i + $j];
	if (_line_eq($exp, $fnd)) {
	    push @lines, "    = " . _show_rec($exp);
	} else {
	    push @lines, "    expected: " . _show_rec($exp);
	    push @lines, "    found:    " . _show_rec($fnd);
	}
    }
    my $m = join("\n", @lines);
    return wantarray ? ($m, $best_d) : $m;
}

sub _show_rec {
    my ($rec) = @_;
    my $t = $rec->{text};
    $t =~ s/\t/\\t/g;
    return "'$t'" . ($rec->{nl} ? '' : ' (no newline)');
}

sub _applier_die {
    my ($ctx, $msg) = @_;
    my @hdr;
    push @hdr, "recipe $ctx->{recipe}"            if defined $ctx->{recipe};
    push @hdr, "file $ctx->{file}"                if defined $ctx->{file};
    if (defined $ctx->{start_anchor}) {
	my $s = "start-anchor $ctx->{start_anchor}";
	$s .= " (value: $ctx->{start_value})" if defined $ctx->{start_value};
	push @hdr, $s;
    }
    push @hdr, "end-anchor $ctx->{end_anchor}"    if defined $ctx->{end_anchor};
    my $prefix = @hdr ? join(', ', @hdr) . ":\n  " : '';
    die "fragment_patch: ${prefix}${msg}\n";
}

sub quote {
    my ($v) = @_;
    $v =~ s(([\s\\])){ sprintf "\\x%02x", ord($1) }ge;
    $v;
}

sub unquote {
    my ($v) = @_;
    $v =~ s(\\x([[:xdigit:]]{2})){ chr(hex $1) }ge;
    $v;
}

1;
