File Coverage

blib/lib/TAP/Convert/TET.pm

Criterion	Covered	Total	%
statement	86	93	92.4
branch	14	22	63.6
condition	11	25	44.0
subroutine	24	26	92.3
pod	6	6	100.0
total	141	172	81.9

package TAP::Convert::TET;

use warnings;
use strict;
use Carp;
use TAP::Parser;
use Scalar::Util qw/blessed/;
use POSIX qw/strftime uname/;

use version; our $VERSION = qv( '0.2.1' );

use constant TCC_VERSION     => '3.7a';
use constant TIME_FORMAT     => '%H:%M:%S';           # 20:09:33
use constant DATETIME_FORMAT => '%H:%M:%S %Y%m%d';    # 20:09:33 19961128

my %RESULT_TYPE = (
    0 => "PASS",
    1 => "FAIL",
    2 => "UNRESOLVED",
    3 => "NOTINUSE",
    4 => "UNSUPPORTED",
    5 => "UNTESTED",
    6 => "UNINITIATED",
    7 => "NORESULT",
);

BEGIN {
    for my $attr (
        qw(writer tcc_version time_format datetime_format program
        sequence)
      ) {
        no strict 'refs';
        *$attr = sub {
            my $self = shift;
            return $self->{$attr} unless @_;
            $self->{$attr} = shift;
            return;
        };
    }
}

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->_initialize( @_ );
    return $self;
}

sub _initialize {
    my $self = shift;
    my $args = shift || {};

    croak "The only argument to new must be a hash reference"
      unless 'HASH' eq ref $args;

    $self->writer(
        $self->_writer_for_output( delete $args->{output} || \*STDOUT ) );

    $self->tcc_version( delete $args->{tcc_version} || TCC_VERSION );
    $self->time_format( delete $args->{time_format} || TIME_FORMAT );
    $self->datetime_format( delete $args->{datetime_format}
          || DATETIME_FORMAT );
    $self->program( delete $args->{program} || __PACKAGE__ );
    $self->sequence( 1 );
}

sub _next_sequence { shift->{sequence}++ }

# Return a closure that outputs to the specified reference. Handles
# filehandles, objects that can print, array references, scalar
# references
sub _writer_for_output {
    my ( $self, $output ) = @_;

    if ( my $ref = ref $output ) {
        if ( $ref eq 'GLOB'
            || ( blessed $output && $output->can( 'print' ) ) ) {
            return sub { $output->print( @_, "\n" ) };
        }
        elsif ( $ref eq 'ARRAY' ) {
            return sub { push @$output, @_ };
        }
        elsif ( $ref eq 'SCALAR' ) {
            return sub { $$output .= $_[0] . "\n" };
        }
        else {
            croak "Don't know how to write to a $ref";
        }
    }
    else {
        croak "output must be a reference to an array, scalar or filehandle";
    }

    return;
}

sub write {
    my $self = shift;
    $self->writer->( join( '', @_ ) );
}

sub tet {
    my $self = shift;
    croak "TET lines have three parts"
      unless @_ == 3;
    $self->write( join( '|', @_ ) );
}

sub _timestamp {
    my $self = shift;
    return strftime( $self->time_format, localtime );
}

sub start {
    my $self = shift;

    $self->tet(
        0,
        join( ' ',
            $self->tcc_version, strftime( $self->datetime_format, localtime ) ),
        "User: "
          . ( $ENV{USER} || 'unknown' )
          . " ($<) "
          . $self->program
          . " Start"
    );

    $self->tet( 5, join( ' ', uname ), 'System Information' );
}

sub end {
    my $self = shift;
    $self->tet( 900, $self->_timestamp, 'TCC End' );
}

sub convert {
    my $self   = shift;
    my $parser = shift;

    my $seq  = $self->_next_sequence;
    my $name = shift || "unnamed test $seq";
    my $time = $self->_timestamp;

    $self->tet( 10, "$seq $name $time", 'TC Start' );

    while ( my $result = $parser->next ) {
        if ( $result->is_test ) {
            my $test_number = $result->number;

            $self->tet( 400, "$seq $test_number 1 $time", 'IC Start' );
            $self->tet( 200, "$seq $test_number $time",   'TP Start' );
            $self->tet( 520, "$seq $test_number 000000000 1 1",
                $result->as_string );

            my $rc =
                $result->has_skip ? 3
              : $result->has_todo ? 5
              : $result->is_ok    ? 0
              :                     1;

            $self->tet(
                220,
                "$seq $test_number $rc $time",
                $RESULT_TYPE{$rc} || 'UNKNOWN'
            );

            $self->tet( 410, "$seq $test_number 1 $time", 'IC End' );
        }
        else {
            # Ignore everything else for now
        }
    }

    $self->tet( 80, "$seq 0 $time", 'TC End' );
}

1;
__END__