Frey/Test/Runner.pm

package Frey::Test::Runner;
use Moose;

extends 'Frey';
with 'Frey::Web';
with 'Frey::Storage';

use TAP::Harness;
use TAP::Formatter::HTML;
use Data::Dump qw/dump/;

use Frey::SVK;
use Frey::PPI;

has tests => (
        is => 'rw',
        isa => 'ArrayRef[Str]',
        required => 1,
        lazy => 1, # FIXME ask users which tests to run
        default => sub {
#               [ glob('t/*.t') ] # all tests
                [ Frey::SVK->modified ]
        },
);

sub as_markup {
        my ($self) = @_;

        my $f = TAP::Formatter::HTML->new({
#               silent => 1,

                inline_css => 1,
                inline_js  => 0,
        });
        my $h = TAP::Harness->new({
                merge => 1,
                formatter => $f,
        });

        my $tests;

        map {
                $tests->{$_}++ if m{\.t$};
        } @{ $self->tests };

        map {
                if ( m{(.+)\.pm$} ) {
                        my $class = $1;
                        $class =~ s{^lib/}{};
                        $class =~ s{/}{::}g;
                        warn "extract tests from $_ class $class";
                        $tests->{$_}++ foreach Frey::PPI->new( class => $class )->has_tests;
                }
        } @{ $self->tests };

        my @tests = grep {
                ! m{$0} # break recursion       
        } sort keys %$tests;
        die "no tests for files ", dump( $self->tests ),dump( $tests ) unless @tests;

        warn "testing ",dump( @tests );
        $h->runtests( @tests );

        $self->store( 'var/test/' . time() . '.yaml', $h );

        push @{ $self->status }, { test => $tests };

        my $html = ${ $f->html };
#       warn $html;
        warn "got ",length($html), " bytes";

        while ( $html =~ s{(<style.+?/style>)}{}gs ) {
                $self->add_head( $1 );
        }

        $self->add_head(qq|
                <style type="text/css">
                /* CSS to show-hide full text results */
                ul.test-out { display: none; }
                td.results:hover ul.test-out { display: block; }
                </style>
        |);

        $html =~ s{^.*<body>}{}s;
        $html =~ s{</body>.*$}{}s;

        $html =~ s{(<a class="file") href="#"(.+?)>t/(.+?)</a>}{<a class="editor" href="/editor+t/$3.t+1" name="t/$3.t" $2>$3</a>}sg;

        return 
                $self->editor_links( $html )
                . qq|<ul><li>| . join("</li>\n<li>", map { qq|<a href="#$_"><tt>$_</tt></a>| } @tests) . qq|</li></ul>|
                ;
        
}

1;
1	dpavlin	484	package Frey::Test::Runner;
2			use Moose;
3
4			extends 'Frey';
5			with 'Frey::Web';
6	dpavlin	486	with 'Frey::Storage';
7	dpavlin	484
8			use TAP::Harness;
9			use TAP::Formatter::HTML;
10			use Data::Dump qw/dump/;
11
12	dpavlin	486	use Frey::SVK;
13	dpavlin	489	use Frey::PPI;
14	dpavlin	486
15	dpavlin	484	has tests => (
16			is => 'rw',
17			isa => 'ArrayRef[Str]',
18			required => 1,
19			lazy => 1, # FIXME ask users which tests to run
20	dpavlin	486	default => sub {
21			# [ glob('t/*.t') ] # all tests
22			[ Frey::SVK->modified ]
23			},
24	dpavlin	484	);
25
26			sub as_markup {
27			my ($self) = @_;
28
29			my $f = TAP::Formatter::HTML->new({
30	dpavlin	491	# silent => 1,
31	dpavlin	484
32			inline_css => 1,
33	dpavlin	491	inline_js => 0,
34	dpavlin	484	});
35			my $h = TAP::Harness->new({
36			merge => 1,
37			formatter => $f,
38			});
39
40	dpavlin	491	my $tests;
41
42			map {
43			$tests->{$_}++ if m{\.t$};
44			} @{ $self->tests };
45
46			map {
47			if ( m{(.+)\.pm$} ) {
48			my $class = $1;
49			$class =~ s{^lib/}{};
50			$class =~ s{/}{::}g;
51			warn "extract tests from $_ class $class";
52			$tests->{$_}++ foreach Frey::PPI->new( class => $class )->has_tests;
53	dpavlin	489	}
54	dpavlin	491	} @{ $self->tests };
55	dpavlin	489
56	dpavlin	491	my @tests = grep {
57			! m{$0} # break recursion
58			} sort keys %$tests;
59			die "no tests for files ", dump( $self->tests ),dump( $tests ) unless @tests;
60	dpavlin	489
61	dpavlin	484	warn "testing ",dump( @tests );
62			$h->runtests( @tests );
63
64	dpavlin	491	$self->store( 'var/test/' . time() . '.yaml', $h );
65	dpavlin	486
66	dpavlin	494	push @{ $self->status }, { test => $tests };
67
68	dpavlin	484	my $html = ${ $f->html };
69			# warn $html;
70			warn "got ",length($html), " bytes";
71	dpavlin	494
72			while ( $html =~ s{(<style.+?/style>)}{}gs ) {
73			$self->add_head( $1 );
74			}
75
76			$self->add_head(qq\|
77			<style type="text/css">
78			/* CSS to show-hide full text results */
79			ul.test-out { display: none; }
80			td.results:hover ul.test-out { display: block; }
81			</style>
82			\|);
83
84			$html =~ s{^.*<body>}{}s;
85			$html =~ s{</body>.*$}{}s;
86
87			$html =~ s{(<a class="file") href="#"(.+?)>t/(.+?)</a>}{<a class="editor" href="/editor+t/$3.t+1" name="t/$3.t" $2>$3</a>}sg;
88
89			return
90			$self->editor_links( $html )
91			. qq\|<ul><li>\| . join("</li>\n<li>", map { qq\|<a href="#$_"><tt>$_</tt></a>\| } @tests) . qq\|</li></ul>\|
92			;
93
94	dpavlin	484	}
95
96			1;