=head1 NAME

TAP::Formatter::HTML::Session - TAP Test Harness output delegate for html output

=head1 SYNOPSIS

 # see TAP::Formatter::HTML

=cut

package TAP::Formatter::HTML::Session;

use strict;
use warnings;

# DEBUG:
#use Data::Dumper 'Dumper';

use base qw( TAP::Base );
use accessors qw( test formatter parser results html_id meta closed );

our $VERSION = '0.11';

sub _initialize {
    my ($self, $args) = @_;

    $args ||= {};
    $self->SUPER::_initialize($args);

    $self->results([])->meta({})->closed(0);
    foreach my $arg (qw( test parser formatter )) {
	$self->$arg($args->{$arg}) if defined $args->{$arg};
    }

    # make referring to it in HTML easy:
    my $html_id = $self->test;
    $html_id    =~ s/[^a-zA-Z\d-]/-/g;
    $self->html_id( $html_id );

    $self->info( $self->test, ':' );

    return $self;
}

# Called by TAP::Parser to create a result after a session is opened
# TODO: override TAP::Parser::ResultFactory and add html-aware results?
# OR: mixin some methods to the results.
# this logic is getting cumbersome. :-/
sub result {
    my ($self, $result) = @_;
    #warn ref($self) . "->result called with args: " . Dumper( $result );

    my $iter = $self->html_id_iterator;
    if ($result->is_test) {
	$self->log( $result->as_string );
	# make referring to it in HTML easy:
	$result->{html_id} = $iter ? $iter->() : $self->html_id . '-' . $result->number;

	# set test status to avoid the hassle of recalculating it in the template:
	$result->{test_status}  = $result->has_todo ? 'todo-' : '';
	$result->{test_status} .= $result->has_skip ? 'skip-' : '';
	$result->{test_status} .= $result->is_actual_ok ? 'ok' : 'not-ok';

	# also provide a 'short' status name to reduce size of html:
	my $short;
	if ($result->has_todo) {
	    if ($result->is_actual_ok) {
		$short = 'u'; # todo-ok = "unexpected" ok
	    } else {
		$short = 't'; # todo-not-ok
	    }
	} elsif ($result->has_skip) {
	    $short = 's'; # skip-ok
	} elsif ($result->is_actual_ok) {
	    $short = 'k'; # ok
	} else {
	    $short = 'n'; # not-ok
	}
	$result->{short_test_status} = $short;

	# keep track of passes for percent_passed calcs:
	if ($result->is_ok) {
	    $self->meta->{passed}++;
	}

	# keep track of passes (including unplanned!) for actual_percent_passed calcs:
	if ($result->is_ok || $result->is_unplanned && $result->is_actual_ok) {
	    $self->meta->{passed_including_unplanned}++;
	}

	# mark passed todo tests for easy reference:
	if ($result->has_todo && $result->is_actual_ok) {
	    $result->{todo_passed} = 1;
	}
    } else {
	$self->info( $result->as_string );
    }

    $self->set_result_css_type( $result );

    push @{ $self->results }, $result;
    return;
}

# TODO: inheritance was created for a reason... use it
use constant result_css_type_map =>
  {
   plan    => 'pln',
   pragma  => 'prg',
   test    => 'tst',
   comment => 'cmt',
   bailout => 'blt',
   version => 'ver',
   unknown => 'unk',
   yaml    => 'yml',
  };

sub set_result_css_type {
    my ($self, $result) = @_;
    my $type = $result->type || 'unknown';
    my $css_type = $self->result_css_type_map->{$type} || 'unk';
    $result->{css_type} = $css_type;
    return $self;
}

# Called by TAP::?? to indicate there are no more test results coming
sub close_test {
    my ($self, @args) = @_;
    # warn ref($self) . "->close_test called with args: " . Dumper( [@args] );
    #print STDERR 'end of: ', $self->test, "\n\n";
    $self->closed(1);
    return;
}

sub as_report {
    my ($self) = @_;
    my $p = $self->parser;
    my $r = {
	     test => $self->test,
	     html_id => $self->html_id,
	     results => $self->results,
	    };

    # add parser info:
    for my $key (qw(
		    tests_planned
		    tests_run
		    start_time
		    end_time
		    skip_all
		    has_problems
		    passed
		    failed
		    todo_passed
		    actual_passed
		    actual_failed
		    wait
		    exit
		   )) {
	$r->{$key} = $p->$key;
    }

    $r->{num_parse_errors} = scalar $p->parse_errors;
    $r->{parse_errors} = [ $p->parse_errors ];
    $r->{passed_tests} = [ $p->passed ];
    $r->{failed_tests} = [ $p->failed ];

    # do some other handy calcs:
    $r->{test_status} = $r->{has_problems} ? 'failed' : 'passed';
    $r->{elapsed_time} = $r->{end_time} - $r->{start_time};
    $r->{severity} = '';
    if ($r->{tests_planned}) {
	# Calculate percentage passed as # passes *excluding* unplanned passes
	# so we can't get > 100%.  Also calc # passes _including_ unplanned
	# in case that's useful for someone.
	my $num_passed = $self->meta->{passed} || 0;
	my $num_actual_passed = $self->meta->{passed_including_unplanned} || 0;
	my $p = $r->{percent_passed} = sprintf('%.1f', $num_passed / $r->{tests_planned} * 100);
	$r->{percent_actual_passed}  = sprintf('%.1f', $num_actual_passed / $r->{tests_planned} * 100);
	if ($p != 100) {
	    my $s;
	    if ($p < 25)    { $s = 'very-high' }
	    elsif ($p < 50) { $s = 'high' }
	    elsif ($p < 75) { $s = 'med' }
	    elsif ($p < 95) { $s = 'low' }
	    else            { $s = 'very-low' }
	    # classify >100% as very-low
	    $r->{severity} = $s;
	}
    } elsif ($r->{skip_all}) {
	; # do nothing
    } else {
	$r->{percent_passed} = 0;
	$r->{severity} = 'very-high';
    }

    if (my $num = $r->{num_parse_errors}) {
	if ($num == 1 && ! $p->is_good_plan) {
	    $r->{severity} ||= 'low'; # prefer value set calculating % passed
	} else {
	    $r->{severity} = 'very-high';
	}
    }

    # check for scripts that died abnormally:
    if ($r->{exit} && $r->{exit} == 255 && $p->is_good_plan) {
	$r->{severity} ||= 'very-high';
    }

    # catch-all:
    if ($r->{has_problems}) {
	$r->{severity} ||= 'high';
    }

    return $r;
}

sub html_id_iterator {
    shift->formatter->html_id_iterator;
}

sub log {
    my ($self, @args) = @_;
    $self->formatter->log_test(@args);
}

sub info {
    my ($self, @args) = @_;
    $self->formatter->log_test_info(@args);
}


1;

__END__


=head1 DESCRIPTION

This module is part of L<TAP::Formatter::HTML>, which provides HTML output
formatting for L<TAP::Harness>.  It handles individual test I<sessions>, eg.
output from an individual test script.

As documentation is a bit sparse at the moment, you'll need to read the source
if you need to inherit/hack on the module at all.

=head1 BUGS

Please use http://rt.cpan.org to report any issues.

=head1 AUTHOR

Steve Purkis <spurkis@cpan.org>

=head1 COPYRIGHT

Copyright (c) 2008-2010 Steve Purkis <spurkis@cpan.org>, S Purkis Consulting Ltd.
All rights reserved.

This module is released under the same terms as Perl itself.

=head1 SEE ALSO

L<TAP::Formatter::HTML>

L<TAP::Formatter::Console::Session> - the default TAP formatter used by L<TAP::Harness>

=cut