|
0
|
1 #!/usr/bin/env perl
|
|
|
2 #
|
|
|
3 # Copyright (C) 2012-2013 Genome Research Ltd.
|
|
|
4 #
|
|
|
5 # Author: Petr Danecek <pd3@sanger.ac.uk>
|
|
|
6 #
|
|
|
7 # Permission is hereby granted, free of charge, to any person obtaining a copy
|
|
|
8 # of this software and associated documentation files (the "Software"), to deal
|
|
|
9 # in the Software without restriction, including without limitation the rights
|
|
|
10 # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
|
|
11 # copies of the Software, and to permit persons to whom the Software is
|
|
|
12 # furnished to do so, subject to the following conditions:
|
|
|
13 #
|
|
|
14 # The above copyright notice and this permission notice shall be included in
|
|
|
15 # all copies or substantial portions of the Software.
|
|
|
16 #
|
|
|
17 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
|
|
18 # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
|
|
19 # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
|
|
20 # THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
|
|
21 # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
|
|
22 # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
|
|
23 # DEALINGS IN THE SOFTWARE.
|
|
|
24
|
|
|
25 use strict;
|
|
|
26 use warnings;
|
|
|
27 use Carp;
|
|
|
28 use FindBin;
|
|
|
29 use lib "$FindBin::Bin";
|
|
|
30 use Getopt::Long;
|
|
|
31 use File::Temp qw/ tempfile tempdir /;
|
|
|
32
|
|
|
33 my $opts = parse_params();
|
|
|
34
|
|
|
35 test_vcf_api($opts,out=>'test-vcf-api.out');
|
|
|
36 test_vcf_sweep($opts,out=>'test-vcf-sweep.out');
|
|
|
37
|
|
|
38 print "\nNumber of tests:\n";
|
|
|
39 printf " total .. %d\n", $$opts{nok}+$$opts{nfailed};
|
|
|
40 printf " passed .. %d\n", $$opts{nok};
|
|
|
41 printf " failed .. %d\n", $$opts{nfailed};
|
|
|
42 print "\n";
|
|
|
43
|
|
|
44 exit ($$opts{nfailed} > 0);
|
|
|
45
|
|
|
46 #--------------------
|
|
|
47
|
|
|
48 sub error
|
|
|
49 {
|
|
|
50 my (@msg) = @_;
|
|
|
51 if ( scalar @msg ) { confess @msg; }
|
|
|
52 print
|
|
|
53 "About: samtools/htslib consistency test script\n",
|
|
|
54 "Usage: test.pl [OPTIONS]\n",
|
|
|
55 "Options:\n",
|
|
|
56 " -r, --redo-outputs Recreate expected output files.\n",
|
|
|
57 " -t, --temp-dir <path> When given, temporary files will not be removed.\n",
|
|
|
58 " -h, -?, --help This help message.\n",
|
|
|
59 "\n";
|
|
|
60 exit 1;
|
|
|
61 }
|
|
|
62 sub parse_params
|
|
|
63 {
|
|
|
64 my $opts = { keep_files=>0, nok=>0, nfailed=>0 };
|
|
|
65 my $help;
|
|
|
66 Getopt::Long::Configure('bundling');
|
|
|
67 my $ret = GetOptions (
|
|
|
68 't|temp-dir:s' => \$$opts{keep_files},
|
|
|
69 'r|redo-outputs' => \$$opts{redo_outputs},
|
|
|
70 'h|?|help' => \$help
|
|
|
71 );
|
|
|
72 if ( !$ret or $help ) { error(); }
|
|
|
73 $$opts{tmp} = $$opts{keep_files} ? $$opts{keep_files} : tempdir(CLEANUP=>1);
|
|
|
74 if ( $$opts{keep_files} ) { cmd("mkdir -p $$opts{keep_files}"); }
|
|
|
75 $$opts{path} = $FindBin::RealBin;
|
|
|
76 $$opts{bin} = $FindBin::RealBin;
|
|
|
77 $$opts{bin} =~ s{/test/?$}{};
|
|
|
78 return $opts;
|
|
|
79 }
|
|
|
80 sub _cmd
|
|
|
81 {
|
|
|
82 my ($cmd) = @_;
|
|
|
83 my $kid_io;
|
|
|
84 my @out;
|
|
|
85 my $pid = open($kid_io, "-|");
|
|
|
86 if ( !defined $pid ) { error("Cannot fork: $!"); }
|
|
|
87 if ($pid)
|
|
|
88 {
|
|
|
89 # parent
|
|
|
90 @out = <$kid_io>;
|
|
|
91 close($kid_io);
|
|
|
92 }
|
|
|
93 else
|
|
|
94 {
|
|
|
95 # child
|
|
|
96 exec('/bin/bash', '-o','pipefail','-c', $cmd) or error("Cannot execute the command [/bin/sh -o pipefail -c $cmd]: $!");
|
|
|
97 }
|
|
|
98 return ($? >> 8, join('',@out));
|
|
|
99 }
|
|
|
100 sub cmd
|
|
|
101 {
|
|
|
102 my ($cmd) = @_;
|
|
|
103 my ($ret,$out) = _cmd($cmd);
|
|
|
104 if ( $ret ) { error("The command failed [$ret]: $cmd\n", $out); }
|
|
|
105 return $out;
|
|
|
106 }
|
|
|
107 sub test_cmd
|
|
|
108 {
|
|
|
109 my ($opts,%args) = @_;
|
|
|
110 if ( !exists($args{out}) )
|
|
|
111 {
|
|
|
112 if ( !exists($args{in}) ) { error("FIXME: expected out or in key\n"); }
|
|
|
113 $args{out} = "$args{in}.out";
|
|
|
114 }
|
|
|
115 my ($package, $filename, $line, $test)=caller(1);
|
|
|
116 $test =~ s/^.+:://;
|
|
|
117
|
|
|
118 print "$test:\n";
|
|
|
119 print "\t$args{cmd}\n";
|
|
|
120
|
|
|
121 my ($ret,$out) = _cmd("$args{cmd} 2>&1");
|
|
|
122 if ( $ret ) { failed($opts,$test); return; }
|
|
|
123 if ( $$opts{redo_outputs} && -e "$$opts{path}/$args{out}" )
|
|
|
124 {
|
|
|
125 rename("$$opts{path}/$args{out}","$$opts{path}/$args{out}.old");
|
|
|
126 open(my $fh,'>',"$$opts{path}/$args{out}") or error("$$opts{path}/$args{out}: $!");
|
|
|
127 print $fh $out;
|
|
|
128 close($fh);
|
|
|
129 my ($ret,$out) = _cmd("diff -q $$opts{path}/$args{out} $$opts{path}/$args{out}.old");
|
|
|
130 if ( !$ret && $out eq '' ) { unlink("$$opts{path}/$args{out}.old"); }
|
|
|
131 else
|
|
|
132 {
|
|
|
133 print "\tthe expected output changed, saving:\n";
|
|
|
134 print "\t old .. $$opts{path}/$args{out}.old\n";
|
|
|
135 print "\t new .. $$opts{path}/$args{out}\n";
|
|
|
136 }
|
|
|
137 }
|
|
|
138 my $exp = '';
|
|
|
139 if ( open(my $fh,'<',"$$opts{path}/$args{out}") )
|
|
|
140 {
|
|
|
141 my @exp = <$fh>;
|
|
|
142 $exp = join('',@exp);
|
|
|
143 close($fh);
|
|
|
144 }
|
|
|
145 elsif ( !$$opts{redo_outputs} ) { failed($opts,$test,"$$opts{path}/$args{out}: $!"); return; }
|
|
|
146
|
|
|
147 if ( $exp ne $out )
|
|
|
148 {
|
|
|
149 open(my $fh,'>',"$$opts{path}/$args{out}.new") or error("$$opts{path}/$args{out}.new");
|
|
|
150 print $fh $out;
|
|
|
151 close($fh);
|
|
|
152 if ( !-e "$$opts{path}/$args{out}" )
|
|
|
153 {
|
|
|
154 rename("$$opts{path}/$args{out}.new","$$opts{path}/$args{out}") or error("rename $$opts{path}/$args{out}.new $$opts{path}/$args{out}: $!");
|
|
|
155 print "\tthe file with expected output does not exist, creating new one:\n";
|
|
|
156 print "\t\t$$opts{path}/$args{out}\n";
|
|
|
157 }
|
|
|
158 else
|
|
|
159 {
|
|
|
160 failed($opts,$test,"The outputs differ:\n\t\t$$opts{path}/$args{out}\n\t\t$$opts{path}/$args{out}.new");
|
|
|
161 }
|
|
|
162 return;
|
|
|
163 }
|
|
|
164 passed($opts,$test);
|
|
|
165 }
|
|
|
166 sub failed
|
|
|
167 {
|
|
|
168 my ($opts,$test,$reason) = @_;
|
|
|
169 $$opts{nfailed}++;
|
|
|
170 if ( defined $reason ) { print "\n\t$reason"; }
|
|
|
171 print "\n.. failed ...\n\n";
|
|
|
172 }
|
|
|
173 sub passed
|
|
|
174 {
|
|
|
175 my ($opts,$test) = @_;
|
|
|
176 $$opts{nok}++;
|
|
|
177 print ".. ok\n\n";
|
|
|
178 }
|
|
|
179 sub is_file_newer
|
|
|
180 {
|
|
|
181 my ($afile,$bfile) = @_;
|
|
|
182 my (@astat) = stat($afile) or return 0;
|
|
|
183 my (@bstat) = stat($bfile) or return 0;
|
|
|
184 if ( $astat[9]>$bstat[9] ) { return 1 }
|
|
|
185 return 0;
|
|
|
186 }
|
|
|
187
|
|
|
188
|
|
|
189 # The tests --------------------------
|
|
|
190
|
|
|
191 sub test_vcf_api
|
|
|
192 {
|
|
|
193 my ($opts,%args) = @_;
|
|
|
194 test_cmd($opts,%args,cmd=>"$$opts{path}/test-vcf-api $$opts{tmp}/test-vcf-api.bcf");
|
|
|
195 }
|
|
|
196
|
|
|
197 sub test_vcf_sweep
|
|
|
198 {
|
|
|
199 my ($opts,%args) = @_;
|
|
|
200 test_cmd($opts,%args,cmd=>"$$opts{path}/test-vcf-sweep $$opts{tmp}/test-vcf-api.bcf");
|
|
|
201 }
|
|
|
202
|
