File Coverage

lib/Git/Hooks/Test.pm
Criterion Covered Total %
statement 118 155 76.1
branch 23 50 46.0
condition 6 13 46.1
subroutine 18 19 94.7
pod 0 9 0.0
total 165 246 67.0


line stmt bran cond sub pod time code
1 15     15   125537 use warnings;
  15         119  
  15         775  
2              
3             package Git::Hooks::Test;
4             # ABSTRACT: Git::Hooks testing utilities
5             $Git::Hooks::Test::VERSION = '3.5.0';
6             ## no critic (RequireExplicitPackage)
7             ## no critic (ErrorHandling::RequireCarping)
8 15     15   171 use v5.16.0;
  15         48  
9 15     15   8505 use utf8;
  15         210  
  15         69  
10 15     15   449 use Carp;
  15         26  
  15         1308  
11 15     15   93 use Config;
  15         24  
  15         485  
12 15     15   77 use Exporter qw/import/;
  15         22  
  15         473  
13 15     15   12018 use Path::Tiny;
  15         208385  
  15         874  
14 15     15   9320 use Git::Repository 'GitHooks';
  15         670793  
  15         68  
15 15     15   14046 use Test::More;
  15         820997  
  15         184  
16              
17             our @EXPORT_OK = qw/
18             install_hooks
19             new_commit
20             newdir
21             new_repos
22             test_command
23             test_nok
24             test_nok_match
25             test_ok
26             test_ok_match
27             /;
28              
29             our %EXPORT_TAGS = (
30             all => \@EXPORT_OK
31             );
32              
33             # Make sure the git messages come in English. (LC_ALL)
34             # Eliminate the effects of system wide (GIT_CONFIG_NOSYSTEM)
35             # and global configuration (XDG_CONFIG_HOME and HOME).
36             # https://metacpan.org/dist/Git-Repository/view/lib/Git/Repository/Tutorial.pod#Ignore-the-system-and-global-configuration-files
37             my %git_test_env = (
38             LC_ALL => 'C',
39             GIT_CONFIG_NOSYSTEM => 1,
40             XDG_CONFIG_HOME => undef,
41             HOME => undef,
42             );
43              
44             my $cwd = Path::Tiny->cwd;
45              
46             # It's better to perform all tests in a temporary directory because
47             # otherwise the author runs the risk of messing with its local
48             # Git::Hooks git repository.
49              
50             my $T = Path::Tiny->tempdir(
51             TEMPLATE => 'githooks.XXXXX',
52             TMPDIR => 1,
53             CLEANUP => exists $ENV{REPO_CLEANUP} ? $ENV{REPO_CLEANUP} : 1,
54             );
55              
56             chdir $T or croak "Can't chdir $T: $!";
57 14     14   114332 END { chdir '/' }
58              
59             my $tmpldir = $T->child('templates');
60             mkdir $tmpldir, 0777 or BAIL_OUT("can't mkdir $tmpldir: $!");
61             {
62             my $hooksdir = $tmpldir->child('hooks');
63             mkdir $hooksdir, 0777 or BAIL_OUT("can't mkdir $hooksdir: $!");
64             }
65              
66             my $git_version = eval { Git::Repository->version } || 'unknown';
67              
68             sub newdir {
69 0     0 0 0 my $num = 1 + Test::Builder->new()->current_test();
70 0         0 my $dir = $T->child($num);
71 0         0 mkdir $dir;
72 0         0 return $dir;
73             }
74              
75             sub install_hooks {
76 32     32 0 121066 my ($git, $extra_perl, @hooks) = @_;
77 32         418 my $hooks_dir = path($git->git_dir())->child('hooks');
78 32         5279 my $hook_pl = $hooks_dir->child('hook.pl');
79             {
80             ## no critic (RequireBriefOpen)
81 32 50       1291 open my $fh, '>', $hook_pl or BAIL_OUT("Can't create $hook_pl: $!");
  32         771  
82 32 50       3407 state $debug = $ENV{DBG} ? '-d' : '';
83 32         223 state $bliblib = $cwd->child('blib', 'lib');
84 32         3602 print $fh <<"EOS";
85             #!$Config{perlpath} $debug
86             use strict;
87             use warnings;
88             use lib '$bliblib';
89             EOS
90              
91 32 50       605 state $pathsep = $^O eq 'MSWin32' ? ';' : ':';
92 32 50 33     463 if (defined $ENV{PERL5LIB} and length $ENV{PERL5LIB}) {
93 32         736 foreach my $path (reverse split "$pathsep", $ENV{PERL5LIB}) {
94 64 50       448 say $fh "use lib '$path';" if $path;
95             }
96             }
97              
98 32         139 print $fh <<'EOS';
99             use Git::Hooks;
100             EOS
101              
102 32 100       151 print $fh $extra_perl if defined $extra_perl;
103              
104             # Not all hooks defined the GIT_DIR environment variable
105             # (e.g., pre-rebase doesn't).
106 32         101 print $fh <<'EOS';
107             $ENV{GIT_DIR} = '.git' unless exists $ENV{GIT_DIR};
108             $ENV{GIT_CONFIG} = "$ENV{GIT_DIR}/config";
109             EOS
110              
111             # Hooks on Windows are invoked indirectly.
112 32 50       241 if ($^O eq 'MSWin32') {
113 0         0 print $fh <<'EOS';
114             my $hook = shift;
115             run_hook($hook, @ARGV);
116             EOS
117             } else {
118 32         1506 print $fh <<'EOS';
119             run_hook($0, @ARGV);
120             EOS
121             }
122             }
123 32         263 chmod 0755 => $hook_pl;
124              
125 32 100       876 @hooks = qw/ applypatch-msg pre-applypatch post-applypatch
126             pre-commit prepare-commit-msg commit-msg
127             post-commit pre-rebasen post-checkout post-merge
128             pre-push pre-receive update post-receive post-update
129             push-to-checkout pre-auto-gc post-rewrite
130             / unless @hooks;
131              
132 32         196 foreach my $hook (@hooks) {
133 77         2420 my $hookfile = $hooks_dir->child($hook);
134 77 50       3463 if ($^O eq 'MSWin32') {
135 0         0 (my $perl = $^X) =~ tr:\\:/:;
136 0         0 $hook_pl =~ tr:\\:/:;
137 0 0       0 my $d = $ENV{DBG} ? '-d' : '';
138 0         0 my $script = <<"EOS";
139             #!/bin/sh
140             $perl $d $hook_pl $hook \"\$@\"
141             EOS
142 0 0       0 path($hookfile)->spew($script)
143             or BAIL_OUT("can't path('$hookfile')->spew('$script')\n");
144 0         0 chmod 0755 => $hookfile;
145             } else {
146 77         384 $hookfile->remove; # in case we're replacing the hooks
147 77 50       2678 symlink 'hook.pl', $hookfile
148             or BAIL_OUT("can't symlink '$hooks_dir', '$hook': $!");
149             }
150             }
151 32         1616 return;
152             }
153              
154             sub new_repos {
155 22     22 0 115898 my $repodir = $T->child('repo');
156 22         2932 my $filename = $repodir->child('file.txt');
157 22         942 my $clonedir = $T->child('clone');
158              
159             # Remove the directories recursively to create new ones.
160 22         1087 $repodir->remove_tree({safe => 0});
161 22         68814 $clonedir->remove_tree({safe => 0});
162              
163 22 50       14903 mkdir $repodir, 0777 or BAIL_OUT("can't mkdir $repodir: $!");
164             {
165 22 50       2366 open my $fh, '>', $filename or croak BAIL_OUT("can't open $filename: $!");
  22         363  
166 22         1914 say $fh "first line";
167 22         1085 close $fh;
168             }
169              
170 22         193 my $stderr = $T->child('stderr');
171              
172 22         1165 my @result = eval {
173 22         143 Git::Repository->run(qw/-c init.defaultBranch=master init -q/,
174             "--template=$tmpldir", $repodir, { env => \%git_test_env });
175              
176 22         689237 my $repo = Git::Repository->new(work_tree => $repodir,
177             { env => \%git_test_env });
178              
179 22         890101 $repo->run(qw/config user.email myself@example.com/);
180 22         588881 $repo->run(qw/config user.name/, 'My Self');
181              
182             {
183 22         276328 my $cmd = Git::Repository->command(
  22         697  
184             qw/clone -q --bare --no-hardlinks/, "--template=$tmpldir", $repodir, $clonedir,
185             );
186              
187 22         228110 my $my_stderr = $cmd->stderr;
188              
189 22 50       951 open my $err_h, '>', $T->child('stderr')
190 0         0 or croak "Can't open '@{[$T->child('stderr')]}' for writing: $!\n";
191 22         212205 while (<$my_stderr>) {
192 22         898 $err_h->print($_);
193             }
194 22         24040 close $err_h;
195              
196 22         409 $cmd->close();
197 22 50       4808 croak "Can't git-clone $repodir into $clonedir" unless $cmd->exit() == 0;
198             }
199              
200 22         1953 my $clone = Git::Repository->new(git_dir => $clonedir);
201              
202 22         680990 $repo->run(qw/remote add clone/, $clonedir);
203              
204 22         309405 return ($repo, $filename, $clone, $T);
205             };
206              
207 22 50       360 if (my $E = $@) {
208 0         0 my $exception = "$E"; # stringify it
209 0 0       0 if (-s $stderr) {
210 0 0       0 open my $err_h, '<', $stderr
211             or croak "Can't open '$stderr' for reading: $!\n";
212 0         0 local $/ = undef; # slurp mode
213 0         0 $exception .= 'STDERR=';
214 0         0 $exception .= <$err_h>;
215 0         0 close $err_h;
216             }
217              
218             # The BAIL_OUT function can't show a message with newlines
219             # inside. So, we have to make sure to get rid of any.
220 0         0 $exception =~ s/\n/;/g;
221 0         0 local $, = ':';
222 0         0 BAIL_OUT("Error setting up repos for test: Exception='$exception'; CWD=$T; git-version=$git_version; \@INC=(@INC).\n");
223 0         0 @result = ();
224             };
225              
226 22         778 return @result;
227             }
228              
229             sub new_commit {
230 13     13 0 496127 my ($git, $file, $msg) = @_;
231              
232 13   50     296 $file->append($msg || 'new commit');
233              
234 13         4984 $git->run(add => $file);
235 13   50     180953 $git->run(qw/commit -q -m/, $msg || 'commit');
236              
237 13         1136846 return;
238             }
239              
240              
241             # Executes a git command with arguments and return a four-elements
242             # list containing: (a) a boolean indication of success, (b) the exit
243             # code, (c) the command's STDOUT, and (d) the command's STDERR.
244             sub test_command {
245 202     202 0 669795 my ($git, $command, @args) = @_;
246              
247 202         1987 my $cmd = $git->command($command, @args);
248              
249 202         2213618 my $stdout = do { local $/ = undef; readline($cmd->stdout); };
  202         1727  
  202         2434  
250 202         49938501 my $stderr = do { local $/ = undef; readline($cmd->stderr); };
  202         1733  
  202         3543  
251              
252 202         12465 $cmd->close;
253              
254 202         57367 return ($cmd->exit() == 0, $cmd->exit(), $stdout, $stderr);
255             }
256              
257             sub test_ok {
258 103     103 0 4722197 my ($testname, @args) = @_;
259 103         845 my ($ok, $exit, $stdout, $stderr) = test_command(@args);
260 103 50       12283 if ($ok) {
261 103         2053 pass($testname);
262             } else {
263 0         0 fail($testname);
264 0         0 diag(" exit=$exit\n stdout=$stdout\n stderr=$stderr\n git-version=$git_version\n");
265             }
266 103         103708 return $ok;
267             }
268              
269             sub test_ok_match {
270 3     3 0 41300 my ($testname, $regex, @args) = @_;
271 3         76 my ($ok, $exit, $stdout, $stderr) = test_command(@args);
272 3 50       420 if ($ok) {
273 3 50 66     140 if ($stdout =~ $regex || $stderr =~ $regex) {
274 3         63 pass($testname);
275             } else {
276 0         0 fail($testname);
277 0         0 diag(" did not match regex ($regex)\n stdout=$stdout\n stderr=$stderr\n git-version=$git_version\n");
278             }
279             } else {
280 0         0 fail($testname);
281 0         0 diag(" exit=$exit\n stdout=$stdout\n stderr=$stderr\n git-version=$git_version\n");
282             }
283 3         3496 return $ok;
284             }
285              
286             sub test_nok {
287 7     7 0 184990 my ($testname, @args) = @_;
288 7         89 my ($ok, $exit, $stdout, $stderr) = test_command(@args);
289 7 50       819 if ($ok) {
290 0         0 fail($testname);
291 0         0 diag(" succeeded without intention\n stdout=$stdout\n stderr=$stderr\n git-version=$git_version\n");
292             } else {
293 7         163 pass($testname);
294             }
295 7         7100 return !$ok;
296             }
297              
298             sub test_nok_match {
299 78     78 0 4037427 my ($testname, $regex, @args) = @_;
300 78         924 my ($ok, $exit, $stdout, $stderr) = test_command(@args);
301 78 50 33     13040 if ($ok) {
    50          
302 0         0 fail($testname);
303 0         0 diag(" succeeded without intention\n exit=$exit\n stdout=$stdout\n stderr=$stderr\n git-version=$git_version\n");
304 0         0 return 0;
305             } elsif ($stdout =~ $regex || $stderr =~ $regex) {
306 78         1643 pass($testname);
307 78         78973 return 1;
308             } else {
309 0         0 fail($testname);
310 0         0 diag(" did not match regex ($regex)\n exit=$exit\n stdout=$stdout\n stderr=$stderr\n git-version=$git_version\n");
311 0         0 return 0;
312             }
313             }
314              
315             1;
316              
317             __END__