convert remaining two scripts to App:: modules

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

6 files changed, 228 insertions, 163 deletions

diff --git a/bin/annex-to-annex-dropunused b/bin/annex-to-annex-dropunused
index 9abb25f..bbbea80 100755
--- a/bin/annex-to-annex-dropunused
+++ b/bin/annex-to-annex-dropunused
@@ -40,42 +40,5 @@ git-annex-dropunused(1), annex-to-annex(1), annex-to-annex-reinject(1)
 
 =cut
 
-use 5.028;
-use strict;
-use warnings;
-
-use autodie;
-use Git::Annex;
-
-# This script used to have a --dest option which specified the
-# destination annex previously used with annex-to-annex.  Then, if the
-# unused file had a hardlink count of 1, but was present in the
-# destination annex, this script would drop it.
-#
-# That was somewhat dangerous functionality because it involves this
-# script running `git annex dropunused --force` for files with a
-# hardlink count of 1.  And further, it is not actually needed,
-# because running annex-to-annex-reinject after
-# annex-to-annex-dropunused handles such files in a way that is safer.
-#
-# It is still good to run this script before annex-to-annex-reinject
-# to make the latter faster.
-
-my $annex = Git::Annex->new;
-
-my @to_drop;
-my @unused_files = grep { !$_->{bad} && !$_->{tmp} } @{ $annex->unused };
-
-foreach my $unused_file (@unused_files) {
-    my $content = $annex->abs_contentlocation($unused_file->{key});
-    my $link_count = (stat $content)[3];
-    my @logs
-      = $annex->git->log({ no_textconv => 1 }, "-S", $unused_file->{key});
-
-    next unless $logs[0] and $logs[0]->message =~ /migrated by annex-to-annex/;
-    next unless $link_count > 1;
-
-    push @to_drop, $unused_file->{number};
-}
-
-$annex->git->annex("dropunused", { force => 1 }, @to_drop);
+use App::annex_to_annex_dropunused;
+exit App::annex_to_annex->main;
diff --git a/bin/annex-to-annex-reinject b/bin/annex-to-annex-reinject
index 897c007..b3f5970 100755
--- a/bin/annex-to-annex-reinject
+++ b/bin/annex-to-annex-reinject
@@ -50,102 +50,5 @@ git-annex-reinject(1), annex-to-annex(1), annex-to-annex-dropunused(1)
 
 =cut
 
-use 5.028;
-use strict;
-use warnings;
-
-use autodie;
-use Git::Annex;
-use File::Basename qw(basename dirname);
-use File::chmod;
-$File::chmod::UMASK = 0;
-use File::Path qw(rmtree);
-use File::Spec::Functions qw(rel2abs);
-use File::Find;
-use Try::Tiny;
-
-die "usage: annex-to-annex-reinject SOURCEANNEX DESTANNEX\n" unless @ARGV == 2;
-
-my $source = Git::Annex->new($ARGV[0]);
-my $dest   = Git::Annex->new($ARGV[1]);
-#<<<
-try {
-    $source->git->rev_parse({ git_dir => 1 });
-} catch {
-    die "$ARGV[0] doesn't look like a git repository ..\n";
-};
-try {
-    $dest->git->rev_parse({ git_dir => 1 });
-} catch {
-    die "$ARGV[1] doesn't look like a git repository ..\n";
-};
-#>>>
-
-# `git annex reinject` doesn't work in a bare repo atm
-my $use_worktree
-  = ($dest->git->rev_parse({ is_bare_repository => 1 }))[0] eq 'true';
-my ($temp, $worktree);
-if ($use_worktree) {
-    $temp = tempdir(CLEANUP => 1, DIR => dirname $ARGV[1]);
-    say "bare repo; our git worktree is in $temp";
-    $dest->git->worktree("add", { force => 1, detach => 1 },
-        rel2abs($temp), "synced/master");
-}
-
-my ($source_uuid) = $source->git->config('annex.uuid');
-die "couldn't get source annex uuid" unless $source_uuid =~ /\A[a-z0-9-]+\z/;
-my $spk = $source->batch("setpresentkey");
-
-my ($source_objects_dir)
-  = $source->git->rev_parse({ git_path => 1 }, "annex/objects");
-$source_objects_dir = rel2abs $source_objects_dir, $ARGV[0];
-my $reinject_from = $use_worktree ? $temp : $ARGV[1];
-say "reinjecting from $source_objects_dir into $reinject_from";
-find({
-        wanted => sub {
-            -f or return;
-            say "\nconsidering $_";
-            my $dir = dirname $_;
-            chmod "u+w", $dir, $_;
-            system "git", "-C", $reinject_from, "annex", "reinject",
-              "--known", $_;
-            if (-e $_) {
-                chmod "u-w", $dir, $_;
-            } else {
-                my $key = basename $_;
-                say "telling setpresentkey process '$key $source_uuid 0'";
-                say for $spk->say("$key $source_uuid 0");
-                # alt. to setpresentkey:
-                # say "fscking key $key in $ARGV[0]";
-                # system 'git', '-C', $ARGV[0], 'annex', 'fsck',
-                #     '--numcopies=1', '--key', $key;
-                say "cleaning up empty dirs";
-                foreach my $d ($dir, dirname($dir), dirname(dirname($dir))) {
-                    last unless is_empty_dir($d);
-                    rmdir $d;
-                }
-            }
-        },
-        no_chdir => 1
-    },
-    $source_objects_dir
-);
-if ($use_worktree) {
-    # we can't use `git worktree remove` because the way git-annex
-    # worktree support works breaks that command: git-annex replaces
-    # the .git worktree file with a symlink
-    rmtree $temp;
-    $dest->git->worktree("prune");
-}
-
-# cause setpresentkey changes to be recorded in git-annex branch
-undef $spk;
-sleep 1;
-$source->git->annex("merge");
-
-sub is_empty_dir {
-    -d $_[0] or return 0;
-    opendir(my $dirh, $_[0]);
-    my @files = grep { $_ ne '.' && $_ ne '..' } readdir $dirh;
-    return @files == 0;
-}
+use App::annex_to_annex_reinject;
+exit App::annex_to_annex_reinject->main;
diff --git a/lib/App/annex_to_annex_dropunused.pm b/lib/App/annex_to_annex_dropunused.pm
new file mode 100644
index 0000000..89b16b5
--- /dev/null
+++ b/lib/App/annex_to_annex_dropunused.pm
@@ -0,0 +1,74 @@
+package App::annex_to_annex_dropunused;
+# ABSTRACT: drop old hardlinks migrated by annex-to-annex
+#
+# Copyright (C) 2019-2020  Sean Whitton <spwhitton@spwhitton.name>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or (at
+# your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+use 5.028;
+use strict;
+use warnings;
+
+use autodie;
+use Git::Annex;
+
+# This script used to have a --dest option which specified the
+# destination annex previously used with annex-to-annex.  Then, if the
+# unused file had a hardlink count of 1, but was present in the
+# destination annex, this script would drop it.
+#
+# That was somewhat dangerous functionality because it involves this
+# script running `git annex dropunused --force` for files with a
+# hardlink count of 1.  And further, it is not actually needed,
+# because running annex-to-annex-reinject after
+# annex-to-annex-dropunused handles such files in a way that is safer.
+#
+# It is still good to run this script before annex-to-annex-reinject
+# to make the latter faster.
+
+exit main() unless caller;
+
+=func main
+
+Implementation of annex-to-annex-dropunused(1).  Please see
+documentation for that command.
+
+=cut
+
+sub main {
+    my $annex = Git::Annex->new;
+
+    my @to_drop;
+    my @unused_files = grep { !$_->{bad} && !$_->{tmp} } @{ $annex->unused };
+
+    foreach my $unused_file (@unused_files) {
+        my $content    = $annex->abs_contentlocation($unused_file->{key});
+        my $link_count = (stat $content)[3];
+        my @logs
+          = $annex->git->log({ no_textconv => 1 }, "-S", $unused_file->{key});
+
+        next
+          unless $logs[0]
+          and $logs[0]->message =~ /migrated by annex-to-annex/;
+        next unless $link_count > 1;
+
+        push @to_drop, $unused_file->{number};
+    }
+
+    $annex->git->annex("dropunused", { force => 1 }, @to_drop);
+
+    return 0;
+}
+
+1;
diff --git a/lib/App/annex_to_annex_reinject.pm b/lib/App/annex_to_annex_reinject.pm
new file mode 100644
index 0000000..c208d05
--- /dev/null
+++ b/lib/App/annex_to_annex_reinject.pm
@@ -0,0 +1,136 @@
+package App::annex_to_annex_reinject;
+# ABSTRACT: annex-to-annex-reinject
+#
+# Copyright (C) 2019-2020  Sean Whitton <spwhitton@spwhitton.name>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or (at
+# your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+use 5.028;
+use strict;
+use warnings;
+
+use autodie;
+use Git::Annex;
+use File::Basename qw(basename dirname);
+use File::chmod;
+$File::chmod::UMASK = 0;
+use File::Path qw(rmtree);
+use File::Spec::Functions qw(rel2abs);
+use File::Find;
+use Try::Tiny;
+
+exit main() unless caller;
+
+=func main
+
+Implementation of annex-to-annex-reinject(1).  Please see
+documentation for that command.
+
+=cut
+
+sub main {
+    die "usage: annex-to-annex-reinject SOURCEANNEX DESTANNEX\n"
+      unless @ARGV == 2;
+
+    my $source = Git::Annex->new($ARGV[0]);
+    my $dest   = Git::Annex->new($ARGV[1]);
+    #<<<
+    try {
+        $source->git->rev_parse({ git_dir => 1 });
+    } catch {
+        die "$ARGV[0] doesn't look like a git repository ..\n";
+    };
+    try {
+        $dest->git->rev_parse({ git_dir => 1 });
+    } catch {
+        die "$ARGV[1] doesn't look like a git repository ..\n";
+    };
+    #>>>
+
+    # `git annex reinject` doesn't work in a bare repo atm
+    my $use_worktree
+      = ($dest->git->rev_parse({ is_bare_repository => 1 }))[0] eq 'true';
+    my ($temp, $worktree);
+    if ($use_worktree) {
+        $temp = tempdir(CLEANUP => 1, DIR => dirname $ARGV[1]);
+        say "bare repo; our git worktree is in $temp";
+        $dest->git->worktree("add", { force => 1, detach => 1 },
+            rel2abs($temp), "synced/master");
+    }
+
+    my ($source_uuid) = $source->git->config('annex.uuid');
+    die "couldn't get source annex uuid"
+      unless $source_uuid =~ /\A[a-z0-9-]+\z/;
+    my $spk = $source->batch("setpresentkey");
+
+    my ($source_objects_dir)
+      = $source->git->rev_parse({ git_path => 1 }, "annex/objects");
+    $source_objects_dir = rel2abs $source_objects_dir, $ARGV[0];
+    my $reinject_from = $use_worktree ? $temp : $ARGV[1];
+    say "reinjecting from $source_objects_dir into $reinject_from";
+    find({
+            wanted => sub {
+                -f or return;
+                say "\nconsidering $_";
+                my $dir = dirname $_;
+                chmod "u+w", $dir, $_;
+                system "git", "-C", $reinject_from, "annex", "reinject",
+                  "--known", $_;
+                if (-e $_) {
+                    chmod "u-w", $dir, $_;
+                } else {
+                    my $key = basename $_;
+                    say "telling setpresentkey process '$key $source_uuid 0'";
+                    say for $spk->say("$key $source_uuid 0");
+                    # alt. to setpresentkey:
+                    # say "fscking key $key in $ARGV[0]";
+                    # system 'git', '-C', $ARGV[0], 'annex', 'fsck',
+                    #     '--numcopies=1', '--key', $key;
+                    say "cleaning up empty dirs";
+                    foreach
+                      my $d ($dir, dirname($dir), dirname(dirname($dir))) {
+                        last unless _is_empty_dir($d);
+                        rmdir $d;
+                    }
+                }
+            },
+            no_chdir => 1
+        },
+        $source_objects_dir
+    );
+    if ($use_worktree) {
+        # we can't use `git worktree remove` because the way git-annex
+        # worktree support works breaks that command: git-annex replaces
+        # the .git worktree file with a symlink
+        rmtree $temp;
+        $dest->git->worktree("prune");
+    }
+
+    # cause setpresentkey changes to be recorded in git-annex branch
+    undef $spk;
+    sleep 1;
+    $source->git->annex("merge");
+
+    return 0;
+}
+
+
+sub _is_empty_dir {
+    -d $_[0] or return 0;
+    opendir(my $dirh, $_[0]);
+    my @files = grep { $_ ne '.' && $_ ne '..' } readdir $dirh;
+    return @files == 0;
+}
+
+1;
diff --git a/t/22_annex-to-annex-dropunused.t b/t/22_annex-to-annex-dropunused.t
index c8bd47a..41db816 100755
--- a/t/22_annex-to-annex-dropunused.t
+++ b/t/22_annex-to-annex-dropunused.t
@@ -5,6 +5,8 @@ use strict;
 use warnings;
 use lib 't/lib';
 
+use App::annex_to_annex;
+use App::annex_to_annex_dropunused;
 use Test::More;
 use File::Spec::Functions qw(rel2abs);
 use t::Setup;
@@ -15,22 +17,14 @@ use File::Copy qw(copy);
 
 plan skip_all => "device ID issues" if device_id_issues;
 
-# make sure that `make test` will always use the right version of the
-# script we seek to test
-my $a2a    = "annex-to-annex";
-my $a2a_du = "annex-to-annex-dropunused";
-$a2a = rel2abs "blib/script/annex-to-annex" if -x "blib/script/annex-to-annex";
-$a2a_du = rel2abs "blib/script/annex-to-annex-dropunused"
-  if -x "blib/script/annex-to-annex-dropunused";
-
 with_temp_annexes {
     my (undef, undef, $source2) = @_;
 
-    system $a2a, qw(--commit source1/foo source2/other dest);
+    run_bin qw(annex-to-annex --commit source1/foo source2/other dest);
 
     {
         local $CWD = "source2";
-        system $a2a_du;
+        run_bin "annex-to-annex-dropunused";
         $source2->checkout("master~1");
         ok((lstat "other" and not stat "other"), "other was dropped");
     }
@@ -39,7 +33,7 @@ with_temp_annexes {
 with_temp_annexes {
     my (undef, undef, $source2) = @_;
 
-    system $a2a, qw(--commit source1/foo source2/other dest);
+    run_bin qw(annex-to-annex --commit source1/foo source2/other dest);
 
     {
         local $CWD = "source2";
@@ -55,11 +49,11 @@ with_temp_annexes {
         system "mv", "-f", "$other_content.tmp", $other_content;
         chmod 0555, dirname $other_content;
 
-        system $a2a_du;
+        run_bin "annex-to-annex-dropunused";
         $source2->checkout("master~1");
         ok((lstat "other" and stat "other"), "other was not dropped");
         # $source2->checkout("master");
-        # system $a2a_du, "--dest=../dest";
+        # run_bin qw(annex-to-annex-dropunused --dest=../dest);
         # $source2->checkout("master~1");
         # ok((lstat "other" and not stat "other"), "other was dropped");
     }
@@ -68,7 +62,7 @@ with_temp_annexes {
 # with_temp_annexes {
 #     my (undef, undef, $source2, $dest) = @_;
 
-#     system $a2a, qw(--commit source1/foo source2/other dest);
+#     run_bin qw(annex-to-annex --commit source1/foo source2/other dest);
 
 #     $dest->annex(qw(drop --force other));
 #     {
@@ -85,7 +79,7 @@ with_temp_annexes {
 #         system "mv", "-f", "$other_content.tmp", $other_content;
 #         chmod 0555, dirname $other_content;
 
-#         system $a2a_du, "--dest=../dest";
+#         run_bin qw(annex-to-annex-dropunused --dest=../dest);
 #         $source2->checkout("master~1");
 #         ok((lstat "other" and stat "other"), "other was not dropped");
 #     }
diff --git a/t/23_annex-to-annex-reinject.t b/t/23_annex-to-annex-reinject.t
index 2e672ea..5791c81 100755
--- a/t/23_annex-to-annex-reinject.t
+++ b/t/23_annex-to-annex-reinject.t
@@ -5,23 +5,18 @@ use strict;
 use warnings;
 use lib 't/lib';
 
+use App::annex_to_annex;
+use App::annex_to_annex_reinject;
 use Test::More;
 use File::Spec::Functions qw(rel2abs);
 use t::Setup;
+use t::Util;
 use File::chdir;
 
-# make sure that `make test` will always use the right version of the
-# script we seek to test
-my $a2a    = "annex-to-annex";
-my $a2a_ri = "annex-to-annex-reinject";
-$a2a = rel2abs "blib/script/annex-to-annex" if -x "blib/script/annex-to-annex";
-$a2a_ri = rel2abs "blib/script/annex-to-annex-reinject"
-  if -x "blib/script/annex-to-annex-reinject";
-
 with_temp_annexes {
     my (undef, undef, $source2) = @_;
 
-    system $a2a, qw(--commit source1/foo source2/other dest);
+    run_bin qw(annex-to-annex --commit source1/foo source2/other dest);
     {
         local $CWD = "source2";
         $source2->checkout("master~1");
@@ -29,7 +24,7 @@ with_temp_annexes {
           "other is initially present";
         $source2->checkout("master");
     }
-    system $a2a_ri, qw(source2 dest);
+    run_bin qw(annex-to-annex-reinject source2 dest);
     {
         local $CWD = "source2";
         $source2->checkout("master~1");