c_cpp/lib/htslib/test/test.pl

   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 use IO::Handle;
  33
  34 my $opts = parse_params();
  35
  36 test_view($opts,0);
  37 test_view($opts,4);
  38
  39 test_vcf_api($opts,out=>'test-vcf-api.out');
  40 test_vcf_sweep($opts,out=>'test-vcf-sweep.out');
  41 test_vcf_various($opts);
  42 test_bcf_sr_sort($opts);
  43 test_convert_padded_header($opts);
  44 test_rebgzip($opts);
  45 test_logging($opts);
  46
  47 print "\nNumber of tests:\n";
  48 printf "    total   .. %d\n", $$opts{nok}+$$opts{nfailed};
  49 printf "    passed  .. %d\n", $$opts{nok};
  50 printf "    failed  .. %d\n", $$opts{nfailed};
  51 print "\n";
  52
  53 exit ($$opts{nfailed} > 0);
  54
  55 #--------------------
  56
  57 sub error
  58 {
  59     my (@msg) = @_;
  60     if ( scalar @msg ) { confess @msg; }
  61     print
  62         "About: samtools/htslib consistency test script\n",
  63         "Usage: test.pl [OPTIONS]\n",
  64         "Options:\n",
  65         "   -r, --redo-outputs              Recreate expected output files.\n",
  66         "   -t, --temp-dir <path>           When given, temporary files will not be removed.\n",
  67         "   -h, -?, --help                  This help message.\n",
  68         "\n";
  69     exit 1;
  70 }
  71 sub parse_params
  72 {
  73     my $opts = { keep_files=>0, nok=>0, nfailed=>0 };
  74     my $help;
  75     Getopt::Long::Configure('bundling');
  76     my $ret = GetOptions (
  77             't|temp-dir:s' => \$$opts{keep_files},
  78             'r|redo-outputs' => \$$opts{redo_outputs},
  79             'h|?|help' => \$help
  80             );
  81     if ( !$ret or $help ) { error(); }
  82     $$opts{tmp} = $$opts{keep_files} ? $$opts{keep_files} : tempdir(CLEANUP=>1);
  83     if ( $$opts{keep_files} ) { cmd("mkdir -p $$opts{keep_files}"); }
  84     $$opts{path} = $FindBin::RealBin;
  85     $$opts{bin}  = $FindBin::RealBin;
  86     $$opts{bin}  =~ s{/test/?$}{};
  87     return $opts;
  88 }
  89 sub _cmd
  90 {
  91     my ($cmd) = @_;
  92     my $kid_io;
  93     my @out;
  94     my $pid = open($kid_io, "-|");
  95     if ( !defined $pid ) { error("Cannot fork: $!"); }
  96     if ($pid)
  97     {
  98         # parent
  99         @out = <$kid_io>;
 100         close($kid_io);
 101     }
 102     else
 103     {
 104         # child
 105         exec('bash', '-o','pipefail','-c', $cmd) or error("Cannot execute the command [/bin/sh -o pipefail -c $cmd]: $!");
 106     }
 107     return ($? >> 8, join('',@out));
 108 }
 109 sub cmd
 110 {
 111     my ($cmd) = @_;
 112     my ($ret,$out) = _cmd($cmd);
 113     if ( $ret ) { error("The command failed [$ret]: $cmd\n", $out); }
 114     return $out;
 115 }
 116 sub test_cmd
 117 {
 118     my ($opts,%args) = @_;
 119     if ( !exists($args{out}) )
 120     {
 121         if ( !exists($args{in}) ) { error("FIXME: expected out or in key\n"); }
 122         $args{out} = "$args{in}.out";
 123     }
 124     my ($package, $filename, $line, $test)=caller(1);
 125     $test =~ s/^.+:://;
 126
 127     print "$test:\n";
 128     print "\t$args{cmd}\n";
 129
 130     my ($ret,$out) = _cmd("$args{cmd}");
 131     if ( $ret ) { failed($opts,$test); return; }
 132     if ( $$opts{redo_outputs} && -e "$$opts{path}/$args{out}" )
 133     {
 134         rename("$$opts{path}/$args{out}","$$opts{path}/$args{out}.old");
 135         open(my $fh,'>',"$$opts{path}/$args{out}") or error("$$opts{path}/$args{out}: $!");
 136         print $fh $out;
 137         close($fh);
 138         my ($ret,$out) = _cmd("diff -q $$opts{path}/$args{out} $$opts{path}/$args{out}.old");
 139         if ( !$ret && $out eq '' ) { unlink("$$opts{path}/$args{out}.old"); }
 140         else
 141         {
 142             print "\tthe expected output changed, saving:\n";
 143             print "\t  old .. $$opts{path}/$args{out}.old\n";
 144             print "\t  new .. $$opts{path}/$args{out}\n";
 145         }
 146     }
 147     my $exp = '';
 148     if ( open(my $fh,'<',"$$opts{path}/$args{out}") )
 149     {
 150         my @exp = <$fh>;
 151         $exp = join('',@exp);
 152         close($fh);
 153     }
 154     elsif ( !$$opts{redo_outputs} ) { failed($opts,$test,"$$opts{path}/$args{out}: $!"); return; }
 155
 156     if ( $exp ne $out )
 157     {
 158         open(my $fh,'>',"$$opts{path}/$args{out}.new") or error("$$opts{path}/$args{out}.new");
 159         print $fh $out;
 160         close($fh);
 161         if ( !-e "$$opts{path}/$args{out}" )
 162         {
 163             rename("$$opts{path}/$args{out}.new","$$opts{path}/$args{out}") or error("rename $$opts{path}/$args{out}.new $$opts{path}/$args{out}: $!");
 164             print "\tthe file with expected output does not exist, creating new one:\n";
 165             print "\t\t$$opts{path}/$args{out}\n";
 166         }
 167         else
 168         {
 169             failed($opts,$test,"The outputs differ:\n\t\t$$opts{path}/$args{out}\n\t\t$$opts{path}/$args{out}.new");
 170         }
 171         return;
 172     }
 173     passed($opts,$test);
 174 }
 175 sub failed
 176 {
 177     my ($opts,$test,$reason) = @_;
 178     $$opts{nfailed}++;
 179     print "\n";
 180     STDOUT->flush();
 181     if ( defined $reason ) { print STDERR "\t$reason\n"; }
 182     print STDERR ".. failed ...\n\n";
 183     STDERR->flush();
 184 }
 185 sub passed
 186 {
 187     my ($opts,$test) = @_;
 188     $$opts{nok}++;
 189     print ".. ok\n\n";
 190 }
 191 sub is_file_newer
 192 {
 193     my ($afile,$bfile) = @_;
 194     my (@astat) = stat($afile) or return 0;
 195     my (@bstat) = stat($bfile) or return 0;
 196     if ( $astat[9]>$bstat[9] ) { return 1 }
 197     return 0;
 198 }
 199
 200
 201 # The tests --------------------------
 202
 203 my $test_view_failures;
 204 sub testv {
 205     my ($cmd) = @_;
 206     print "  $cmd\n";
 207     my ($ret, $out) = _cmd($cmd);
 208     if ($ret != 0) {
 209         STDOUT->flush();
 210         print STDERR "FAILED\n$out\n";
 211         STDERR->flush();
 212         $test_view_failures++;
 213     }
 214 }
 215
 216 sub test_view
 217 {
 218     my ($opts, $nthreads) = @_;
 219     my $tv_args = $nthreads ? "-\@$nthreads" : "";
 220
 221     foreach my $sam (glob("*#*.sam")) {
 222         my ($base, $ref) = ($sam =~ /((.*)#.*)\.sam/);
 223         $ref .= ".fa";
 224
 225         my $bam  = "$base.tmp.bam";
 226         my $cram = "$base.tmp.cram";
 227
 228         my $md = "-nomd";
 229         if ($sam =~ /^md/) {
 230             $md = "";
 231         }
 232
 233         print "test_view testing $sam, ref $ref:\n";
 234         $test_view_failures = 0;
 235
 236         # SAM -> BAM -> SAM
 237         testv "./test_view $tv_args -S -b $sam > $bam";
 238         testv "./test_view $tv_args $bam > $bam.sam_";
 239         testv "./compare_sam.pl $sam $bam.sam_";
 240
 241         # SAM -> CRAM -> SAM
 242         testv "./test_view $tv_args -t $ref -S -C $sam > $cram";
 243         testv "./test_view $tv_args -D $cram > $cram.sam_";
 244         testv "./compare_sam.pl $md $sam $cram.sam_";
 245
 246         # BAM -> CRAM -> BAM -> SAM
 247         $cram = "$bam.cram";
 248         testv "./test_view $tv_args -t $ref -C $bam > $cram";
 249         testv "./test_view $tv_args -b -D $cram > $cram.bam";
 250         testv "./test_view $tv_args $cram.bam > $cram.bam.sam_";
 251         testv "./compare_sam.pl $md $sam $cram.bam.sam_";
 252
 253         # SAM -> CRAM3 -> SAM
 254         $cram = "$base.tmp.cram";
 255         testv "./test_view $tv_args -t $ref -S -C -o VERSION=3.0 $sam > $cram";
 256         testv "./test_view $tv_args -D $cram > $cram.sam_";
 257         testv "./compare_sam.pl $md $sam $cram.sam_";
 258
 259         # BAM -> CRAM3 -> BAM -> SAM
 260         $cram = "$bam.cram";
 261         testv "./test_view $tv_args -t $ref -C -o VERSION=3.0 $bam > $cram";
 262         testv "./test_view $tv_args -b -D $cram > $cram.bam";
 263         testv "./test_view $tv_args $cram.bam > $cram.bam.sam_";
 264         testv "./compare_sam.pl $md $sam $cram.bam.sam_";
 265
 266         # CRAM3 -> CRAM2
 267         $cram = "$base.tmp.cram";
 268         testv "./test_view $tv_args -t $ref -C -o VERSION=2.1 $cram > $cram.cram";
 269
 270         # CRAM2 -> CRAM3
 271         testv "./test_view $tv_args -t $ref -C -o VERSION=3.0 $cram.cram > $cram";
 272         testv "./test_view $tv_args $cram > $cram.sam_";
 273         testv "./compare_sam.pl $md $sam $cram.sam_";
 274
 275         # Java pre-made CRAM -> SAM
 276         my $jcram = "${base}_java.cram";
 277         if (-e $jcram) {
 278             my $jsam = "${base}_java.tmp.sam_";
 279             testv "./test_view $tv_args -i reference=$ref $jcram > $jsam";
 280             testv "./compare_sam.pl -Baux $md $sam $jsam";
 281         }
 282
 283         if ($test_view_failures == 0)
 284         {
 285             passed($opts, "$sam conversions");
 286         }
 287         else
 288         {
 289             failed($opts, "$sam conversions", "$test_view_failures subtests failed");
 290         }
 291     }
 292 }
 293
 294 sub test_vcf_api
 295 {
 296     my ($opts,%args) = @_;
 297     test_cmd($opts,%args,cmd=>"$$opts{path}/test-vcf-api $$opts{tmp}/test-vcf-api.bcf");
 298 }
 299
 300 sub test_vcf_sweep
 301 {
 302     my ($opts,%args) = @_;
 303     test_cmd($opts,%args,cmd=>"$$opts{path}/test-vcf-sweep $$opts{tmp}/test-vcf-api.bcf");
 304 }
 305
 306 sub test_vcf_various
 307 {
 308     my ($opts, %args) = @_;
 309
 310     # Excess spaces in header lines
 311     test_cmd($opts, %args, out => "test-vcf-hdr.out",
 312         cmd => "$$opts{bin}/htsfile -ch $$opts{path}/test-vcf-hdr-in.vcf");
 313
 314     # Various VCF parsing issues
 315     test_cmd($opts, %args, out => "formatcols.vcf",
 316         cmd => "$$opts{bin}/htsfile -c $$opts{path}/formatcols.vcf");
 317     test_cmd($opts, %args, out => "noroundtrip-out.vcf",
 318         cmd => "$$opts{bin}/htsfile -c $$opts{path}/noroundtrip.vcf");
 319     test_cmd($opts, %args, out => "formatmissing-out.vcf",
 320         cmd => "$$opts{bin}/htsfile -c $$opts{path}/formatmissing.vcf");
 321 }
 322
 323 sub test_rebgzip
 324 {
 325     my ($opts, %args) = @_;
 326
 327     test_cmd($opts, %args, out => "bgziptest.txt.gz",
 328         cmd => "$$opts{bin}/bgzip -I $$opts{path}/bgziptest.txt.gz.gzi -c -g $$opts{path}/bgziptest.txt");
 329 }
 330
 331 sub test_convert_padded_header
 332 {
 333     my ($opts, %args) = @_;
 334
 335     $args{out} = "headernul.tmp.cram";
 336     cmd("$$opts{path}/test_view -t ce.fa -C ce#1.sam > $args{out}");
 337
 338     foreach my $nuls (0, 1, 678) {
 339         my $nulsbam = "$$opts{tmp}/headernul$nuls.bam";
 340         cmd("$$opts{path}/test_view -b -Z $nuls ce#1.sam > $nulsbam");
 341         test_cmd($opts, %args,
 342             cmd => "$$opts{path}/test_view -t ce.fa -C $nulsbam");
 343     }
 344 }
 345
 346 sub test_bcf_sr_sort
 347 {
 348     my ($opts, %args) = @_;
 349     for (my $i=0; $i<10; $i++)
 350     {
 351         my $seed = int(rand(time));
 352         my $test = 'test-bcf-sr';
 353         my $cmd  = "$$opts{path}/test-bcf-sr.pl -t $$opts{tmp} -s $seed";
 354         print "$test:\n";
 355         print "\t$cmd\n";
 356         my ($ret,$out) = _cmd($cmd);
 357         if ( $ret ) { failed($opts,$test); }
 358         else { passed($opts,$test); }
 359     }
 360 }
 361
 362 sub test_logging
 363 {
 364   my ($opts) = @_;
 365   my $test = 'test-logging';
 366   my $cmd  = "$$opts{path}/test-logging.pl";
 367   print "$test:\n";
 368   print "\t$cmd\n";
 369   my ($ret,$out) = _cmd($cmd);
 370   if ( $ret ) { failed($opts,$test); }
 371   else { passed($opts,$test); }
 372 }