X-Git-Url: https://vcs.maemo.org/git/?a=blobdiff_plain;ds=sidebyside;f=dev%2Fi386%2Flibtest-harness-perl%2Flibtest-harness-perl-3.12%2Flib%2FApp%2FProve%2FState.pm;fp=dev%2Fi386%2Flibtest-harness-perl%2Flibtest-harness-perl-3.12%2Flib%2FApp%2FProve%2FState.pm;h=7da4425807ec0664c041eaa42984cf550d5dff49;hb=8977e561d8a9eae6959218b0306c9df2056a38a9;hp=0000000000000000000000000000000000000000;hpb=df794b845212301ea0d267c919232538bfef356a;p=dh-make-perl

diff --git a/dev/i386/libtest-harness-perl/libtest-harness-perl-3.12/lib/App/Prove/State.pm b/dev/i386/libtest-harness-perl/libtest-harness-perl-3.12/lib/App/Prove/State.pm
new file mode 100644
index 0000000..7da4425
--- /dev/null
+++ b/dev/i386/libtest-harness-perl/libtest-harness-perl-3.12/lib/App/Prove/State.pm
@@ -0,0 +1,438 @@
+package App::Prove::State;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use File::Find;
+use File::Spec;
+use Carp;
+use TAP::Parser::YAMLish::Reader ();
+use TAP::Parser::YAMLish::Writer ();
+use TAP::Base;
+
+@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<prove> command.
+
+=head1 VERSION
+
+Version 3.12
+
+=cut
+
+$VERSION = '3.12';
+
+=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
+
+# override TAP::Base::new:
+sub new {
+    my $class = shift;
+    my %args = %{ shift || {} };
+
+    my $self = bless {
+        _ => {
+            tests      => {},
+            generation => 1
+        },
+        select    => [],
+        seq       => 1,
+        store     => delete $args{store},
+        extension => delete $args{extension} || '.t',
+    }, $class;
+
+    my $store = $self->{store};
+    $self->load($store)
+      if defined $store && -f $store;
+
+    return $self;
+}
+
+=head2 C<extension>
+
+Get or set the extension files must have in order to be considered
+tests. Defaults to '.t'.
+
+=cut
+
+sub extension {
+    my $self = shift;
+    $self->{extension} = shift if @_;
+    return $self->{extension};
+}
+
+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 { -$_->{mtime} } );
+        },
+        old => sub {
+            $self->_select( order => sub { $_->{mtime} } );
+        },
+        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} } ) {
+        @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 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 ) {
+        next unless -f $test;
+        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;
+    my $extension = $self->{extension};
+
+    for my $arg (@argv) {
+        if ( '-' eq $arg ) {
+            push @argv => <STDIN>;
+            chomp(@argv);
+            next;
+        }
+
+        push @tests,
+            sort -d $arg
+          ? $recurse
+              ? $self->_expand_dir_recursive( $arg, $extension )
+              : glob( File::Spec->catfile( $arg, "*$extension" ) )
+          : $arg;
+    }
+    return @tests;
+}
+
+sub _expand_dir_recursive {
+    my ( $self, $dir, $extension ) = @_;
+
+    my @tests;
+    find(
+        {   follow => 1,      #21938
+            wanted => sub {
+                -f 
+                  && /\Q$extension\E$/
+                  && 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->_prune_and_stamp;
+    $self->{_}->{generation}++;
+}
+
+sub _prune_and_stamp {
+    my $self = shift;
+    for my $name ( keys %{ $self->{_}->{tests} || {} } ) {
+        if ( my @stat = stat $name ) {
+            $self->{_}->{tests}->{$name}->{mtime} = $stat[9];
+        }
+        else {
+            delete $self->{_}->{tests}->{$name};
+        }
+    }
+}
+
+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};
+    }
+}