add Git::Annex::BatchCommand

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

3 files changed, 216 insertions, 0 deletions

diff --git a/lib/Git/Annex.pm b/lib/Git/Annex.pm
index 985f982..6964b89 100644
--- a/lib/Git/Annex.pm
+++ b/lib/Git/Annex.pm
@@ -68,6 +68,7 @@ use Storable;
 use Data::Compare;
 use List::Util qw(all);
 use Time::HiRes qw(stat time);
+use Git::Annex::BatchCommand;
 
 use Moo;
 use namespace::clean;
@@ -263,6 +264,22 @@ sub abs_contentlocation {
     $contentlocation ? rel2abs($contentlocation, $self->toplevel) : undef;
 }
 
+=head2 batch($cmd, @args)
+
+Instantiate a C<Git::Annex::BatchCommand> object by starting up a
+git-annex C<--batch> command.
+
+  my $batch = $annex->batch("find", "--in=here");
+  say "foo/bar annexed content is present in this repo"
+    if $batch->say("foo/bar");
+
+  # kill the batch process:
+  undef $batch;
+
+=cut
+
+sub batch { Git::Annex::BatchCommand->new(@_) }
+
 sub _git_path {
     my ($self, @input) = @_;
     my ($path) = $self->git->rev_parse({ git_path => 1 }, catfile @input);
diff --git a/lib/Git/Annex/BatchCommand.pm b/lib/Git/Annex/BatchCommand.pm
new file mode 100644
index 0000000..e9e9379
--- /dev/null
+++ b/lib/Git/Annex/BatchCommand.pm
@@ -0,0 +1,137 @@
+# Git::Annex
+# Perl interface to git-annex repositories
+#
+# Copyright (C) 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/>.
+
+=head1 NAME
+
+Git::Annex::BatchCommand - Perl interface to git-annex --batch commands
+
+=head1 SYNOPSIS
+
+  # you should not instantiate this class yourself; use Git::Annex::batch
+  my $annex = Git::Annex->new("/home/spwhitton/annex");
+  my $batch = $annex->batch("find", "--not", "--in=here");
+
+  # see git-annex-find(1) -- `git annex find --batch --not --in here`
+  # prints an empty string for each file which is not present
+  say "foo/bar is not present in this repo" if $batch->say("foo/bar");
+
+=head1 DESCRIPTION
+
+This class can be used to run git-annex commands which take the
+C<--batch> option.  You can feed the command lines of input and you
+will get back git-annex's responses.
+
+The main point of using C<--batch> commands from Perl is to keep
+git-annex running rather than repeatedly executing new git-annex
+processes to perform queries or request changes.
+
+=cut
+
+package Git::Annex::BatchCommand;
+
+use 5.028;
+use strict;
+use warnings;
+
+use autodie;
+use Carp;
+use IPC::Open2;
+
+=head1 METHODS
+
+=head1 new($annex, $cmd, @args)
+
+Initialise a batch process in Git::Annex C<$annex>, running git-annex
+subcommand C<$cmd> (e.g. C<setpresentkey>) with arguments C<@args>.
+
+You should use Git::Annex::batch in preference to this method.
+
+=cut
+
+sub new {
+    my (undef, $annex, $cmd, @params) = @_;
+    croak "not enough arguments to Git::Annex::BatchCommand constructor"
+      unless $annex and $cmd;
+
+    # normalise supplied arguments a little
+    unshift @params, "--batch" unless grep /\A--batch\z/, @params;
+
+    my $self = bless { _annex => $annex, _cmd => [$cmd, @params] }
+      => "Git::Annex::BatchCommand";
+    $self->_spawn;
+    return $self;
+}
+
+=head2 say($input, ...)
+
+Say a line or lines of input to the batch command's standard input.
+Trailing line breaks in C<$input> are optional.
+
+In list context, returns a list of chomped git-annex's responses to
+the items of input, chomped.  In scalar context, returns the number of
+trueish responses.
+
+=cut
+
+sub say {
+    my ($self, @input) = @_;
+    my @output;
+    for (@input) {
+        chomp;
+        say { $self->{_in} } $_;
+        chomp(my $out = readline $self->{_out});
+        push @output, $out;
+    }
+    return wantarray ? @output : scalar @output;
+}
+
+=head2 restart
+
+Kill and restart the C<--batch> command.
+
+This is sometimes needed to ensure the C<--batch> command picks up
+changes made to the git-annex branch.
+
+=cut
+
+sub restart {
+    my $self = shift;
+    $self->_despawn;
+    $self->_spawn;
+}
+
+sub _spawn {
+    my $self = shift;
+    my ($out, $in);
+    $self->{_pid} = open2 $out, $in, "git",
+      "-C", $self->{_annex}->toplevel,
+      "annex", @{ $self->{_cmd} };
+    ($self->{_out}, $self->{_in}) = ($out, $in);
+}
+
+sub _despawn {
+    my $self = shift;
+    close $self->{_in};
+    close $self->{_out};
+    # reap the child per IPC::Open2 docs
+    waitpid $self->{_pid}, 0;
+}
+
+sub DESTROY { local($., $@, $!, $^E, $?); shift->_despawn }
+
+1;
diff --git a/t/13_batchcommand.t b/t/13_batchcommand.t
new file mode 100755
index 0000000..109b24d
--- /dev/null
+++ b/t/13_batchcommand.t
@@ -0,0 +1,62 @@
+#!/usr/bin/perl
+
+use 5.028;
+use strict;
+use warnings;
+use lib 't/lib';
+
+use Test::More;
+use Git::Annex;
+use Git::Annex::BatchCommand;
+use t::Setup;
+use Scalar::Util qw(looks_like_number);
+use Try::Tiny;
+
+with_temp_annexes {
+    my (undef, $source1) = @_;
+
+    my $annex = Git::Annex->new($source1->dir);
+    #<<<
+    try {
+        my $nope = Git::Annex::BatchCommand->new;
+    } catch {
+        ok grep(/not enough arguments/, $_), "it requires an annex";
+    };
+    #>>>
+    #<<<
+    try {
+        my $nope = $annex->batch;
+    } catch {
+        ok grep(/not enough arguments/, $_), "it requires a command";
+    };
+    #>>>
+
+    my $batch = $annex->batch("find", "--in=here");
+
+    # TODO there are races here due to the (faint) possibility of PID reuse
+    my $first_pid = $batch->{_pid};
+    ok looks_like_number $first_pid, "it stores a PID";
+    ok kill(0, $first_pid), "the PID is a running process";
+    $batch->restart;
+    ok !kill(0, $first_pid), "the old PID is no longer a running process";
+    my $second_pid = $batch->{_pid};
+    isnt $first_pid, $second_pid, "it starts a new process";
+    ok looks_like_number $second_pid, "it stores a PID again";
+    ok kill(0, $second_pid), "the new PID is a running process";
+
+    ok grep(/\A--batch\z/, @{ $batch->{_cmd} }),
+      "it passes --batch to git-annex";
+    my ($response1, $response2) = $batch->say("foo/foo2/baz", "foo/foo2/baz");
+    is $response1, $response2, "it returns a list in list context";
+    is scalar $batch->say("foo/foo2/baz", "foo/foo2/baz"), 2,
+      "it returns a scalar in scalar context";
+    my ($response3, $response4) = $batch->say("foo/foo2/baz", "foo/bar");
+    is_deeply [$response3, $response4], ["foo/foo2/baz", ""],
+      "it returns results in the correct order";
+
+    undef $batch;
+    ok !kill(0, $second_pid),
+      "it cleans up the process when object goes out of scope";
+};
+
+done_testing;