perl/lib/App/Prove/State.pm - chromium/deps/perl - Git at Google

 package App::Prove::State;

 use strict;
 use vars qw($VERSION @ISA);

 use File::Find;
 use File::Spec;
 use Carp;

 use App::Prove::State::Result;
 use TAP::Parser::YAMLish::Reader ();
 use TAP::Parser::YAMLish::Writer ();
 use TAP::Base;

 BEGIN {
     @ISA = qw( TAP::Base );
     __PACKAGE__->mk_methods('result_class');
 }

 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.23

 =cut

 $VERSION = '3.23';

 =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>

 Accepts a hashref with the following key/value pairs:

 =over 4

 =item * C<store>

 The filename of the data store holding the data that App::Prove::State reads.

 =item * C<extensions> (optional)

 The test name extensions.  Defaults to C<.t>.

 =item * C<result_class> (optional)

 The name of the C<result_class>.  Defaults to C<App::Prove::State::Result>.

 =back

 =cut

 # override TAP::Base::new:
 sub new {
     my $class = shift;
     my %args = %{ shift || {} };

     my $self = bless {
         select       => [],
         seq          => 1,
         store        => delete $args{store},
         extensions   => ( delete $args{extensions} || ['.t'] ),
         result_class => ( delete $args{result_class} || 'App::Prove::State::Result' ),
     }, $class;

     $self->{_} = $self->result_class->new(
         {   tests      => {},
             generation => 1,
         }
     );
     my $store = $self->{store};
     $self->load($store)
       if defined $store && -f $store;

     return $self;
 }

 =head2 C<result_class>

 Getter/setter for the name of the class used for tracking test results.  This
 class should either subclass from C<App::Prove::State::Result> or provide an
 identical interface.

 =cut

 =head2 C<extensions>

 Get or set the list of extensions that files must have in order to be
 considered tests. Defaults to ['.t'].

 =cut

 sub extensions {
     my $self = shift;
     $self->{extensions} = shift if @_;
     return $self->{extensions};
 }

 =head2 C<results>

 Get the results of the last test run.  Returns a C<result_class()> instance.

 =cut

 sub results {
     my $self = shift;
     $self->{_} || $self->result_class->new;
 }

 =head2 C<commit>

 Save the test results. Should be called after all tests have run.

 =cut

 sub commit {
     my $self = shift;
     if ( $self->{should_save} ) {
         $self->save;
     }
 }

 =head2 Instance Methods

 =head3 C<apply_switch>

  $self->apply_switch('failed,save');

 Apply a list of switch options to the state, updating the internal
 object state as a result. Nothing is returned.

 Diagnostics:
     - "Illegal state option: %s"

 =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->results->generation - 1;
     my $last_run_time = $self->results->last_run_time;
     my $now           = $self->get_time;

     my @switches = map { split /,/ } @opts;

     my %handler = (
         last => sub {
             $self->_select(
                 where => sub { $_->generation >= $last_gen },
                 order => sub { $_->sequence }
             );
         },
         failed => sub {
             $self->_select(
                 where => sub { $_->result != 0 },
                 order => sub { -$_->result }
             );
         },
         passed => sub {
             $self->_select( where => sub { $_->result == 0 } );
         },
         all => sub {
             $self->_select();
         },
         todo => sub {
             $self->_select(
                 where => sub { $_->num_todo != 0 },
                 order => sub { -$_->num_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 { -$_->mtime } );
         },
         old => sub {
             $self->_select( order => sub { $_->mtime } );
         },
         fresh => sub {
             $self->_select( where => sub { $_->mtime >= $last_run_time } );
         },
         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);
     }
     return;
 }

 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} } ) {
         @argv = $recurse ? '.' : 't';
         croak qq{No tests named and '@argv' directory not found}
           unless -d $argv[0];
     }

     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 $self->results->num_tests;
         return map { $self->_query_clause($_) } @sel;
     }
     return;
 }

 sub _query_clause {
     my ( $self, $clause ) = @_;
     my @got;
     my $results = $self->results;
     my $where = $clause->{where} || sub {1};

     # Select
     for my $name ( $results->test_names ) {
         next unless -f $name;
         local $_ = $results->test($name);
         push @got, $name 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 $_ = $results->test($_); $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;
     my $extensions = $self->{extensions};

     for my $arg (@argv) {
         if ( '-' eq $arg ) {
             push @argv => <STDIN>;
             chomp(@argv);
             next;
         }

         push @tests,
             sort -d $arg
           ? $recurse
               ? $self->_expand_dir_recursive( $arg, $extensions )
               : map { glob( File::Spec->catfile( $arg, "*$_" ) ) } @{$extensions}
           : $arg;
     }
     return @tests;
 }

 sub _expand_dir_recursive {
     my ( $self, $dir, $extensions ) = @_;

     my @tests;
     my $ext_string = join( '|', map { quotemeta } @{$extensions} );

     find(
         {   follow      => 1,      #21938
             follow_skip => 2,
             wanted      => sub {
                 -f
                   && /(?:$ext_string)$/
                   && push @tests => $File::Find::name;
               }
         },
         $dir
     );
     return @tests;
 }

 =head3 C<observe_test>

 Store the results of a test.

 =cut

 # Store:
 #     last fail time
 #     last pass time
 #     last run time
 #     most recent result
 #     most recent todos
 #     total failures
 #     total passes
 #     state generation
 #     parser

 sub observe_test {

     my ( $self, $test_info, $parser ) = @_;
     my $name = $test_info->[0];
     my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 );
     my $todo = scalar( $parser->todo );
     my $start_time = $parser->start_time;
     my $end_time   = $parser->end_time,

       my $test = $self->results->test($name);

     $test->sequence( $self->{seq}++ );
     $test->generation( $self->results->generation );

     $test->run_time($end_time);
     $test->result($fail);
     $test->num_todo($todo);
     $test->elapsed( $end_time - $start_time );

     $test->parser($parser);

     if ($fail) {
         $test->total_failures( $test->total_failures + 1 );
         $test->last_fail_time($end_time);
     }
     else {
         $test->total_passes( $test->total_passes + 1 );
         $test->last_pass_time($end_time);
     }
 }

 =head3 C<save>

 Write the state to a file.

 =cut

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

     my $store = $self->{store} or return;
     $self->results->last_run_time( $self->get_time );

     my $writer = TAP::Parser::YAMLish::Writer->new;
     local *FH;
     open FH, ">$store" or croak "Can't write $store ($!)";
     $writer->write( $self->results->raw, \*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 ($!)";

     # XXX this is temporary
     $self->{_} = $self->result_class->new(
         $reader->read(
             sub {
                 my $line = <FH>;
                 defined $line && chomp $line;
                 return $line;
             }
         )
     );

     # $writer->write( $self->{tests} || {}, \*FH );
     close FH;
     $self->_regen_seq;
     $self->_prune_and_stamp;
     $self->results->generation( $self->results->generation + 1 );
 }

 sub _prune_and_stamp {
     my $self = shift;

     my $results = $self->results;
     my @tests   = $self->results->tests;
     for my $test (@tests) {
         my $name = $test->name;
         if ( my @stat = stat $name ) {
             $test->mtime( $stat[9] );
         }
         else {
             $results->remove($name);
         }
     }
 }

 sub _regen_seq {
     my $self = shift;
     for my $test ( $self->results->tests ) {
         $self->{seq} = $test->sequence + 1
           if defined $test->sequence && $test->sequence >= $self->{seq};
     }
 }

 1;
	package App::Prove::State;

	use strict;
	use vars qw($VERSION @ISA);

	use File::Find;
	use File::Spec;
	use Carp;

	use App::Prove::State::Result;
	use TAP::Parser::YAMLish::Reader ();
	use TAP::Parser::YAMLish::Writer ();
	use TAP::Base;

	BEGIN {
	@ISA = qw( TAP::Base );
	__PACKAGE__->mk_methods('result_class');
	}

	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.23

	=cut

	$VERSION = '3.23';

	=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>

	Accepts a hashref with the following key/value pairs:

	=over 4

	=item * C<store>

	The filename of the data store holding the data that App::Prove::State reads.

	=item * C<extensions> (optional)

	The test name extensions. Defaults to C<.t>.

	=item * C<result_class> (optional)

	The name of the C<result_class>. Defaults to C<App::Prove::State::Result>.

	=back

	=cut

	# override TAP::Base::new:
	sub new {
	my $class = shift;
	my %args = %{ shift \|\| {} };

	my $self = bless {
	select => [],
	seq => 1,
	store => delete $args{store},
	extensions => ( delete $args{extensions} \|\| ['.t'] ),
	result_class => ( delete $args{result_class} \|\| 'App::Prove::State::Result' ),
	}, $class;

	$self->{_} = $self->result_class->new(
	{ tests => {},
	generation => 1,
	}
	);
	my $store = $self->{store};
	$self->load($store)
	if defined $store && -f $store;

	return $self;
	}

	=head2 C<result_class>

	Getter/setter for the name of the class used for tracking test results. This
	class should either subclass from C<App::Prove::State::Result> or provide an
	identical interface.

	=cut

	=head2 C<extensions>

	Get or set the list of extensions that files must have in order to be
	considered tests. Defaults to ['.t'].

	=cut

	sub extensions {
	my $self = shift;
	$self->{extensions} = shift if @_;
	return $self->{extensions};
	}

	=head2 C<results>

	Get the results of the last test run. Returns a C<result_class()> instance.

	=cut

	sub results {
	my $self = shift;
	$self->{_} \|\| $self->result_class->new;
	}

	=head2 C<commit>

	Save the test results. Should be called after all tests have run.

	=cut

	sub commit {
	my $self = shift;
	if ( $self->{should_save} ) {
	$self->save;
	}
	}

	=head2 Instance Methods

	=head3 C<apply_switch>

	$self->apply_switch('failed,save');

	Apply a list of switch options to the state, updating the internal
	object state as a result. Nothing is returned.

	Diagnostics:
	- "Illegal state option: %s"

	=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->results->generation - 1;
	my $last_run_time = $self->results->last_run_time;
	my $now = $self->get_time;

	my @switches = map { split /,/ } @opts;

	my %handler = (
	last => sub {
	$self->_select(
	where => sub { $_->generation >= $last_gen },
	order => sub { $_->sequence }
	);
	},
	failed => sub {
	$self->_select(
	where => sub { $_->result != 0 },
	order => sub { -$_->result }
	);
	},
	passed => sub {
	$self->_select( where => sub { $_->result == 0 } );
	},
	all => sub {
	$self->_select();
	},
	todo => sub {
	$self->_select(
	where => sub { $_->num_todo != 0 },
	order => sub { -$_->num_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 { -$_->mtime } );
	},
	old => sub {
	$self->_select( order => sub { $_->mtime } );
	},
	fresh => sub {
	$self->_select( where => sub { $_->mtime >= $last_run_time } );
	},
	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);
	}
	return;
	}

	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} } ) {
	@argv = $recurse ? '.' : 't';
	croak qq{No tests named and '@argv' directory not found}
	unless -d $argv[0];
	}

	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 $self->results->num_tests;
	return map { $self->_query_clause($_) } @sel;
	}
	return;
	}

	sub _query_clause {
	my ( $self, $clause ) = @_;
	my @got;
	my $results = $self->results;
	my $where = $clause->{where} \|\| sub {1};

	# Select
	for my $name ( $results->test_names ) {
	next unless -f $name;
	local $_ = $results->test($name);
	push @got, $name 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 $_ = $results->test($_); $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;
	my $extensions = $self->{extensions};

	for my $arg (@argv) {
	if ( '-' eq $arg ) {
	push @argv => <STDIN>;
	chomp(@argv);
	next;
	}

	push @tests,
	sort -d $arg
	? $recurse
	? $self->_expand_dir_recursive( $arg, $extensions )
	: map { glob( File::Spec->catfile( $arg, "*$_" ) ) } @{$extensions}
	: $arg;
	}
	return @tests;
	}

	sub _expand_dir_recursive {
	my ( $self, $dir, $extensions ) = @_;

	my @tests;
	my $ext_string = join( '\|', map { quotemeta } @{$extensions} );

	find(
	{ follow => 1, #21938
	follow_skip => 2,
	wanted => sub {
	-f
	&& /(?:$ext_string)$/
	&& push @tests => $File::Find::name;
	}
	},
	$dir
	);
	return @tests;
	}

	=head3 C<observe_test>

	Store the results of a test.

	=cut

	# Store:
	# last fail time
	# last pass time
	# last run time
	# most recent result
	# most recent todos
	# total failures
	# total passes
	# state generation
	# parser

	sub observe_test {

	my ( $self, $test_info, $parser ) = @_;
	my $name = $test_info->[0];
	my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 );
	my $todo = scalar( $parser->todo );
	my $start_time = $parser->start_time;
	my $end_time = $parser->end_time,

	my $test = $self->results->test($name);

	$test->sequence( $self->{seq}++ );
	$test->generation( $self->results->generation );

	$test->run_time($end_time);
	$test->result($fail);
	$test->num_todo($todo);
	$test->elapsed( $end_time - $start_time );

	$test->parser($parser);

	if ($fail) {
	$test->total_failures( $test->total_failures + 1 );
	$test->last_fail_time($end_time);
	}
	else {
	$test->total_passes( $test->total_passes + 1 );
	$test->last_pass_time($end_time);
	}
	}

	=head3 C<save>

	Write the state to a file.

	=cut

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

	my $store = $self->{store} or return;
	$self->results->last_run_time( $self->get_time );

	my $writer = TAP::Parser::YAMLish::Writer->new;
	local *FH;
	open FH, ">$store" or croak "Can't write $store ($!)";
	$writer->write( $self->results->raw, \*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 ($!)";

	# XXX this is temporary
	$self->{_} = $self->result_class->new(
	$reader->read(
	sub {
	my $line = <FH>;
	defined $line && chomp $line;
	return $line;
	}
	)
	);

	# $writer->write( $self->{tests} \|\| {}, \*FH );
	close FH;
	$self->_regen_seq;
	$self->_prune_and_stamp;
	$self->results->generation( $self->results->generation + 1 );
	}

	sub _prune_and_stamp {
	my $self = shift;

	my $results = $self->results;
	my @tests = $self->results->tests;
	for my $test (@tests) {
	my $name = $test->name;
	if ( my @stat = stat $name ) {
	$test->mtime( $stat[9] );
	}
	else {
	$results->remove($name);
	}
	}
	}

	sub _regen_seq {
	my $self = shift;
	for my $test ( $self->results->tests ) {
	$self->{seq} = $test->sequence + 1
	if defined $test->sequence && $test->sequence >= $self->{seq};
	}
	}

	1;