The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w

use strict;
use FileHandle;
use Test::More 0.88;
use Test::Reporter;
use Data::Dumper;

$Test::Reporter::VERSION ||= 999; # dzil will set it for us on release

my $distro = "Foo-Bar-1.23";
my $distfile = "AUTHOR/" . $distro . ".tar.gz";

my $reporter = Test::Reporter->new();
isa_ok($reporter, 'Test::Reporter');

$reporter->grade('pass');
$reporter->distribution('Mail-Freshmeat-1.20');
$reporter->distfile('ASPIERS/Mail-Freshmeat-1.20.tar.gz');
like($reporter->subject, '/^PASS Mail-Freshmeat-1.20\s/');
like($reporter->report, '/This distribution has been tested/');
like($reporter->report, '/Summary of my/');
is($reporter->grade, 'pass');
is($reporter->distribution, 'Mail-Freshmeat-1.20');
is($reporter->timeout, 120);

undef $reporter;

$reporter = Test::Reporter->new();
isa_ok($reporter, 'Test::Reporter');

$reporter->grade('fail');
$reporter->distribution('Foo-Bar-1.50');
$reporter->distfile('ASPIERS/Mail-Freshmeat-1.20.tar.gz');
$reporter->comments('blah');
$reporter->timeout(60);
$reporter->via('CPANPLUS');
$reporter->from('foo@bar.com');
$reporter->address('send@reports.here');
$reporter->mx([1, 2, 3, 4, 5, 6, 7, 8, 9]);

like($reporter->subject, '/^FAIL Foo-Bar-1.50\s/');
like($reporter->report, '/This distribution has been tested/');
like($reporter->report, '/Summary of my/');
like($reporter->report, '/blah/');
is($reporter->grade, 'fail');
is($reporter->distribution, 'Foo-Bar-1.50');
is($reporter->timeout, 60);
is($reporter->comments, 'blah');
is($reporter->via, 'CPANPLUS');
is($reporter->from, 'foo@bar.com');
is($reporter->address, 'send@reports.here');
is($reporter->debug, 0);
is(scalar @{$reporter->mx}, 9);

undef $reporter;

$reporter = Test::Reporter->new();
isa_ok($reporter, 'Test::Reporter');

$reporter->grade('na');
is($reporter->grade, 'na');
is($reporter->timeout, 120);

undef $reporter;

$reporter = Test::Reporter->new();
isa_ok($reporter, 'Test::Reporter');

$reporter->grade('unknown');
is($reporter->grade, 'unknown');

undef $reporter;

$reporter = Test::Reporter->new
(
    mx => [1, 2, 3, 4, 5],
    address => 'foo@bar',
    grade => 'pass',
    distribution => 'Bar-1.0',
    from => 'me@me.com',
    comments => 'woo',
    via => 'something',
    timeout => 500,
    debug => 0,
    dir => '/tmp',
);
isa_ok($reporter, 'Test::Reporter');
like($reporter->subject, '/^PASS Bar-1.0\s/');
like($reporter->report, '/This distribution has been tested/');
like($reporter->report, '/Summary of my/');
like($reporter->report, '/woo/');
is($reporter->grade, 'pass');
is($reporter->distribution, 'Bar-1.0');
is($reporter->timeout, 500);
is($reporter->comments, 'woo');
is($reporter->via, 'something');
is($reporter->from, 'me@me.com');
is($reporter->address, 'foo@bar');
is($reporter->debug, 0);
is(scalar @{$reporter->mx}, 5);
is($reporter->dir, '/tmp');

# ---

undef $reporter;

$reporter = Test::Reporter->new
(
    grade => 'pass',
    distribution => $distro,
    distfile => $distfile,
    from => 'johndoe@example.net',
);
isa_ok($reporter, 'Test::Reporter');
my $file = $reporter->write();
like($file, "/$distro/");
ok(-e $file);

my $orig_subject = $reporter->subject;
my $orig_from = $reporter->from;
my $orig_report = $reporter->report;
my $orig_perl_version = $reporter->perl_version->{_version};

undef $reporter;

$reporter = Test::Reporter->new
(
)->read($file);
isa_ok($reporter, 'Test::Reporter');
like($reporter->subject,"/^PASS $distro\\s/");
like($reporter->report, '/This distribution has been tested/');
like($reporter->report,'/Summary of my/');
is($reporter->grade, 'pass');
is($reporter->distribution, $distro);
is($reporter->distfile, $distfile);
like($reporter->perl_version->{_myconfig}, '/Summary of my/', "Regenerated _myconfig");

# confirm roundtrip -- particularly newlines
is($reporter->subject, $orig_subject);
is($reporter->from, $orig_from);
is($reporter->report, $orig_report);
is($reporter->perl_version->{_version}, $orig_perl_version, 'perl version roundtrip');

unlink $file;

# testing perl-version with the current perl
my $alt_perl = 'alt_perl.pl';
my $no_version = $reporter->perl_version;
my $same_version = $reporter->perl_version($^X);
for my $field ( qw( _archname _osvers _myconfig) )
  { is( $no_version->{$field}, $same_version->{$field}); }

# testing error
{
    my $fh = FileHandle->new();
    open( $fh, ">$alt_perl") or die "cannot create (fake, not working) $alt_perl: $!";
    # fake perl, gives wrong output
    print {$fh} qq{print "booh"; };
    close $fh;

    eval { $reporter->perl_version( "$^X $alt_perl"); };
    like($@, q{/^Test::Reporter: cannot get perl version info from/});
    1 while (unlink $alt_perl);
}

ok($reporter->_is_a_perl_release('perl-5.9.3'));
ok($reporter->_is_a_perl_release('perl-5.9.2'));
ok($reporter->_is_a_perl_release('perl-5.9.1'));
ok($reporter->_is_a_perl_release('perl-5.9.0'));
ok($reporter->_is_a_perl_release('perl-5.8.7'));
ok($reporter->_is_a_perl_release('perl-5.8.6'));
ok($reporter->_is_a_perl_release('perl-5.8.5'));
ok($reporter->_is_a_perl_release('perl-5.8.4'));
ok($reporter->_is_a_perl_release('perl-5.8.3'));
ok($reporter->_is_a_perl_release('perl-5.8.2'));
ok($reporter->_is_a_perl_release('perl-5.8.1'));
ok($reporter->_is_a_perl_release('perl-5.8.0'));
ok($reporter->_is_a_perl_release('perl-5.7.3'));
ok($reporter->_is_a_perl_release('perl-5.7.2'));
ok($reporter->_is_a_perl_release('perl-5.7.1'));
ok($reporter->_is_a_perl_release('perl-5.7.0'));
ok($reporter->_is_a_perl_release('perl-5.6.2'));
ok($reporter->_is_a_perl_release('perl-5.6.1-TRIAL3'));
ok($reporter->_is_a_perl_release('perl-5.6.1-TRIAL2'));
ok($reporter->_is_a_perl_release('perl-5.6.1-TRIAL1'));
ok($reporter->_is_a_perl_release('perl-5.6.1'));
ok($reporter->_is_a_perl_release('perl-5.6.0'));
ok($reporter->_is_a_perl_release('perl-5.6-info'));
ok($reporter->_is_a_perl_release('perl5.005_04'));
ok($reporter->_is_a_perl_release('perl5.005_03'));
ok($reporter->_is_a_perl_release('perl5.005_02'));
ok($reporter->_is_a_perl_release('perl5.005_01'));
ok($reporter->_is_a_perl_release('perl5.005'));
ok($reporter->_is_a_perl_release('perl5.004_05'));
ok($reporter->_is_a_perl_release('perl5.004_04'));
ok($reporter->_is_a_perl_release('perl5.004_03'));
ok($reporter->_is_a_perl_release('perl5.004_02'));
ok($reporter->_is_a_perl_release('perl5.004_01'));
ok($reporter->_is_a_perl_release('perl5.004'));
ok($reporter->_is_a_perl_release('perl5.003_07'));
ok($reporter->_is_a_perl_release('perl-1.0_16'));
ok($reporter->_is_a_perl_release('perl-1.0_15'));
ok(not $reporter->_is_a_perl_release('Perl-BestPractice-0.01'));
ok(not $reporter->_is_a_perl_release('Perl-Compare-0.10'));
ok(not $reporter->_is_a_perl_release('Perl-Critic-0.2'));
ok(not $reporter->_is_a_perl_release('Perl-Dist-0.0.5'));
ok(not $reporter->_is_a_perl_release('Perl-Dist-Strawberry-0.1.2'));
ok(not $reporter->_is_a_perl_release('Perl-Dist-Vanilla-7'));
ok(not $reporter->_is_a_perl_release('Perl-Editor-0.02'));
ok(not $reporter->_is_a_perl_release('Perl-Editor-Plugin-Squish-0.01'));
ok(not $reporter->_is_a_perl_release('Perl-Metrics-0.06'));
ok(not $reporter->_is_a_perl_release('Perl-MinimumVersion-0.13'));
ok(not $reporter->_is_a_perl_release('Perl-Repository-APC-1.216'));
ok(not $reporter->_is_a_perl_release('Perl-SAX-0.07'));
ok(not $reporter->_is_a_perl_release('Perl-Signature-0.08'));
ok(not $reporter->_is_a_perl_release('Perl-Tags-0.23'));
ok(not $reporter->_is_a_perl_release('Perl-Tidy-20060719'));
ok(not $reporter->_is_a_perl_release('Perl-Squish-0.02'));
ok(not $reporter->_is_a_perl_release('Perl-Visualize-1.02'));

like($reporter->message_id, '/^<\d+\.[^.]+\.\d+@[^>]+>$/');

undef $reporter;

# Default transport is Null
$reporter = Test::Reporter->new();
isa_ok($reporter, 'Test::Reporter');
is($reporter->transport(), 'Null');
is($reporter->{_transport}, 'Null');

# Arguments stored in _tls
$reporter->transport('File', dir => "/foo");
my %tls_args = $reporter->transport_args();
is( $tls_args{dir}, '/foo' );

eval { $reporter->transport('Invalid'); };
like($@, q{/could not load 'Test::Reporter::Transport::Invalid'/})
    or print "# $@\n";

done_testing;