--- /dev/null
+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} = \@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<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 ? \@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<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
--- /dev/null
+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<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};
+ }
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff