From: Nicholas Clark Date: Wed, 19 Dec 2007 18:26:03 +0000 (+0000) Subject: Missing files from Test::Harness 3.05 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7f01fda6962e4275f16922db832d6ea330918849;p=p5sagit%2Fp5-mst-13.2.git Missing files from Test::Harness 3.05 p4raw-id: //depot/perl@32660 --- diff --git a/lib/App/Prove.pm b/lib/App/Prove.pm new file mode 100644 index 0000000..592f92b --- /dev/null +++ b/lib/App/Prove.pm @@ -0,0 +1,603 @@ +package App::Prove; + +use strict; +use TAP::Harness; +use File::Spec; +use Getopt::Long; +use App::Prove::State; +use Carp; + +use vars qw($VERSION); + +=head1 NAME + +App::Prove - Implements the C command. + +=head1 VERSION + +Version 3.05 + +=cut + +$VERSION = '3.05'; + +=head1 DESCRIPTION + +L provides a command, C, which runs a TAP based +test suite and prints a report. The C command is a minimal +wrapper around an instance of this module. + +=head1 SYNOPSIS + + use App::Prove; + + my $app = App::Prove->new; + $app->process_args(@ARGV); + $app->run; + +=cut + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant IS_VMS => $^O eq 'VMS'; +use constant IS_UNIXY => !( IS_VMS || IS_WIN32 ); + +use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove'; +use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc'; + +use constant PLUGINS => 'App::Prove::Plugin'; + +my @ATTR; + +BEGIN { + @ATTR = qw( + archive argv blib color directives exec failures fork formatter + harness includes modules plugins jobs lib merge parse quiet + really_quiet recurse backwards shuffle taint_fail taint_warn timer + verbose warnings_fail warnings_warn show_help show_man + show_version test_args state + ); + for my $attr (@ATTR) { + no strict 'refs'; + *$attr = sub { + my $self = shift; + croak "$attr is read-only" if @_; + $self->{$attr}; + }; + } +} + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +Create a new C. Optionally a hash ref of attribute +initializers may be passed. + +=cut + +sub new { + my $class = shift; + my $args = shift || {}; + + my $self = bless { + argv => [], + rc_opts => [], + includes => [], + modules => [], + state => [], + plugins => [], + harness_class => 'TAP::Harness', + _state => App::Prove::State->new( { store => STATE_FILE } ), + }, $class; + + for my $attr (@ATTR) { + if ( exists $args->{$attr} ) { + + # TODO: Some validation here + $self->{$attr} = $args->{$attr}; + } + } + return $self; +} + +=head3 C + + $prove->add_rc_file('myproj/.proverc'); + +Called before C to prepend the contents of an rc file to +the options. + +=cut + +sub add_rc_file { + my ( $self, $rc_file ) = @_; + + local *RC; + open RC, "<$rc_file" or croak "Can't read $rc_file ($!)"; + while ( defined( my $line = ) ) { + push @{ $self->{rc_opts} }, grep $_ && $_ !~ /^#/, + $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S*) }xg; + } + close RC; +} + +=head3 C + + $prove->process_args(@args); + +Processes the command-line arguments. Attributes will be set +appropriately. Any filenames may be found in the C attribute. + +Dies on invalid arguments. + +=cut + +sub process_args { + my $self = shift; + + my @rc = RC_FILE; + unshift @rc, glob '~/' . RC_FILE if IS_UNIXY; + + # Preprocess meta-args. + my @args; + while ( defined( my $arg = shift ) ) { + if ( $arg eq '--norc' ) { + @rc = (); + } + elsif ( $arg eq '--rc' ) { + defined( my $rc = shift ) + or croak "Missing argument to --rc"; + push @rc, $rc; + } + elsif ( $arg =~ m{^--rc=(.+)$} ) { + push @rc, $1; + } + else { + push @args, $arg; + } + } + + # Everything after the arisdottle '::' gets passed as args to + # test programs. + if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) { + my @test_args = splice @args, $stop_at; + shift @test_args; + $self->{test_args} = \@test_args; + } + + # Grab options from RC files + $self->add_rc_file($_) for grep -f, @rc; + unshift @args, @{ $self->{rc_opts} }; + + if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) { + die "Long options should be written with two dashes: ", + join( ', ', @bad ), "\n"; + } + + # And finally... + + { + local @ARGV = @args; + Getopt::Long::Configure( 'no_ignore_case', 'bundling' ); + + # Don't add coderefs to GetOptions + GetOptions( + 'v|verbose' => \$self->{verbose}, + 'f|failures' => \$self->{failures}, + 'l|lib' => \$self->{lib}, + 'b|blib' => \$self->{blib}, + 's|shuffle' => \$self->{shuffle}, + 'color!' => \$self->{color}, + 'c' => \$self->{color}, + 'harness=s' => \$self->{harness}, + 'formatter=s' => \$self->{formatter}, + 'r|recurse' => \$self->{recurse}, + 'reverse' => \$self->{backwards}, + 'fork' => \$self->{fork}, + 'p|parse' => \$self->{parse}, + 'q|quiet' => \$self->{quiet}, + 'Q|QUIET' => \$self->{really_quiet}, + 'e|exec=s' => \$self->{exec}, + 'm|merge' => \$self->{merge}, + 'I=s@' => $self->{includes}, + 'M=s@' => $self->{modules}, + 'P=s@' => $self->{plugins}, + 'state=s@' => $self->{state}, + 'directives' => \$self->{directives}, + 'h|help|?' => \$self->{show_help}, + 'H|man' => \$self->{show_man}, + 'V|version' => \$self->{show_version}, + 'a|archive=s' => \$self->{archive}, + 'j|jobs=i' => \$self->{jobs}, + 'timer' => \$self->{timer}, + 'T' => \$self->{taint_fail}, + 't' => \$self->{taint_warn}, + 'W' => \$self->{warnings_fail}, + 'w' => \$self->{warnings_warn}, + ) or croak('Unable to continue'); + + # Stash the remainder of argv for later + $self->{argv} = [@ARGV]; + } + + return; +} + +sub _first_pos { + my $want = shift; + for ( 0 .. $#_ ) { + return $_ if $_[$_] eq $want; + } + return; +} + +sub _exit { exit( $_[1] || 0 ) } + +sub _help { + my ( $self, $verbosity ) = @_; + + eval('use Pod::Usage 1.12 ()'); + if ( my $err = $@ ) { + die 'Please install Pod::Usage for the --help option ' + . '(or try `perldoc prove`.)' + . "\n ($@)"; + } + + Pod::Usage::pod2usage( { -verbose => $verbosity } ); + + return; +} + +sub _color_default { + my $self = shift; + + return -t STDOUT && !IS_WIN32; +} + +sub _get_args { + my $self = shift; + + my %args; + + if ( defined $self->color ? $self->color : $self->_color_default ) { + $args{color} = 1; + } + + if ( $self->archive ) { + $self->require_harness( archive => 'TAP::Harness::Archive' ); + $args{archive} = $self->archive; + } + + if ( my $jobs = $self->jobs ) { + $args{jobs} = $jobs; + } + + if ( my $fork = $self->fork ) { + $args{fork} = $fork; + } + + if ( my $harness_opt = $self->harness ) { + $self->require_harness( harness => $harness_opt ); + } + + if ( my $formatter = $self->formatter ) { + $args{formatter_class} = $formatter; + } + + if ( $self->taint_fail && $self->taint_warn ) { + die '-t and -T are mutually exclusive'; + } + + if ( $self->warnings_fail && $self->warnings_warn ) { + die '-w and -W are mutually exclusive'; + } + + for my $a (qw( lib switches )) { + my $method = "_get_$a"; + my $val = $self->$method(); + $args{$a} = $val if defined $val; + } + + # Handle verbose, quiet, really_quiet flags + my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, ); + + my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 } + keys %verb_map; + + die "Only one of verbose, quiet or really_quiet should be specified\n" + if @verb_adj > 1; + + $args{verbosity} = shift @verb_adj || 0; + + for my $a (qw( merge failures timer directives )) { + $args{$a} = 1 if $self->$a(); + } + + $args{errors} = 1 if $self->parse; + + # defined but zero-length exec runs test files as binaries + $args{exec} = [ split( /\s+/, $self->exec ) ] + if ( defined( $self->exec ) ); + + if ( defined( my $test_args = $self->test_args ) ) { + $args{test_args} = $test_args; + } + + return ( \%args, $self->{harness_class} ); +} + +sub _find_module { + my ( $self, $class, @search ) = @_; + + croak "Bad module name $class" + unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; + + for my $pfx (@search) { + my $name = join( '::', $pfx, $class ); + print "$name\n"; + eval "require $name"; + return $name unless $@; + } + + eval "require $class"; + return $class unless $@; + return; +} + +sub _load_extension { + my ( $self, $class, @search ) = @_; + + my @args = (); + if ( $class =~ /^(.*?)=(.*)/ ) { + $class = $1; + @args = split( /,/, $2 ); + } + + if ( my $name = $self->_find_module( $class, @search ) ) { + $name->import(@args); + } + else { + croak "Can't load module $class"; + } +} + +sub _load_extensions { + my ( $self, $ext, @search ) = @_; + $self->_load_extension( $_, @search ) for @$ext; +} + +=head3 C + +Perform whatever actions the command line args specified. The C +command line tool consists of the following code: + + use App::Prove; + + my $app = App::Prove->new; + $app->process_args(@ARGV); + $app->run; + +=cut + +sub run { + my $self = shift; + + if ( $self->show_help ) { + $self->_help(1); + } + elsif ( $self->show_man ) { + $self->_help(2); + } + elsif ( $self->show_version ) { + $self->print_version; + } + else { + + $self->_load_extensions( $self->modules ); + $self->_load_extensions( $self->plugins, PLUGINS ); + + my $state = $self->{_state}; + if ( defined( my $state_switch = $self->state ) ) { + $state->apply_switch(@$state_switch); + } + + my @tests = $state->get_tests( $self->recurse, @{ $self->argv } ); + + $self->_shuffle(@tests) if $self->shuffle; + @tests = reverse @tests if $self->backwards; + + $self->_runtests( $self->_get_args, @tests ); + } + + return; +} + +sub _runtests { + my ( $self, $args, $harness_class, @tests ) = @_; + my $harness = $harness_class->new($args); + + $harness->callback( + after_test => sub { + $self->{_state}->observe_test(@_); + } + ); + + my $aggregator = $harness->runtests(@tests); + + $self->_exit( $aggregator->has_problems ? 1 : 0 ); + + return; +} + +sub _get_switches { + my $self = shift; + my @switches; + + # notes that -T or -t must be at the front of the switches! + if ( $self->taint_fail ) { + push @switches, '-T'; + } + elsif ( $self->taint_warn ) { + push @switches, '-t'; + } + if ( $self->warnings_fail ) { + push @switches, '-W'; + } + elsif ( $self->warnings_warn ) { + push @switches, '-w'; + } + + return @switches ? \@switches : (); +} + +sub _get_lib { + my $self = shift; + my @libs; + if ( $self->lib ) { + push @libs, 'lib'; + } + if ( $self->blib ) { + push @libs, 'blib/lib', 'blib/arch'; + } + if ( @{ $self->includes } ) { + push @libs, @{ $self->includes }; + } + + #24926 + @libs = map { File::Spec->rel2abs($_) } @libs; + + # Huh? + return @libs ? \@libs : (); +} + +sub _shuffle { + my $self = shift; + + # Fisher-Yates shuffle + my $i = @_; + while ($i) { + my $j = rand $i--; + @_[ $i, $j ] = @_[ $j, $i ]; + } + return; +} + +=head3 C + +Load a harness replacement class. + + $prove->require_harness($for => $class_name); + +=cut + +sub require_harness { + my ( $self, $for, $class ) = @_; + + eval("require $class"); + die "$class is required to use the --$for feature: $@" if $@; + + $self->{harness_class} = $class; + + return; +} + +=head3 C + +Display the version numbers of the loaded L and the +current Perl. + +=cut + +sub print_version { + my $self = shift; + printf( + "TAP::Harness v%s and Perl v%vd\n", + $TAP::Harness::VERSION, $^V + ); + + return; +} + +1; + +# vim:ts=4:sw=4:et:sta + +__END__ + +=head2 Attributes + +After command line parsing the following attributes reflect the values +of the corresponding command line switches. They may be altered before +calling C. + +=over + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=item C + +=back diff --git a/lib/App/Prove/State.pm b/lib/App/Prove/State.pm new file mode 100644 index 0000000..fc4f035 --- /dev/null +++ b/lib/App/Prove/State.pm @@ -0,0 +1,417 @@ +package App::Prove::State; + +use strict; +use File::Find; +use File::Spec; +use Carp; +use TAP::Parser::YAMLish::Reader (); +use TAP::Parser::YAMLish::Writer (); +use TAP::Base; + +use vars qw($VERSION @ISA); +@ISA = qw( TAP::Base ); + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant NEED_GLOB => IS_WIN32; + +=head1 NAME + +App::Prove::State - State storage for the C command. + +=head1 VERSION + +Version 3.05 + +=cut + +$VERSION = '3.05'; + +=head1 DESCRIPTION + +The C command supports a C<--state> option that instructs it to +store persistent state across runs. This module implements that state +and the operations that may be performed on it. + +=head1 SYNOPSIS + + # Re-run failed tests + $ prove --state=fail,save -rbv + +=cut + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +=cut + +sub new { + my $class = shift; + my %args = %{ shift || {} }; + + my $self = bless { + _ => { + tests => {}, + generation => 1 + }, + select => [], + seq => 1, + store => delete $args{store}, + }, $class; + + my $store = $self->{store}; + $self->load($store) + if defined $store && -f $store; + + return $self; +} + +sub DESTROY { + my $self = shift; + if ( $self->{should_save} && defined( my $store = $self->{store} ) ) { + $self->save($store); + } +} + +=head2 Instance Methods + +=head3 C + +Apply a list of switch options to the state. + +=over + +=item C + +Run in the same order as last time + +=item C + +Run only the failed tests from last time + +=item C + +Run only the passed tests from last time + +=item C + +Run all tests in normal order + +=item C + +Run the tests that most recently failed first + +=item C + +Run the tests ordered by number of todos. + +=item C + +Run the tests in slowest to fastest order. + +=item C + +Run test tests in fastest to slowest order. + +=item C + +Run the tests in newest to oldest order. + +=item C + +Run the tests in oldest to newest order. + +=item C + +Save the state on exit. + +=back + +=cut + +sub apply_switch { + my $self = shift; + my @opts = @_; + + my $last_gen = $self->{_}->{generation} - 1; + my $now = $self->get_time; + + my @switches = map { split /,/ } @opts; + + my %handler = ( + last => sub { + $self->_select( + where => sub { $_->{gen} >= $last_gen }, + order => sub { $_->{seq} } + ); + }, + failed => sub { + $self->_select( + where => sub { $_->{last_result} != 0 }, + order => sub { -$_->{last_result} } + ); + }, + passed => sub { + $self->_select( where => sub { $_->{last_result} == 0 } ); + }, + all => sub { + $self->_select(); + }, + todo => sub { + $self->_select( + where => sub { $_->{last_todo} != 0 }, + order => sub { -$_->{last_todo}; } + ); + }, + hot => sub { + $self->_select( + where => sub { defined $_->{last_fail_time} }, + order => sub { $now - $_->{last_fail_time} } + ); + }, + slow => sub { + $self->_select( order => sub { -$_->{elapsed} } ); + }, + fast => sub { + $self->_select( order => sub { $_->{elapsed} } ); + }, + new => sub { + $self->_select( + order => sub { + ( $_->{total_failures} || 0 ) + + ( $_->{total_passes} || 0 ); + } + ); + }, + old => sub { + $self->_select( + order => sub { + -( ( $_->{total_failures} || 0 ) + + ( $_->{total_passes} || 0 ) ); + } + ); + }, + save => sub { + $self->{should_save}++; + }, + adrian => sub { + unshift @switches, qw( hot all save ); + }, + ); + + while ( defined( my $ele = shift @switches ) ) { + my ( $opt, $arg ) + = ( $ele =~ /^([^:]+):(.*)/ ) + ? ( $1, $2 ) + : ( $ele, undef ); + my $code = $handler{$opt} + || croak "Illegal state option: $opt"; + $code->($arg); + } +} + +sub _select { + my ( $self, %spec ) = @_; + push @{ $self->{select} }, \%spec; +} + +=head3 C + +Given a list of args get the names of tests that should run + +=cut + +sub get_tests { + my $self = shift; + my $recurse = shift; + my @argv = @_; + my %seen; + + my @selected = $self->_query; + + unless ( @argv || @{ $self->{select} } ) { + croak q{No tests named and 't' directory not found} + unless -d 't'; + @argv = 't'; + } + + push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv; + return grep { !$seen{$_}++ } @selected; +} + +sub _query { + my $self = shift; + if ( my @sel = @{ $self->{select} } ) { + warn "No saved state, selection will be empty\n" + unless keys %{ $self->{_}->{tests} }; + return map { $self->_query_clause($_) } @sel; + } + return; +} + +sub _query_clause { + my ( $self, $clause ) = @_; + my @got; + my $tests = $self->{_}->{tests}; + my $where = $clause->{where} || sub {1}; + + # Select + for my $test ( sort keys %$tests ) { + local $_ = $tests->{$test}; + push @got, $test if $where->(); + } + + # Sort + if ( my $order = $clause->{order} ) { + @got = map { $_->[0] } + sort { + ( defined $b->[1] <=> defined $a->[1] ) + || ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) ) + } map { + [ $_, + do { local $_ = $tests->{$_}; $order->() } + ] + } @got; + } + + return @got; +} + +sub _get_raw_tests { + my $self = shift; + my $recurse = shift; + my @argv = @_; + my @tests; + + # Do globbing on Win32. + @argv = map { glob "$_" } @argv if NEED_GLOB; + + for my $arg (@argv) { + if ( '-' eq $arg ) { + push @argv => ; + chomp(@argv); + next; + } + + push @tests, + sort -d $arg + ? $recurse + ? $self->_expand_dir_recursive($arg) + : glob( File::Spec->catfile( $arg, '*.t' ) ) + : $arg; + } + return @tests; +} + +sub _expand_dir_recursive { + my ( $self, $dir ) = @_; + + my @tests; + find( + { follow => 1, #21938 + wanted => sub { + -f + && /\.t$/ + && push @tests => $File::Find::name; + } + }, + $dir + ); + return @tests; +} + +=head3 C + +Store the results of a test. + +=cut + +sub observe_test { + my ( $self, $test, $parser ) = @_; + $self->_record_test( + $test, scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ), + scalar( $parser->todo ), $parser->start_time, $parser->end_time + ); +} + +# Store: +# last fail time +# last pass time +# last run time +# most recent result +# most recent todos +# total failures +# total passes +# state generation + +sub _record_test { + my ( $self, $test, $fail, $todo, $start_time, $end_time ) = @_; + my $rec = $self->{_}->{tests}->{ $test->[0] } ||= {}; + + $rec->{seq} = $self->{seq}++; + $rec->{gen} = $self->{_}->{generation}; + + $rec->{last_run_time} = $end_time; + $rec->{last_result} = $fail; + $rec->{last_todo} = $todo; + $rec->{elapsed} = $end_time - $start_time; + + if ($fail) { + $rec->{total_failures}++; + $rec->{last_fail_time} = $end_time; + } + else { + $rec->{total_passes}++; + $rec->{last_pass_time} = $end_time; + } +} + +=head3 C + +Write the state to a file. + +=cut + +sub save { + my ( $self, $name ) = @_; + my $writer = TAP::Parser::YAMLish::Writer->new; + local *FH; + open FH, ">$name" or croak "Can't write $name ($!)"; + $writer->write( $self->{_} || {}, \*FH ); + close FH; +} + +=head3 C + +Load the state from a file + +=cut + +sub load { + my ( $self, $name ) = @_; + my $reader = TAP::Parser::YAMLish::Reader->new; + local *FH; + open FH, "<$name" or croak "Can't read $name ($!)"; + $self->{_} = $reader->read( + sub { + my $line = ; + defined $line && chomp $line; + return $line; + } + ); + + # $writer->write( $self->{tests} || {}, \*FH ); + close FH; + $self->_regen_seq; + $self->{_}->{generation}++; +} + +sub _regen_seq { + my $self = shift; + for my $rec ( values %{ $self->{_}->{tests} || {} } ) { + $self->{seq} = $rec->{seq} + 1 + if defined $rec->{seq} && $rec->{seq} >= $self->{seq}; + } +}