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__
=head1 NAME
TAP::Convert::TET - Convert TAP to TET
=head1 VERSION
This document describes TAP::Convert::TET version 0.2.1
=head1 SYNOPSIS
use TAP::Convert::TET;
use TAP::Parser;
# Output to STDOUT by default
my $converter = TAP::Convert::TET->new;
$converter->start;
my $parser = TAP::Parser->new( { source => $fh } );
$converter->convert( $parser, 'test' );
$converter->end;
=head1 DESCRIPTION
Simpleminded converter that turns TAP into a TET journal. See
L for more information about TET.
TET is used by the Linux Standard Base project. This module and the
associated tap2tet program are intended to help integrate Perl's tests
with LSB as part of an effort to incorporate Perl into LSB 3.2. See:
L
for more information.
=head1 INTERFACE
=over
=item C<< new( $options ) >>
Create a new C<< TAP::Convert::TET >>. Options may be passed as a hash:
my @buffer = ( );
# Capture output in an array
my $converter = TAP::Convert::TET->new( { output => \@buffer } );
Available options are:
=over
=item C