patchmarriage.pl

#!/usr/bin/env perl

use v5.26.1;
use strict;
use warnings;
use autodie qw(:all);

our $VERSION = 'v1.0';

use Digest::file qw(digest_file_base64);
use File::Copy;
use File::Temp;
use Getopt::Long;
use Pod::Usage;
use IO::File;

my $original_path;
my $patched_path;
my $range = 15;
my $invert = 1;
my $help = 0;

GetOptions('original=s' => \$original_path,
           'patched=s' => \$patched_path,
           'range=i' => \$range,
           'invert!' => \$invert,
           'help|?' => \$help);

pod2usage(0) if $help;

if (!defined($original_path) || !defined($patched_path)
    || !defined($range) || !defined($invert)) {
    pod2usage(1);
}

die "$patched_path already exists" if -e $patched_path;

my $original_digest = digest_file_base64($original_path, "SHA-1");

sub expect {
    my ($fh, $offset, $expected) = @_;
    $fh->seek($offset, 0);
    my $original;
    $fh->read($original, length($expected));
    if ($original ne $expected) {
        die <<ERROR;
expected @{[unpack('H*', $expected)]}
received @{[unpack('H*', $original)]}
ERROR
    }
}

sub patch {
    my ($fh, $offset, $expected, $patched) = @_;
    printf("@%x\n", $offset);
    say unpack('H*', $expected);
    say unpack('H*', $patched);
    die "length mismatch" if length($expected) != length($patched);
    expect($fh, $offset, $expected);
    $fh->seek($offset, 0);
    $fh->write($patched);
    expect($fh, $offset, $patched);
}

sub linux64_44_12 {
    my ($fh) = @_;
    #  (eax = age difference) add $9, %eax; cmp $18, %eax; ja
    my $original = pack('H*', '83c00983f8120f87');
    die "range must not be zero" if !$range;
    die "range must be less than 128" if 2 * $range > 255;
    my $patched = '83c0' . sprintf('%02x', $range);
    $patched .= '83f8' . sprintf('%02x', 2 * $range);
    if ($invert) {
        $patched .= '0f86'; # jbe
    } else {
        $patched .= '0f87';
    }
    for my $offset (0x0c4ed67, 0x0c7d82f) {
        patch($fh, $offset, $original, pack('H*', $patched));
    }
}

my %digests = (hTVmt1eReW9h36t2uKQv4nTjoEA => \&linux64_44_12);

unless (exists $digests{$original_digest}) {
    die "$original_path ($original_digest) not a supported version";
}

my ($tmp_file, $tmp_path) = File::Temp::tempfile;
File::Copy::copy($original_path, $tmp_path);

$digests{$original_digest}->($tmp_file);

File::Copy::move($tmp_path, $patched_path);

say "wrote $patched_path";

__END__

=head1 patchmarriage.pl

patchmarriage.pl - manipulate Dwarf Fortress marriageability

=head1 SYNOPSIS

patchmarriage.pl [options] --original <infile-DF-binary> --patched <outfile>

=head1 OPTIONS

=item B<--range=<years>>

Require being within <years> of age to marry (default: 15). Can't be 0
presently

=item B<--[no-]invert>

Invert marriageability requirements (default: --invert)