Change 33962 by [EMAIL PROTECTED] on 2008/05/31 14:32:23
Integrate:
[ 32660]
Missing files from Test::Harness 3.05
[ 32662]
Extraneous test files that change 32659 failed to delete. Oops.
(But they would not have been being run, because the only tests that
are run are those that are in MANIFEST, and I had deleted them from
there.)
[ 32663]
Subject: [PATCH] Test::Harness 3.05, tests pass in core
From: Andy Armstrong <[EMAIL PROTECTED]>
Message-Id: <[EMAIL PROTECTED]>
Date: Thu, 20 Dec 2007 02:32:55 +0000
[ 32668]
The APC doesn't like empty files
Affected files ...
... //depot/maint-5.10/perl/lib/App/Prove.pm#1 branch
... //depot/maint-5.10/perl/lib/App/Prove/State.pm#1 branch
... //depot/maint-5.10/perl/lib/Test/Harness/t/000-load.t#2 integrate
... //depot/maint-5.10/perl/lib/Test/Harness/t/00compile.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/assert.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/callback.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/compat/inc-propagation.t#2
integrate
... //depot/maint-5.10/perl/lib/Test/Harness/t/failure.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/from_line.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/inc_taint.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/nonumbers.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/ok.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/point-parse.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/point.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/prove-globbing.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/prove-switches.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/regression.t#2 integrate
... //depot/maint-5.10/perl/lib/Test/Harness/t/strap-analyze.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/strap.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/test-harness.t#2 delete
... //depot/maint-5.10/perl/lib/Test/Harness/t/version.t#2 delete
... //depot/maint-5.10/perl/t/lib/sample-tests/delayed#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/empty#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/inc_taint#3 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/out_err_mix#2 integrate
... //depot/maint-5.10/perl/t/lib/sample-tests/stdout_stderr#2 integrate
Differences ...
==== //depot/maint-5.10/perl/lib/App/Prove.pm#1 (text) ====
Index: perl/lib/App/Prove.pm
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/App/Prove.pm 2008-05-31 07:32:23.000000000 -0700
@@ -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<prove> command.
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+L<Test::Harness> provides a command, C<prove>, which runs a TAP based
+test suite and prints a report. The C<prove> 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<new>
+
+Create a new C<App::Prove>. 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<add_rc_file>
+
+ $prove->add_rc_file('myproj/.proverc');
+
+Called before C<process_args> 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 = <RC> ) ) {
+ push @{ $self->{rc_opts} }, grep $_ && $_ !~ /^#/,
+ $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S*) }xg;
+ }
+ close RC;
+}
+
+=head3 C<process_args>
+
+ $prove->process_args(@args);
+
+Processes the command-line arguments. Attributes will be set
+appropriately. Any filenames may be found in the C<argv> 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} = [EMAIL PROTECTED];
+ }
+
+ # 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} = [EMAIL PROTECTED];
+ }
+
+ 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<run>
+
+Perform whatever actions the command line args specified. The C<prove>
+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 ? [EMAIL PROTECTED] : ();
+}
+
+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 ? [EMAIL PROTECTED] : ();
+}
+
+sub _shuffle {
+ my $self = shift;
+
+ # Fisher-Yates shuffle
+ my $i = @_;
+ while ($i) {
+ my $j = rand $i--;
+ @_[ $i, $j ] = @_[ $j, $i ];
+ }
+ return;
+}
+
+=head3 C<require_harness>
+
+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<print_version>
+
+Display the version numbers of the loaded L<TAP::Harness> 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<run>.
+
+=over
+
+=item C<archive>
+
+=item C<argv>
+
+=item C<backwards>
+
+=item C<blib>
+
+=item C<color>
+
+=item C<directives>
+
+=item C<exec>
+
+=item C<failures>
+
+=item C<fork>
+
+=item C<formatter>
+
+=item C<harness>
+
+=item C<includes>
+
+=item C<jobs>
+
+=item C<lib>
+
+=item C<merge>
+
+=item C<modules>
+
+=item C<parse>
+
+=item C<plugins>
+
+=item C<quiet>
+
+=item C<really_quiet>
+
+=item C<recurse>
+
+=item C<show_help>
+
+=item C<show_man>
+
+=item C<show_version>
+
+=item C<shuffle>
+
+=item C<state>
+
+=item C<taint_fail>
+
+=item C<taint_warn>
+
+=item C<test_args>
+
+=item C<timer>
+
+=item C<verbose>
+
+=item C<warnings_fail>
+
+=item C<warnings_warn>
+
+=back
==== //depot/maint-5.10/perl/lib/App/Prove/State.pm#1 (text) ====
Index: perl/lib/App/Prove/State.pm
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/lib/App/Prove/State.pm 2008-05-31 07:32:23.000000000 -0700
@@ -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);
[EMAIL PROTECTED] = 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<prove> command.
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+The C<prove> 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<new>
+
+=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_switch>
+
+Apply a list of switch options to the state.
+
+=over
+
+=item C<last>
+
+Run in the same order as last time
+
+=item C<failed>
+
+Run only the failed tests from last time
+
+=item C<passed>
+
+Run only the passed tests from last time
+
+=item C<all>
+
+Run all tests in normal order
+
+=item C<hot>
+
+Run the tests that most recently failed first
+
+=item C<todo>
+
+Run the tests ordered by number of todos.
+
+=item C<slow>
+
+Run the tests in slowest to fastest order.
+
+=item C<fast>
+
+Run test tests in fastest to slowest order.
+
+=item C<new>
+
+Run the tests in newest to oldest order.
+
+=item C<old>
+
+Run the tests in oldest to newest order.
+
+=item C<save>
+
+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<get_tests>
+
+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 => <STDIN>;
+ 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<observe_test>
+
+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<save>
+
+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>
+
+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 = <FH>;
+ 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};
+ }
+}
==== //depot/maint-5.10/perl/lib/Test/Harness/t/000-load.t#2 (text) ====
Index: perl/lib/Test/Harness/t/000-load.t
--- perl/lib/Test/Harness/t/000-load.t#1~33961~ 2008-05-31 07:30:09.000000000
-0700
+++ perl/lib/Test/Harness/t/000-load.t 2008-05-31 07:32:23.000000000 -0700
@@ -45,5 +45,7 @@
is $class->VERSION, TAP::Parser->VERSION,
"... and $class should have the correct version";
}
- diag("Testing Test::Harness $Test::Harness::VERSION, Perl $], $^X");
+
+ diag("Testing Test::Harness $Test::Harness::VERSION, Perl $], $^X")
+ unless $ENV{PERL_CORE};
}
==== //depot/maint-5.10/perl/lib/Test/Harness/t/compat/inc-propagation.t#2
(text) ====
Index: perl/lib/Test/Harness/t/compat/inc-propagation.t
--- perl/lib/Test/Harness/t/compat/inc-propagation.t#1~33961~ 2008-05-31
07:30:09.000000000 -0700
+++ perl/lib/Test/Harness/t/compat/inc-propagation.t 2008-05-31
07:32:23.000000000 -0700
@@ -40,6 +40,10 @@
= Data::Dumper->new( [ [ grep { $_ ne '.' } @INC ] ] )->Terse(1)->Purity(1)
->Dump;
+# The tail of @INC is munged during core testing. We're only *really*
+# interested in whether 'wibble' makes it anyway.
+my $cmp_slice = $ENV{PERL_CORE} ? '[0..1]' : '';
+
my $test_template = <<'END';
#!/usr/bin/perl %s
@@ -48,7 +52,8 @@
sub _strip_dups {
my %%dups;
# Drop '.' which sneaks in on some platforms
- return grep { $_ ne '.' } grep { !$dups{$_}++ } @_;
+ my @r = grep { $_ ne '.' } grep { !$dups{$_}++ } @_;
+ return @r%s;
}
# Make sure we did something sensible with PERL5LIB
@@ -66,11 +71,11 @@
END
open TEST, ">inc_check.t.tmp";
-printf TEST $test_template, '', $inc, $inc;
+printf TEST $test_template, '', $cmp_slice, $inc, $inc;
close TEST;
open TEST, ">inc_check_taint.t.tmp";
-printf TEST $test_template, '-T', $taint_inc, $taint_inc;
+printf TEST $test_template, '-T', $cmp_slice, $taint_inc, $taint_inc;
close TEST;
END { 1 while unlink 'inc_check_taint.t.tmp', 'inc_check.t.tmp'; }
==== //depot/maint-5.10/perl/lib/Test/Harness/t/regression.t#2 (text) ====
Index: perl/lib/Test/Harness/t/regression.t
--- perl/lib/Test/Harness/t/regression.t#1~33961~ 2008-05-31
07:30:09.000000000 -0700
+++ perl/lib/Test/Harness/t/regression.t 2008-05-31 07:32:23.000000000
-0700
@@ -1,11 +1,16 @@
#!/usr/bin/perl -w
BEGIN {
- chdir 't' and @INC = '../lib' if $ENV{PERL_CORE};
+ if ( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+ else {
+ push @INC, 't/lib';
+ }
}
use strict;
-use lib 't/lib';
use Test::More 'no_plan';
@@ -23,9 +28,11 @@
my $IsVMS = $^O eq 'VMS';
my $IsWin32 = $^O eq 'MSWin32';
-my $SAMPLE_TESTS
- = File::Spec->catdir( File::Spec->curdir, ($ENV{PERL_CORE} ? 'lib' : 't'),
- 'sample-tests' );
+my $SAMPLE_TESTS = File::Spec->catdir(
+ File::Spec->curdir,
+ ( $ENV{PERL_CORE} ? 'lib' : 't' ),
+ 'sample-tests'
+);
my %deprecated = map { $_ => 1 } qw(
TAP::Parser::good_plan
@@ -2350,44 +2357,45 @@
wait => 0,
version => 12,
},
- switches => {
- results => [
- { is_plan => TRUE,
- passed => TRUE,
- is_ok => TRUE,
- raw => '1..1',
- tests_planned => 1,
- },
- { actual_passed => TRUE,
- is_actual_ok => TRUE,
- passed => TRUE,
- is_ok => TRUE,
- is_test => TRUE,
- has_skip => FALSE,
- has_todo => FALSE,
- number => 1,
- description => "",
- explanation => '',
- },
- ],
- __ARGS__ => { switches => ['-Mstrict'] },
- plan => '1..1',
- passed => [1],
- actual_passed => [1],
- failed => [],
- actual_failed => [],
- todo => [],
- todo_passed => [],
- skipped => [],
- good_plan => TRUE,
- is_good_plan => TRUE,
- tests_planned => 1,
- tests_run => TRUE,
- parse_errors => [],
- 'exit' => 0,
- wait => 0,
- version => 12,
- },
+
+ # switches => {
+ # results => [
+ # { is_plan => TRUE,
+ # passed => TRUE,
+ # is_ok => TRUE,
+ # raw => '1..1',
+ # tests_planned => 1,
+ # },
+ # { actual_passed => TRUE,
+ # is_actual_ok => TRUE,
+ # passed => TRUE,
+ # is_ok => TRUE,
+ # is_test => TRUE,
+ # has_skip => FALSE,
+ # has_todo => FALSE,
+ # number => 1,
+ # description => "",
+ # explanation => '',
+ # },
+ # ],
+ # __ARGS__ => { switches => ['-Mstrict'] },
+ # plan => '1..1',
+ # passed => [1],
+ # actual_passed => [1],
+ # failed => [],
+ # actual_failed => [],
+ # todo => [],
+ # todo_passed => [],
+ # skipped => [],
+ # good_plan => TRUE,
+ # is_good_plan => TRUE,
+ # tests_planned => 1,
+ # tests_run => TRUE,
+ # parse_errors => [],
+ # 'exit' => 0,
+ # wait => 0,
+ # version => 12,
+ # },
inc_taint => {
results => [
{ is_plan => TRUE,
@@ -2796,7 +2804,7 @@
tests_planned => 5,
tests_run => 5,
parse_errors =>
- ['Explicit TAP version must be at least 13. Got version 12'],
+ [ 'Explicit TAP version must be at least 13. Got version 12' ],
'exit' => 0,
wait => 0,
version => 12,
@@ -2876,7 +2884,7 @@
tests_planned => 5,
tests_run => 5,
parse_errors =>
- ['If TAP version is present it must be the first line of output'],
+ [ 'If TAP version is present it must be the first line of output' ],
'exit' => 0,
wait => 0,
version => 12,
@@ -3027,14 +3035,17 @@
# the following acrobatics are necessary to make it easy for the
# Test::Builder::failure_output() method to be overridden when
# TAP::Parser is not installed. Otherwise, these tests will fail.
- unshift @{ $args->{switches} }, '-It/lib';
+
+ unshift @{ $args->{switches} },
+ $ENV{PERL_CORE} ? ( map {"-I$_"} @INC ) : ('-It/lib');
$args->{source} = File::Spec->catfile( $SAMPLE_TESTS, $test );
$args->{merge} = !$hide_fork;
my $parser = eval { analyze_test( $test, [EMAIL PROTECTED], $args ) };
my $error = $@;
- ok !$error, "'$test' should parse successfully" or diag $error;
+ ok !$error, "'$test' should parse successfully"
+ or diag $error;
if ($error) {
my $tests = 0;
@@ -3070,9 +3081,7 @@
}
}
-my %Unix2VMS_Exit_Codes = (
- 1 => 4,
-);
+my %Unix2VMS_Exit_Codes = ( 1 => 4, );
sub _vmsify_answer {
my ( $method, $answer ) = @_;
@@ -3100,7 +3109,8 @@
= $result->is_test
? $result->description
: $result->raw;
- $desc = $result->plan if $result->is_plan && $desc =~ /SKIP/i;
+ $desc = $result->plan
+ if $result->is_plan && $desc =~ /SKIP/i;
$desc =~ s/#/<hash>/g;
$desc =~ s/\s+/ /g; # Drop newlines
ok defined $expected,
==== //depot/maint-5.10/perl/t/lib/sample-tests/delayed#2 (text) ====
Index: perl/t/lib/sample-tests/delayed
--- perl/t/lib/sample-tests/delayed#1~33961~ 2008-05-31 07:30:09.000000000
-0700
+++ perl/t/lib/sample-tests/delayed 2008-05-31 07:32:23.000000000 -0700
@@ -1,5 +1,11 @@
# Used to test Process.pm
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ unshift @INC, '../lib';
+ }
+}
+
use Time::HiRes qw(sleep);
my $delay = 0.01;
@@ -19,7 +25,7 @@
my $delay_at = shift || 0;
-while ( @parts ) {
+while (@parts) {
sleep $delay if ( $delay_at & 1 );
$delay_at >>= 1;
print shift @parts;
==== //depot/maint-5.10/perl/t/lib/sample-tests/empty#2 (text) ====
Index: perl/t/lib/sample-tests/empty
--- perl/t/lib/sample-tests/empty#1~33961~ 2008-05-31 07:30:09.000000000
-0700
+++ perl/t/lib/sample-tests/empty 2008-05-31 07:32:23.000000000 -0700
@@ -0,0 +1 @@
+__END__
==== //depot/maint-5.10/perl/t/lib/sample-tests/inc_taint#3 (text) ====
Index: perl/t/lib/sample-tests/inc_taint
--- perl/t/lib/sample-tests/inc_taint#2~33961~ 2008-05-31 07:30:09.000000000
-0700
+++ perl/t/lib/sample-tests/inc_taint 2008-05-31 07:32:23.000000000 -0700
@@ -1,6 +1,14 @@
#!/usr/bin/perl -Tw
-use lib qw(t/lib);
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ unshift @INC, '../lib';
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
use Test::More tests => 1;
ok( grep( /examples/, @INC ) );
==== //depot/maint-5.10/perl/t/lib/sample-tests/out_err_mix#2 (text) ====
Index: perl/t/lib/sample-tests/out_err_mix
--- perl/t/lib/sample-tests/out_err_mix#1~33961~ 2008-05-31
07:30:09.000000000 -0700
+++ perl/t/lib/sample-tests/out_err_mix 2008-05-31 07:32:23.000000000 -0700
@@ -1,5 +1,3 @@
-use strict;
-
sub _autoflush {
my $flushed = shift;
my $old_fh = select $flushed;
==== //depot/maint-5.10/perl/t/lib/sample-tests/stdout_stderr#2 (text) ====
Index: perl/t/lib/sample-tests/stdout_stderr
--- perl/t/lib/sample-tests/stdout_stderr#1~33961~ 2008-05-31
07:30:09.000000000 -0700
+++ perl/t/lib/sample-tests/stdout_stderr 2008-05-31 07:32:23.000000000
-0700
@@ -1,3 +1,8 @@
+BEGIN {
+ if ( $ENV{PERL_CORE} ) {
+ unshift @INC, '../lib';
+ }
+}
use Test::More 'no_plan';
diag 'comments';
ok 1;
End of Patch.
