our $DATE = '2017-07-03';
our $VERSION = '0.002';
use 5.010001;
our %SPEC;
$SPEC{progpatcher} = {
v => 1.1,
summary => 'Apply a set of patches to your programs',
description => <<'_',
This is like <prog:pmpatcher> except for programs. You might have a set of
patches that you want to apply on programs in the `PATH`. For example, currently
as of this writing I have this on my `patches` directory:
prog-cpanm.20161127-only_use_uri_from_mirror_where_we_found_module.patch
These patches might be pending for merge upstream, or are of private nature so
might never be merged, or of any other nature. Applying patches is a lightweight
alternative to creating a fork for each of these programs.
This utility helps you making the process of applying these patches more
convenient. Basically this utility just locates all the target modules and
feeds all of these patches to the `patch` program.
To use this utility, first of all you need to gather all your program patches in
a single directory (see `patches_dir` option). Also, you need to make sure that
all patches you want to use match this name pattern:
prog-<PROGRAM-NAME>.<TOPIC>.patch
This directory can be the same as the one you use for `pmpatcher`, since
`pmpatcher` uses another prefix.
Then, to apply all the patches, you just call:
% progpatcher --patches-dir ~/patches
(Or, you might also want to put `patches_dir=/path/to/patches` into
`~/progpatcher.conf` to save you from having to type the option repeatedly.)
Example result:
% progpatcher
+--------------------------------------------------------------------------+--------+---------+
| item_id | status | message |
+--------------------------------------------------------------------------+--------+---------+
| prog-cpanm.20161127-only_use_uri_from_mirror_where_we_found_module.patch | 200 | Applied |
+--------------------------------------------------------------------------+--------+---------+
If you try to run it again, you might get:
% progpatcher
+--------------------------------------------------------------------------+--------+-----------------+
| item_id | status | message |
+--------------------------------------------------------------------------+--------+-----------------+
| prog-cpanm.20161127-only_use_uri_from_mirror_where_we_found_module.patch | 304 | Already applied |
+--------------------------------------------------------------------------+--------+-----------------+
There's also a `--dry-run` and a `-R` (`--reverse`) option, just like `patch`.
_
args => {
patches_dir => {
schema => 'str*',
req => 1,
},
reverse => {
schema => ['bool', is=>1],
cmdline_aliases => {R=>{}},
},
},
deps => {
prog => 'patch',
},
features => {
dry_run => 1,
},
links => [
{url=>'prog:pmpatcher'},
],
};
sub progpatcher {
my %args = @_;
my $patches_dir = $args{patches_dir}
or return [400, "Please specify patches_dir"];
$patches_dir =~ s!/\z!!;
log_trace("Opening patches_dir '%s' ...", $patches_dir);
opendir my($dh), $patches_dir
or return [500, "Can't open patches_dir '$patches_dir': $!"];
my $envres = Perinci::Object::envresmulti();
FILE:
for my $fname (sort readdir $dh) {
next if $fname eq '.' || $fname eq '..';
log_trace("Considering file '%s' ...", $fname);
unless ($fname =~ /\A
prog-
(.+)\.
([^.]+)
\.patch\z/x) {
log_trace("Skipped file '%s' (doesn't match pattern)", $fname);
next FILE;
}
my ($prog, $topic) = ($1, $2);
my $prog_path = File::Which::which($prog);
unless ($prog_path) {
log_info("Skipping patch '%s' (program %s not found in PATH)",
$fname, $prog);
next FILE;
}
(my $prog_dir = $prog_path) =~ s!(.+)[/\\].+!$1!;
open my($fh), "<", "$patches_dir/$fname" or do {
log_error("Skipping patch '%s' (can't open file: %s)",
$fname, $!);
$envres->add_result(500, "Can't open: $!", {item_id=>$fname});
next FILE;
};
my $out;
system(
{shell=>1, log=>1, lang=>"C", capture_stdout=>\$out},
join(" ",
"patch", "-d", shell_quote($prog_dir),
"-t", "--dry-run",
"<", shell_quote("$patches_dir/$fname"),
),
);
if ($?) {
log_error("Skipping patch '%s' (can't patch(1) to detect applied: %s)",
$fname, $?);
$envres->add_result(
500, "Can't patch(1) to detect applied: $?", {item_id=>$fname});
next FILE;
}
my $already_applied = 0;
if ($out =~ /Reversed .*patch detected/) {
$already_applied = 1;
}
if ($args{reverse}) {
if (!$already_applied) {
log_info("Skipping patch '%s' (already reversed)", $fname);
$envres->add_result(
304, "Already reversed", {item_id=>$fname});
next FILE;
} else {
if ($args{-dry_run}) {
$envres->add_result(
200, "Reverse-applying (dry-run)", {item_id=>$fname});
next FILE;
}
system(
{shell=>1, log=>1, lang=>"C", capture_stdout=>\$out},
join(" ",
"patch", "-d", shell_quote($prog_dir),
"--reverse",
"<", shell_quote("$patches_dir/$fname"),
),
);
if ($?) {
log_error("Skipping patch '%s' (can't patch(2b) to reverse-apply: %s)",
$fname, $?);
$envres->add_result(
500, "Can't patch(2b) to reverse-apply: $?", {item_id=>$fname});
next FILE;
}
}
} else {
if ($already_applied) {
log_info("Skipping patch '%s' (already applied)", $fname);
$envres->add_result(
304, "Already applied", {item_id=>$fname});
next FILE;
} else {
if ($args{-dry_run}) {
$envres->add_result(
200, "Applying (dry-run)", {item_id=>$fname});
next FILE;
}
system(
{shell=>1, log=>1, lang=>"C", capture_stdout=>\$out},
join(" ",
"patch", "-d", shell_quote($prog_dir),
"--forward",
"<", shell_quote("$patches_dir/$fname"),
),
);
if ($?) {
log_error("Skipping patch '%s' (can't patch(2) to apply: %s)",
$fname, $?);
$envres->add_result(
500, "Can't patch(2) to apply: $?", {item_id=>$fname});
next FILE;
}
}
}
$envres->add_result(
200, ($args{reverse} ? "Reverse-applied" : "Applied"),
{item_id=>$fname});
}
my $res = $envres->as_struct;
$res->[2] = $res->[3]{results};
$res->[3]{'table.fields'} = [qw/item_id status message/];
$res;
}
1;