Line 0
Link Here
|
0 |
- |
1 |
#!/usr/bin/env perl |
|
|
2 |
|
3 |
# Copyright 2017 KohaSuomi |
4 |
# |
5 |
# This file is part of Koha. |
6 |
# |
7 |
|
8 |
use 5.22.0; |
9 |
use Carp; |
10 |
use autodie; |
11 |
$Carp::Verbose = 'true'; #die with stack trace |
12 |
use English; #Use verbose alternatives for perl's strange $0 and $\ etc. |
13 |
use Getopt::Long qw(:config no_ignore_case); |
14 |
|
15 |
my ($help, $dryRun); |
16 |
my ($verbose, $gitTailLength) = (0, 0); |
17 |
my ($clover, $tar); |
18 |
my ($testAll, $testBasic, $testXt, $testSip2, $testDb); |
19 |
|
20 |
|
21 |
GetOptions( |
22 |
'h|help' => \$help, |
23 |
'v|verbose:i' => \$verbose, |
24 |
'dry-run' => \$dryRun, |
25 |
'clover' => \$clover, |
26 |
'tar' => \$tar, |
27 |
'a|all' => \$testAll, |
28 |
'b|basic' => \$testBasic, |
29 |
'x|xt' => \$testXt, |
30 |
's|sip2' => \$testSip2, |
31 |
'd|db' => \$testDb, |
32 |
'g|git:i' => \$gitTailLength, |
33 |
); |
34 |
|
35 |
my $usage = <<USAGE; |
36 |
|
37 |
Runs a ton of tests with other metrics if needed |
38 |
|
39 |
-h --help This friendly help! |
40 |
|
41 |
-v --verbose Integer, the level of verbosity |
42 |
|
43 |
--tar Create a testResults.tar.gz from all tests and deliverables |
44 |
|
45 |
--dry-run Don't run tests or other metrics. Simply show what would happen. |
46 |
|
47 |
--clover Run Devel::Cover and output Clover-reports |
48 |
|
49 |
-a --all Run all tests. |
50 |
|
51 |
-b --basic Basic tests t/*.t |
52 |
|
53 |
-x --xt XT tests |
54 |
|
55 |
-s --sip2 SIP2 tests |
56 |
|
57 |
-d --db db_dependent tests |
58 |
|
59 |
--git Integer, look for this many git commits from HEAD and run |
60 |
all '.t'-files that they have changed. |
61 |
This is meaningful as a quick smoke test to verify that |
62 |
the latest changes haven't been broken or work as expected. |
63 |
Thus where the most probably reason for breakage occurs, |
64 |
is tested first, before executing more lengthy test suites. |
65 |
|
66 |
EXAMPLE |
67 |
|
68 |
##First run a smoke test for latest changes |
69 |
ks-test-harness.pl --git 5 --tar |
70 |
##Then run a big test suite |
71 |
ks-test-harness.pl --all --tar |
72 |
|
73 |
##Just fiddling with options here |
74 |
ks-test-harness.pl --basic --db -v 1 |
75 |
|
76 |
USAGE |
77 |
|
78 |
if ($help) { |
79 |
print $usage; |
80 |
exit 0; |
81 |
} |
82 |
|
83 |
use File::Basename; |
84 |
use TAP::Harness::JUnit; |
85 |
use Git; |
86 |
|
87 |
my $dir = File::Basename::dirname($0); |
88 |
chdir $dir; |
89 |
|
90 |
|
91 |
##Prepare directories to store test results |
92 |
my $testResultsDir = 'testResults'; |
93 |
my $testResultsArchive = 'testResults.tar.gz'; |
94 |
my $junitDir = $testResultsDir.'/junit'; |
95 |
my $cloverDir = $testResultsDir.'/clover'; |
96 |
my @archivableDirs = ($junitDir, $cloverDir); |
97 |
mkdir $testResultsDir unless -d $testResultsDir; |
98 |
_shell("rm -r $junitDir"); |
99 |
_shell("rm -r $cloverDir"); |
100 |
mkdir $junitDir unless -d $junitDir; |
101 |
mkdir $cloverDir unless -d $cloverDir; |
102 |
unlink $testResultsArchive if -e $testResultsArchive; |
103 |
|
104 |
|
105 |
run(); |
106 |
sub run { |
107 |
clearCoverDb() if $clover; |
108 |
runharness(_getAllTests()) if $testAll; |
109 |
runharness(_getBasicTests()) if $testBasic; |
110 |
runharness(_getXTTests()) if $testXt; |
111 |
runharness(_getSIPTests()) if $testSip2; |
112 |
runharness(_getDbDependentTests()) if $testDb; |
113 |
runharness(_getGitTailTests()) if $gitTailLength; |
114 |
createCoverReport() if $clover; |
115 |
tar() if $tar; |
116 |
} |
117 |
|
118 |
=head2 clearCoverDb |
119 |
|
120 |
Empty previous coverage test results |
121 |
|
122 |
=cut |
123 |
|
124 |
sub clearCoverDb { |
125 |
my $cmd = "/usr/bin/cover -delete $testResultsDir/cover_db"; |
126 |
print "$cmd\n" if $dryRun; |
127 |
_shell($cmd) unless $dryRun; |
128 |
} |
129 |
|
130 |
=head2 createCoverReport |
131 |
|
132 |
Create Clover coverage reports |
133 |
|
134 |
=cut |
135 |
|
136 |
sub createCoverReport { |
137 |
my $cmd = "/usr/bin/cover -report clover -outputdir $testResultsDir/clover $testResultsDir/cover_db"; |
138 |
print "$cmd\n" if $dryRun; |
139 |
_shell($cmd) unless $dryRun; |
140 |
} |
141 |
|
142 |
=head2 tar |
143 |
|
144 |
Create a tar.gz-package out of test deliverables |
145 |
|
146 |
=cut |
147 |
|
148 |
sub tar { |
149 |
my $cmd = "/bin/tar -czf $testResultsArchive @archivableDirs"; |
150 |
print "$cmd\n" if $dryRun; |
151 |
_shell($cmd) unless $dryRun; |
152 |
} |
153 |
|
154 |
=head2 runharness |
155 |
|
156 |
Runs all given test files |
157 |
|
158 |
=cut |
159 |
|
160 |
sub runharness { |
161 |
my ($files) = @_; |
162 |
unless (ref($files) eq 'HASH') { |
163 |
carp "\$files is not a HASHRef"; |
164 |
} |
165 |
|
166 |
foreach my $dir (sort keys %$files) { |
167 |
my @tests = sort @{$files->{$dir}}; |
168 |
unless (scalar(@tests)) { |
169 |
carp "\@tests is empty?"; |
170 |
} |
171 |
|
172 |
##Prepare test harness params |
173 |
my $dirToPackage = $dir; |
174 |
$dirToPackage =~ s!^\./!!; #Drop leading "current"-dir chars |
175 |
$dirToPackage =~ s!/!\.!gsm; #Change directories to dot-separated packages |
176 |
my $xmlfile = $testResultsDir.'/junit'.'/'.$dirToPackage.'.xml'; |
177 |
my @exec = ( |
178 |
$EXECUTABLE_NAME, |
179 |
'-w', |
180 |
); |
181 |
push(@exec, '-MDevel::Cover=-silent,1,-coverage,all') if $clover; |
182 |
|
183 |
if ($dryRun) { |
184 |
print "TAP::Harness::JUnit would run tests with this config:\nxmlfile => $xmlfile\npackage => $dirToPackage\nexec => @exec\ntests => @tests\n"; |
185 |
} |
186 |
else { |
187 |
my $harness = TAP::Harness::JUnit->new({ |
188 |
xmlfile => $xmlfile, |
189 |
# package => $dirToPackage, |
190 |
package => "", |
191 |
verbosity => 1, |
192 |
namemangle => 'perl', |
193 |
exec => \@exec, |
194 |
}); |
195 |
$harness->runtests(@tests); |
196 |
} |
197 |
} |
198 |
} |
199 |
|
200 |
sub _getAllTests { |
201 |
return _getTests('.', '*.t'); |
202 |
} |
203 |
sub _getBasicTests { |
204 |
return _getTests('t', '*.t', 1); #maxdepth 1 |
205 |
} |
206 |
sub _getXTTests { |
207 |
return _getTests('xt', '*.t'); |
208 |
} |
209 |
sub _getSIPTests { |
210 |
return _getTests('C4/SIP/t', '*.t'); |
211 |
} |
212 |
sub _getDbDependentTests { |
213 |
return _getTests('t/db_dependent', '*.t'); |
214 |
} |
215 |
sub _getTests { |
216 |
my ($dir, $selector, $maxDepth) = @_; |
217 |
$maxDepth = 999 unless(defined($maxDepth)); |
218 |
my $files = _shell("/usr/bin/find $dir -name '$selector' -maxdepth $maxDepth"); |
219 |
my @files = split(/\n/, $files); |
220 |
return _sortFilesByDir(\@files); |
221 |
} |
222 |
sub _getGitTailTests { |
223 |
my $repo = Git->repository(Directory => '.'); |
224 |
#We can read and print 10000 git commits in less than three seconds :) good Git! |
225 |
my @commits = $repo->command('show', '--pretty=oneline', '--no-patch', '-'.($gitTailLength+1)); #Diff tree needs to include one extra commit to diff properly. |
226 |
my $lastCommitHash = $commits[-1]; |
227 |
if ($lastCommitHash =~ /^(\w+)\s/ && length($1) == 40) { |
228 |
$lastCommitHash = $1; |
229 |
} |
230 |
else { |
231 |
carp "Commit '$lastCommitHash' couldn't be parsed for it's leading commit hash"; |
232 |
} |
233 |
my @changedFiles = $repo->command('diff-tree', '--no-commit-id', '--name-only', '-r', 'HEAD..'.$lastCommitHash); |
234 |
my @testFiles; |
235 |
foreach my $f (@changedFiles) { |
236 |
if ($f =~ /.+?\.t$/) { |
237 |
push(@testFiles, $f); |
238 |
} |
239 |
} |
240 |
print "Found these changed test files in Git history: @testFiles\n" if $verbose > 0; |
241 |
return {} unless scalar(@testFiles); |
242 |
return _sortFilesByDir(\@testFiles); |
243 |
} |
244 |
|
245 |
sub _shell { |
246 |
my (@cmd) = @_; |
247 |
my $rv = `@cmd`; |
248 |
my $exitCode = ${^CHILD_ERROR_NATIVE} >> 8; |
249 |
my $killSignal = ${^CHILD_ERROR_NATIVE} & 127; |
250 |
my $coreDumpTriggered = ${^CHILD_ERROR_NATIVE} & 128; |
251 |
warn "Shell command: @cmd\n exited with code '$exitCode'. Killed by signal '$killSignal'.".(($coreDumpTriggered) ? ' Core dumped.' : '')."\n STDOUT: $rv\n" |
252 |
if $exitCode != 0; |
253 |
print "@cmd\n$rv\n" if $rv && $verbose > 0; |
254 |
return $rv; |
255 |
} |
256 |
|
257 |
=head2 _sortFilesByDir |
258 |
|
259 |
Sort files in arrays by directory |
260 |
@RETURNS HASHRef of directory-name keys and test file names |
261 |
{ |
262 |
't/db_dependent' => [ |
263 |
't/db_dependent/01-test.t', |
264 |
], |
265 |
... |
266 |
} |
267 |
=cut |
268 |
|
269 |
sub _sortFilesByDir { |
270 |
my ($files) = @_; |
271 |
unless (ref($files) eq 'ARRAY') { |
272 |
carp "\$files is not an ARRAYRef"; |
273 |
} |
274 |
unless (scalar(@$files)) { |
275 |
carp "\$files is an ampty array?"; |
276 |
} |
277 |
|
278 |
my %dirsWithFiles; |
279 |
foreach my $f (@$files) { |
280 |
my $dir = File::Basename::dirname($f); |
281 |
$dirsWithFiles{$dir} = [] unless $dirsWithFiles{$dir}; |
282 |
push (@{$dirsWithFiles{$dir}}, $f); |
283 |
} |
284 |
return \%dirsWithFiles; |
285 |
} |