450 lines
18 KiB
Perl
Executable File
450 lines
18 KiB
Perl
Executable File
#!/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";
|
|
|