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

Uploaded
author youngkim
date Thu, 24 Mar 2016 17:12:52 -0400
parents
children
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/ezBAMQC/src/htslib/test/test.pl	Thu Mar 24 17:12:52 2016 -0400
@@ -0,0 +1,202 @@
+#!/usr/bin/env perl
+#
+#    Copyright (C) 2012-2013 Genome Research Ltd.
+#
+#    Author: Petr Danecek <pd3@sanger.ac.uk>
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to deal
+# in the Software without restriction, including without limitation the rights
+# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+# copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in
+# all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+# DEALINGS IN THE SOFTWARE.
+
+use strict;
+use warnings;
+use Carp;
+use FindBin;
+use lib "$FindBin::Bin";
+use Getopt::Long;
+use File::Temp qw/ tempfile tempdir /;
+
+my $opts = parse_params();
+
+test_vcf_api($opts,out=>'test-vcf-api.out');
+test_vcf_sweep($opts,out=>'test-vcf-sweep.out');
+
+print "\nNumber of tests:\n";
+printf "    total   .. %d\n", $$opts{nok}+$$opts{nfailed};
+printf "    passed  .. %d\n", $$opts{nok};
+printf "    failed  .. %d\n", $$opts{nfailed};
+print "\n";
+
+exit ($$opts{nfailed} > 0);
+
+#--------------------
+
+sub error
+{
+    my (@msg) = @_;
+    if ( scalar @msg ) { confess @msg; }
+    print
+        "About: samtools/htslib consistency test script\n",
+        "Usage: test.pl [OPTIONS]\n",
+        "Options:\n",
+        "   -r, --redo-outputs              Recreate expected output files.\n",
+        "   -t, --temp-dir <path>           When given, temporary files will not be removed.\n",
+        "   -h, -?, --help                  This help message.\n",
+        "\n";
+    exit 1;
+}
+sub parse_params
+{
+    my $opts = { keep_files=>0, nok=>0, nfailed=>0 };
+    my $help;
+    Getopt::Long::Configure('bundling');
+    my $ret = GetOptions (
+            't|temp-dir:s' => \$$opts{keep_files},
+            'r|redo-outputs' => \$$opts{redo_outputs},
+            'h|?|help' => \$help
+            );
+    if ( !$ret or $help ) { error(); }
+    $$opts{tmp} = $$opts{keep_files} ? $$opts{keep_files} : tempdir(CLEANUP=>1);
+    if ( $$opts{keep_files} ) { cmd("mkdir -p $$opts{keep_files}"); }
+    $$opts{path} = $FindBin::RealBin;
+    $$opts{bin}  = $FindBin::RealBin;
+    $$opts{bin}  =~ s{/test/?$}{};
+    return $opts;
+}
+sub _cmd
+{
+    my ($cmd) = @_;
+    my $kid_io;
+    my @out;
+    my $pid = open($kid_io, "-|");
+    if ( !defined $pid ) { error("Cannot fork: $!"); }
+    if ($pid)
+    {
+        # parent
+        @out = <$kid_io>;
+        close($kid_io);
+    }
+    else
+    {
+        # child
+        exec('/bin/bash', '-o','pipefail','-c', $cmd) or error("Cannot execute the command [/bin/sh -o pipefail -c $cmd]: $!");
+    }
+    return ($? >> 8, join('',@out));
+}
+sub cmd
+{
+    my ($cmd) = @_;
+    my ($ret,$out) = _cmd($cmd);
+    if ( $ret ) { error("The command failed [$ret]: $cmd\n", $out); }
+    return $out;
+}
+sub test_cmd
+{
+    my ($opts,%args) = @_;
+    if ( !exists($args{out}) )
+    {
+        if ( !exists($args{in}) ) { error("FIXME: expected out or in key\n"); }
+        $args{out} = "$args{in}.out";
+    }
+    my ($package, $filename, $line, $test)=caller(1);
+    $test =~ s/^.+:://;
+
+    print "$test:\n";
+    print "\t$args{cmd}\n";
+
+    my ($ret,$out) = _cmd("$args{cmd} 2>&1");
+    if ( $ret ) { failed($opts,$test); return; }
+    if ( $$opts{redo_outputs} && -e "$$opts{path}/$args{out}" )
+    {
+        rename("$$opts{path}/$args{out}","$$opts{path}/$args{out}.old");
+        open(my $fh,'>',"$$opts{path}/$args{out}") or error("$$opts{path}/$args{out}: $!");
+        print $fh $out;
+        close($fh);
+        my ($ret,$out) = _cmd("diff -q $$opts{path}/$args{out} $$opts{path}/$args{out}.old");
+        if ( !$ret && $out eq '' ) { unlink("$$opts{path}/$args{out}.old"); }
+        else
+        {
+            print "\tthe expected output changed, saving:\n";
+            print "\t  old .. $$opts{path}/$args{out}.old\n";
+            print "\t  new .. $$opts{path}/$args{out}\n";
+        }
+    }
+    my $exp = '';
+    if ( open(my $fh,'<',"$$opts{path}/$args{out}") )
+    {
+        my @exp = <$fh>;
+        $exp = join('',@exp);
+        close($fh);
+    }
+    elsif ( !$$opts{redo_outputs} ) { failed($opts,$test,"$$opts{path}/$args{out}: $!"); return; }
+
+    if ( $exp ne $out )
+    {
+        open(my $fh,'>',"$$opts{path}/$args{out}.new") or error("$$opts{path}/$args{out}.new");
+        print $fh $out;
+        close($fh);
+        if ( !-e "$$opts{path}/$args{out}" )
+        {
+            rename("$$opts{path}/$args{out}.new","$$opts{path}/$args{out}") or error("rename $$opts{path}/$args{out}.new $$opts{path}/$args{out}: $!");
+            print "\tthe file with expected output does not exist, creating new one:\n";
+            print "\t\t$$opts{path}/$args{out}\n";
+        }
+        else
+        {
+            failed($opts,$test,"The outputs differ:\n\t\t$$opts{path}/$args{out}\n\t\t$$opts{path}/$args{out}.new");
+        }
+        return;
+    }
+    passed($opts,$test);
+}
+sub failed
+{
+    my ($opts,$test,$reason) = @_;
+    $$opts{nfailed}++;
+    if ( defined $reason ) { print "\n\t$reason"; }
+    print "\n.. failed ...\n\n";
+}
+sub passed
+{
+    my ($opts,$test) = @_;
+    $$opts{nok}++;
+    print ".. ok\n\n";
+}
+sub is_file_newer
+{
+    my ($afile,$bfile) = @_;
+    my (@astat) = stat($afile) or return 0;
+    my (@bstat) = stat($bfile) or return 0;
+    if ( $astat[9]>$bstat[9] ) { return 1 }
+    return 0;
+}
+
+
+# The tests --------------------------
+
+sub test_vcf_api
+{
+    my ($opts,%args) = @_;
+    test_cmd($opts,%args,cmd=>"$$opts{path}/test-vcf-api $$opts{tmp}/test-vcf-api.bcf");
+}
+
+sub test_vcf_sweep
+{
+    my ($opts,%args) = @_;
+    test_cmd($opts,%args,cmd=>"$$opts{path}/test-vcf-sweep $$opts{tmp}/test-vcf-api.bcf");
+}
+