Mercurial > repos > youngkim > ezbamqc

comparison ezBAMQC/src/htslib/test/test.pl @ 0:dfa3745e5fd8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Uploaded
author youngkim
date Thu, 24 Mar 2016 17:12:52 -0400
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:dfa3745e5fd8
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