#!/usr/bin/perl

use 5.006;
use strict;
use warnings;
use Carp;

use POSIX 'setsid';
use Net::Server;
use vars qw(@ISA $VERSION);

@ISA = qw(Net::Server);
$VERSION = '0.0.1';

use Net::Telnet;
use IPC::Run qw(start finish run pump);

use AppConfig qw/:argcount :expand/;

use Digest::MD5 qw(md5);

use File::Temp qw/tempfile/;

my $config = AppConfig->new(
                            "host|h=s" => {DEFAULT => "localhost"},
                            "port|p=s" => {DEFAULT => 8999},
                            "parser=s" => {DEFAULT => "frmgtel"},
                            "rparser=s" => {DEFAULT => "frmgtelr"},
                            "test|t=s" => {DEFAULT => "sentences.txt"},
			    "display|d=s" => {DEFAULT => ''},
			    "verbose|v!" => {DEFAULT => 1},
			    "range|r=s@" => {DEFAULT => []},
			    "stats|s!" => {DEFAULT => 0},
			    "forest!" => {DEFAULT => 0},
			    "grammar!" => {DEFAULT => 0},
			    "tagger!" => {DEFAULT => 0},
			    "xmldep!" => {DEFAULT => 0},
			    "lpdep!" => {DEFAULT => 0},
			    "easy!" => {DEFAULT => 0},
			    "easyhtml!" => {DEFAULT => 0},
			    "sigfile=s" => {DEFAULT => ".signatures"},
			    "errfile=s" => {DEFAULT => "errors"},
			    "setsid!" => { DEFAULT => 0 },
			    "log_file=f" =>  {DEFAULT => '/tmp/testparser.log'},
			    "status!" => {DEFAULT => 0},
			    "time!" => {DEFAULT => 0},
			    "robust!" => {DEFAULT => 0},
			    "easyinput" => {DEFAULT => 0},
			    "colldir=f" => {DEFAULT => "./easy_results"}
                           );

my %display = (dep => 'dependency', tree => 'tree' );

$config->args();

my $host = $config->host;
my $port = $config->port;
my $parser = $config->parser;
my $rparser = $config->rparser;
my $test = $config->test;
my $display = get_display($config->display);
my $verbose = $config->verbose;
my @ranges = map(range_expand($_),@{$config->range});
my %range = (map {$_ => 1} @ranges);
my $errfile = $config->errfile();

my $section = "s0";

my %stats = 
  ( tried => 0,
    skipped => 0,
    failed => 0,
    time => 0,
    clusters => 0,
    nodes => 0,
    edges => 0
  );

my %errors = ();

my %Kid_Status = ();

use POSIX ":sys_wait_h";
sub REAPER {
  my $child;
  # If a second child dies while in the signal handler caused by the
  # first death, we won't get another signal. So must loop here else
  # we will leave the unreaped child as a zombie. And the next time
  # two children die we get another zombie. And so on.
  while (($child = waitpid(-1,WNOHANG)) > 0) {
    $Kid_Status{$child} = $?;
  }
  $SIG{CHLD} = \&REAPER;  # still loathe sysV
}
# $SIG{CHLD} = \&REAPER;

$SIG{INT} = sub {
  exit;				# to go trough END block
};

STDOUT->autoflush;

## reading error files
if (-r $errfile) {
  open(ERRFILE,"<$errfile") || die "can't open $errfile: $!";
  while(<ERRFILE>) {
    $errors{$_} = 1;
  }
  close(ERRFILE);
}

my %handlers = 
  ( display => \&display_handler,
    tagger => canonical_display_hander('tagger','TAGGER'),
    forest => canonical_display_hander('xml','FOREST'),
    xmldep => canonical_display_hander('xmldep','XMLDEP'),
    lpdep => canonical_display_hander('lpdep','LPDEP'),
    stats => \&stats_handler,
    easy => canonical_display_hander('easy','EASY'),
    grammar => \&grammar_handler,
    easyhtml => \&easyhtml_handler
  );

## setting output handlers
my @handlers = ();

foreach my $key (sort keys %handlers) {
  push(@handlers,$handlers{$key}) if ($config->get($key));
}

## Starting connection
my $connect = new Net::Telnet;
$connect->max_buffer_length(3*$connect->max_buffer_length);

start_connection();

sub start_connection {
  $connect->open(Host => $host,
		 Port=>$port) || die "can't connect: $!";
  $connect->prompt('/\s*Command\?\s*/');
  $connect->cmd("");
}

## Opening signature files if needed
my %signatures = ();
my $sigfile = $config->sigfile();

if ($config->stats() && -r $sigfile) {
  print "** Reading signature file $sigfile\n" if $verbose;
  open(SIG,"<$sigfile") || die "can't read $sigfile: $!";
  $signatures{$1} = $2 while (<SIG> =~ /^(\S+)\s+(\S+)/);
  close SIG || die "can't close $sigfile: $!";
}


## Setting status bar

my $report;
my $statusBar;

if ($config->status) {
  use Term::Report;

  $report = Term::Report->new( fh => \*STDERR
			     );
#  $statusBar = $report->{statusBar};
  $report->savePoint('total', "Total: ", 0);
  $report->savePoint('success', "\nSuccess: ", 0);
  $report->savePoint('failed', "\nFailed: ", 0);
}

## Reading sentences

if ($test eq '-') {
  open(SENTENCES,"<&",\*STDIN) || die "can't read on stdin";
} else {
  $test =~ s/^(.+\.xml)$/xsltproc easyinput2txt.xsl $1 |/;
  open(SENTENCES,"$test") || die "can open $test: $!";
}

my @sentences = ();
my $label;
my @failed = ();
my $collection;

while (<SENTENCES>){
  if (/^##\s*(\d+)(\..*)/) {
    print "\n## Section $1$2\n\n" if ($verbose);
    $section = "s$1";
    next;
  }
  if (/^##\s*E(\d+)$/) {
    $label = $1 - 1;
    next;
  }
  if (/^##\s*FICHIER=(\S+)/) {
    collection_start($1);
    next;
  }
  next if /^#/;
  next if /^\s*$/;
  my $status = 'YES';
  my $sentence = $_;
  $label++;
  chomp $sentence;
  if ($sentence =~ s/^>\s*//) {
    $status = 'SKIP';
  } elsif ($sentence =~ s/^\*\s*//) {
    $status = 'NO';
  }
  handle_sentence($label,$status,$sentence);
}

close(SENTENCES);

$connect->close;

sub final_stats {
  printf "\nStats: %3u tried %3u failed %3u skipped %3.2f%% coverage %.2fs avtime\n", 
    $stats{tried}, 
      $stats{failed}, 
	$stats{skipped},
	  100 * (1 - $stats{failed} / $stats{tried}),
	  $stats{time} / $stats{tried};

  if ($config->stats) {
    my $clusters = $stats{clusters};
    $clusters ||= 1;
    printf "Stats:  %1.1f ambiguity\n",
      ($stats{edges} - $clusters) / $clusters;
  }

  if (@failed) {
    my $failed = @failed;
    print <<EOF;

*** $failed tests failed !
EOF
} else {
  print <<EOF;

All tests successul !
EOF

}
}

END {
  closing();
  final_stats();
}

sub closing {

  collection_stop();

  if ($config->stats()) {
    ## Saving signatures
    print "** Saving signature file $sigfile\n" if $verbose;
    rename($sigfile,"$sigfile.bak") if (-r $sigfile);
    open(SIG,">$sigfile") || die "can't open $sigfile: $!";
    foreach my $sigs (keys %signatures) {
      print SIG "$sigs\t$signatures{$sigs}\n";
    }
    close SIG || die "can't close $sigfile: $!";
  }

  open(ERRORS,">$errfile") || die "can't open $errfile: $!";
  foreach my $sentence (sort keys %errors) {
    print ERRORS "$sentence\n";
  }
  close ERRORS;
}

sub handle_sentence {
  my ($label,$status,$sentence) = @_;
  return if (@ranges && !$range{$label} && !$range{"$section"});
  my $short = $sentence;
  $short = substr($short,0,60).' ...' if (length($short) > 60);
  if ($status eq 'SKIP') {
    $stats{skipped}++;
    print <<EOF  if $verbose;
ok $label\t> $short
EOF
    return;
  }
  $stats{tried}++;
  $connect->cmd("set forest yesno");
##  print "GO $sentence\n";
  my @lines =   $connect->cmd( String => "$label $parser $sentence",
			       Timeout => undef,
			       Errmode => \&handle_parsing_error	      
			     );
  ##  print "HERE @lines\n";
  my $mark = ($status eq 'YES') ? ' ' : '*';
  pop @lines;
  my $answer = ($lines[0] =~ /Success/) ? 'YES' :  'NO';
  if ($answer eq $status) {
    print <<EOF if ($verbose) ;
ok $label\t$mark $short
EOF
  } else {
    $stats{failed}++;
    push(@failed,{label=>$label,status=>$status,sentence=>$sentence});
    print <<EOF ;
**********************************************
fail $label\t$mark $sentence
**********************************************
EOF
    handle_error($sentence,$status); 
  }
##  @lines = $connect->cmd("last time");
##  print @lines;
##  my ($time) = ($lines[0] =~ /^\s*last\s+time=(\S+)/);
##  pop @lines;
##  $stats{time} += $time;
  if ($config->time()) {
    my @lines = $connect->cmd( String => "last time",
			       Timeout => undef,
			       Errmode => \&handle_parsing_error
			     );
    pop @lines;
    my ($time) = ($lines[0] =~ /=(.+)/);
    print " <time> $time\n";
    $stats{time} += $time;
  }

  if ($answer eq 'NO' && $config->robust) {
    ## print "** try robust parsing\n";
    $connect->cmd("set forest yesno");
    ##  print "GO $sentence\n";
    my @lines =   $connect->cmd( String => "$label $rparser $sentence",
				 Timeout => undef,
				 Errmode => \&handle_parsing_error	      
			       );
    ##  print "HERE @lines\n";
    pop @lines;
    $answer = ($lines[0] =~ /Success/) ? 'YES' :  'NO';

    if ($config->time()) {
      my @lines = $connect->cmd( String => "last time",
				 Timeout => undef,
				 Errmode => \&handle_parsing_error
			       );
      pop @lines;
      my ($time) = ($lines[0] =~ /=(.+)/);
      print " <time2> $time\n";
      $stats{time} += $time;
    }
    
  }

  if ($answer eq 'YES') {
    my @processes = map($_->($sentence,$label),@handlers);
    $_->finish foreach (@processes);
  }

  if ($collection && $answer eq 'YES') {
    collection_handler($sentence,$label);
  }

  report_stats() if ($config->status);

}

sub get_display {
  my $display = shift;
  return $display{$display} || $display;
}

sub range_expand {
 my $r = shift;
 my @r = split(',',$r);
 my @rr = ();
 foreach my $x (@r) {
   if ($x =~ /(\d+)\.\.(\d+)/) {
     push(@rr,$1..$2);
   } elsif ($x =~ /(s\d+)\.\.(s\d+)/) {
     push(@rr,$1..$2);
   } else {
     push(@rr,$x)
   }
 }
## print "RANGE @rr\n";
 return @rr;
}

## Recording error sentence
sub handle_error {
  my $sentence = shift;
  my $status = shift;
  $sentence = "* $sentence" if ($status eq 'NO');
  $errors{$sentence} = 1;
}

sub handle_parsing_error {
  my $msg = shift;
  print STDERR "Parsing error somewhere: $msg\n";
##  $connect->cmd("quit");
##  $connect->close;
  start_connection();
}

sub report_stats {
  $report->finePrint('total',0,$stats{tried});
  $report->finePrint('success',10,$stats{tried} - $stats{failed});
  $report->finePrint('failed',20,$stats{failed});
}

sub last_forest {
  my $type = shift;
  $connect->cmd("set forest $type");
  return $connect->cmd( String => "last forest",
			Timeout => undef,
			Errmode => \&handle_parsing_error	      
		      );
}

######################################################################
# all display handlers

sub canonical_display_hander {
  my ($type,$info) = @_;
  ## build and return a simple display handler
  sub {
    my @lines = last_forest($type);
    pop @lines;
    print "------------  START $info ---------\n";
    print @lines;
    print "------------  END $info ---------\n";
    return;
  }
}

## Specific handlers

sub stats_handler {
  my ($sentence) = @_;
  my @lines = last_forest('stats');
  my $sigs = md5($sentence);
  my $sigstats = md5($lines[0]);
  my $info = $lines[0];
  $info =~ s/^\s*Dependency stats:\s*//o;
  my ($clusters,$nodes,$edges) = (split(/\s+/,$info))[2,4,6];
  $stats{clusters} += $clusters;
  $stats{nodes} += $nodes;
  $stats{edges} += $edges;
  print " <ambiguity> $info";
  if (exists $signatures{$sigs} && $signatures{$sigs} ne $sigstats) {
    print <<EOF;
     *** signature mismatch !
EOF
  }
  $signatures{$sigs} = $sigstats;
  return;
}

sub display_handler {
  my @lines = last_forest($display);
  pop @lines;
  my $h = start ['recode','..u8'],
    '<pipe',\*DOT,,
      '|', ['dot','-Tgif',"-Glabel=test $label"],
	'|', ['display'],
	  '2>/dev/null'
	    or die "dot returned $?";
  print DOT @lines;
  close DOT;
  return $h;
}

sub grammar_handler {
  my @lines = last_forest('html');
  pop @lines;
  my ($fh,$filename) = tempfile( DIR => '/tmp/',
				 SUFFIX => '.html',
##				 UNLINK => 1,
			       );
  print $fh @lines;
  close $fh;
  my $h = start ['dillo',$filename],'>/dev/null','2>/dev/null';
##  run ['firefox','-remote',"openFile($filename,new-window)"],'>/dev/null','2>/dev/null';
  return $h;
}

sub easyhtml_handler {
  my @lines = last_forest('easy');
  pop @lines;
  my ($fh,$filename) = tempfile( DIR => '/tmp/',
				 SUFFIX => '.html',
##				 UNLINK => 1,
			       );
  close $fh;
  my $h = start 
    ['xsltproc','-o',$filename,'easy2html.xsl','-'],'<pipe',\*EASY,
      ,'&',
##	['konqueror',$filename],'>/dev/null','2>/dev/null';
	['dillo','-f','-l',$filename],'>/dev/null','2>/dev/null';
##	['firefox','-remote',"openFile($filename)"] ;
  print EASY @lines;
  close EASY;
  return $h;
}

sub collection_handler {
  my @lines = last_forest('easy');
  pop @lines;
  foreach (@lines) {
    next if (m{^<[/]?DOCUMENT});
    next if (m{<\?xml});
    print COLLECTION $_;
  }
}

sub collection_stop {
  if (defined $collection) {
    print COLLECTION "</DOCUMENT>\n";
    close COLLECTION || die "can't close $collection";
  }
}

sub collection_start {
  my $base = shift;
  ## close old collection (if open) and start new one;
  collection_stop;
  $collection = $config->colldir()."/$base.ph2.xml";
  open(COLLECTION,">$collection") || die "can't open $collection";
  autoflush COLLECTION;
  print COLLECTION <<EOF;
<?xml version="1.0"  encoding="latin1"?>
<DOCUMENT fichier="$base" xmlns:xlink="http://www.w3.org/1999/xlink">
EOF
}
