summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/App
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/App')
-rw-r--r--Master/tlpkg/tlperl/lib/App/Prove.pm157
-rw-r--r--Master/tlpkg/tlperl/lib/App/Prove/State.pm45
-rw-r--r--Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm6
-rw-r--r--Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm4
4 files changed, 137 insertions, 75 deletions
diff --git a/Master/tlpkg/tlperl/lib/App/Prove.pm b/Master/tlpkg/tlperl/lib/App/Prove.pm
index fd431ed2f05..0e74fb4cacb 100644
--- a/Master/tlpkg/tlperl/lib/App/Prove.pm
+++ b/Master/tlpkg/tlperl/lib/App/Prove.pm
@@ -17,11 +17,11 @@ App::Prove - Implements the C<prove> command.
=head1 VERSION
-Version 3.17
+Version 3.23
=cut
-$VERSION = '3.17';
+$VERSION = '3.23';
=head1 DESCRIPTION
@@ -58,8 +58,8 @@ BEGIN {
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 extension ignore_exit rules state_manager
- normalize
+ state_class test_args state dry extensions ignore_exit rules state_manager
+ normalize sources tapversion trap
);
__PACKAGE__->mk_methods(@ATTR);
}
@@ -81,8 +81,12 @@ 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 (qw( argv rc_opts includes modules state plugins rules )) {
+ for my $key (@is_array) {
$self->{$key} = [];
}
$self->{harness_class} = 'TAP::Harness';
@@ -197,49 +201,57 @@ sub process_args {
{
local @ARGV = @args;
- Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
+ 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' => \$self->{extension},
- 'harness=s' => \$self->{harness},
- 'ignore-exit' => \$self->{ignore_exit},
- '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},
+ '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
@@ -283,6 +295,8 @@ sub _get_args {
my %args;
+ $args{trap} = 1 if $self->trap;
+
if ( defined $self->color ? $self->color : $self->_color_default ) {
$args{color} = 1;
}
@@ -310,6 +324,11 @@ sub _get_args {
$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;
}
@@ -349,6 +368,8 @@ sub _get_args {
$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;
}
@@ -411,6 +432,42 @@ sub _load_extensions {
$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 =~ /(?<!\\)=/ ) {
+
+ # It's a hash option.
+ croak "Option $name must be consistently used as a hash"
+ if exists $config{$k} && ref $config{$k} ne 'HASH';
+ $config{$k} ||= {};
+ my ( $hk, $hv ) = split /(?<!\\)=/, $v, 2;
+ $config{$k}{$hk} = $hv;
+ }
+ else {
+ $v =~ s/\\=/=/g;
+ if ( exists $config{$k} ) {
+ $config{$k} = [ $config{$k} ]
+ unless ref $config{$k} eq 'ARRAY';
+ push @{ $config{$k} } => $v;
+ }
+ else {
+ $config{$k} = $v;
+ }
+ }
+ }
+ );
+ $self->{argv} = \@ARGV;
+ return ( $handler, \%config );
+}
+
=head3 C<run>
Perform whatever actions the command line args specified. The C<prove>
@@ -461,8 +518,8 @@ sub _get_tests {
my $self = shift;
my $state = $self->state_manager;
- my $ext = $self->extension;
- $state->extension($ext) if defined $ext;
+ my $ext = $self->extensions;
+ $state->extensions($ext) if defined $ext;
if ( defined( my $state_switch = $self->state ) ) {
$state->apply_switch(@$state_switch);
}
@@ -624,7 +681,7 @@ calling C<run>.
=item C<exec>
-=item C<extension>
+=item C<extensions>
=item C<failures>
@@ -686,6 +743,10 @@ calling C<run>.
=item C<warnings_warn>
+=item C<tapversion>
+
+=item C<trap>
+
=back
=head1 PLUGINS
diff --git a/Master/tlpkg/tlperl/lib/App/Prove/State.pm b/Master/tlpkg/tlperl/lib/App/Prove/State.pm
index 202f7aadd3b..91275b0cddd 100644
--- a/Master/tlpkg/tlperl/lib/App/Prove/State.pm
+++ b/Master/tlpkg/tlperl/lib/App/Prove/State.pm
@@ -26,11 +26,11 @@ App::Prove::State - State storage for the C<prove> command.
=head1 VERSION
-Version 3.17
+Version 3.23
=cut
-$VERSION = '3.17';
+$VERSION = '3.23';
=head1 DESCRIPTION
@@ -59,9 +59,9 @@ Accepts a hashref with the following key/value pairs:
The filename of the data store holding the data that App::Prove::State reads.
-=item * C<extension> (optional)
+=item * C<extensions> (optional)
-The test name extension. Defaults to C<.t>.
+The test name extensions. Defaults to C<.t>.
=item * C<result_class> (optional)
@@ -77,12 +77,11 @@ sub new {
my %args = %{ shift || {} };
my $self = bless {
- select => [],
- seq => 1,
- store => delete $args{store},
- extension => ( delete $args{extension} || '.t' ),
- result_class =>
- ( delete $args{result_class} || 'App::Prove::State::Result' ),
+ 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(
@@ -105,17 +104,17 @@ identical interface.
=cut
-=head2 C<extension>
+=head2 C<extensions>
-Get or set the extension files must have in order to be considered
-tests. Defaults to '.t'.
+Get or set the list of extensions that files must have in order to be
+considered tests. Defaults to ['.t'].
=cut
-sub extension {
+sub extensions {
my $self = shift;
- $self->{extension} = shift if @_;
- return $self->{extension};
+ $self->{extensions} = shift if @_;
+ return $self->{extensions};
}
=head2 C<results>
@@ -356,7 +355,7 @@ sub _get_raw_tests {
# Do globbing on Win32.
@argv = map { glob "$_" } @argv if NEED_GLOB;
- my $extension = $self->{extension};
+ my $extensions = $self->{extensions};
for my $arg (@argv) {
if ( '-' eq $arg ) {
@@ -368,23 +367,25 @@ sub _get_raw_tests {
push @tests,
sort -d $arg
? $recurse
- ? $self->_expand_dir_recursive( $arg, $extension )
- : glob( File::Spec->catfile( $arg, "*$extension" ) )
+ ? $self->_expand_dir_recursive( $arg, $extensions )
+ : map { glob( File::Spec->catfile( $arg, "*$_" ) ) } @{$extensions}
: $arg;
}
return @tests;
}
sub _expand_dir_recursive {
- my ( $self, $dir, $extension ) = @_;
+ my ( $self, $dir, $extensions ) = @_;
my @tests;
+ my $ext_string = join( '|', map { quotemeta } @{$extensions} );
+
find(
{ follow => 1, #21938
follow_skip => 2,
wanted => sub {
- -f
- && /\Q$extension\E$/
+ -f
+ && /(?:$ext_string)$/
&& push @tests => $File::Find::name;
}
},
diff --git a/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm b/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm
index 274676a62f9..6fb3aa8a094 100644
--- a/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm
+++ b/Master/tlpkg/tlperl/lib/App/Prove/State/Result.pm
@@ -14,11 +14,11 @@ App::Prove::State::Result - Individual test suite results.
=head1 VERSION
-Version 3.17
+Version 3.23
=cut
-$VERSION = '3.17';
+$VERSION = '3.23';
=head1 DESCRIPTION
@@ -223,7 +223,7 @@ sub raw {
my %raw = %$self;
my %tests;
- foreach my $test ( $self->tests ) {
+ for my $test ( $self->tests ) {
$tests{ $test->name } = $test->raw;
}
$raw{tests} = \%tests;
diff --git a/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm b/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm
index 231f78919e2..9aa3153a360 100644
--- a/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm
+++ b/Master/tlpkg/tlperl/lib/App/Prove/State/Result/Test.pm
@@ -10,11 +10,11 @@ App::Prove::State::Result::Test - Individual test results.
=head1 VERSION
-Version 3.17
+Version 3.23
=cut
-$VERSION = '3.17';
+$VERSION = '3.23';
=head1 DESCRIPTION