1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
|
package t::Util;
use 5.028;
use strict;
use warnings;
use parent 'Exporter';
use File::Slurp;
use File::Spec::Functions qw(rel2abs);
use File::chdir;
use File::Temp qw(tempdir);
use Try::Tiny;
use Capture::Tiny qw(capture);
our @EXPORT
= qw( corrupt_annexed_file device_id_issues git_annex_available run_bin );
sub corrupt_annexed_file {
my ($git, $file) = @_;
my ($key) = $git->annex("lookupkey", $file);
my ($loc) = $git->annex("contentlocation", $key);
$loc = rel2abs $loc, $git->dir;
chmod 0777, $loc;
append_file $loc, "bazbaz\n";
}
# on a tmpfs as commonly used with sbuild, the device IDs for files
# and directories can be different, which will cause annex-to-annex to
# refuse to hardlink. we use this sub to skip some tests if we detect
# that. possibly annex-to-annex should only look at the device IDs of
# files (by creating a temporary file inside $dest and looking at the
# device ID of that)
sub device_id_issues {
local $CWD = tempdir CLEANUP => 1;
mkdir "foo";
write_file "bar", "bar\n";
my $foo_id = (stat "foo")[0];
my $bar_id = (stat "bar")[0];
return ($foo_id != $bar_id);
}
sub git_annex_available {
`which git-annex`;
return !$?;
}
sub run_bin {
(my $bin = "App::" . shift) =~ tr/-/_/;
local @ARGV = @_;
my ($stdout, $stderr, $exit) = capture {
my $exit;
# in order to simulate calling the program at the command
# line, convert exceptions into what happens when an ordinary
# perl script, invoked from the command line, calls 'die'
#<<<
try {
$exit = $bin->main;
} catch {
say STDERR $_;
$exit = 255;
};
#>>>
return $exit;
};
my @stdout = split "\n", $stdout;
my @stderr = split "\n", $stderr;
return (\@stdout, \@stderr, $exit);
}
1;
|
