diff options
author | Karl Berry <karl@freefriends.org> | 2015-04-26 22:16:26 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2015-04-26 22:16:26 +0000 |
commit | 342e672574c4e67d510e46ab6acd0e21a7d0cf54 (patch) | |
tree | 79e04202d08c0404bbd780bd26c1e34710e539b6 /Master/tlpkg/tlperl/lib/TAP | |
parent | be2706af7c57a0ef0f4d4e9f684ca4ef74922a82 (diff) |
(tl)perl 5.20.2 for windows, from siep
git-svn-id: svn://tug.org/texlive/trunk@37064 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/TAP')
45 files changed, 1033 insertions, 390 deletions
diff --git a/Master/tlpkg/tlperl/lib/TAP/Base.pm b/Master/tlpkg/tlperl/lib/TAP/Base.pm index ff8da427c8b..02f8b5e48ce 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Base.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Base.pm @@ -1,11 +1,9 @@ package TAP::Base; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Object; - -@ISA = qw(TAP::Object); +use base 'TAP::Object'; =head1 NAME @@ -14,11 +12,11 @@ and L<TAP::Harness> =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; use constant GOT_TIME_HIRES => do { eval 'use Time::HiRes qw(time);'; @@ -29,10 +27,7 @@ use constant GOT_TIME_HIRES => do { package TAP::Whatever; - use TAP::Base; - - use vars qw($VERSION @ISA); - @ISA = qw(TAP::Base); + use base 'TAP::Base'; # ... later ... diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm index af7b3fca304..1bb357d9bd0 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Base.pm @@ -1,17 +1,14 @@ package TAP::Formatter::Base; use strict; -use TAP::Base (); +use warnings; +use base 'TAP::Base'; use POSIX qw(strftime); -use vars qw($VERSION @ISA); - my $MAX_ERRORS = 5; my %VALIDATION_FOR; BEGIN { - @ISA = qw(TAP::Base); - %VALIDATION_FOR = ( directives => sub { shift; shift }, verbosity => sub { shift; shift }, @@ -61,11 +58,11 @@ TAP::Formatter::Base - Base class for harness output delegates =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Color.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Color.pm index 16d6f79d45f..d22752e12ee 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Formatter/Color.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Color.pm @@ -1,11 +1,11 @@ package TAP::Formatter::Color; use strict; -use vars qw($VERSION @ISA); +use warnings; use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); -@ISA = qw(TAP::Object); +use base 'TAP::Object'; my $NO_COLOR; @@ -71,11 +71,11 @@ TAP::Formatter::Color - Run Perl test scripts with color =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Console.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console.pm index 0a9115f9e48..5ac9fa1a16e 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Formatter/Console.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console.pm @@ -1,24 +1,21 @@ package TAP::Formatter::Console; use strict; -use TAP::Formatter::Base (); +use warnings; +use base 'TAP::Formatter::Base'; use POSIX qw(strftime); -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Formatter::Base); - =head1 NAME TAP::Formatter::Console - Harness output delegate for default console output =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION @@ -70,16 +67,28 @@ sub _set_colors { } } +sub _failure_color { + my ($self) = @_; + + return $ENV{'HARNESS_SUMMARY_COLOR_FAIL'} || 'red'; +} + +sub _success_color { + my ($self) = @_; + + return $ENV{'HARNESS_SUMMARY_COLOR_SUCCESS'} || 'green'; +} + sub _output_success { my ( $self, $msg ) = @_; - $self->_set_colors('green'); + $self->_set_colors( $self->_success_color() ); $self->_output($msg); $self->_set_colors('reset'); } sub _failure_output { my $self = shift; - $self->_set_colors('red'); + $self->_set_colors( $self->_failure_color() ); my $out = join '', @_; my $has_newline = chomp $out; $self->_output($out); diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm index 873903988d0..f9cd7af5964 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm @@ -1,15 +1,14 @@ package TAP::Formatter::Console::ParallelSession; use strict; +use warnings; use File::Spec; use File::Path; -use TAP::Formatter::Console::Session; use Carp; -use constant WIDTH => 72; # Because Eric says -use vars qw($VERSION @ISA); +use base 'TAP::Formatter::Console::Session'; -@ISA = qw(TAP::Formatter::Console::Session); +use constant WIDTH => 72; # Because Eric says my %shared; @@ -42,11 +41,11 @@ TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/Session.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/Session.pm index f5b3dc12295..16ce97153d9 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/Session.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/Session.pm @@ -1,11 +1,9 @@ package TAP::Formatter::Console::Session; use strict; -use TAP::Formatter::Session; +use warnings; -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Formatter::Session); +use base 'TAP::Formatter::Session'; my @ACCESSOR; @@ -28,11 +26,11 @@ TAP::Formatter::Console::Session - Harness output delegate for default console o =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/File.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/File.pm index 8d94a2cff7a..2e72d914ba8 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Formatter/File.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/File.pm @@ -1,13 +1,11 @@ package TAP::Formatter::File; use strict; -use TAP::Formatter::Base (); +use warnings; use TAP::Formatter::File::Session; use POSIX qw(strftime); -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Formatter::Base); +use base 'TAP::Formatter::Base'; =head1 NAME @@ -15,11 +13,11 @@ TAP::Formatter::File - Harness output delegate for file output =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/File/Session.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/File/Session.pm index 9b61cab3670..4719f22b1b6 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Formatter/File/Session.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/File/Session.pm @@ -1,11 +1,8 @@ package TAP::Formatter::File::Session; use strict; -use TAP::Formatter::Session; - -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Formatter::Session); +use warnings; +use base 'TAP::Formatter::Session'; =head1 NAME @@ -13,11 +10,11 @@ TAP::Formatter::File::Session - Harness output delegate for file output =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Session.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Session.pm index 081ca9aec95..120b4953c36 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Formatter/Session.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Session.pm @@ -1,11 +1,9 @@ package TAP::Formatter::Session; use strict; -use TAP::Base; +use warnings; -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Base); +use base 'TAP::Base'; my @ACCESSOR; @@ -25,11 +23,11 @@ TAP::Formatter::Session - Abstract base class for harness output delegate =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 METHODS diff --git a/Master/tlpkg/tlperl/lib/TAP/Harness.pm b/Master/tlpkg/tlperl/lib/TAP/Harness.pm index c60d1d98014..53d8d18bea6 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Harness.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Harness.pm @@ -1,17 +1,14 @@ package TAP::Harness; use strict; +use warnings; use Carp; use File::Spec; use File::Path; use IO::Handle; -use TAP::Base; - -use vars qw($VERSION @ISA); - -@ISA = qw(TAP::Base); +use base 'TAP::Base'; =head1 NAME @@ -19,11 +16,11 @@ TAP::Harness - Run test scripts with statistics =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; $ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_VERSION} = $VERSION; @@ -248,7 +245,7 @@ I<NEW to 3.18>. If set, C<sources> must be a hashref containing the names of the L<TAP::Parser::SourceHandler>s to load and/or configure. The values are a -hash of configuration that will be accessible to to the source handlers via +hash of configuration that will be accessible to the source handlers via L<TAP::Parser::Source/config_for>. For example: @@ -330,20 +327,37 @@ run only one test at a time. =item * C<rules> -A reference to a hash of rules that control which tests may be -executed in parallel. This is an experimental feature and the -interface may change. - - $harness->rules( - { par => [ - { seq => '../ext/DB_File/t/*' }, - { seq => '../ext/IO_Compress_Zlib/t/*' }, - { seq => '../lib/CPANPLUS/*' }, - { seq => '../lib/ExtUtils/t/*' }, - '*' - ] - } - ); +A reference to a hash of rules that control which tests may be executed in +parallel. If no rules are declared, all tests are eligible for being run in +parallel. Here some simple examples. For the full details of the data structure +and the related glob-style pattern matching, see +L<TAP::Parser::Scheduler/"Rules data structure">. + + # Run all tests in sequence, except those starting with "p" + $harness->rules({ + par => 't/p*.t' + }); + + # Run all tests in parallel, except those starting with "p" + $harness->rules({ + seq => [ + { seq => 't/p*.t' }, + { par => '**' }, + ], + }); + + # Run some startup tests in sequence, then some parallel tests than some + # teardown tests in sequence. + $harness->rules({ + seq => [ + { seq => 't/startup/*.t' }, + { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], } + { seq => 't/shutdown/*.t' }, + ], + + }); + +This is an experimental feature and the interface may change. =item * C<stdout> diff --git a/Master/tlpkg/tlperl/lib/TAP/Harness/Beyond.pod b/Master/tlpkg/tlperl/lib/TAP/Harness/Beyond.pod new file mode 100644 index 00000000000..b70564ec956 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/TAP/Harness/Beyond.pod @@ -0,0 +1,422 @@ +=head1 NAME + +Test::Harness::Beyond - Beyond make test + +=head1 Beyond make test + +Test::Harness is responsible for running test scripts, analysing +their output and reporting success or failure. When I type +F<make test> (or F<./Build test>) for a module, Test::Harness is usually +used to run the tests (not all modules use Test::Harness but the +majority do). + +To start exploring some of the features of Test::Harness I need to +switch from F<make test> to the F<prove> command (which ships with +Test::Harness). For the following examples I'll also need a recent +version of Test::Harness installed; 3.14 is current as I write. + +For the examples I'm going to assume that we're working with a +'normal' Perl module distribution. Specifically I'll assume that +typing F<make> or F<./Build> causes the built, ready-to-install module +code to be available below ./blib/lib and ./blib/arch and that +there's a directory called 't' that contains our tests. Test::Harness +isn't hardwired to that configuration but it saves me from explaining +which files live where for each example. + +Back to F<prove>; like F<make test> it runs a test suite - but it +provides far more control over which tests are executed, in what +order and how their results are reported. Typically F<make test> +runs all the test scripts below the 't' directory. To do the same +thing with prove I type: + + prove -rb t + +The switches here are -r to recurse into any directories below 't' +and -b which adds ./blib/lib and ./blib/arch to Perl's include path +so that the tests can find the code they will be testing. If I'm +testing a module of which an earlier version is already installed +I need to be careful about the include path to make sure I'm not +running my tests against the installed version rather than the new +one that I'm working on. + +Unlike F<make test>, typing F<prove> doesn't automatically rebuild +my module. If I forget to make before prove I will be testing against +older versions of those files - which inevitably leads to confusion. +I either get into the habit of typing + + make && prove -rb t + +or - if I have no XS code that needs to be built I use the modules +below F<lib> instead + + prove -Ilib -r t + +So far I've shown you nothing that F<make test> doesn't do. Let's +fix that. + +=head2 Saved State + +If I have failing tests in a test suite that consists of more than +a handful of scripts and takes more than a few seconds to run it +rapidly becomes tedious to run the whole test suite repeatedly as +I track down the problems. + +I can tell prove just to run the tests that are failing like this: + + prove -b t/this_fails.t t/so_does_this.t + +That speeds things up but I have to make a note of which tests are +failing and make sure that I run those tests. Instead I can use +prove's --state switch and have it keep track of failing tests for +me. First I do a complete run of the test suite and tell prove to +save the results: + + prove -rb --state=save t + +That stores a machine readable summary of the test run in a file +called '.prove' in the current directory. If I have failures I can +then run just the failing scripts like this: + + prove -b --state=failed + +I can also tell prove to save the results again so that it updates +its idea of which tests failed: + + prove -b --state=failed,save + +As soon as one of my failing tests passes it will be removed from +the list of failed tests. Eventually I fix them all and prove can +find no failing tests to run: + + Files=0, Tests=0, 0 wallclock secs ( 0.00 usr + 0.00 sys = 0.00 CPU) + Result: NOTESTS + +As I work on a particular part of my module it's most likely that +the tests that cover that code will fail. I'd like to run the whole +test suite but have it prioritize these 'hot' tests. I can tell +prove to do this: + + prove -rb --state=hot,save t + +All the tests will run but those that failed most recently will be +run first. If no tests have failed since I started saving state all +tests will run in their normal order. This combines full test +coverage with early notification of failures. + +The --state switch supports a number of options; for example to run +failed tests first followed by all remaining tests ordered by the +timestamps of the test scripts - and save the results - I can use + + prove -rb --state=failed,new,save t + +See the prove documentation (type prove --man) for the full list +of state options. + +When I tell prove to save state it writes a file called '.prove' +('_prove' on Windows) in the current directory. It's a YAML document +so it's quite easy to write tools of your own that work on the saved +test state - but the format isn't officially documented so it might +change without (much) warning in the future. + +=head2 Parallel Testing + +If my tests take too long to run I may be able to speed them up by +running multiple test scripts in parallel. This is particularly +effective if the tests are I/O bound or if I have multiple CPU +cores. I tell prove to run my tests in parallel like this: + + prove -rb -j 9 t + +The -j switch enables parallel testing; the number that follows it +is the maximum number of tests to run in parallel. Sometimes tests +that pass when run sequentially will fail when run in parallel. For +example if two different test scripts use the same temporary file +or attempt to listen on the same socket I'll have problems running +them in parallel. If I see unexpected failures I need to check my +tests to work out which of them are trampling on the same resource +and rename temporary files or add locks as appropriate. + +To get the most performance benefit I want to have the test scripts +that take the longest to run start first - otherwise I'll be waiting +for the one test that takes nearly a minute to complete after all +the others are done. I can use the --state switch to run the tests +in slowest to fastest order: + + prove -rb -j 9 --state=slow,save t + +=head2 Non-Perl Tests + +The Test Anything Protocol (http://testanything.org/) isn't just +for Perl. Just about any language can be used to write tests that +output TAP. There are TAP based testing libraries for C, C++, PHP, +Python and many others. If I can't find a TAP library for my language +of choice it's easy to generate valid TAP. It looks like this: + + 1..3 + ok 1 - init OK + ok 2 - opened file + not ok 3 - appended to file + +The first line is the plan - it specifies the number of tests I'm +going to run so that it's easy to check that the test script didn't +exit before running all the expected tests. The following lines are +the test results - 'ok' for pass, 'not ok' for fail. Each test has +a number and, optionally, a description. And that's it. Any language +that can produce output like that on STDOUT can be used to write +tests. + +Recently I've been rekindling a two-decades-old interest in Forth. +Evidently I have a masochistic streak that even Perl can't satisfy. +I want to write tests in Forth and run them using prove (you can +find my gforth TAP experiments at +https://svn.hexten.net/andy/Forth/Testing/). I can use the --exec +switch to tell prove to run the tests using gforth like this: + + prove -r --exec gforth t + +Alternately, if the language used to write my tests allows a shebang +line I can use that to specify the interpreter. Here's a test written +in PHP: + + #!/usr/bin/php + <?php + print "1..2\n"; + print "ok 1\n"; + print "not ok 2\n"; + ?> + +If I save that as t/phptest.t the shebang line will ensure that it +runs correctly along with all my other tests. + +=head2 Mixing it up + +Subtle interdependencies between test programs can mask problems - +for example an earlier test may neglect to remove a temporary file +that affects the behaviour of a later test. To find this kind of +problem I use the --shuffle and --reverse options to run my tests +in random or reversed order. + +=head2 Rolling My Own + +If I need a feature that prove doesn't provide I can easily write my own. + +Typically you'll want to change how TAP gets I<input> into and I<output> +from the parser. L<App::Prove> supports arbitrary plugins, and L<TAP::Harness> +supports custom I<formatters> and I<source handlers> that you can load using +either L<prove> or L<Module::Build>; there are many examples to base mine on. +For more details see L<App::Prove>, L<TAP::Parser::SourceHandler>, and +L<TAP::Formatter::Base>. + +If writing a plugin is not enough, you can write your own test harness; one of +the motives for the 3.00 rewrite of Test::Harness was to make it easier to +subclass and extend. + +The Test::Harness module is a compatibility wrapper around TAP::Harness. +For new applications I should use TAP::Harness directly. As we'll +see, prove uses TAP::Harness. + +When I run prove it processes its arguments, figures out which test +scripts to run and then passes control to TAP::Harness to run the +tests, parse, analyse and present the results. By subclassing +TAP::Harness I can customise many aspects of the test run. + +I want to log my test results in a database so I can track them +over time. To do this I override the summary method in TAP::Harness. +I start with a simple prototype that dumps the results as a YAML +document: + + package My::TAP::Harness; + + use base 'TAP::Harness'; + use YAML; + + sub summary { + my ( $self, $aggregate ) = @_; + print Dump( $aggregate ); + $self->SUPER::summary( $aggregate ); + } + + 1; + +I need to tell prove to use my My::TAP::Harness. If My::TAP::Harness +is on Perl's @INC include path I can + + prove --harness=My::TAP::Harness -rb t + +If I don't have My::TAP::Harness installed on @INC I need to provide +the correct path to perl when I run prove: + + perl -Ilib `which prove` --harness=My::TAP::Harness -rb t + +I can incorporate these options into my own version of prove. It's +pretty simple. Most of the work of prove is handled by App::Prove. +The important code in prove is just: + + use App::Prove; + + my $app = App::Prove->new; + $app->process_args(@ARGV); + exit( $app->run ? 0 : 1 ); + +If I write a subclass of App::Prove I can customise any aspect of +the test runner while inheriting all of prove's behaviour. Here's +myprove: + + #!/usr/bin/env perl use lib qw( lib ); # Add ./lib to @INC + use App::Prove; + + my $app = App::Prove->new; + + # Use custom TAP::Harness subclass + $app->harness( 'My::TAP::Harness' ); + + $app->process_args( @ARGV ); exit( $app->run ? 0 : 1 ); + +Now I can run my tests like this + + ./myprove -rb t + +=head2 Deeper Customisation + +Now that I know how to subclass and replace TAP::Harness I can +replace any other part of the harness. To do that I need to know +which classes are responsible for which functionality. Here's a +brief guided tour; the default class for each component is shown +in parentheses. Normally any replacements I write will be subclasses +of these default classes. + +When I run my tests TAP::Harness creates a scheduler +(TAP::Parser::Scheduler) to work out the running order for the +tests, an aggregator (TAP::Parser::Aggregator) to collect and analyse +the test results and a formatter (TAP::Formatter::Console) to display +those results. + +If I'm running my tests in parallel there may also be a multiplexer +(TAP::Parser::Multiplexer) - the component that allows multiple +tests to run simultaneously. + +Once it has created those helpers TAP::Harness starts running the +tests. For each test it creates a new parser (TAP::Parser) which +is responsible for running the test script and parsing its output. + +To replace any of these components I call one of these harness +methods with the name of the replacement class: + + aggregator_class + formatter_class + multiplexer_class + parser_class + scheduler_class + +For example, to replace the aggregator I would + + $harness->aggregator_class( 'My::Aggregator' ); + +Alternately I can supply the names of my substitute classes to the +TAP::Harness constructor: + + my $harness = TAP::Harness->new( + { aggregator_class => 'My::Aggregator' } + ); + +If I need to reach even deeper into the internals of the harness I +can replace the classes that TAP::Parser uses to execute test scripts +and tokenise their output. Before running a test script TAP::Parser +creates a grammar (TAP::Parser::Grammar) to decode the raw TAP into +tokens, a result factory (TAP::Parser::ResultFactory) to turn the +decoded TAP results into objects and, depending on whether it's +running a test script or reading TAP from a file, scalar or array +a source or an iterator (TAP::Parser::IteratorFactory). + +Each of these objects may be replaced by calling one of these parser +methods: + + source_class + perl_source_class + grammar_class + iterator_factory_class + result_factory_class + +=head2 Callbacks + +As an alternative to subclassing the components I need to change I +can attach callbacks to the default classes. TAP::Harness exposes +these callbacks: + + parser_args Tweak the parameters used to create the parser + made_parser Just made a new parser + before_runtests About to run tests + after_runtests Have run all tests + after_test Have run an individual test script + +TAP::Parser also supports callbacks; bailout, comment, plan, test, +unknown, version and yaml are called for the corresponding TAP +result types, ALL is called for all results, ELSE is called for all +results for which a named callback is not installed and EOF is +called once at the end of each TAP stream. + +To install a callback I pass the name of the callback and a subroutine +reference to TAP::Harness or TAP::Parser's callback method: + + $harness->callback( after_test => sub { + my ( $script, $desc, $parser ) = @_; + } ); + +I can also pass callbacks to the constructor: + + my $harness = TAP::Harness->new({ + callbacks => { + after_test => sub { + my ( $script, $desc, $parser ) = @_; + # Do something interesting here + } + } + }); + +When it comes to altering the behaviour of the test harness there's +more than one way to do it. Which way is best depends on my +requirements. In general if I only want to observe test execution +without changing the harness' behaviour (for example to log test +results to a database) I choose callbacks. If I want to make the +harness behave differently subclassing gives me more control. + +=head2 Parsing TAP + +Perhaps I don't need a complete test harness. If I already have a +TAP test log that I need to parse all I need is TAP::Parser and the +various classes it depends upon. Here's the code I need to run a +test and parse its TAP output + + use TAP::Parser; + + my $parser = TAP::Parser->new( { source => 't/simple.t' } ); + while ( my $result = $parser->next ) { + print $result->as_string, "\n"; + } + +Alternately I can pass an open filehandle as source and have the +parser read from that rather than attempting to run a test script: + + open my $tap, '<', 'tests.tap' + or die "Can't read TAP transcript ($!)\n"; + my $parser = TAP::Parser->new( { source => $tap } ); + while ( my $result = $parser->next ) { + print $result->as_string, "\n"; + } + +This approach is useful if I need to convert my TAP based test +results into some other representation. See TAP::Convert::TET +(http://search.cpan.org/dist/TAP-Convert-TET/) for an example of +this approach. + +=head2 Getting Support + +The Test::Harness developers hang out on the tapx-dev mailing +list[1]. For discussion of general, language independent TAP issues +there's the tap-l[2] list. Finally there's a wiki dedicated to the +Test Anything Protocol[3]. Contributions to the wiki, patches and +suggestions are all welcome. + +[1] L<http://www.hexten.net/mailman/listinfo/tapx-dev> +[2] L<http://testanything.org/mailman/listinfo/tap-l> +[3] L<http://testanything.org/> diff --git a/Master/tlpkg/tlperl/lib/TAP/Harness/Env.pm b/Master/tlpkg/tlperl/lib/TAP/Harness/Env.pm new file mode 100644 index 00000000000..1a9d7196c40 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/TAP/Harness/Env.pm @@ -0,0 +1,149 @@ +package TAP::Harness::Env; + +use strict; +use warnings; + +use constant IS_VMS => ( $^O eq 'VMS' ); +use TAP::Object; +use Text::ParseWords qw/shellwords/; + +our $VERSION = '3.30'; + +# Get the parts of @INC which are changed from the stock list AND +# preserve reordering of stock directories. +sub _filtered_inc_vms { + my @inc = grep { !ref } @INC; #28567 + + # VMS has a 255-byte limit on the length of %ENV entries, so + # toss the ones that involve perl_root, the install location + @inc = grep { !/perl_root/i } @inc; + + my @default_inc = _default_inc(); + + my @new_inc; + my %seen; + for my $dir (@inc) { + next if $seen{$dir}++; + + if ( $dir eq ( $default_inc[0] || '' ) ) { + shift @default_inc; + } + else { + push @new_inc, $dir; + } + + shift @default_inc while @default_inc and $seen{ $default_inc[0] }; + } + return @new_inc; +} + +# Cache this to avoid repeatedly shelling out to Perl. +my @inc; + +sub _default_inc { + return @inc if @inc; + + local $ENV{PERL5LIB}; + local $ENV{PERLLIB}; + + my $perl = $ENV{HARNESS_PERL} || $^X; + + # Avoid using -l for the benefit of Perl 6 + chomp( @inc = `"$perl" -e "print join qq[\\n], \@INC, q[]"` ); + return @inc; +} + +sub create { + my $package = shift; + my %input = %{ shift || {} }; + + my @libs = @{ delete $input{libs} || [] }; + my @raw_switches = @{ delete $input{switches} || [] }; + my @opt + = ( @raw_switches, shellwords( $ENV{HARNESS_PERL_SWITCHES} || '' ) ); + my @switches; + while ( my $opt = shift @opt ) { + if ( $opt =~ /^ -I (.*) $ /x ) { + push @libs, length($1) ? $1 : shift @opt; + } + else { + push @switches, $opt; + } + } + + # Do things the old way on VMS... + push @libs, _filtered_inc_vms() if IS_VMS; + + # If $Verbose isn't numeric default to 1. This helps core. + my $verbose + = $ENV{HARNESS_VERBOSE} + ? $ENV{HARNESS_VERBOSE} !~ /\d/ + ? 1 + : $ENV{HARNESS_VERBOSE} + : 0; + + my %args = ( + lib => \@libs, + timer => $ENV{HARNESS_TIMER} || 0, + switches => \@switches, + color => $ENV{HARNESS_COLOR} || 0, + verbosity => $verbose, + ignore_exit => $ENV{HARNESS_IGNORE_EXIT} || 0, + ); + + my $class = $ENV{HARNESS_SUBCLASS} || 'TAP::Harness'; + if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) { + for my $opt ( split /:/, $env_opt ) { + if ( $opt =~ /^j(\d*)$/ ) { + $args{jobs} = $1 || 9; + } + elsif ( $opt eq 'c' ) { + $args{color} = 1; + } + elsif ( $opt =~ m/^f(.*)$/ ) { + my $fmt = $1; + $fmt =~ s/-/::/g; + $args{formatter_class} = $fmt; + } + elsif ( $opt =~ m/^a(.*)$/ ) { + my $archive = $1; + $class = 'TAP::Harness::Archive'; + $args{archive} = $archive; + } + else { + die "Unknown HARNESS_OPTIONS item: $opt\n"; + } + } + } + return TAP::Object->_construct($class, { %args, %input }); +} + +1; + +=head1 NAME + +TAP::Harness::Env - Parsing harness related environmental variables where appropriate + +=head1 VERSION + +Version 3.30 + +=head1 SYNOPSIS + + my ($class, $args) = get_test_arguments(); + require_module($class); + $class->new($args); + +=head1 DESCRIPTION + +This module implements the environmental variables that L<Test::Harness> for use with TAP::Harness. + +=head1 FUNCTIONS + +=over 4 + +=item * get_test_options( \%args ) + +This function reads the environment and generates an appropriate argument hash from it. If given any arguments, there will override the environmental defaults. It will return of C<$class> and C<$args>. + +=back diff --git a/Master/tlpkg/tlperl/lib/TAP/Object.pm b/Master/tlpkg/tlperl/lib/TAP/Object.pm index 6d0bc308217..21c53dc06a8 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Object.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Object.pm @@ -1,7 +1,7 @@ package TAP::Object; use strict; -use vars qw($VERSION); +use warnings; =head1 NAME @@ -9,22 +9,19 @@ TAP::Object - Base class that provides common functionality to all C<TAP::*> mod =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS package TAP::Whatever; use strict; - use vars qw(@ISA); - use TAP::Object; - - @ISA = qw(TAP::Object); + use base 'TAP::Object'; # new() implementation by TAP::Object sub _initialize { @@ -127,7 +124,7 @@ sub _construct { unless ( $class->can('new') ) { local $@; eval "require $class"; - $self->_croak("Can't load $class") if $@; + $self->_croak("Can't load $class: $@") if $@; } return $class->new(@args); diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser.pm b/Master/tlpkg/tlperl/lib/TAP/Parser.pm index 95909032418..1ebb0db969c 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser.pm @@ -1,9 +1,8 @@ package TAP::Parser; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Base (); use TAP::Parser::Grammar (); use TAP::Parser::Result (); use TAP::Parser::ResultFactory (); @@ -18,17 +17,21 @@ use TAP::Parser::SourceHandler::Handle (); use Carp qw( confess ); +use base 'TAP::Base'; + +=encoding utf8 + =head1 NAME TAP::Parser - Parse L<TAP|Test::Harness::TAP> output =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; my $DEFAULT_TAP_VERSION = 12; my $MAX_TAP_VERSION = 13; @@ -42,8 +45,6 @@ END { } BEGIN { # making accessors - @ISA = qw(TAP::Base); - __PACKAGE__->mk_methods( qw( _iterator @@ -174,7 +175,7 @@ I<NEW to 3.18>. If set, C<sources> must be a hashref containing the names of the L<TAP::Parser::SourceHandler>s to load and/or configure. The values are a -hash of configuration that will be accessible to to the source handlers via +hash of configuration that will be accessible to the source handlers via L<TAP::Parser::Source/config_for>. For example: @@ -638,7 +639,7 @@ C<$result> object. Returns a list of pragmas each of which is a + or - followed by the pragma name. - + =head2 C<comment> methods if ( $result->is_comment ) { ... } @@ -795,7 +796,11 @@ but had a TODO directive, it will be counted as a passed test. =cut -sub passed { @{ shift->{passed} } } +sub passed { + return @{ $_[0]->{passed} } + if ref $_[0]->{passed}; + return wantarray ? 1 .. $_[0]->{passed} : $_[0]->{passed}; +} =head3 C<failed> @@ -822,7 +827,11 @@ regardless of whether or not a TODO directive was found. =cut -sub actual_passed { @{ shift->{actual_passed} } } +sub actual_passed { + return @{ $_[0]->{actual_passed} } + if ref $_[0]->{actual_passed}; + return wantarray ? 1 .. $_[0]->{actual_passed} : $_[0]->{actual_passed}; +} *actual_ok = \&actual_passed; =head3 C<actual_ok> @@ -1496,6 +1505,17 @@ sub _finish { } $self->is_good_plan(0) unless defined $self->is_good_plan; + + unless ( $self->parse_errors ) { + # Optimise storage where possible + if ( $self->tests_run == @{$self->{passed}} ) { + $self->{passed} = $self->tests_run; + } + if ( $self->tests_run == @{$self->{actual_passed}} ) { + $self->{actual_passed} = $self->tests_run; + } + } + return $self; } @@ -1745,7 +1765,7 @@ so without sub-classing C<TAP::Parser> by setting L</iterator_factory_class>. If you just need to customize the objects on creation, subclass L<TAP::Parser> and override L</make_iterator_factory>. -Note that L</make_source> & L</make_perl_source> have been I<DEPRECATED> and +Note that C<make_source> & C<make_perl_source> have been I<DEPRECATED> and are now removed. =head3 Iterators diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm index d2836e552cb..ee4befd3fa3 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Aggregator.pm @@ -1,12 +1,10 @@ package TAP::Parser::Aggregator; use strict; +use warnings; use Benchmark; -use vars qw($VERSION @ISA); -use TAP::Object (); - -@ISA = qw(TAP::Object); +use base 'TAP::Object'; =head1 NAME @@ -14,11 +12,11 @@ TAP::Parser::Aggregator - Aggregate TAP::Parser results =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm index aba4c66086b..fe1b9adba2e 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Grammar.pm @@ -1,13 +1,12 @@ package TAP::Parser::Grammar; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Object (); use TAP::Parser::ResultFactory (); use TAP::Parser::YAMLish::Reader (); -@ISA = qw(TAP::Object); +use base 'TAP::Object'; =head1 NAME @@ -15,11 +14,11 @@ TAP::Parser::Grammar - A grammar for the Test Anything Protocol. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS @@ -405,7 +404,10 @@ sub _make_test_token { my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_; return { ok => $ok, - test_num => $num, + + # forcing this to be an integer (and not a string) reduces memory + # consumption. RT #84939 + test_num => ( defined $num ? 0 + $num : undef ), description => _trim($desc), directive => ( defined $dir ? uc $dir : '' ), explanation => _trim($explanation), diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm index aebcb94a5f4..886f5f4656b 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator.pm @@ -1,11 +1,9 @@ package TAP::Parser::Iterator; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Object (); - -@ISA = qw(TAP::Object); +use base 'TAP::Object'; =head1 NAME @@ -13,18 +11,17 @@ TAP::Parser::Iterator - Base class for TAP source iterators =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS # to subclass: - use vars qw(@ISA); use TAP::Parser::Iterator (); - @ISA = qw(TAP::Parser::Iterator); + use base 'TAP::Parser::Iterator'; sub _initialize { # see TAP::Object... } diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm index a3bb6621e7a..929b1004585 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Array.pm @@ -1,11 +1,9 @@ package TAP::Parser::Iterator::Array; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Parser::Iterator (); - -@ISA = 'TAP::Parser::Iterator'; +use base 'TAP::Parser::Iterator'; =head1 NAME @@ -13,11 +11,11 @@ TAP::Parser::Iterator::Array - Iterator for array-based TAP sources =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Process.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Process.pm index 8f43f0a45bc..aaf6b6cf61a 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Process.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Process.pm @@ -1,13 +1,12 @@ package TAP::Parser::Iterator::Process; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Parser::Iterator (); use Config; use IO::Handle; -@ISA = 'TAP::Parser::Iterator'; +use base 'TAP::Parser::Iterator'; my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ ); @@ -17,11 +16,11 @@ TAP::Parser::Iterator::Process - Iterator for process-based TAP sources =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS @@ -79,7 +78,7 @@ Get the exit status for this iterator's process. { - local $^W; # no warnings + no warnings 'uninitialized'; # get around a catch22 in the test suite that causes failures on Win32: local $SIG{__DIE__} = undef; eval { require POSIX; &POSIX::WEXITSTATUS(0) }; @@ -138,7 +137,7 @@ sub _initialize { # HOTPATCH {{{ my $xclose = \&IPC::Open3::xclose; - local $^W; # no warnings + no warnings; local *IPC::Open3::xclose = sub { my $fh = shift; no strict 'refs'; @@ -158,9 +157,7 @@ sub _initialize { }; die "Could not execute (@command): $@" if $@; if ( $] >= 5.006 ) { - - # Kludge to avoid warning under 5.5 - eval 'binmode($out, ":crlf")'; + binmode($out, ":crlf"); } } else { diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm index 1d045744103..9181fc7ae79 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Iterator/Stream.pm @@ -1,11 +1,9 @@ package TAP::Parser::Iterator::Stream; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Parser::Iterator (); - -@ISA = 'TAP::Parser::Iterator'; +use base 'TAP::Parser::Iterator'; =head1 NAME @@ -13,11 +11,11 @@ TAP::Parser::Iterator::Stream - Iterator for filehandle-based TAP sources =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm index cda251e8d72..8b75724fd8e 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/IteratorFactory.pm @@ -1,14 +1,12 @@ package TAP::Parser::IteratorFactory; use strict; -use vars qw($VERSION @ISA); - -use TAP::Object (); +use warnings; use Carp qw( confess ); use File::Basename qw( fileparse ); -@ISA = qw(TAP::Object); +use base 'TAP::Object'; use constant handlers => []; @@ -18,11 +16,11 @@ TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use fo =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS @@ -302,11 +300,8 @@ But in case you find the need to... package MyIteratorFactory; use strict; - use vars '@ISA'; - - use TAP::Parser::IteratorFactory; - @ISA = qw( TAP::Parser::IteratorFactory ); + use base 'TAP::Parser::IteratorFactory'; # override source detection algorithm sub detect_source { diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm index a3a23dae757..65cd46de13e 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Multiplexer.pm @@ -1,28 +1,27 @@ package TAP::Parser::Multiplexer; use strict; -use vars qw($VERSION @ISA); +use warnings; use IO::Select; -use TAP::Object (); + +use base 'TAP::Object'; use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/; use constant IS_VMS => $^O eq 'VMS'; use constant SELECT_OK => !( IS_VMS || IS_WIN32 ); -@ISA = 'TAP::Object'; - =head1 NAME TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm index a0caebe24ca..eaad1d2f41b 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result.pm @@ -1,11 +1,9 @@ package TAP::Parser::Result; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Object (); - -@ISA = 'TAP::Object'; +use base 'TAP::Object'; BEGIN { @@ -26,11 +24,11 @@ TAP::Parser::Result - Base class for TAP::Parser output objects =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS @@ -274,9 +272,8 @@ subclass L<TAP::Parser::Grammar> too, or else it'll never get used. package MyResult; use strict; - use vars '@ISA'; - @ISA = 'TAP::Parser::Result'; + use base 'TAP::Parser::Result'; # register with the factory: TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm index 14bef6c9ade..2ae35d6e603 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Bailout.pm @@ -1,10 +1,9 @@ package TAP::Parser::Result::Bailout; use strict; +use warnings; -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; +use base 'TAP::Parser::Result'; =head1 NAME @@ -12,11 +11,11 @@ TAP::Parser::Result::Bailout - Bailout result token. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm index 8a2cb934de5..d69ec5189c2 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Comment.pm @@ -1,10 +1,9 @@ package TAP::Parser::Result::Comment; use strict; +use warnings; -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; +use base 'TAP::Parser::Result'; =head1 NAME @@ -12,11 +11,11 @@ TAP::Parser::Result::Comment - Comment result token. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm index b515e61c99a..d85243c9766 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Plan.pm @@ -1,10 +1,9 @@ package TAP::Parser::Result::Plan; use strict; +use warnings; -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; +use base 'TAP::Parser::Result'; =head1 NAME @@ -12,11 +11,11 @@ TAP::Parser::Result::Plan - Plan result token. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm index 0416e3a81f1..1479e8836cd 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Pragma.pm @@ -1,10 +1,9 @@ package TAP::Parser::Result::Pragma; use strict; +use warnings; -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; +use base 'TAP::Parser::Result'; =head1 NAME @@ -12,11 +11,11 @@ TAP::Parser::Result::Pragma - TAP pragma token. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm index b977f71d9ba..749f26cbe2b 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Test.pm @@ -1,12 +1,9 @@ package TAP::Parser::Result::Test; use strict; +use warnings; -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; - -use vars qw($VERSION); +use base 'TAP::Parser::Result'; =head1 NAME @@ -14,11 +11,11 @@ TAP::Parser::Result::Test - Test result token. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm index 0d0e58304b6..3e1a6112271 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Unknown.pm @@ -1,12 +1,9 @@ package TAP::Parser::Result::Unknown; use strict; +use warnings; -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; - -use vars qw($VERSION); +use base 'TAP::Parser::Result'; =head1 NAME @@ -14,11 +11,11 @@ TAP::Parser::Result::Unknown - Unknown result token. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm index 2380c43349e..8b08e33d063 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/Version.pm @@ -1,10 +1,9 @@ package TAP::Parser::Result::Version; use strict; +use warnings; -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; +use base 'TAP::Parser::Result'; =head1 NAME @@ -12,11 +11,11 @@ TAP::Parser::Result::Version - TAP syntax version token. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm index f92b43a78c7..a6f86e3c46d 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Result/YAML.pm @@ -1,10 +1,9 @@ package TAP::Parser::Result::YAML; use strict; +use warnings; -use vars qw($VERSION @ISA); -use TAP::Parser::Result; -@ISA = 'TAP::Parser::Result'; +use base 'TAP::Parser::Result'; =head1 NAME @@ -12,11 +11,11 @@ TAP::Parser::Result::YAML - YAML result token. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm index 729bf4fa6f4..65d31d25367 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/ResultFactory.pm @@ -1,9 +1,8 @@ package TAP::Parser::ResultFactory; use strict; -use vars qw($VERSION @ISA %CLASS_FOR); +use warnings; -use TAP::Object (); use TAP::Parser::Result::Bailout (); use TAP::Parser::Result::Comment (); use TAP::Parser::Result::Plan (); @@ -13,7 +12,7 @@ use TAP::Parser::Result::Unknown (); use TAP::Parser::Result::Version (); use TAP::Parser::Result::YAML (); -@ISA = 'TAP::Object'; +use base 'TAP::Object'; ############################################################################## @@ -30,11 +29,11 @@ TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head2 DESCRIPTION @@ -83,8 +82,7 @@ a completely new type, eg: # create a custom result type: package MyResult; use strict; - use vars qw(@ISA); - @ISA = 'TAP::Parser::Result'; + use base 'TAP::Parser::Result'; # register with the factory: TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); @@ -96,18 +94,16 @@ Your custom type should then be picked up automatically by the L<TAP::Parser>. =cut -BEGIN { - %CLASS_FOR = ( - plan => 'TAP::Parser::Result::Plan', - pragma => 'TAP::Parser::Result::Pragma', - test => 'TAP::Parser::Result::Test', - comment => 'TAP::Parser::Result::Comment', - bailout => 'TAP::Parser::Result::Bailout', - version => 'TAP::Parser::Result::Version', - unknown => 'TAP::Parser::Result::Unknown', - yaml => 'TAP::Parser::Result::YAML', - ); -} +our %CLASS_FOR = ( + plan => 'TAP::Parser::Result::Plan', + pragma => 'TAP::Parser::Result::Pragma', + test => 'TAP::Parser::Result::Test', + comment => 'TAP::Parser::Result::Comment', + bailout => 'TAP::Parser::Result::Bailout', + version => 'TAP::Parser::Result::Version', + unknown => 'TAP::Parser::Result::Unknown', + yaml => 'TAP::Parser::Result::YAML', +); sub class_for { my ( $class, $type ) = @_; @@ -166,12 +162,10 @@ Of course, it's up to you to decide whether or not to ignore them. package MyResultFactory; use strict; - use vars '@ISA'; use MyResult; - use TAP::Parser::ResultFactory; - @ISA = qw( TAP::Parser::ResultFactory ); + use base 'TAP::Parser::ResultFactory'; # force all results to be 'MyResult' sub class_for { diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm index f7a3e46c67b..7c5cedf7edc 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler.pm @@ -1,7 +1,8 @@ package TAP::Parser::Scheduler; use strict; -use vars qw($VERSION); +use warnings; + use Carp; use TAP::Parser::Scheduler::Job; use TAP::Parser::Scheduler::Spinner; @@ -12,11 +13,11 @@ TAP::Parser::Scheduler - Schedule tests during parallel testing =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS @@ -30,9 +31,98 @@ $VERSION = '3.26'; =head3 C<new> - my $sched = TAP::Parser::Scheduler->new; + my $sched = TAP::Parser::Scheduler->new(tests => \@tests); + my $sched = TAP::Parser::Scheduler->new( + tests => [ ['t/test_name.t','Test Description'], ... ], + rules => \%rules, + ); + +Given 'tests' and optional 'rules' as input, returns a new +C<TAP::Parser::Scheduler> object. Each member of C<@tests> should be either a +a test file name, or a two element arrayref, where the first element is a test +file name, and the second element is a test description. By default, we'll use +the test name as the description. + +The optional C<rules> attribute provides direction on which tests should be run +in parallel and which should be run sequentially. If no rule data structure is +provided, a default data structure is used which makes every test eligible to +be run in parallel: + + { par => '**' }, + +The rules data structure is documented more in the next section. + +=head2 Rules data structure + +The "C<rules>" data structure is the the heart of the scheduler. It allows you +to express simple rules like "run all tests in sequence" or "run all tests in +parallel except these five tests.". However, the rules structure also supports +glob-style pattern matching and recursive definitions, so you can also express +arbitarily complicated patterns. + +The rule must only have one top level key: either 'par' for "parallel" or 'seq' +for "sequence". + +Values must be either strings with possible glob-style matching, or arrayrefs +of strings or hashrefs which follow this pattern recursively. + +Every element in an arrayref directly below a 'par' key is eligible to be run +in parallel, while vavalues directly below a 'seq' key must be run in sequence. + +=head3 Rules examples + +Here are some examples: + + # All tests be run in parallel (the default rule) + { par => '**' }, + + # Run all tests in sequence, except those starting with "p" + { par => 't/p*.t' }, + + # Run all tests in parallel, except those starting with "p" + { + seq => [ + { seq => 't/p*.t' }, + { par => '**' }, + ], + } + + # Run some startup tests in sequence, then some parallel tests than some + # teardown tests in sequence. + { + seq => [ + { seq => 't/startup/*.t' }, + { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], } + { seq => 't/shutdown/*.t' }, + ], + }, -Returns a new C<TAP::Parser::Scheduler> object. + +=head3 Rules resolution + +=over4 + +=item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one. + +=item * "First match wins". The first rule that matches a test will be the one that applies. + +=item * Any test which does not match a rule will be run in sequence at the end of the run. + +=item * The existence of a rule does not imply selecting a test. You must still specify the tests to run. + +=item * Specifying a rule to allow tests to run in parallel does not make the run in parallel. You still need specify the number of parallel C<jobs> in your Harness object. + +=back + +=head3 Glob-style pattern matching for rules + +We implement our own glob-style pattern matching. Here are the patterns it supports: + + ** is any number of characters, including /, within a pathname + * is zero or more characters within a filename/directory name + ? is exactly one character within a filename/directory name + {foo,bar,baz} is any of foo, bar or baz. + \ is an escape character =cut @@ -70,6 +160,9 @@ sub new { sub _set_rules { my ( $self, $rules, $tests ) = @_; + + # Convert all incoming tests to job objects. + # If no test description is provided use the file name as the description. my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) } map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests; my $schedule = $self->_rule_clause( $rules, \@tests ); @@ -185,6 +278,8 @@ sub _expand { return @match; } +=head2 Instance Methods + =head3 C<get_all> Get a list of all remaining tests. @@ -207,9 +302,9 @@ sub _gather { =head3 C<get_job> -Return the next available job or C<undef> if none are available. Returns -a C<TAP::Parser::Scheduler::Spinner> if the scheduler still has pending -jobs but none are available to run right now. +Return the next available job as L<TAP::Parser::Scheduler::Job> object or +C<undef> if none are available. Returns a L<TAP::Parser::Scheduler::Spinner> if +the scheduler still has pending jobs but none are available to run right now. =cut @@ -281,9 +376,50 @@ sub _find_next_job { =head3 C<as_string> Return a human readable representation of the scheduling tree. +For example: + + my @tests = (qw{ + t/startup/foo.t + t/shutdown/foo.t + + t/a/foo.t t/b/foo.t t/c/foo.t t/d/foo.t + }); + my $sched = TAP::Parser::Scheduler->new( + tests => \@tests, + rules => { + seq => [ + { seq => 't/startup/*.t' }, + { par => ['t/a/*.t','t/b/*.t','t/c/*.t'] }, + { seq => 't/shutdown/*.t' }, + ], + }, + ); + +Produces: + + par: + seq: + par: + seq: + par: + seq: + 't/startup/foo.t' + par: + seq: + 't/a/foo.t' + seq: + 't/b/foo.t' + seq: + 't/c/foo.t' + par: + seq: + 't/shutdown/foo.t' + 't/d/foo.t' + =cut + sub as_string { my $self = shift; return $self->_as_string( $self->{schedule} ); diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm index bac5883f48f..6375a7b8786 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Job.pm @@ -1,7 +1,7 @@ package TAP::Parser::Scheduler::Job; use strict; -use vars qw($VERSION); +use warnings; use Carp; =head1 NAME @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Job - A single testing job. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS @@ -31,10 +31,11 @@ Represents a single test 'job'. =head3 C<new> my $job = TAP::Parser::Scheduler::Job->new( - $name, $desc + $filename, $description ); -Returns a new C<TAP::Parser::Scheduler::Job> object. +Given the filename and description of a test as scalars, returns a new +L<TAP::Parser::Scheduler::Job> object. =cut @@ -47,9 +48,14 @@ sub new { }, $class; } +=head2 Instance Methods + =head3 C<on_finish> -Register a closure to be called when this job is destroyed. + $self->on_finish(\&method). + +Register a closure to be called when this job is destroyed. The callback +will be passed the C<TAP::Parser::Scheduler::Job> object as it's only argument. =cut @@ -60,7 +66,10 @@ sub on_finish { =head3 C<finish> -Called when a job is complete to unlock it. + $self->finish; + +Called when a job is complete to unlock it. If a callback has been registered +with C<on_finish>, it calls it. Otherwise, it does nothing. =cut @@ -71,6 +80,15 @@ sub finish { } } +=head2 Attributes + + $self->filename; + $self->description; + $self->context; + +These are all "getters" which return the data set for these attributes during object construction. + + =head3 C<filename> =head3 C<description> @@ -96,6 +114,8 @@ sub as_array_ref { =head3 C<is_spinner> + $self->is_spinner; + Returns false indicating that this is a real job rather than a 'spinner'. Spinners are returned when the scheduler still has pending jobs but can't (because of locking) return one right now. diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Spinner.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Spinner.pm index 21d4d67647a..f590ea58f04 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Spinner.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Scheduler/Spinner.pm @@ -1,7 +1,7 @@ package TAP::Parser::Scheduler::Spinner; use strict; -use vars qw($VERSION); +use warnings; use Carp; =head1 NAME @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Spinner - A no-op job. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS @@ -34,12 +34,14 @@ return a real job. my $job = TAP::Parser::Scheduler::Spinner->new; -Returns a new C<TAP::Parser::Scheduler::Spinner> object. +Ignores any arguments and returns a new C<TAP::Parser::Scheduler::Spinner> object. =cut sub new { bless {}, shift } +=head2 Instance Methods + =head3 C<is_spinner> Returns true indicating that is a 'spinner' job. Spinners are returned @@ -50,4 +52,10 @@ return one right now. sub is_spinner {1} +=head1 SEE ALSO + +L<TAP::Parser::Scheduler>, L<TAP::Parser::Scheduler::Job> + +=cut + 1; diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm index 6eda5db839d..0e2da09f644 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Source.pm @@ -1,26 +1,24 @@ package TAP::Parser::Source; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Object (); use File::Basename qw( fileparse ); +use base 'TAP::Object'; use constant BLK_SIZE => 512; -@ISA = qw(TAP::Object); - =head1 NAME TAP::Parser::Source - a TAP source & meta data about it =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS @@ -329,7 +327,7 @@ May be called as a class method open my $fh, '<', $file or die "Can't read $file: $!\n"; # Might be a binary file - so read a fixed number of bytes. - my $got = read $fh, my $buf, BLK_SIZE; + my $got = read $fh, my ($buf), BLK_SIZE; defined $got or die "I/O error: $!\n"; return $1 if $buf =~ /(.*)/; return; diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler.pm index e8412ab309b..dc257e0ed9f 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler.pm @@ -1,12 +1,10 @@ package TAP::Parser::SourceHandler; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Object (); use TAP::Parser::Iterator (); - -@ISA = qw(TAP::Object); +use base 'TAP::Object'; =head1 NAME @@ -14,11 +12,11 @@ TAP::Parser::SourceHandler - Base class for different TAP source handlers =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS @@ -27,7 +25,7 @@ $VERSION = '3.26'; # must be sub-classed for use package MySourceHandler; - use base qw( TAP::Parser::SourceHandler ); + use base 'TAP::Parser::SourceHandler'; sub can_handle { return $confidence_level } sub make_iterator { return $iterator } @@ -105,7 +103,7 @@ a quick overview. Start by familiarizing yourself with L<TAP::Parser::Source> and L<TAP::Parser::IteratorFactory>. L<TAP::Parser::SourceHandler::RawTAP> is -the easiest sub-class to use an an example. +the easiest sub-class to use as an example. It's important to point out that if you want your subclass to be automatically used by L<TAP::Parser> you'll have to and make sure it gets loaded somehow. @@ -123,12 +121,11 @@ L<TAP::Parser::IteratorFactory/register_handler>. package MySourceHandler; use strict; - use vars '@ISA'; # compat with older perls use MySourceHandler; # see TAP::Parser::SourceHandler use TAP::Parser::IteratorFactory; - @ISA = qw( TAP::Parser::SourceHandler ); + use base 'TAP::Parser::SourceHandler'; TAP::Parser::IteratorFactory->register_handler( __PACKAGE__ ); diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Executable.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Executable.pm index f20e6514ab0..5522625d317 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Executable.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Executable.pm @@ -1,13 +1,12 @@ package TAP::Parser::SourceHandler::Executable; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Parser::SourceHandler (); use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Process (); -@ISA = qw(TAP::Parser::SourceHandler); +use base 'TAP::Parser::SourceHandler'; TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); @@ -17,11 +16,11 @@ TAP::Parser::SourceHandler::Executable - Stream output from an executable TAP so =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS @@ -156,12 +155,11 @@ Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. package MyRubySourceHandler; use strict; - use vars '@ISA'; use Carp qw( croak ); use TAP::Parser::SourceHandler::Executable; - @ISA = qw( TAP::Parser::SourceHandler::Executable ); + use base 'TAP::Parser::SourceHandler::Executable'; # expect $handler->(['mytest.rb', 'cmdline', 'args']); sub make_iterator { diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/File.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/File.pm index 1faacebe513..b48660fc782 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/File.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/File.pm @@ -1,13 +1,12 @@ package TAP::Parser::SourceHandler::File; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Parser::SourceHandler (); use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Stream (); -@ISA = qw(TAP::Parser::SourceHandler); +use base 'TAP::Parser::SourceHandler'; TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); @@ -17,11 +16,11 @@ TAP::Parser::SourceHandler::File - Stream TAP from a text file. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Handle.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Handle.pm index f0043471250..944fb2a9b37 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Handle.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Handle.pm @@ -1,13 +1,12 @@ package TAP::Parser::SourceHandler::Handle; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Parser::SourceHandler (); use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Stream (); -@ISA = qw(TAP::Parser::SourceHandler); +use base 'TAP::Parser::SourceHandler'; TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); @@ -17,11 +16,11 @@ TAP::Parser::SourceHandler::Handle - Stream TAP from an IO::Handle or a GLOB. =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Perl.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Perl.pm index 97eba8ebc17..1a1867b922d 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Perl.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/Perl.pm @@ -1,18 +1,17 @@ package TAP::Parser::SourceHandler::Perl; use strict; +use warnings; use Config; -use vars qw($VERSION @ISA); use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); use constant IS_VMS => ( $^O eq 'VMS' ); -use TAP::Parser::SourceHandler::Executable (); use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Process (); -use TAP::Parser::Utils qw( split_shell ); +use Text::ParseWords qw(shellwords); -@ISA = 'TAP::Parser::SourceHandler::Executable'; +use base 'TAP::Parser::SourceHandler::Executable'; TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); @@ -22,11 +21,11 @@ TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS @@ -152,18 +151,27 @@ sub make_iterator { $class->_run( $source, $libs, $switches ); } + +sub _has_taint_switch { + my( $class, $switches ) = @_; + + my $has_taint = grep { $_ eq "-T" || $_ eq "-t" } @{$switches}; + return $has_taint ? 1 : 0; +} + sub _mangle_switches { my ( $class, $libs, $switches ) = @_; # Taint mode ignores environment variables so we must retranslate # PERL5LIB as -I switches and place PERL5OPT on the command line # in order that it be seen. - if ( grep { $_ eq "-T" || $_ eq "-t" } @{$switches} ) { + if ( $class->_has_taint_switch($switches) ) { + my @perl5lib = defined $ENV{PERL5LIB} ? split /$Config{path_sep}/, $ENV{PERL5LIB} : (); return ( $libs, [ @{$switches}, - $class->_libs2switches($libs), - split_shell( $ENV{PERL5OPT} ) + $class->_libs2switches([@$libs, @perl5lib]), + defined $ENV{PERL5OPT} ? shellwords( $ENV{PERL5OPT} ) : () ], ); } @@ -200,10 +208,10 @@ sub _filter_libs { } sub _iterator_hooks { - my ( $class, $source, $libs ) = @_; + my ( $class, $source, $libs, $switches ) = @_; my $setup = sub { - if ( @{$libs} ) { + if ( @{$libs} and !$class->_has_taint_switch($switches) ) { $ENV{PERL5LIB} = join( $Config{path_sep}, grep {defined} @{$libs}, $ENV{PERL5LIB} @@ -211,8 +219,8 @@ sub _iterator_hooks { } }; - # Cargo culted from comments seen elsewhere about VMS / environment - # variables. I don't know if this is actually necessary. + # VMS environment variables aren't guaranteed to reset at the end of + # the process, so we need to put PERL5LIB back. my $previous = $ENV{PERL5LIB}; my $teardown = sub { if ( defined $previous ) { @@ -232,7 +240,7 @@ sub _run { my @command = $class->_get_command_for_switches( $source, $switches ) or $class->_croak("No command found!"); - my ( $setup, $teardown ) = $class->_iterator_hooks( $source, $libs ); + my ( $setup, $teardown ) = $class->_iterator_hooks( $source, $libs, $switches ); return $class->_create_iterator( $source, \@command, $setup, $teardown ); } @@ -333,11 +341,10 @@ Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. package MyPerlSourceHandler; use strict; - use vars '@ISA'; use TAP::Parser::SourceHandler::Perl; - @ISA = qw( TAP::Parser::SourceHandler::Perl ); + use base 'TAP::Parser::SourceHandler::Perl'; # use the version of perl from the shebang line in the test file sub get_perl { diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/RawTAP.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/RawTAP.pm index 04b4b9c2da1..627a1e1311a 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/RawTAP.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/SourceHandler/RawTAP.pm @@ -1,13 +1,12 @@ package TAP::Parser::SourceHandler::RawTAP; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Parser::SourceHandler (); use TAP::Parser::IteratorFactory (); use TAP::Parser::Iterator::Array (); -@ISA = qw(TAP::Parser::SourceHandler); +use base 'TAP::Parser::SourceHandler'; TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); @@ -17,11 +16,11 @@ TAP::Parser::SourceHandler::RawTAP - Stream output from raw TAP in a scalar/arra =head1 VERSION -Version 3.26 +Version 3.30 =cut -$VERSION = '3.26'; +our $VERSION = '3.30'; =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm deleted file mode 100644 index 2096b0ec4f1..00000000000 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Utils.pm +++ /dev/null @@ -1,72 +0,0 @@ -package TAP::Parser::Utils; - -use strict; -use Exporter; -use vars qw($VERSION @ISA @EXPORT_OK); - -@ISA = qw( Exporter ); -@EXPORT_OK = qw( split_shell ); - -=head1 NAME - -TAP::Parser::Utils - Internal TAP::Parser utilities - -=head1 VERSION - -Version 3.26 - -=cut - -$VERSION = '3.26'; - -=head1 SYNOPSIS - - use TAP::Parser::Utils qw( split_shell ) - my @switches = split_shell( $arg ); - -=head1 DESCRIPTION - -B<FOR INTERNAL USE ONLY!> - -=head2 INTERFACE - -=head3 C<split_shell> - -Shell style argument parsing. Handles backslash escaping, single and -double quoted strings but not shell substitutions. - -Pass one or more strings containing shell escaped arguments. The return -value is an array of arguments parsed from the input strings according -to (approximate) shell parsing rules. It's legal to pass C<undef> in -which case an empty array will be returned. That makes it possible to - - my @args = split_shell( $ENV{SOME_ENV_VAR} ); - -without worrying about whether the environment variable exists. - -This is used to split HARNESS_PERL_ARGS into individual switches. - -=cut - -sub split_shell { - my @parts = (); - - for my $switch ( grep defined && length, @_ ) { - push @parts, $1 while $switch =~ / - ( - (?: [^\\"'\s]+ - | \\. - | " (?: \\. | [^"] )* " - | ' (?: \\. | [^'] )* ' - )+ - ) /xg; - } - - for (@parts) { - s/ \\(.) | ['"] /defined $1 ? $1 : ''/exg; - } - - return @parts; -} - -1; diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm index ac2c455ef3e..8a61a4bfd92 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm @@ -1,12 +1,11 @@ package TAP::Parser::YAMLish::Reader; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Object (); +use base 'TAP::Object'; -@ISA = 'TAP::Object'; -$VERSION = '3.26'; +our $VERSION = '3.30'; # TODO: # Handle blessed object syntax @@ -270,7 +269,7 @@ TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator =head1 VERSION -Version 3.26 +Version 3.30 =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm index 9f20fb2c31b..811c190d124 100644 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm @@ -1,12 +1,11 @@ package TAP::Parser::YAMLish::Writer; use strict; -use vars qw($VERSION @ISA); +use warnings; -use TAP::Object (); +use base 'TAP::Object'; -@ISA = 'TAP::Object'; -$VERSION = '3.26'; +our $VERSION = '3.30'; my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x; my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; @@ -147,7 +146,7 @@ TAP::Parser::YAMLish::Writer - Write YAMLish data =head1 VERSION -Version 3.26 +Version 3.30 =head1 SYNOPSIS |