From ad60c0f67d30e658e785b0d9fc91880678c25b55 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Mon, 3 Feb 2020 21:10:47 -0700 Subject: add Git::Annex::BatchCommand Signed-off-by: Sean Whitton --- lib/Git/Annex.pm | 17 ++++++ lib/Git/Annex/BatchCommand.pm | 137 ++++++++++++++++++++++++++++++++++++++++++ t/13_batchcommand.t | 62 +++++++++++++++++++ 3 files changed, 216 insertions(+) create mode 100644 lib/Git/Annex/BatchCommand.pm create mode 100755 t/13_batchcommand.t 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 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 +# +# 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 . + +=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) 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; -- cgit v1.2.3