File Coverage

lib/Test/Harness/KS.pm
Criterion Covered Total %
statement 63 271 23.2
branch 2 104 1.9
condition 0 9 0.0
subroutine 18 36 50.0
pod 8 9 88.8
total 91 429 21.2


line stmt bran cond sub pod time code
1             package Test::Harness::KS;
2             # ABSTRACT: Harness the power of clover and junit in one easy to use wrapper.
3             #
4             # Copyright 2018 National Library of Finland
5             # Copyright 2017 KohaSuomi
6              
7             =head1 NAME
8            
9             Test::Harness::KS
10            
11             =head1 SYNOPSIS
12            
13             Runs given test files and generates clover, html and junit test reports to the given directory.
14            
15             Automatically sorts given test files by directory and deduplicates them.
16            
17             See
18            
19             test-harness-ks --help
20            
21             for commandline usage
22            
23             =head1 USAGE
24            
25             my $harness = Test::Harness->new($params);
26             $harness->run();
27            
28             =cut
29              
30             ##Pragmas
31 3     3   451240 use Modern::Perl;
  3         27  
  3         25  
32 3     3   1886 use Carp::Always;
  3         4256  
  3         27  
33 3     3   1734 use autodie;
  3         44148  
  3         14  
34 3     3   22525 use English; #Use verbose alternatives for perl's strange $0 and $\ etc.
  3         7315  
  3         19  
35 3     3   2912 use Try::Tiny;
  3         6337  
  3         183  
36 3     3   23 use Scalar::Util qw(blessed);
  3         22  
  3         283  
37 3     3   20 use Cwd;
  3         6  
  3         575  
38              
39             ##Testing harness libraries
40             sub _loadJUnit() {
41 0     0   0   require TAP::Harness::JUnit;
42             }
43             sub _loadCover() {
44 0     0   0   require Devel::Cover; #Require coverage testing and extensions for it. These are not actually used in this package directly, but Dist::Zilla uses this data to autogenerate the dependencies
45 0         0   require Devel::Cover::Report::Clover;
46 0         0   require Template;
47 0         0   require Perl::Tidy;
48 0         0   require Pod::Coverage::CountParents;
49 0         0   require Test::Differences;
50             }
51              
52              
53             ##Remote modules
54 3     3   736 use IPC::Cmd;
  3         54544  
  3         143  
55 3     3   23 use File::Basename;
  3         7  
  3         217  
56 3     3   30 use File::Path qw(make_path);
  3         5  
  3         191  
57 3     3   1855 use Params::Validate qw(:all);
  3         20309  
  3         619  
58 3     3   1688 use Data::Dumper;
  3         13938  
  3         181  
59 3     3   2069 use Storable;
  3         10039  
  3         182  
60              
61 3     3   2588 use Log::Log4perl qw(get_logger);
  3         140875  
  3         17  
62 3     3   267 use Log::Log4perl::Level;
  3         9  
  3         17  
63              
64             =head2 new
65            
66             Creates a new Test runner
67            
68             Configure log verbosity by initializing Log::Log4perl beforehand, otherwise the internal logging defaults to WARN
69            
70             @params HashRef: {
71             resultsDir => String, directory, must be writable. Where the test deliverables are brought
72             tar => Boolean
73             cover => Boolean
74             junit => Boolean
75             testFiles => ARRAYRef, list of files to test
76             dryRun => Boolean
77             lib => ARRAYRef or undef, list of extra include directories for the test files
78             }
79            
80             =cut
81              
82             my $validationTestFilesCallbacks = {
83               'files exist' => sub {
84                 die "not an array" unless (ref($_[0]) eq 'ARRAY');
85                 die "is empty" unless (scalar(@{$_[0]}));
86              
87                 my @errors;
88                 foreach my $file (@{$_[0]}) {
89                   push(@errors, "$file is not readable") unless (-r $file);
90                 }
91                 return 1 unless @errors;
92                 die "files are not readable:\n".join("\n",@errors);
93               },
94             };
95             my $validationNew = {
96               resultsDir => {
97                 callbacks => {
98                   'resultsDir is writable' => sub {
99                     if ($_[0]) {
100                       return (-w $_[0]);
101                     }
102                     else {
103                       return 1 if (-w File::Basename::dirname($0));
104                       die "No --results-dir was passed, so defaulting to the directory of the program used to call me '".File::Basename::dirname($0)."'. Unfortunately that directory is not writable by this process and I don't know where to save the test deliverables."
105                     }
106                   },
107                 },
108               },
109               tar => {default => 0},
110               cover => {default => 0},
111               junit => {default => 0},
112               dryRun => {default => 0},
113               lib => {
114                 default => [],
115                 callbacks => {
116                   'lib is an array or undef' => sub {
117                     return 1 unless ($_[0]);
118                     if (ref($_[0]) eq 'ARRAY') {
119                       return 1;
120                     }
121                     else {
122                       die "param lib is not an array";
123                     }
124                   },
125                 },
126               },
127               testFiles => {
128                 callbacks => $validationTestFilesCallbacks,
129               },
130               dbDiff => {default => 0},
131               dbUser => {default => undef},
132               dbPass => {default => undef},
133               dbHost => {default => undef},
134               dbPort => {default => undef},
135               dbDatabase => {default => undef},
136               dbSocket => {default => undef},
137               dbDiffIgnoreTables => {default => undef}
138             };
139              
140 3     3   3615 use fields qw(resultsDir tar cover junit dryRun lib testFiles testFilesByDir dbDiff dbUser dbPass dbHost dbPort dbDatabase dbSocket dbDiffIgnoreTables);
  3         5225  
  3         41  
141              
142             sub new {
143 0 0   0 1 0   unless (Log::Log4perl->initialized()) { Log::Log4perl->easy_init( Log::Log4perl::Level::to_priority( 'WARN' ) ); }
  0         0  
144              
145 0         0   my $class = shift;
146 0         0   my $params = validate(@_, $validationNew);
147              
148 0         0   my $self = Storable::dclone($params);
149 0         0   bless($self, $class);
150              
151 0         0   $self->{testFilesByDir} = _sortFilesByDir($self->{testFiles});
152              
153 0 0       0   _loadJUnit() if $self->{junit};
154 0 0       0   _loadCover() if $self->{cover};
155              
156 0         0   return $self;
157             }
158              
159             =head2 run
160            
161             $harness->run();
162            
163             Executes the configured test harness.
164            
165             =cut
166              
167             sub run {
168 0     0 1 0   my ($self) = @_;
169              
170             # $self->_changeWorkingDir();
171 0         0   $self->_prepareTestResultDirectories();
172 0 0       0   $self->clearCoverDb() if $self->{cover};
173 0         0   $self->_runharness();
174 0 0       0   $self->createCoverReport() if $self->{cover};
175 0 0       0   $self->tar() if $self->{tar};
176             # $self->_revertWorkingDir();
177             }
178              
179             sub _changeWorkingDir {
180 0     0   0   my ($self) = @_;
181              
182 0         0   $self->{oldWorkingDir} = Cwd::getcwd();
183 0 0       0   chdir $self->{resultsDir} || File::Basename::dirname($0);
184             }
185              
186             sub _revertWorkingDir {
187 0     0   0   my ($self) = @_;
188              
189 0 0       0   die "\$self->{oldWorkingDir} is not known when reverting to the old working directory?? This should never happen!!" unless $self->{oldWorkingDir};
190 0         0   chdir $self->{oldWorkingDir};
191             }
192              
193             sub _prepareTestResultDirectories {
194 0     0   0   my ($self) = @_;
195 0         0   $self->getTestResultFileAndDirectoryPaths($self->{resultsDir});
196 0 0       0   mkdir $self->{testResultsDir} unless -d $self->{testResultsDir};
197 0 0       0   $self->_shell("rm", "-r $self->{junitDir}") if -e $self->{junitDir};
198 0 0       0   $self->_shell("rm", "-r $self->{coverDir}") if -e $self->{coverDir};
199 0 0       0   $self->_shell("rm", "-r $self->{dbDiffDir}") if -e $self->{dbDiffDir};
200 0 0       0   mkdir $self->{junitDir} unless -d $self->{junitDir};
201 0 0       0   mkdir $self->{coverDir} unless -d $self->{coverDir};
202 0 0       0   mkdir $self->{dbDiffDir} unless -d $self->{dbDiffDir};
203 0 0       0   unlink $self->{testResultsArchive} if -e $self->{testResultsArchive};
204             }
205              
206             =head2 clearCoverDb
207            
208             Empty previous coverage test results
209            
210             =cut
211              
212             sub clearCoverDb {
213 0     0 1 0   my ($self) = @_;
214 0         0   $self->_shell('cover', "-delete $self->{cover_dbDir}");
215             }
216              
217             =head2 createCoverReport
218            
219             Create Cover coverage reports
220            
221             =cut
222              
223             sub createCoverReport {
224 0     0 1 0   my ($self) = @_;
225 0         0   $self->_shell('cover', "-report clover -report html -outputdir $self->{coverDir} $self->{cover_dbDir}");
226             }
227              
228             =head2 tar
229            
230             Create a tar.gz-package out of test deliverables
231            
232             Package contains
233            
234             testResults/cover/clover.xml
235             testResults/cover/coverage.html
236             testResults/cover/*
237             testResults/junit/*.xml
238            
239             =cut
240              
241             sub tar {
242 0     0 1 0   my ($self) = @_;
243 0         0   my $baseDir = $self->{resultsDir};
244              
245             #Choose directories that need archiving
246 0         0   my @archivable;
247 0 0       0   push(@archivable, $self->{junitDir}) if $self->{junit};
248 0 0       0   push(@archivable, $self->{coverDir}) if $self->{cover};
249 0         0   my @dirs = map { my $a = $_; $a =~ s/\Q$baseDir\E\/?//; $a;} @archivable; #Change absolute path to relative
  0         0  
  0         0  
  0         0  
250 0         0   my $cwd = Cwd::getcwd();
251 0         0   chdir $baseDir;
252 0         0   $self->_shell("tar", "-czf $self->{testResultsArchive} @dirs");
253 0         0   chdir $cwd;
254             }
255              
256             #
257             # Runs all given test files
258             #
259             sub _runharness {
260 0     0   0   my ($self) = @_;
261              
262 0 0       0   if ($self->{isDbDiff}) {
263 0         0     $self->databaseDiff(); # Initialize first mysqldump before running any tests
264               }
265              
266 0         0   foreach my $dir (sort keys %{$self->{testFilesByDir}}) {
  0         0  
267 0         0     my @tests = sort @{$self->{testFilesByDir}->{$dir}};
  0         0  
268 0 0       0     unless (scalar(@tests)) {
269 0         0         get_logger()->logdie("\@tests is empty?");
270                 }
271             ##Prepare test harness params
272 0         0     my $dirToPackage = $dir;
273 0         0     $dirToPackage =~ s!^\./!!; #Drop leading "current"-dir chars
274 0         0     $dirToPackage =~ s!/!\.!gsm; #Change directories to dot-separated packages
275 0         0     my $xmlfile = $self->{testResultsDir}.'/junit'.'/'.$dirToPackage.'.xml';
276 0         0     my @exec = (
277                     $EXECUTABLE_NAME,
278                     '-w',
279                 );
280 0 0       0     push(@exec, "-MDevel::Cover=-db,$self->{cover_dbDir},-silent,1,-coverage,all") if $self->{cover};
281 0         0     foreach my $lib (@{$self->{lib}}) {
  0         0  
282 0         0       push(@exec, "-I$lib");
283                 }
284              
285 0 0       0     if ($self->{dryRun}) {
286 0         0         print "TAP::Harness::JUnit would run tests with this config:\nxmlfile => $xmlfile\npackage => $dirToPackage\nexec => @exec\ntests => @tests\n";
287                 }
288                 else {
289 0         0       my $harness;
290 0 0       0       if ($self->{junit}) {
291                     $harness = TAP::Harness::JUnit->new({
292                         xmlfile => $xmlfile,
293                         package => "",
294                         verbosity => get_logger()->is_debug(),
295                         namemangle => 'perl',
296                         callbacks => {
297                           after_test => sub {
298                             $self->databaseDiff({
299                               test => shift->[0], parser => shift
300 0 0   0   0                 }) if $self->{isDbDiff};
301                           },
302                         },
303 0         0             exec => \@exec,
304                     });
305 0         0         $harness->runtests(@tests);
306                   }
307                   else {
308                     $harness = TAP::Harness->new({
309                         verbosity => get_logger()->is_debug(),
310                         callbacks => {
311                           after_test => sub {
312                             $self->databaseDiff({
313                               test => shift->[0], parser => shift
314                             }) if $self->{isDbDiff}
315 0 0   0   0               },
316                         },
317 0         0             exec => \@exec,
318                     });
319 0         0         $harness->runtests(@tests);
320                   }
321                 }
322               }
323             }
324              
325             =head2 databaseDiff
326            
327             Diffs two mysqldumps and finds changes to INSERT INTO queries. Collects names of
328             the tables that have new INSERTs.
329            
330             =cut
331              
332             sub databaseDiff {
333 0     0 1 0     my ($self, $params) = @_;
334              
335 0         0     my $test = $params->{test};
336              
337 0         0     my $user = $self->{dbUser};
338 0         0     my $pass = $self->{dbPass};
339 0         0     my $host = $self->{dbHost};
340 0         0     my $port = $self->{dbPort};
341 0         0     my $db = $self->{dbDatabase};
342 0         0     my $sock = $self->{dbSocket};
343              
344 0 0       0     unless (defined $user) {
345 0         0         die 'KSTestHarness->databaseDiff(): Parameter dbUser undefined';
346                 }
347 0 0       0     unless (defined $host) {
348 0         0         die 'KSTestHarness->databaseDiff(): Parameter dbHost undefined';
349                 }
350 0 0       0     unless (defined $port) {
351 0         0         die 'KSTestHarness->databaseDiff(): Parameter dbPort undefined';
352                 }
353 0 0       0     unless (defined $db) {
354 0         0         die 'KSTestHarness->databaseDiff(): Parameter dbDatabase undefined';
355                 }
356              
357 0   0     0     $self->{tmpDbDiffDir} ||= '/tmp/KSTestHarness/dbDiff';
358 0         0     my $path = $self->{tmpDbDiffDir};
359 0 0       0     unless (-e $path) {
360 0         0         make_path($path);
361                 }
362              
363 0         0     my @mysqldumpargs = (
364                     'mysqldump',
365                     '-u', $user,
366                     '-h', $host,
367                     '-P', $port
368                 );
369              
370 0 0       0     push @mysqldumpargs, "-p$pass" if defined $pass;
371              
372 0 0       0     if ($sock) {
373 0         0         push @mysqldumpargs, '--protocol=socket';
374 0         0         push @mysqldumpargs, '-S';
375 0         0         push @mysqldumpargs, $sock;
376                 }
377 0         0     push @mysqldumpargs, $db;
378              
379 0 0 0     0     unless ($test && -e "$path/previous.sql") {
380 0         0         eval { $self->_shell(@mysqldumpargs, '>', "$path/previous.sql"); };
  0         0  
381                 }
382 0 0       0     return 1 unless defined $test;
383              
384 0         0     eval { $self->_shell(@mysqldumpargs, '>', "$path/current.sql"); };
  0         0  
385              
386 0         0     my $diff;
387 0         0     eval {
388 0         0         $self->_shell(
389                         'git', 'diff', '--color-words', '--no-index', '-U0',
390                         "$path/previous.sql", "$path/current.sql"
391                     );
392                 };
393 0         0     my @tables;
394 0 0       0     if ($diff = $@) {
395             # Remove everything else except INSERT INTO queries
396 0         0         $diff =~ s/(?!^.*INSERT INTO .*$)^.+//mg;
397 0         0         $diff =~ s/^\n*//mg;
398 0         0         @tables = $diff =~ /^INSERT INTO `(.*)`/mg; # Collect names of tables
399 0 0       0         if ($self->{dbDiffIgnoreTables}) {
400 0         0           foreach my $table (@{$self->{dbDiffIgnoreTables}}) {
  0         0  
401 0 0       0             if (grep(/$table/, @tables)) {
402 0         0               @tables = grep { $_ ne $table } @tables;
  0         0  
403                         }
404                       }
405                     }
406 0 0       0         if (@tables) {
407 0 0       0             if ($params->{parser}) {
408                           $self->_add_failed_test_dynamically(
409 0         0                   $params->{parser}, "Test $test leaking test data to following ".
410                               "tables:\n". Data::Dumper::Dumper(@tables)
411                           );
412                         }
413 0         0             get_logger()->info("New inserts at tables:\n" . Data::Dumper::Dumper(@tables));
414 0         0             my $filename = dirname($test);
415 0         0             make_path("$self->{dbDiffDir}/$filename");
416 0         0             open my $fh, '>>', "$self->{dbDiffDir}/$test.out";
417 0         0             print $fh $diff;
418 0         0             close $fh;
419                     }
420                 }
421              
422 0         0     $self->_shell('mv', "$path/current.sql", "$path/previous.sql");
423              
424 0         0     return @tables;
425             }
426              
427             sub _sortFilesByDir {
428 0     0   0     my ($files) = @_;
429 0 0       0     unless (ref($files) eq 'ARRAY') {
430 0         0         get_config()->logdie("\$files is not an ARRAYRef");
431                 }
432 0 0       0     unless (scalar(@$files)) {
433 0         0         get_config()->logdie("\$files is an ampty array?");
434                 }
435              
436             #deduplicate files
437 0         0     my (%seen, @files);
438 0         0     @files = grep !$seen{$_}++, @$files;
439              
440             #Sort by dirs
441 0         0     my %dirsWithFiles;
442 0         0     foreach my $f (@files) {
443 0         0         my $dir = File::Basename::dirname($f);
444 0 0       0         $dirsWithFiles{$dir} = [] unless $dirsWithFiles{$dir};
445 0         0         push (@{$dirsWithFiles{$dir}}, $f);
  0         0  
446                 }
447 0         0     return \%dirsWithFiles;
448             }
449              
450             #
451             # Dynamically generates a failed test and pushes the result to the end of
452             # TAP::Parser::Result->{__results} for JUnit.
453             #
454             # C<$parser> is an instance of TAP::Harness::JUnit::Parser
455             # C<$desc> is a custom description for the test
456             #
457             sub _add_failed_test_dynamically {
458 0     0   0   my ($self, $parser, $desc) = @_;
459              
460 0   0     0   $desc ||= 'Dynamically failed test';
461 0         0   my $test_num = $parser->tests_run+1;
462 0         0   my @plan_split = split(/\.\./, $parser->{plan});
463 0         0   my $plan = $plan_split[0].'..'.++$plan_split[1];
464 0         0   $parser->{plan} = $plan;
465              
466 0 0       0   if (ref($parser) eq 'TAP::Harness::JUnit::Parser') {
467 0         0     my $failed = {};
468 0         0     $failed->{ok} = 'not ok';
469 0         0     $failed->{test_num} = $test_num;
470 0         0     $failed->{description} = $desc;
471 0         0     $failed->{raw} = "not ok $test_num - $failed->{description}";
472 0         0     $failed->{type} = 'test';
473 0         0     $failed->{__end_time} = 0;
474 0         0     $failed->{__start_time} = 0;
475 0         0     $failed->{directive} = '';
476 0         0     $failed->{explanation} = '';
477 0         0     bless $failed, 'TAP::Parser::Result::Test';
478              
479 0         0     push @{$parser->{__results}}, $failed;
  0         0  
480 0         0     $parser->{__results}->[0]->{raw} = $plan;
481 0         0     $parser->{__results}->[0]->{tests_planned}++;
482               }
483 0         0   push @{$parser->{failed}}, $test_num;
  0         0  
484 0         0   push @{$parser->{actual_failed}}, $test_num;
  0         0  
485               
486 0         0   $parser->{tests_planned}++;
487 0         0   $parser->{tests_run}++;
488 0         0   print "not ok $test_num - $desc";
489              
490 0         0   return $parser;
491             }
492              
493             sub _shell {
494 0     0   0   my ($self, $program, @params) = @_;
495 0 0       0   my $programPath = IPC::Cmd::can_run($program) or die "$program is not installed!";
496 0         0   my $cmd = "$programPath @params";
497              
498 0 0       0   if ($self->{dryRun}) {
499 0         0     print "$cmd\n";
500               }
501               else {
502 0         0     my( $success, $error_message, $full_buf, $stdout_buf, $stderr_buf ) =
503                     IPC::Cmd::run( command => $cmd, verbose => 0 );
504 0         0     my $exitCode = ${^CHILD_ERROR_NATIVE} >> 8;
505 0         0     my $killSignal = ${^CHILD_ERROR_NATIVE} & 127;
506 0         0     my $coreDumpTriggered = ${^CHILD_ERROR_NATIVE} & 128;
507 0 0       0     die "Shell command: $cmd\n exited with code '$exitCode'. Killed by signal '$killSignal'.".(($coreDumpTriggered) ? ' Core dumped.' : '')."\nERROR MESSAGE: $error_message\nSTDOUT:\n@$stdout_buf\nSTDERR:\n@$stderr_buf\nCWD:".Cwd::getcwd()
    0          
508                     if $exitCode != 0;
509 0   0     0     get_logger->info("CMD: $cmd\nERROR MESSAGE: ".($error_message // '')."\nSTDOUT:\n@$stdout_buf\nSTDERR:\n@$stderr_buf\nCWD:".Cwd::getcwd());
510 0         0     return "@$full_buf";
511               }
512             }
513              
514             =head2 getTestResultFileAndDirectoryPaths
515             @static
516            
517             Injects paths to the given HASHRef.
518            
519             Centers the relevant path calculation logic so the paths can be accessed from external tests as well.
520            
521             =cut
522              
523             sub getTestResultFileAndDirectoryPaths {
524 1     1 1 4392   my ($hash, $resultsDir) = @_;
525 1         5   $hash->{testResultsDir} = $resultsDir.'/testResults';
526 1         4   $hash->{testResultsArchive} = 'testResults.tar.gz';
527 1         5   $hash->{junitDir} = $hash->{testResultsDir}.'/junit';
528 1         4   $hash->{coverDir} = $hash->{testResultsDir}.'/cover';
529 1         4   $hash->{cover_dbDir} = $hash->{testResultsDir}.'/cover_db';
530 1         4   $hash->{dbDiffDir} = $hash->{testResultsDir}.'/dbDiff';
531             }
532              
533             =head2 parseOtherTests
534             @static
535            
536             Parses the given blob of file names and paths invoked from god-knows what ways of shell-magic.
537             Tries to normalize them into something the Test::Harness::* can understand.
538            
539             @param1 ARRAYRef of Strings, which might or might not contain separated textual lists of filepaths.
540             @returns ARRAYRef of Strings, Normalized test file paths
541            
542             =cut
543              
544             sub parseOtherTests {
545 1     1 1 5335     my ($files) = @_;
546 1         25     my @files = split(/(?:,|\s)+/, join(',', @$files));
547              
548 1         3     my @warnings;
549 1         6     for (my $i=0 ; $i<@files ; $i++) {
550 9         16         my $f = $files[$i];
551 9 50       68         if ($f !~ /\.t\b/) {
552 0 0       0             push(@warnings, "File '$f' doesn't look like a Perl test file, as it doesn't have .t ending, ignoring it.") unless (-d $f);
553 0         0             $files[$i] = undef;
554                     }
555                 }
556 1 50       5     if (@warnings) {
557 0 0       0         get_logger->warn(join("\n", @warnings)) if @warnings;
558 0         0         @files = grep { defined $_ } @files;
  0         0  
559                 }
560 1         12     return \@files;
561             }
562              
563             =head2 findfiles
564             @static
565            
566             Helper to the shell command 'find'
567            
568             @param1 String, Dir to look from
569             @param2 String, selector used in the -name -parameter
570             @param3 Integer, -maxdepth, the depth of directories 'find' keeps looking into
571             @returns ARRAYRef of Strings, filepaths found
572            
573             =cut
574              
575             sub findFiles {
576 0     0 0       my ($dir, $selector, $maxDepth) = @_;
577 0 0             $maxDepth = 999 unless(defined($maxDepth));
578 0               my $files = `/usr/bin/find $dir -maxdepth $maxDepth -name '$selector'`;
579 0               my @files = split(/\n/, $files);
580 0               return \@files;
581             }
582              
583             1;
584