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   132413 use warnings;
  15         123  
  15         823  
2              
3             package Git::Hooks::Test;
4             # ABSTRACT: Git::Hooks testing utilities
5             $Git::Hooks::Test::VERSION = '3.4.0';
6             ## no critic (RequireExplicitPackage)
7             ## no critic (ErrorHandling::RequireCarping)
8 15     15   171 use v5.16.0;
  15         46  
9 15     15   9683 use utf8;
  15         249  
  15         91  
10 15     15   479 use Carp;
  15         32  
  15         1424  
11 15     15   93 use Config;
  15         25  
  15         497  
12 15     15   68 use Exporter qw/import/;
  15         23  
  15         598  
13 15     15   11709 use Path::Tiny;
  15         220669  
  15         972  
14 15     15   9902 use Git::Repository 'GitHooks';
  15         704466  
  15         77  
15 15     15   14900 use Test::More;
  15         869202  
  15         185  
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   122214 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 154896 my ($git, $extra_perl, @hooks) = @_;
77 32         503 my $hooks_dir = path($git->git_dir())->child('hooks');
78 32         6395 my $hook_pl = $hooks_dir->child('hook.pl');
79             {
80             ## no critic (RequireBriefOpen)
81 32 50       1589 open my $fh, '>', $hook_pl or BAIL_OUT("Can't create $hook_pl: $!");
  32         929  
82 32 50       4544 state $debug = $ENV{DBG} ? '-d' : '';
83 32         270 state $bliblib = $cwd->child('blib', 'lib');
84 32         4190 print $fh <<"EOS";
85             #!$Config{perlpath} $debug
86             use strict;
87             use warnings;
88             use lib '$bliblib';
89             EOS
90              
91 32 50       777 state $pathsep = $^O eq 'MSWin32' ? ';' : ':';
92 32 50 33     589 if (defined $ENV{PERL5LIB} and length $ENV{PERL5LIB}) {
93 32         1013 foreach my $path (reverse split "$pathsep", $ENV{PERL5LIB}) {
94 64 50       409 say $fh "use lib '$path';" if $path;
95             }
96             }
97              
98 32         168 print $fh <<'EOS';
99             use Git::Hooks;
100             EOS
101              
102 32 100       177 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         126 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       242 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         1810 print $fh <<'EOS';
119             run_hook($0, @ARGV);
120             EOS
121             }
122             }
123 32         386 chmod 0755 => $hook_pl;
124              
125 32 100       1065 @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         166 foreach my $hook (@hooks) {
133 77         2846 my $hookfile = $hooks_dir->child($hook);
134 77 50       4282 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         439 $hookfile->remove; # in case we're replacing the hooks
147 77 50       3189 symlink 'hook.pl', $hookfile
148             or BAIL_OUT("can't symlink '$hooks_dir', '$hook': $!");
149             }
150             }
151 32         1963 return;
152             }
153              
154             sub new_repos {
155 22     22 0 153953 my $repodir = $T->child('repo');
156 22         3433 my $filename = $repodir->child('file.txt');
157 22         1138 my $clonedir = $T->child('clone');
158              
159             # Remove the directories recursively to create new ones.
160 22         1367 $repodir->remove_tree({safe => 0});
161 22         81731 $clonedir->remove_tree({safe => 0});
162              
163 22 50       15996 mkdir $repodir, 0777 or BAIL_OUT("can't mkdir $repodir: $!");
164             {
165 22 50       2823 open my $fh, '>', $filename or croak BAIL_OUT("can't open $filename: $!");
  22         379  
166 22         2116 say $fh "first line";
167 22         1228 close $fh;
168             }
169              
170 22         209 my $stderr = $T->child('stderr');
171              
172 22         1283 my @result = eval {
173 22         213 Git::Repository->run(qw/-c init.defaultBranch=master init -q/,
174             "--template=$tmpldir", $repodir, { env => \%git_test_env });
175              
176 22         468326 my $repo = Git::Repository->new(work_tree => $repodir,
177             { env => \%git_test_env });
178              
179 22         1252448 $repo->run(qw/config user.email myself@example.com/);
180 22         412972 $repo->run(qw/config user.name/, 'My Self');
181              
182             {
183 22         395134 my $cmd = Git::Repository->command(
  22         909  
184             qw/clone -q --bare --no-hardlinks/, "--template=$tmpldir", $repodir, $clonedir,
185             );
186              
187 22         321731 my $my_stderr = $cmd->stderr;
188              
189 22 50       1262 open my $err_h, '>', $T->child('stderr')
190 0         0 or croak "Can't open '@{[$T->child('stderr')]}' for writing: $!\n";
191 22         226536 while (<$my_stderr>) {
192 22         1118 $err_h->print($_);
193             }
194 22         32302 close $err_h;
195              
196 22         544 $cmd->close();
197 22 50       6124 croak "Can't git-clone $repodir into $clonedir" unless $cmd->exit() == 0;
198             }
199              
200 22         2551 my $clone = Git::Repository->new(git_dir => $clonedir);
201              
202 22         963103 $repo->run(qw/remote add clone/, $clonedir);
203              
204 22         409238 return ($repo, $filename, $clone, $T);
205             };
206              
207 22 50       348 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         1436 return @result;
227             }
228              
229             sub new_commit {
230 13     13 0 666895 my ($git, $file, $msg) = @_;
231              
232 13   50     631 $file->append($msg || 'new commit');
233              
234 13         6641 $git->run(add => $file);
235 13   50     247933 $git->run(qw/commit -q -m/, $msg || 'commit');
236              
237 13         1353709 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 783527 my ($git, $command, @args) = @_;
246              
247 202         2420 my $cmd = $git->command($command, @args);
248              
249 202         3031018 my $stdout = do { local $/ = undef; readline($cmd->stdout); };
  202         1442  
  202         2980  
250 202         56021591 my $stderr = do { local $/ = undef; readline($cmd->stderr); };
  202         2553  
  202         3897  
251              
252 202         16064 $cmd->close;
253              
254 202         74961 return ($cmd->exit() == 0, $cmd->exit(), $stdout, $stderr);
255             }
256              
257             sub test_ok {
258 103     103 0 5372371 my ($testname, @args) = @_;
259 103         940 my ($ok, $exit, $stdout, $stderr) = test_command(@args);
260 103 50       15861 if ($ok) {
261 103         2516 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         141062 return $ok;
267             }
268              
269             sub test_ok_match {
270 3     3 0 57029 my ($testname, $regex, @args) = @_;
271 3         45 my ($ok, $exit, $stdout, $stderr) = test_command(@args);
272 3 50       668 if ($ok) {
273 3 50 66     184 if ($stdout =~ $regex || $stderr =~ $regex) {
274 3         85 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         4901 return $ok;
284             }
285              
286             sub test_nok {
287 7     7 0 240335 my ($testname, @args) = @_;
288 7         121 my ($ok, $exit, $stdout, $stderr) = test_command(@args);
289 7 50       1245 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         276 pass($testname);
294             }
295 7         12874 return !$ok;
296             }
297              
298             sub test_nok_match {
299 78     78 0 4583141 my ($testname, $regex, @args) = @_;
300 78         1211 my ($ok, $exit, $stdout, $stderr) = test_command(@args);
301 78 50 33     17133 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         2107 pass($testname);
307 78         101413 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__