eaiovnaovbqoebvqoeavibavo Prove/State.pm000064400000026710147634435020007273 0ustar00package 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 command. =head1 VERSION Version 3.28 =cut $VERSION = '3.28'; =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=failed,save -rbv =cut =head1 METHODS =head2 Class Methods =head3 C Accepts a hashref with the following key/value pairs: =over 4 =item * C The filename of the data store holding the data that App::Prove::State reads. =item * C (optional) The test name extensions. Defaults to C<.t>. =item * C (optional) The name of the C. Defaults to C. =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 Getter/setter for the name of the class used for tracking test results. This class should either subclass from C or provide an identical interface. =cut =head2 C 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 Get the results of the last test run. Returns a C instance. =cut sub results { my $self = shift; $self->{_} || $self->result_class->new; } =head2 C 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 $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 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->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( limit => shift, where => sub { $_->generation >= $last_gen }, order => sub { $_->sequence } ); }, failed => sub { $self->_select( limit => shift, where => sub { $_->result != 0 }, order => sub { -$_->result } ); }, passed => sub { $self->_select( limit => shift, where => sub { $_->result == 0 } ); }, all => sub { $self->_select( limit => shift ); }, todo => sub { $self->_select( limit => shift, where => sub { $_->num_todo != 0 }, order => sub { -$_->num_todo; } ); }, hot => sub { $self->_select( limit => shift, where => sub { defined $_->last_fail_time }, order => sub { $now - $_->last_fail_time } ); }, slow => sub { $self->_select( limit => shift, order => sub { -$_->elapsed } ); }, fast => sub { $self->_select( limit => shift, order => sub { $_->elapsed } ); }, new => sub { $self->_select( limit => shift, order => sub { -$_->mtime } ); }, old => sub { $self->_select( limit => shift, order => sub { $_->mtime } ); }, fresh => sub { $self->_select( limit => shift, 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 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; } if ( my $limit = $clause->{limit} ) { @got = splice @got, 0, $limit if @got > $limit; } return @got; } sub _get_raw_tests { my $self = shift; my $recurse = shift; my @argv = @_; my @tests; # Do globbing on Win32. if (NEED_GLOB) { eval "use File::Glob::Windows"; # [49732] @argv = map { glob "$_" } @argv; } my $extensions = $self->{extensions}; for my $arg (@argv) { if ( '-' eq $arg ) { push @argv => ; 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 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 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 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 = ; 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; Prove/State/Result/Test.pm000064400000006540147634435020011467 0ustar00package App::Prove::State::Result::Test; use strict; use vars qw($VERSION); =head1 NAME App::Prove::State::Result::Test - Individual test results. =head1 VERSION Version 3.28 =cut $VERSION = '3.28'; =head1 DESCRIPTION The C command supports a C<--state> option that instructs it to store persistent state across runs. This module encapsulates the results for a single test. =head1 SYNOPSIS # Re-run failed tests $ prove --state=failed,save -rbv =cut my %methods = ( name => { method => 'name' }, elapsed => { method => 'elapsed', default => 0 }, gen => { method => 'generation', default => 1 }, last_pass_time => { method => 'last_pass_time', default => undef }, last_fail_time => { method => 'last_fail_time', default => undef }, last_result => { method => 'result', default => 0 }, last_run_time => { method => 'run_time', default => undef }, last_todo => { method => 'num_todo', default => 0 }, mtime => { method => 'mtime', default => undef }, seq => { method => 'sequence', default => 1 }, total_passes => { method => 'total_passes', default => 0 }, total_failures => { method => 'total_failures', default => 0 }, parser => { method => 'parser' }, ); while ( my ( $key, $description ) = each %methods ) { my $default = $description->{default}; no strict 'refs'; *{ $description->{method} } = sub { my $self = shift; if (@_) { $self->{$key} = shift; return $self; } return $self->{$key} || $default; }; } =head1 METHODS =head2 Class Methods =head3 C =cut sub new { my ( $class, $arg_for ) = @_; $arg_for ||= {}; bless $arg_for => $class; } =head2 Instance Methods =head3 C The name of the test. Usually a filename. =head3 C The total elapsed times the test took to run, in seconds from the epoch.. =head3 C The number for the "generation" of the test run. The first generation is 1 (one) and subsequent generations are 2, 3, etc. =head3 C The last time the test program passed, in seconds from the epoch. Returns C if the program has never passed. =head3 C The last time the test suite failed, in seconds from the epoch. Returns C if the program has never failed. =head3 C Returns the mtime of the test, in seconds from the epoch. =head3 C Returns a hashref of raw test data, suitable for serialization by YAML. =head3 C Currently, whether or not the test suite passed with no 'problems' (such as TODO passed). =head3 C The total time it took for the test to run, in seconds. If C is available, it will have finer granularity. =head3 C The number of tests with TODO directives. =head3 C The order in which this test was run for the given test suite result. =head3 C The number of times the test has passed. =head3 C The number of times the test has failed. =head3 C The underlying parser object. This is useful if you need the full information for the test program. =cut sub raw { my $self = shift; my %raw = %$self; # this is backwards-compatibility hack and is not guaranteed. delete $raw{name}; delete $raw{parser}; return \%raw; } 1; Prove/State/Result.pm000064400000011526147634435020010550 0ustar00package App::Prove::State::Result; use strict; use Carp 'croak'; use App::Prove::State::Result::Test; use vars qw($VERSION); use constant STATE_VERSION => 1; =head1 NAME App::Prove::State::Result - Individual test suite results. =head1 VERSION Version 3.28 =cut $VERSION = '3.28'; =head1 DESCRIPTION The C command supports a C<--state> option that instructs it to store persistent state across runs. This module encapsulates the results for a single test suite run. =head1 SYNOPSIS # Re-run failed tests $ prove --state=failed,save -rbv =cut =head1 METHODS =head2 Class Methods =head3 C my $result = App::Prove::State::Result->new({ generation => $generation, tests => \%tests, }); Returns a new C instance. =cut sub new { my ( $class, $arg_for ) = @_; $arg_for ||= {}; my %instance_data = %$arg_for; # shallow copy $instance_data{version} = $class->state_version; my $tests = delete $instance_data{tests} || {}; my $self = bless \%instance_data => $class; $self->_initialize($tests); return $self; } sub _initialize { my ( $self, $tests ) = @_; my %tests; while ( my ( $name, $test ) = each %$tests ) { $tests{$name} = $self->test_class->new( { %$test, name => $name } ); } $self->tests( \%tests ); return $self; } =head2 C Returns the current version of state storage. =cut sub state_version {STATE_VERSION} =head2 C Returns the name of the class used for tracking individual tests. This class should either subclass from C or provide an identical interface. =cut sub test_class { return 'App::Prove::State::Result::Test'; } my %methods = ( generation => { method => 'generation', default => 0 }, last_run_time => { method => 'last_run_time', default => undef }, ); while ( my ( $key, $description ) = each %methods ) { my $default = $description->{default}; no strict 'refs'; *{ $description->{method} } = sub { my $self = shift; if (@_) { $self->{$key} = shift; return $self; } return $self->{$key} || $default; }; } =head3 C Getter/setter for the "generation" of the test suite run. The first generation is 1 (one) and subsequent generations are 2, 3, etc. =head3 C Getter/setter for the time of the test suite run. =head3 C Returns the tests for a given generation. This is a hashref or a hash, depending on context called. The keys to the hash are the individual test names and the value is a hashref with various interesting values. Each k/v pair might resemble something like this: 't/foo.t' => { elapsed => '0.0428488254547119', gen => '7', last_pass_time => '1219328376.07815', last_result => '0', last_run_time => '1219328376.07815', last_todo => '0', mtime => '1191708862', seq => '192', total_passes => '6', } =cut sub tests { my $self = shift; if (@_) { $self->{tests} = shift; return $self; } my %tests = %{ $self->{tests} }; my @tests = sort { $a->sequence <=> $b->sequence } values %tests; return wantarray ? @tests : \@tests; } =head3 C my $test = $result->test('t/customer/create.t'); Returns an individual C instance for the given test name (usually the filename). Will return a new C instance if the name is not found. =cut sub test { my ( $self, $name ) = @_; croak("test() requires a test name") unless defined $name; my $tests = $self->{tests} ||= {}; if ( my $test = $tests->{$name} ) { return $test; } else { my $test = $self->test_class->new( { name => $name } ); $self->{tests}->{$name} = $test; return $test; } } =head3 C Returns an list of test names, sorted by run order. =cut sub test_names { my $self = shift; return map { $_->name } $self->tests; } =head3 C $result->remove($test_name); # remove the test my $test = $result->test($test_name); # fatal error Removes a given test from results. This is a no-op if the test name is not found. =cut sub remove { my ( $self, $name ) = @_; delete $self->{tests}->{$name}; return $self; } =head3 C Returns the number of tests for a given test suite result. =cut sub num_tests { keys %{ shift->{tests} } } =head3 C Returns a hashref of raw results, suitable for serialization by YAML. =cut sub raw { my $self = shift; my %raw = %$self; my %tests; for my $test ( $self->tests ) { $tests{ $test->name } = $test->raw; } $raw{tests} = \%tests; return \%raw; } 1; Prove.pm000064400000045357147634435020006223 0ustar00package App::Prove; use strict; use vars qw($VERSION @ISA); use TAP::Object (); use TAP::Harness; use TAP::Parser::Utils qw( split_shell ); use File::Spec; use Getopt::Long; use App::Prove::State; use Carp; =head1 NAME App::Prove - Implements the C command. =head1 VERSION Version 3.28 =cut $VERSION = '3.28'; =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 { @ISA = qw(TAP::Object); @ATTR = qw( archive argv blib show_count color directives exec failures comments 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 state_class test_args state dry extensions ignore_exit rules state_manager normalize sources tapversion trap ); __PACKAGE__->mk_methods(@ATTR); } =head1 METHODS =head2 Class Methods =head3 C Create a new C. Optionally a hash ref of attribute initializers may be passed. =cut # new() implementation supplied by TAP::Object sub _initialize { my $self = shift; my $args = shift || {}; my @is_array = qw( argv rc_opts includes modules state plugins rules sources ); # setup defaults: for my $key (@is_array) { $self->{$key} = []; } $self->{harness_class} = 'TAP::Harness'; for my $attr (@ATTR) { if ( exists $args->{$attr} ) { # TODO: Some validation here $self->{$attr} = $args->{$attr}; } } my %env_provides_default = ( HARNESS_TIMER => 'timer', ); while ( my ( $env, $attr ) = each %env_provides_default ) { $self->{$attr} = 1 if $ENV{$env}; } $self->state_class('App::Prove::State'); return $self; } =head3 C Getter/setter for the name of the class used for maintaining state. This class should either subclass from C or provide an identical interface. =head3 C Getter/setter for the instance of the C. =cut =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 { defined and not /^#/ } $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(qw(no_ignore_case bundling pass_through)); # Don't add coderefs to GetOptions GetOptions( 'v|verbose' => \$self->{verbose}, 'f|failures' => \$self->{failures}, 'o|comments' => \$self->{comments}, 'l|lib' => \$self->{lib}, 'b|blib' => \$self->{blib}, 's|shuffle' => \$self->{shuffle}, 'color!' => \$self->{color}, 'colour!' => \$self->{color}, 'count!' => \$self->{show_count}, 'c' => \$self->{color}, 'D|dry' => \$self->{dry}, 'ext=s@' => sub { my ( $opt, $val ) = @_; # Workaround for Getopt::Long 2.25 handling of # multivalue options push @{ $self->{extensions} ||= [] }, $val; }, 'harness=s' => \$self->{harness}, 'ignore-exit' => \$self->{ignore_exit}, 'source=s@' => $self->{sources}, 'formatter=s' => \$self->{formatter}, 'r|recurse' => \$self->{recurse}, 'reverse' => \$self->{backwards}, '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}, 'normalize' => \$self->{normalize}, 'rules=s@' => $self->{rules}, 'tapversion=s' => \$self->{tapversion}, 'trap' => \$self->{trap}, ) 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 _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 && !$ENV{HARNESS_NOTTY} && !IS_WIN32; } sub _get_args { my $self = shift; my %args; $args{trap} = 1 if $self->trap; if ( defined $self->color ? $self->color : $self->_color_default ) { $args{color} = 1; } if ( !defined $self->show_count ) { $args{show_count} = 1; } else { $args{show_count} = $self->show_count; } if ( $self->archive ) { $self->require_harness( archive => 'TAP::Harness::Archive' ); $args{archive} = $self->archive; } if ( my $jobs = $self->jobs ) { $args{jobs} = $jobs; } if ( my $harness_opt = $self->harness ) { $self->require_harness( harness => $harness_opt ); } if ( my $formatter = $self->formatter ) { $args{formatter_class} = $formatter; } for my $handler ( @{ $self->sources } ) { my ( $name, $config ) = $self->_parse_source($handler); $args{sources}->{$name} = $config; } if ( $self->ignore_exit ) { $args{ignore_exit} = 1; } 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 comments timer directives normalize )) { $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 ) ); $args{version} = $self->tapversion if defined( $self->tapversion ); if ( defined( my $test_args = $self->test_args ) ) { $args{test_args} = $test_args; } if ( @{ $self->rules } ) { my @rules; for ( @{ $self->rules } ) { if (/^par=(.*)/) { push @rules, $1; } elsif (/^seq=(.*)/) { push @rules, { seq => $1 }; } } $args{rules} = { par => [@rules] }; } 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 ); eval "require $name"; return $name unless $@; } eval "require $class"; return $class unless $@; return; } sub _load_extension { my ( $self, $name, @search ) = @_; my @args = (); if ( $name =~ /^(.*?)=(.*)/ ) { $name = $1; @args = split( /,/, $2 ); } if ( my $class = $self->_find_module( $name, @search ) ) { $class->import(@args); if ( $class->can('load') ) { $class->load( { app_prove => $self, args => [@args] } ); } } else { croak "Can't load module $name"; } } sub _load_extensions { my ( $self, $ext, @search ) = @_; $self->_load_extension( $_, @search ) for @$ext; } sub _parse_source { my ( $self, $handler ) = @_; # Load any options. ( my $opt_name = lc $handler ) =~ s/::/-/g; local @ARGV = @{ $self->{argv} }; my %config; Getopt::Long::GetOptions( "$opt_name-option=s%" => sub { my ( $name, $k, $v ) = @_; if ( $v =~ /(? $v; } else { $config{$k} = $v; } } } ); $self->{argv} = \@ARGV; return ( $handler, \%config ); } =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); exit( $app->run ? 0 : 1 ); # if you need the exit code =cut sub run { my $self = shift; unless ( $self->state_manager ) { $self->state_manager( $self->state_class->new( { store => STATE_FILE } ) ); } if ( $self->show_help ) { $self->_help(1); } elsif ( $self->show_man ) { $self->_help(2); } elsif ( $self->show_version ) { $self->print_version; } elsif ( $self->dry ) { print "$_\n" for $self->_get_tests; } else { $self->_load_extensions( $self->modules ); $self->_load_extensions( $self->plugins, PLUGINS ); local $ENV{TEST_VERBOSE} = 1 if $self->verbose; return $self->_runtests( $self->_get_args, $self->_get_tests ); } return 1; } sub _get_tests { my $self = shift; my $state = $self->state_manager; my $ext = $self->extensions; $state->extensions($ext) if defined $ext; 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; return @tests; } sub _runtests { my ( $self, $args, $harness_class, @tests ) = @_; my $harness = $harness_class->new($args); my $state = $self->state_manager; $harness->callback( after_test => sub { $state->observe_test(@_); } ); $harness->callback( after_runtests => sub { $state->commit(@_); } ); my $aggregator = $harness->runtests(@tests); return !$aggregator->has_errors; } 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'; } push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} ); 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 ) = @_; my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/; # Emulate Perl's -MModule=arg1,arg2 behaviour $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!; eval("use $class;"); die "$class_name is required to use the --$for feature: $@" if $@; $self->{harness_class} = $class_name; 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 =item C =item C =item C =item C =item C =item C =item C =item C =back =head1 PLUGINS C provides support for 3rd-party plugins. These are currently loaded at run-time, I arguments have been parsed (so you can not change the way arguments are processed, sorry), typically with the C<< -PI >> switch, eg: prove -PMyPlugin This will search for a module named C, or failing that, C. If the plugin can't be found, C will complain & exit. You can pass an argument to your plugin by appending an C<=> after the plugin name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas: prove -PMyPlugin=foo,bar,baz These are passed in to your plugin's C class method (if it has one), along with a reference to the C object that is invoking your plugin: sub load { my ($class, $p) = @_; my @args = @{ $p->{args} }; # @args will contain ( 'foo', 'bar', 'baz' ) $p->{app_prove}->do_something; ... } Note that the user's arguments are also passed to your plugin's C function as a list, eg: sub import { my ($class, @args) = @_; # @args will contain ( 'foo', 'bar', 'baz' ) ... } This is for backwards compatibility, and may be deprecated in the future. =head2 Sample Plugin Here's a sample plugin, for your reference: package App::Prove::Plugin::Foo; # Sample plugin, try running with: # prove -PFoo=bar -r -j3 # prove -PFoo -Q # prove -PFoo=bar,My::Formatter use strict; use warnings; sub load { my ($class, $p) = @_; my @args = @{ $p->{args} }; my $app = $p->{app_prove}; print "loading plugin: $class, args: ", join(', ', @args ), "\n"; # turn on verbosity $app->verbose( 1 ); # set the formatter? $app->formatter( $args[1] ) if @args > 1; # print some of App::Prove's state: for my $attr (qw( jobs quiet really_quiet recurse verbose )) { my $val = $app->$attr; $val = 'undef' unless defined( $val ); print "$attr: $val\n"; } return 1; } 1; =head1 SEE ALSO L, L =cut