|
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 |
} |