#!/usr/bin/perl -w
use strict;
use warnings;

use Test::More;

use MIME::Tools;
use File::Path;
use File::Spec;
use File::Basename;
use MIME::WordDecoder qw(unmime);

use lib qw( ./t/ );
use Globby;

use MIME::Parser;

#print STDERR "\n";

### Verify directory paths:
(-d "testout") or die "missing testout directory\n";
my $output_dir = File::Spec->catdir(".", "testout", "Ref_t");

### Get messages to process:
my @refpaths = @ARGV;
if (!@refpaths) { 
    opendir DIR, "testmsgs" or die "opendir: $!\n";
    @refpaths = map { File::Spec->catfile(".", "testmsgs", $_) 
		      } grep /\w.*\.ref$/, readdir(DIR);
    closedir DIR; 
}

plan( tests => 2 * scalar(@refpaths) );

### For each reference:
foreach my $refpath (@refpaths) {

    ### Get message:
    my $msgpath = $refpath; $msgpath =~ s/\.ref$/.msg/;
#   print STDERR "   $msgpath\n";

    ### HACK HACK HACK: MailTools behaviour has changed!!!
    if ($msgpath =~ /hdr-fakeout.msg$/ &&
	$::Mail::Header::VERSION > 2.14) {
	    $refpath = 'testmsgs/hdr-fakeout-newmailtools-ref';
    }
    ### Get reference, as ref to array:
    my $ref = read_ref($refpath);
    if ($ref->{Parser}{Message}) {
	$msgpath = File::Spec->catfile(".", (split /\//, $ref->{Parser}{Message}));
    }
    # diag("Trying $refpath [$msgpath]\n");

    ### Create parser which outputs to testout/scratch:
    my $parser = MIME::Parser->new;
    $parser->output_dir($output_dir);
    $parser->extract_nested_messages($ref->{Parser}{ExtractNested});
    $parser->extract_uuencode($ref->{Parser}{ExtractUuencode});
    $parser->output_to_core(0);
    $parser->ignore_errors(0);

    ### Set character set:
    my $tgt = $ref->{Parser}{Charset} || 'ISO-8859-1';
    my $wd;
    if ($tgt =~ /^ISO-8859-(\d+)/) {
	$wd = new MIME::WordDecoder::ISO_8859 $1;
    }
    else {
	$wd = new MIME::WordDecoder([uc($tgt)   => 'KEEP',
				     'US-ASCII' => 'KEEP',
      				     '*'        => 'WARN']);
    }
    # diag("Default charset: $tgt");
    MIME::WordDecoder->default($wd);
	
    ### Pre-clean:    
    rmtree($output_dir);
    (-d $output_dir) or mkpath($output_dir) or die "mkpath $output_dir: $!\n";

    ### Parse:
    my $ent = eval { $parser->parse_open($msgpath) };
    my $parse_error = $@;

    ### Output parse log:
#    diag("PARSE LOG FOR $refpath [$msgpath]");
    if ($parser->results) {
#	diag($parser->results->msgs);
    }
    else {
	diag("Parse failed before results object was created");
    }

    ### Interpret results:
    if ($parse_error || !$ent) {
	ok($ref->{Msg}{Fail}, "$refpath, problem: $parse_error" );
    }
    else {
	# TODO: check_ref is evil
	my $ok = eval { check_ref($msgpath, $ent, $ref) };
	if( $@ ) {
		diag("Eval failed: $@");
	}
	ok($ok, "$refpath Message => $msgpath, Parser => " . ($ref->{Parser}{Name} || 'default'));
    }

    ### Is purge working?
    my @a_files = list_dir($output_dir);
    my @p_files = $parser->filer->purgeable;
    $parser->filer->purge;
    my @z_files = list_dir($output_dir);
    is(@z_files, 0, 'Did purge work?');
	
    ### Cleanup for real:
    rmtree($output_dir);
}

### Done!
exit(0);
1;

#------------------------------

sub list_dir {
    my $dir = shift;
    opendir DIR, $dir or die "opendir $dir; $!\n";
    my @files = grep !/^\.+$/, readdir DIR;
    closedir DIR;
    return sort @files;
}

#------------------------------

sub read_ref {
    my $path = shift;
    open IN, "<$path" or die "open $path: $!\n";
    my $expr = join('', <IN>);
    close IN;
    my $ref = eval $expr; $@ and die "syntax error in $path\n";
    $ref;
}

#------------------------------

sub trim {
    local $_ = shift;
    s/^\s*//;
    s/\s*$//;
    $_;
}

#------------------------------
# TODO: replace with cmp_deeply from Test::Deep?
sub check_ref {
    my ($msgpath, $ent, $ref) = @_;

    my $wd = supported MIME::WordDecoder 'UTF-8';
    ### For each Msg in the ref:
  MSG:
    foreach my $partname (sort keys %$ref) {
	$partname =~ /^(Msg|Part_)/ or next;
	my $msg_ref = $ref->{$partname};
	my $part    = get_part($ent, $partname) || 
	    die "no such part: $partname\n";
	my $head    = $part->head; $head->unfold;
	my $body    = $part->bodyhandle;

	### For each attribute in the Msg:
      ATTR:
	foreach (sort keys %$msg_ref) {

	    my $want = $msg_ref->{$_};
	    my $got = undef;

	    if    (/^Boundary$/) { 
		$got = $head->multipart_boundary;
	    }
	    elsif (/^From$/)     { 
		$got  = trim($head->get("From", 0)); 
		$want = trim($want); 
	    }
	    elsif (/^To$/)       { 
		$got  = trim($head->get("To", 0)); 
		$want = trim($want); 
	    }
	    elsif (/^Subject$/)  { 
		$got  = trim($head->get("Subject", 0));
		$want = trim($want); 
	    }
	    elsif (/^Charset$/)  { 
		$got = $head->mime_attr("content-type.charset"); 
	    }
	    elsif (/^Disposition$/) { 
		$got = $head->mime_attr("content-disposition"); 
	    }
	    elsif (/^Type$/)     {
		$got = $head->mime_type;
	    }
	    elsif (/^Encoding$/) {
		$got = $head->mime_encoding;
	    }
	    elsif (/^Filename$/) {
		$got = $head->recommended_filename; 
	    }
	    elsif (/^BodyFilename$/) {
		$got = (($body and $body->path) 
			? basename($body->path) 
			: undef);
	    }
	    elsif (/^Preamble$/) {
		$got = join('', @{$part->preamble});
	    }
	    elsif (/^Epilogue$/) {
		$got = join('', @{$part->epilogue});
	    }
	    elsif (/^Size$/)     { 
		if ($head->mime_type =~ m{^(text|message)}) {
#		    diag("Skipping Size evaluation in text message ".
#			    "due to variations in local newline ".
#			    "conventions\n\n");
		    next ATTR;
		}
		if ($body and $body->path) { $got = (-s $body->path) }
	    }
	    else {
		die "$partname: unrecognized reference attribute: $_\n";
	    }

	    ### Log this sub-test:
#	    diag("SUB-TEST: msg=$msgpath; part=$partname; attr=$_:\n");
#	    diag("  want: ".encode($want)."\n");
#	    diag("  got:  ".encode($got )."\n");
#	    diag("\n");

	    next ATTR if (!defined($want) and !defined($got));
	    next ATTR if ($want eq $got);
	    die "$partname: wanted qq{$want}, got qq{$got}\n";
	}
    }

    1;
}

# Encode a string
sub encode {
	local $_ = shift;
	return '<undef>' if !defined($_);

	s{([\n\t\x00-\x1F\x7F-\xFF\\\"])}
         {'\\'.sprintf("%02X",ord($1)) }exg;
        s{\\0A}{\\n}g;
	return qq{"$_"};
}

#------------------------------

sub get_part {
    my ($ent, $name) = @_;

    if ($name eq 'Msg') {
	return $ent;
    }
    elsif ($name =~ /^Part_(.*)$/) {
	my @path = split /_/, $1;
	my $part = $ent;
	while (@path) {
	    my $i = shift @path;
	    $part = $part->parts($i - 1);
	}
	return $part;
    }
    undef;   
}

1;