#!/usr/bin/perl -w
#
# improve - Run Rasqal test suites
#
# USAGE: improve [options] [DIRECTORY [TESTSUITE]]
#
# Copyright (C) 2009, David Beckett http://www.dajobe.org/
#
# This package is Free Software and part of Redland http://librdf.org/
#
# It is licensed under the following three licenses as alternatives:
#   1. GNU Lesser General Public License (LGPL) V2.1 or any newer version
#   2. GNU General Public License (GPL) V2 or any newer version
#   3. Apache License, V2.0 or any newer version
#
# You may not use this file except in compliance with at least one of
# the above three licenses.
#
# See LICENSE.html or LICENSE.txt at the top of this package for the
# complete terms and further detail along with the license texts for
# the licenses in COPYING.LIB, COPYING and LICENSE-2.0.txt respectively.
#
# REQUIRES:
#   'rapper' from raptor in the PATH (or where envariable RAPPER is)
#   GNU 'make' in the PATH (or where envariable MAKE is)
#


use strict;
use File::Basename;
use Getopt::Long;
use Pod::Usage;
use Cwd 'abs_path';

our $RAPPER=$ENV{RAPPER} || 'rapper';
our $MAKE=$ENV{MAKE} || 'make';
our $INDENT='  ';
our $mf='http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#';
our $rdf='http://www.w3.org/1999/02/22-rdf-syntax-ns#';
our $rdfs='http://www.w3.org/2000/01/rdf-schema#';
our $t='http://ns.librdf.org/2009/test-manifest#';

our $linewrap=78;

our $banner_width=$linewrap-10;

our $program=basename $0;
our $debug=0;

our(@counters)=qw( passed failed  skipped  xfailed uxpassed );


sub get_testsuites($) {
  my $dir=shift;

  my $cmd="cd $dir && $MAKE >/dev/null 2>&1";
  print STDERR "$program: Running $cmd\n"
    if $debug > 1;
  system $cmd;

  $cmd="cd $dir && $MAKE get-testsuites-list 2>/dev/null | grep -v 'ing directory' | tail -1";
  print STDERR "$program: Running $cmd\n"
    if $debug > 1;
  my $raw=`$cmd`;
  return split(/\s+/,$raw);
}


sub decode_literal ($) {
  my $lit=shift;
  $lit =~ s/^\"(.*)\"$/$1/;
  $lit =~ s/\\"/"/g;
  return $lit;
}


sub read_plan($$) {
  my($testsuite, $plan_file)=@_;

  my $dir = $testsuite->{dir};

  my(%triples);
  my $manifest_node;
  my $entries_node;

  my $rapper_error='rapper.err';
  my $cmd="$RAPPER -q -i turtle -o ntriples $plan_file 2> $rapper_error";
  print STDERR "$program: Running pipe from $cmd\n"
    if $debug > 1;
  open(MF, "$cmd |") 
    or die "Cannot open pipe from '$cmd' - $!\n";
  while(<MF>) {
    chomp;
    s/\s+\.$//;
    my($s,$p,$o)=split(/ /,$_,3);
    die "no p in '$_'\n" unless defined $p;
    die "no o in '$_'\n" unless defined $o;
    push(@{$triples{$s}->{$p}}, $o);
    $manifest_node=$s if $p eq "<${rdf}type>" && $o eq "<${mf}Manifest>";
    $entries_node=$o if $p eq "<${mf}entries>";
  }
  close(MF);
  if(!-z $rapper_error) {
    my $status = {status => 'fail', details => `cat $rapper_error` };
    unlink $rapper_error;
    return $status;
  }
  unlink $rapper_error;


  warn "Manifest node is '$manifest_node'\n"
    if $debug > 1;
  if($manifest_node) {
    my $desc=$triples{$manifest_node}->{"<${rdfs}comment>"}->[0];
    if($desc) {
      $testsuite->{desc}=decode_literal($desc);
    }
    my $path=$triples{$manifest_node}->{"<${t}path>"}->[0];
    if($path) {
      $testsuite->{path}=decode_literal($path);
    }
  }

  warn "Entries node is '$entries_node'\n"
    if $debug > 1;

  my $list_node=$entries_node;

  my(@tests);
  while($list_node) {
    warn "List node is '$list_node'\n"
      if $debug > 2;

    my $entry_node=$triples{$list_node}->{"<${rdf}first>"}->[0];
    warn "Entry node is '$entry_node'\n"
      if $debug > 2;

    my $name=$triples{$entry_node}->{"<${mf}name>"}->[0] | '';
    $name = decode_literal($name);
    warn "Entry name=$name\n"
      if $debug > 1;

    my $comment=$triples{$entry_node}->{"<${rdfs}comment>"}->[0] || '';
    $comment = decode_literal($comment);
    warn "Entry comment=$comment\n"
      if $debug > 1;

    my $action=$triples{$entry_node}->{"<${mf}action>"}->[0] || '';
    $action = decode_literal($action);
    warn "Entry action $action\n"
       if $debug > 1;

    my $entry_type=$triples{$entry_node}->{"<${rdf}type>"}->[0] || '';
    warn "Entry type is ".($entry_type ? $entry_type : "NONE")."\n"
      if $debug > 1;

    my $expect_fail=0;
    my $execute=1;

    $expect_fail=1 if
      $entry_type eq "<${t}NegativeTest>" ||
      $entry_type eq "<${t}XFailTest>";

    my $test_uri=$entry_node; $test_uri =~ s/^<(.+)>$/$1/;
    warn "Test uri $test_uri\n"
       if $debug > 1;

    push(@tests, {name => $name,
		  comment => $comment,
		  dir => $dir,
		  expect_fail => $expect_fail,
		  test_uri => $test_uri,
		  action => $action
	   } );

  next_list_node:
    $list_node=$triples{$list_node}->{"<${rdf}rest>"}->[0];
    last if $list_node eq "<${rdf}nil>";
  }

  $testsuite->{tests}=\@tests;

  return {status => 'pass', details => ''};
}


sub run_test($$) {
  my($testsuite,$test)=@_;
  my $name=$test->{name};
  my $action=$test->{action};

  $test->{status}= 'fail';
  $test->{detail}= '';
  $test->{log}= '';

  my $path=$testsuite->{path} ? "PATH=$testsuite->{path} " : "";

  print STDERR "$program: Running test $name: $path$action\n"
    if $debug > 1;

  my $sname=$name; $sname =~ s/\W/-/g;
  my $log="$sname.log";
  system "$action > '$log' 2>&1";
  my $rc=$?;
  my $status='fail';

  if($rc == -1) {
    # exec() failed
    $test->{detail}="failed to execute $action: $!";
    $status='fail';
  } elsif($rc & 127) {
    # exec()ed but died on a signal
    my($signal,$coredump_p);
    ($signal,$coredump_p)=(($rc & 127),  ($rc & 128));
    $test->{detail}=sprintf("$path$action died with signal $signal, %s coredump". $coredump_p ? 'with' : 'without');
    open(LOG, '<', $log);
    $test->{log}=join('', <LOG>);
    close(LOG);
    $status='fail';
    if($signal == 2) { # SIGINT
      $testsuite->{abort}=1;
    }
  } elsif($rc) {
    # exec()ed and exited with non-0
    $rc >>= 8;
    $test->{detail}="$path$action exited with code $rc";
    if(open(LOG, '<', $log)) {
      $test->{log}=join('', <LOG>);
      close(LOG);
    } else {
      $test->{log}='';
    }
    $status='fail';
  } else {
    # exec()ed and exit 0
    $status='pass';
  }
  unlink $log;

  if($test->{expect_fail}) {
    if($status eq 'fail') {
      $status='xfail' ;
      $test->{detail}="Test failed as expected"
    } else {
      $status='uxpass';
      $test->{detail}="Test passed but expected to fail"
    }
  }

  $test->{status}=$status;

  return $status;
}


sub prepare_testsuite($) {
  my($testsuite)=@_;
  my $dir = $testsuite->{dir};
  my $name = $testsuite->{name};

  my $plan_file=$name."-plan.ttl";
  $testsuite->{plan}=$plan_file;
  unlink $plan_file;
  if(!-r $plan_file) {
    system("$MAKE >/dev/null 2>&1");
    my $cmd="$MAKE get-testsuite-$name 2>/dev/null | grep -v 'ing directory' | sed -n -e '/\@prefix/,\$p' > $plan_file";
    print STDERR "$program: Running $cmd\n"
      if $debug > 1;
    system $cmd;
    my $rc=$?;
    return { status => 'fail',
	     details => "Running '$cmd' failed with status $rc"
	   }
      if $rc;
  }
  return { status => 'fail',
	   details => "No testsuite plan file $plan_file could be created in $dir"
         }
    unless -r $plan_file && !-z $plan_file;

  my $result=read_plan($testsuite, $plan_file);

  if($testsuite->{path}) {
    $ENV{PATH}=$testsuite->{path};
  }
  return $result;
}


sub run_testsuite($) {
  my($testsuite)=@_;
  my $dir = $testsuite->{dir};
  my $name = $testsuite->{name};
  my $indent = $testsuite->{indent};
  my $verbose = $testsuite->{verbose};

  my(@tests)=@{$testsuite->{tests}};

  my $desc=$testsuite->{desc} || $name;
  print $indent."Running testsuite $name: $desc\n";

  my $ntests=scalar @tests;

  my(@passed);
  my(@failed);
  my(@xfailed); # Expected failure
  my(@skipped);
  my(@uxpassed); # Unexpected pass

  my $expected_failures_count = 0;
  print $indent unless $verbose;

  my $result=0;
  my $column=length($indent);
  for my $test (@tests) {
    $test->{testsuite}=$name;
    if($testsuite->{dryrun}) {
      $test->{status} = 'skip';
      $test->{detail} = '';
    } else {
      run_test($testsuite,$test);
    }

    $expected_failures_count++ if $test->{expect_fail};

    my $rc=$test->{status};

    if($rc eq 'fail') {
      print "F" unless $verbose;
      push(@failed, $test);
    } elsif($rc eq 'xfail') {
      print "*" unless $verbose;
      push(@xfailed, $test);
    } elsif($rc eq 'uxpass') {
      print "!" unless $verbose;
      push(@uxpassed, $test);
    } elsif($rc eq 'skip') {
      print "-" unless $verbose;
      push(@skipped, $test);
    } else {
      print "." unless $verbose;
      push(@passed, $test);
    }
    $column++;
    if(!$verbose && $column > $linewrap) {
      print "\n$indent";
      $column=$indent;
    }

    if($verbose) {
      my $rcv = $rc; $rcv = uc $rc if $rc ne 'pass';
      my $i = $indent . $INDENT;
      printf "${i}$test->{name}: $rcv%s\n",
	     (length($test->{detail}) ? " - ".$test->{detail} : '');
      if($verbose > 1) {
	if($rc eq 'fail' && $test->{log}) {
	  my(@lines)=split(/\n/, $test->{log});
	  print $i."  ".join("\n${i}  ", @lines)."\n";
	}
      }
    }

    if($testsuite->{abort}) {
      print "aborted";
      last;
    }
  }
  print "\n" unless $verbose;

  my $plan_file= $testsuite->{plan};
  unlink $plan_file;

  my $status = ((scalar(@xfailed) == $expected_failures_count) && !@failed) ?
      'pass' : 'fail';

  return {
    passed => \@passed,
    failed => \@failed,
    xfailed => \@xfailed,
    skipped => \@skipped,
    uxpassed => \@uxpassed,
    status => $status
  };
}


sub format_testsuite_result($$$;$) {
  my($fh,$result,$indent,$verbose)=@_;
  $verbose ||= 0;

  if(ref($result->{failed})) {
    my(@failed)=@{$result->{failed}};
    if(@failed) {
      print $fh $indent."Failed tests:\n";
      for my $ftest (@failed) {
	my $i=$indent.$INDENT;
	print $i . "=" x $banner_width . "\n" if $verbose;
	printf $i . "$ftest->{name}%s\n",
          ($verbose ? " in suite $ftest->{testsuite} in $ftest->{dir}" : "");

	print $i . $ftest->{detail} . "\n" if $verbose && $ftest->{detail};
	if($ftest->{log} && $verbose) {
	  my $i2=$i.$INDENT;
	  my(@lines)=split(/\n/, $ftest->{log});
	  @lines = splice(@lines, -15) if scalar(@lines) > 15;
	  print $i2.join("\n${i2}", "...", @lines)."\n";
	}
	print $i . "=" x $banner_width . "\n" if $verbose;
      }
    }
  }

  if(ref($result->{uxpassed})) {
    my(@uxpassed)=@{$result->{uxpassed}};
    print $fh $indent."Unexpected passed tests:\n" . $indent . $INDENT .
      join("\n".$indent.$INDENT,
	   map { $_->{name}. ($debug ? " (".$_->{test_uri}.")" : "") }
	         @uxpassed) .
      "\n"
      if @uxpassed;
  }

  print $fh $indent;
  for my $counter (@counters) {
    my $count=ref($result->{$counter}) ? (scalar(@{$result->{$counter}}) || 0) : $result->{$counter};
    print $fh ucfirst($counter).": ".$count."  ";
  }
  print $fh "\n";

}


sub run_testsuites_in_dir($) {
  my($config)=@_;
  my $dir=$config->{dir};
  my(@testsuites)=@{$config->{testsuites}};
  my $verbose=$config->{verbose};
  my $dryrun=$config->{dryrun};
  my $indent=$config->{indent};

  chdir($dir) or die "$program: Directory $dir not found\n";
  
  my(@known_testsuites)=get_testsuites('.');
  if(!@known_testsuites) {
    warn "$program: Could not find any testsuites in $dir\n";
    return { status => 'fail', details => 'No testsuites found'};
  }
  
  my(%is_known_testsuite)=map { $_ => 1} @known_testsuites;
  
  if(!@testsuites) {
    @testsuites = @known_testsuites;
  } else {
    my(@t)=grep($is_known_testsuite{$_}, @testsuites);
    if(!@t) {
      return { status => 'skip',
	       details => 'No known testsuites given in: @testsuites'};
    }
    @testsuites=@t;
  }

  print "$indent$program: Running testsuites @testsuites in $dir\n";
  $indent.=$INDENT;

  my $total_result = {  };
  my $total_status='pass';

  for my $testsuite_name (@testsuites) {
    my $testsuite = {dir => $dir,
		     name => $testsuite_name,
		     verbose => $verbose,
		     indent => $indent.$INDENT,
		     dryrun => $dryrun
    };

    my $result=prepare_testsuite($testsuite);
    if($result->{status} eq 'fail') {
      my $details=$result->{details};
      print "$indent$program: Suite $testsuite->{name} failed preparation - $details\n";
      $total_status='fail';
      next;
    }

    $result=run_testsuite($testsuite);

    format_testsuite_result(*STDOUT, $result, $indent.$INDENT, $verbose);

    for my $counter (@counters) {
      push(@{$total_result->{$counter}}, @{$result->{$counter}});
    }

    $total_status='fail' if $result->{status} eq 'fail';

    print "\n" if @testsuites > 1;
  }

  $total_result->{status} = $total_status;

  printf $indent."Testsuites summary%s:\n", ($verbose ? " for dir $dir" : '');
  format_testsuite_result(*STDOUT, $total_result, $indent.$INDENT, $verbose);

  printf $indent."Result status: $total_status\n" if $verbose;

  return $total_result;
}

######################################################################

$debug=1 if defined $ENV{'RASQAL_DEBUG'};

my $dryrun=0;
my $usage=0;
my $verbose=0;
my $recursive=0;

# Argument handling
GetOptions(
  'debug|d+'   => \$debug, # incremental
  'dryrun|n'   => \$dryrun,
  'recursive|r'   => \$recursive,
  'verbose|v+' => \$verbose, # incremental
  'help|h|?'   => \$usage
) || pod2usage(2);

pod2usage(-verbose => 2) if $usage;
pod2usage("$program: Too many arguments.\n") if (@ARGV > 2);

my($dir,@testsuites)=@ARGV;

$dir ||= '.';

$verbose++ if $debug;

$dir = abs_path($dir);

my(@dirs);
if($recursive) {
  my $cmd="find . -type d -print | grep -v \.svn";
  warn "$program: Recursive scan for testsuites\n" 
     if $verbose;
  open(PIPE, "$cmd|") or die "$program: Cannot open pipe from '$cmd' - $!\n";
  while(<PIPE>) {
    chomp;
    my $dir=abs_path($_);
    my(@testsuites)=get_testsuites($dir);
    if(@testsuites) {
      warn "  $_: @testsuites\n" 
        if $verbose;
      push(@dirs, $dir)
    }
  }
  close(PIPE);
} else {
  push(@dirs, abs_path($dir));
}


warn "$program: Running testsuites in dirs: @dirs\n"
  if $debug;

my $total_result = {  };

my $rc = 0;
for my $dir (@dirs) {
  my(%config)=(
    dir => $dir,
    testsuites => \@testsuites,
    verbose => $verbose,
    dryrun => $dryrun,
    indent => '',
  );

  my $result=run_testsuites_in_dir(\%config);

  for my $counter (@counters) {
    my $r = $result->{$counter};
    push(@{$total_result->{$counter}}, @$r)
      if $r;
  }

  $rc=1 if $result->{status} eq 'fail';
}

if($recursive) {
  print "\nTotal of all Testsuites\n";
  format_testsuite_result(*STDOUT, $total_result, $INDENT, 1);
}

exit $rc;


__END__

=head1 NAME

improve - run Rasqal testsuites

=head1 SYNOPSIS

improve [options] [DIR [TESTSUITES]]

=head1 OPTIONS

=over 8

=item B<-d>, B<--debug>

Enable extra debugging output.

=item B<-n>, B<--dryrun>

Do not run tests.

=item B<-r>, B<--recursive>

Run all testsuites below the given I<DIR>

=item B<-h>, B<--help>

Give help summary.

=item B<-v>, B<--verbose>

Enable extra verbosity when running tests.

=back

=head1 DESCRIPTION

Run Rasqal testsuites from a Turtle manifest in the I<DIR>.  If
I<TESTSUITES> are not given, provides a list of known testsuites in
I<DIR>.  I<DIR> defaults to '.' if not given.

=cut
