#!/usr/bin/env perl
# ======================================================================
# NAME: fettle.pl (Dynamic via $me)
# PURPOSE: A high-integrity utility for making exact, precise, and
#          repeatable changes to files using only perl-base.
# ======================================================================
use strict;
use warnings;
use Getopt::Long;
use File::Basename;

# Identify the script name dynamically for usage and error reporting
my $me = basename($0);

# ======================================================================
# DEPENDENCIES:
# This utility requires only 'perl-base' and the following binaries
# which are standard in Debian 12/13 base images:
#   - /usr/bin/cksum (from coreutils) for integrity verification
#   - /usr/bin/gzip  (for compressed patch support)
# ======================================================================

# --- 1. Global Constants & Indices ---
# Stat array indices for readability and easy maintenance
my ($ST_MODE, $ST_UID, $ST_GID, $ST_SIZE, $ST_MTIME) = (2, 4, 5, 7, 9);

# --- 2. Minimal Native Copy ---
# Performs a binary-safe copy without external dependencies.
# Used for creating temporary work files and original backups.
sub native_copy {
    my ($source_path, $destination_path) = @_;
    open(my $in,  '<', $source_path)      or die "$me: Could not read $source_path: $!";
    open(my $out, '>', $destination_path) or die "$me: Could not write $destination_path: $!";
    binmode($in);
    binmode($out);
    print $out $_ while <$in>;
    close($in);
    close($out);
}

# --- 3. Hashing Helpers ---
# Internal helper to get a file's fingerprint using the system 'cksum' utility.
sub _get_digest {
    my ($file_path, $algo) = @_;
    return "" unless -f $file_path;
    # Executes system cksum with specified algorithm (e.g., sha1, sha512).
    # Safely open a pipe without invoking a shell
    open(my $pipe, "-|", "/usr/bin/cksum", "-a", $algo, $file_path) or return "";
    my $cksum_output = <$pipe>;
    close($pipe);
    chomp($cksum_output);
    return "" unless $cksum_output;
    # Extract only the hex fingerprint from the tool's output.
    my ($fingerprint) = $cksum_output =~ /=\s+([a-f0-9]+)/i;
    return $fingerprint || "";
}

# Specific aliases for readability: sha1 for patch ID, sha512 for file integrity.
sub get_patch_id { return _get_digest(shift, "sha1"); }
sub get_file_fingerprint { return _get_digest(shift, "sha512"); }

# --- 4. Configuration & Globals ---
# Default fuzz_range allows the patcher to look 25 lines up/down for a match.
my ($dry_run, $revert, $clean, $fuzz_range) = (0, 0, 0, 25);
GetOptions(
    "dry-run" => \$dry_run,    # Pre-calculates offsets and validates files
    "fuzz=i"  => \$fuzz_range, # User-adjustable search range for line drifts
    "revert"  => \$revert,     # Restore files from .orig backups
    "clean"   => \$clean       # Delete .orig backups
);

my $patch_file = $ARGV[0] or die "Usage: $me [--dry-run|--revert|--clean] <patch_file>\n";
my $patch_hash = get_patch_id($patch_file);
die "$me: Could not generate ID for patch file.\n" unless $patch_hash;

# Locate a writable directory for state tracking, preferring /cache if on a tmpfs mount.
my $state_directory;
if (open(my $mount_fh, '<', '/proc/mounts')) {
    while (my $mount_line = <$mount_fh>) {
        if ($mount_line =~ /^\S+\s+\/cache\s+tmpfs\s+/) {
            $state_directory = "/cache" if -w "/cache";
            last;
        }
    }
    close($mount_fh);
}
$state_directory ||= ($ENV{TMPDIR} && -d $ENV{TMPDIR} && -w _) ? $ENV{TMPDIR} : ".";

my $state_file = "$state_directory/.${me}_state_${patch_hash}";
my $temp_suffix = substr($patch_hash, 0, 11);

# --- 5. Patch Parsing ---
# Scans the patch file to build a map of files to be modified and their hunks.
open(my $patch_fh, '<', $patch_file) or die "$me: Cannot open patch: $!\n";
binmode($patch_fh);
read($patch_fh, my $buffer, 2);
close($patch_fh);
if (defined $buffer && $buffer eq "\x1f\x8b") {
    open($patch_fh, "-|", "/usr/bin/gzip", "-dc", "--", $patch_file) or die "$me: Cannot open patch using zcat: $!";
} else {
    open($patch_fh, '<', $patch_file) or die "$me: Cannot open patch: $!\n";
}
my %patches;
my $current_file;
my $is_git_format = 0;

while (my $line = <$patch_fh>) {
    # Detects git-style diff headers to properly handle additions/deletions.
    if ($line =~ /^diff --git\s+a\/.+?\s+b\/.+$/) {
        undef $current_file; # Reset context for high-integrity parsing
        $is_git_format = 1; next;
    }
    elsif ($is_git_format && $line =~ /^deleted file mode/) {
        $patches{$current_file}{deleted} = 1 if $current_file; next;
    }
    # Parse source ('---') and destination ('+++') file paths.
    elsif ($line =~ /^--- (?:a\/)?(.+)$/) {
        my $path = $1; $path =~ s/(?:\t.*|\s+)$//;
        $current_file = $path unless $path eq '/dev/null';
    }
    elsif ($line =~ /^\+\+\+ (?:b\/)?(.+)$/) {
        my $path = $1; $path =~ s/(?:\t.*|\s+)$//;
        if ($path eq '/dev/null') { $patches{$current_file}{deleted} = 1; }
        else { $current_file = $path; $patches{$current_file}{deleted} = 0; }
    }
    # Capture hunk headers: @@ -old_start,len +new_start,len @@
    # Handle hunk header with optional counts (default to 1)
    elsif ($current_file && $line =~ /^@@ \-(\d+)(?:,(\d+))? \+(\d+)(?:,(\d+))? @@/) {
        push @{$patches{$current_file}{hunks}}, {
            old_start      => $1,
            old_count      => $2 // 1, # Default to 1 if count is missing
            new_start      => $3,
            new_count      => $4 // 1, # Default to 1 if count is missing
            lines          => [],
            no_eof_newline => 0
        };
    }
    # Accumulate hunk content (context lines, additions, or deletions).
    elsif ($current_file && @{$patches{$current_file}{hunks}}) {
        if ($line =~ /^\\ No newline at end of file/) {
            $patches{$current_file}{hunks}[-1]{no_eof_newline} = 1;
        }
        else {
            push @{$patches{$current_file}{hunks}[-1]{lines}}, $line if $line =~ /^[ \+\-]/;

        }
    }
}
close($patch_fh);

# --- 6. Clean and Revert ---
# Logic for cleaning up or rolling back previously applied patches using the state file.
my %state_metadata;
if (-e $state_file) {
    open(my $sf_fh, '<', $state_file); <$sf_fh>; # Skip header
    while (<$sf_fh>) {
        chomp;
        my ($filename, $mtime, $size, $offsets, $status, $source_hash) = split(/\|/);
        $state_metadata{$filename} = { status => $status, hash => $source_hash };
    }
    close($sf_fh);
}

if ($clean || $revert) {
    print(($clean ? "Cleaning backups...\n" : "Reverting to original state...\n"));
    my $errors = 0;
    foreach my $target (keys %patches) {
        my $backup = "$target.orig";
        if ($clean && -e $backup) {
            unlink($backup) or (warn("$me: Skip delete $backup: $!\n"), $errors++);
        }
        elsif ($revert && -e $backup) {
            # If the file was created by the patch, remove it entirely.
            if ($state_metadata{$target} && $state_metadata{$target}{status} eq "NEW") {
                # If the patch created it, delete it
                (unlink($target) or $errors++) if -e $target;
                unlink($backup) or $errors++;
                print "  Removed created file: $target\n";
            } else {
                # Restore existing files from their .orig backup.
                # Attempt restoration of all files regardless of individual failures
                rename($backup, $target) or (warn("$me: Failed to restore $target: $!\n"), $errors++);
                print "  Restored: $target\n";
            }
        }
    }

    unlink($state_file) if -e $state_file && $errors == 0;

    # Exit with non-zero status if any part of the operation failed
    exit($errors > 0 ? 1 : 0);
}

# --- 7. Hunk Matching Engine ---
# Finds the correct line index in a file to apply a hunk, accounting for line drifts.
sub find_hunk_index {
    my ($file_content, $hunk_lines, $start_pos) = @_;
    # Only use ' ' (context) and '-' (to-be-removed) lines for matching.
    my @match_search = grep { /^[ -]/ } @$hunk_lines;

    # Try exact match first.
    return $start_pos if verify_context($file_content, \@match_search, $start_pos);

    # Search within the 'fuzz' range for a shifted match.
    for (my $offset = 1; $offset <= $fuzz_range; $offset++) {
        return ($start_pos - $offset) if verify_context($file_content, \@match_search, $start_pos - $offset);
        return ($start_pos + $offset) if verify_context($file_content, \@match_search, $start_pos + $offset);
    }
    return undef; # Hunk does not apply (context mismatch).
}

# Helper to verify if the hunk's context matches the actual file content at a given index.
sub verify_context {
    my ($lines, $search, $idx) = @_;
    my $search_size = scalar @$search;
    return 0 if $idx < 0 || ($idx + $search_size) > scalar @$lines;
    for (my $i = 0; $i < $search_size; $i++) {
        my $f_text = $lines->[$idx + $i]; $f_text =~ s/[\r]?$//;
        my $h_text = substr($search->[$i], 1); $h_text =~ s/[\r]?$//;
        return 0 if $f_text ne $h_text;
    }
    return 1;
}

# --- 8. Dry Run ---
# Pre-validation phase: Checks if all hunks can be matched and records offsets.
if ($dry_run) {
    use Cwd 'abs_path';
    open(my $sf_out, '>', $state_file) or die "$me: Cannot create state file: $!\n";
    print $sf_out "CKSUM:$patch_hash\n";
    
    my ($ready_cnt, $fail_cnt, $new_cnt, $del_cnt) = (0, 0, 0, 0);
    
    foreach my $f (sort keys %patches) {
        my $abs_target = -e $f ? abs_path($f) : $f;
        
        if ($patches{$f}{deleted}) {
            print "DELETE: [Target Removal]\n  Path: $abs_target\n\n";
            $ready_cnt++; $del_cnt++; next;
        }

        if (-f $f) {
            my @stats = stat($f);
            my $file_hash = get_file_fingerprint($f);

            if (exists $state_metadata{$f} && $state_metadata{$f}{hash} ne "" 
                && $state_metadata{$f}{hash} ne $file_hash) {
                print "FAIL:   [Hash Conflict] (Content changed since state recorded)\n";
                print "  Path: $abs_target\n";
                my $oct_mode = sprintf("%05o", $stats[$ST_MODE] & 07777);
                print "  Stat: Size:$stats[$ST_SIZE] UID:$stats[$ST_UID] GID:$stats[$ST_GID] Mode:$oct_mode\n\n";
                $fail_cnt++;
                next; 
            }

            open(my $fh, '<', $f); my @content = <$fh>; close($fh);

            my (@offsets, $failed, $matched_hunks) = ((), 0, 0);
            foreach my $h (@{$patches{$f}{hunks}}) {
                my $idx = find_hunk_index(\@content, $h->{lines}, $h->{old_start} - 1);
                if (defined $idx) {
                    push @offsets, ($idx - ($h->{old_start} - 1));
                    $matched_hunks++;
                } else { $failed = 1; }
            }

            my $total = scalar @{$patches{$f}{hunks}};
            if ($failed) {
                print "FAIL:   ($matched_hunks/$total hunks matched)\n";
                $fail_cnt++;
            } else {
                # Report if we found it exactly or had to use fuzz
                my $drift = 0; foreach (@offsets) { $drift = abs($_) if abs($_) > $drift; }
                my $type = $drift == 0 ? "Exact" : "Fuzzed (drift $drift)";
                print "READY:  [$type] ($matched_hunks/$total hunks)\n";
                $ready_cnt++;
            }
            
            my $oct_mode = sprintf("%05o", $stats[$ST_MODE] & 07777);
            print "  Path: $abs_target\n";
            print "  Stat: Size:$stats[$ST_SIZE] UID:$stats[$ST_UID] GID:$stats[$ST_GID] Mode:$oct_mode\n\n";

            # Save metadata to ensure the file hasn't changed between dry-run and apply.
            print $sf_out "$f|$stats[$ST_MTIME]|$stats[$ST_SIZE]|" . join(",", @offsets) . "|EXISTING|$file_hash\n" unless $failed;
        } 
        elsif (!-e $f) {
            print "CREATE: [New File]\n";
            print "  Path: $abs_target\n";
            print "  Stat: # File does not yet exist\n\n";
            
            print $sf_out "$f|0|0||NEW|\n";
            $ready_cnt++; $new_cnt++;
        }
    }
    close($sf_out);

    if ($fail_cnt > 0) {
        print "VERDICT: FAILED\n";
        print "  $fail_cnt file(s) could not be matched.\n";
        exit 1;
    } else {
        print "VERDICT: SUCCESS\n";
        print "  $ready_cnt file(s) ready to patch.\n";
        print "  $new_cnt file(s) pending creation.\n" if $new_cnt > 0;
        print "  $del_cnt file(s) pending removal.\n" if $del_cnt > 0;
        exit 0;
    }
}

# --- 9. Execution ---
# Load offsets/hashes generated during the Dry Run to ensure consistent application.
my %stabilized_data;
if (-e $state_file) {
    open(my $sf_in, '<', $state_file); <$sf_in>;
    while (<$sf_in>) {
        chomp; my ($f, $m, $s, $o, $st, $shash) = split(/\|/);
        @{$stabilized_data{$f}} = (split(",", $o), $st, $shash);
    }
    close($sf_in);
}

my @processed_files;
my @deferred_unlinks;

# Use eval to handle errors gracefully and trigger a rollback if any file fails.
eval {
    foreach my $target (keys %patches) {
        my $temp_work_file = "${target}.tmp_${temp_suffix}";
        unlink($temp_work_file) if -e $temp_work_file;
        my $backup_file = "$target.orig";
        my $expected_hash = defined $stabilized_data{$target} ? $stabilized_data{$target}[-1] : "";

        # Step A: Safe Backup Sequence
        # Creates a backup before any modification. rename() is used to ensure atomicity.
        if (-e $target && !-e $backup_file) {
            my $current_disk_hash = get_file_fingerprint($target);
            die "State Conflict: $target drift detected!\n" if $expected_hash ne $current_disk_hash;

            native_copy($target, $temp_work_file);
            rename($target, $backup_file) or die "Renaming backup failed: $target\n";
            push @processed_files, $target;
            rename($temp_work_file, $target) or die "Activating working copy failed: $target\n";

            # Validate that the file hasn't been corrupted during the copy/move process.
            my $work_hash = get_file_fingerprint($target);
            die "Integrity Check Failed: $target corruption!\n" if $expected_hash ne $work_hash;

            push @deferred_unlinks, $target if $patches{$target}{deleted};
        }
        elsif (!-e $target && !-e $backup_file) {
            # For new files, create a marker backup so rollback knows to delete them.
            open(my $marker_fh, '>', $backup_file); close($marker_fh);
            push @processed_files, $target;
        }

        next if $patches{$target}{deleted};

        # Step B: Application Logic
        # Builds the directory structure if it doesn't exist.
        my $target_dir = dirname($target);
        if (!-d $target_dir) {
            my $path_acc = "";
            foreach my $seg (split(/\//, $target_dir)) {
                next if $seg eq ""; $path_acc .= "/$seg";
                mkdir($path_acc, 0755) if !-d $path_acc;
            }
        }

        my @file_lines = (-e $target) ? do { open(my $fh, '<', $target); <$fh> } : ();
        my @hunks   = @{$patches{$target}{hunks} // []};
        # Accessing metadata status/hash relative to the end of the stored list
        my @offsets = defined $stabilized_data{$target} ? @{$stabilized_data{$target}}[0..$#{$stabilized_data{$target}}-2] : ();
        my $suppress_final_newline = 0;

        # Apply hunks in reverse order to keep line indices stable for earlier hunks.
        for (my $i = $#hunks; $i >= 0; $i--) {
            my $h = $hunks[$i];
            my $zi_ln = $h->{old_start} - 1;
            my $match_idx = (@file_lines) ? (defined $offsets[$i] ? ($zi_ln+$offsets[$i]) : find_hunk_index(\@file_lines, $h->{lines}, $zi_ln)) : 0;
            die "Match failed during apply: $target\n" unless defined $match_idx;

            $suppress_final_newline = 1 if $i == $#hunks && $h->{no_eof_newline};

            my ($removed_count, @transformed) = (0, ());
            foreach my $line (@{$h->{lines}}) {
                my $ind  = substr($line, 0, 1);
                my $text = (length($line) > 1) ? substr($line, 1) : "";
                $text =~ s/\r?[\n]+$//;
                $text = ($text . "\n");
                # '-' lines are not added to the list
                # '+' lines do not increment the removal count
                if ('-' eq $ind || ' ' eq $ind) {
                    $removed_count++;
                    push @transformed, $text if ' ' eq $ind;
                }
                elsif ('+' eq $ind) { push @transformed, $text; }
            }
            # Use splice to replace the matched block with the new transformed lines.
            splice(@file_lines, $match_idx, $removed_count, @transformed);
        }

        # Step C: Final Atomic Commit
        # Writes the fully patched result to a temp file, then swaps it with the target.
        open(my $out_fh, '>', $temp_work_file) or die "Write temp failed: $target\n";
        for (my $i = 0; $i <= $#file_lines; $i++) {
            my $l = $file_lines[$i]; $l =~ s/\r?[\n]+$//;
            print $out_fh ($i == $#file_lines && $suppress_final_newline) ? $l : $l . "\n";
        }
        close($out_fh);

        if (-e $backup_file) {
            my @orig_stat = stat($backup_file);
            # Apply original UID and GID
            chown($orig_stat[$ST_UID], $orig_stat[$ST_GID], $temp_work_file)
                or warn "$me: Warning: Could not preserve ownership for $target: $!\n";
            
            # Apply original permissions (mode)
            # Mask with 07777 to keep only the permission and special bits
            chmod($orig_stat[$ST_MODE] & 07777, $temp_work_file)
                or warn "$me: Warning: Could not preserve permissions for $target: $!\n";
        }

        rename($temp_work_file, $target) or die "Commit failed: $target\n";
    }

    # Clean up files marked for deletion after successful application.
    foreach my $f_to_del (@deferred_unlinks) {
        unlink($f_to_del) or warn "$me: Unlink failed: $f_to_del: $!\n";
    }
};

# Rollback Logic: Restores files to their state before the script began if an error occurred.
if ($@) {
    warn "$me: Application Error: $@. Rolling back changes...\n";
    foreach my $f (@processed_files) {
        my $orig = "$f.orig";
        if (-e $orig) {
            # Accessing metadata status relative to the end of the stored list
            my $status = defined $stabilized_data{$f} ? $stabilized_data{$f}[-2] : "EXISTING";
            if ($status eq "NEW") { unlink($f) if -e $f; unlink($orig); }
            else { rename($orig, $f); }
        }
    }
    exit 1;
}

unlink($state_file) if -e $state_file;
print "Success.\n";