Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Tagging 3.03, version bump

  • Loading branch information...
commit e6a3cd902328a01101bcb93e5ce66caf924415df 1 parent e5eb02c
Andy Armstrong AndyA authored
5 Changes
View
@@ -1,8 +1,11 @@
Revision history for Test-Harness
-NEXT
+3.03 2007-11-17
- Fixed some little bugs-waiting-to-happen inside
TAP::Parser::Grammar.
+ - Added parser_args callback to TAP::Harness.
+ - Made @INC propagation even more compatible with 2.64 so that
+ parrot still works *and* #30796 is fixed.
3.02 2007-11-15
- Process I/O now unbuffered, uses sysread, plays better with
29 META.yml
View
@@ -1,7 +1,6 @@
---
name: Test-Harness
version: 3.03
-
author:
- 'Andy Armstrong C<< <andy@hexten.net> >>'
abstract: Run Perl standard test scripts with statistics
@@ -20,115 +19,87 @@ provides:
App::Prove:
file: lib/App/Prove.pm
version: 3.03
-
TAP::Base:
file: lib/TAP/Base.pm
version: 3.03
-
TAP::Formatter::Color:
file: lib/TAP/Formatter/Color.pm
version: 3.03
-
TAP::Formatter::Console:
file: lib/TAP/Formatter/Console.pm
version: 3.03
-
TAP::Formatter::Console::ParallelSession:
file: lib/TAP/Formatter/Console/ParallelSession.pm
version: 3.03
-
TAP::Formatter::Console::Session:
file: lib/TAP/Formatter/Console/Session.pm
version: 3.03
-
TAP::Harness:
file: lib/TAP/Harness.pm
version: 3.03
-
TAP::Parser:
file: lib/TAP/Parser.pm
version: 3.03
-
TAP::Parser::Aggregator:
file: lib/TAP/Parser/Aggregator.pm
version: 3.03
-
TAP::Parser::Grammar:
file: lib/TAP/Parser/Grammar.pm
version: 3.03
-
TAP::Parser::Iterator:
file: lib/TAP/Parser/Iterator.pm
version: 3.03
-
TAP::Parser::Iterator::Array:
file: lib/TAP/Parser/Iterator/Array.pm
version: 3.03
-
TAP::Parser::Iterator::Process:
file: lib/TAP/Parser/Iterator/Process.pm
version: 3.03
-
TAP::Parser::Iterator::Stream:
file: lib/TAP/Parser/Iterator/Stream.pm
version: 3.03
-
TAP::Parser::Multiplexer:
file: lib/TAP/Parser/Multiplexer.pm
version: 3.03
-
TAP::Parser::Result:
file: lib/TAP/Parser/Result.pm
version: 3.03
-
TAP::Parser::Result::Bailout:
file: lib/TAP/Parser/Result/Bailout.pm
version: 3.03
-
TAP::Parser::Result::Comment:
file: lib/TAP/Parser/Result/Comment.pm
version: 3.03
-
TAP::Parser::Result::Plan:
file: lib/TAP/Parser/Result/Plan.pm
version: 3.03
-
TAP::Parser::Result::Test:
file: lib/TAP/Parser/Result/Test.pm
version: 3.03
-
TAP::Parser::Result::Unknown:
file: lib/TAP/Parser/Result/Unknown.pm
version: 3.03
-
TAP::Parser::Result::Version:
file: lib/TAP/Parser/Result/Version.pm
version: 3.03
-
TAP::Parser::Result::YAML:
file: lib/TAP/Parser/Result/YAML.pm
version: 3.03
-
TAP::Parser::Source:
file: lib/TAP/Parser/Source.pm
version: 3.03
-
TAP::Parser::Source::Perl:
file: lib/TAP/Parser/Source/Perl.pm
version: 3.03
-
TAP::Parser::YAMLish::Reader:
file: lib/TAP/Parser/YAMLish/Reader.pm
version: 3.03
-
TAP::Parser::YAMLish::Writer:
file: lib/TAP/Parser/YAMLish/Writer.pm
version: 3.03
-
Test::Harness:
file: lib/Test/Harness.pm
version: 3.03
-
generated_by: Module::Build version 0.2808
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.2.html
5 lib/TAP/Harness.pm
View
@@ -222,6 +222,7 @@ Any keys for which the value is C<undef> will be ignored.
{
my @legal_callback = qw(
+ parser_args
made_parser
before_runtests
after_runtests
@@ -535,7 +536,9 @@ overridden in subclasses.
sub make_parser {
my ( $self, $test ) = @_;
- my $parser = TAP::Parser->new( $self->_get_parser_args($test) );
+ my $args = $self->_get_parser_args($test);
+ $self->_make_callback( 'parser_args', $test, $args );
+ my $parser = TAP::Parser->new($args);
$self->_make_callback( 'made_parser', $parser );
my $session = $self->formatter->open_test( $test, $parser );
68 lib/TAP/Parser/Source/Perl.pm
View
@@ -189,6 +189,64 @@ sub _libs2switches {
return map {"-I$_"} grep {$_} @_;
}
+=head3 C<shebang>
+
+Get the shebang line for a script file.
+
+ my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
+
+May be called as a class method
+
+=cut
+
+{
+
+ # Global shebang cache.
+ my %shebang_for;
+
+ sub _read_shebang {
+ my $file = shift;
+ local *TEST;
+ my $shebang;
+ if ( open( TEST, $file ) ) {
+ $shebang = <TEST>;
+ close(TEST) or print "Can't close $file. $!\n";
+ }
+ else {
+ print "Can't open $file. $!\n";
+ }
+ return $shebang;
+ }
+
+ sub shebang {
+ my ( $class, $file ) = @_;
+ unless ( exists $shebang_for{$file} ) {
+ $shebang_for{$file} = _read_shebang($file);
+ }
+ return $shebang_for{$file};
+ }
+}
+
+=head3 C<get_taint>
+
+Decode any taint switches from a Perl shebang line.
+
+ # $taint will be 't'
+ my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
+
+ # $untaint will be undefined
+ my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
+
+=cut
+
+sub get_taint {
+ my ( $class, $shebang ) = @_;
+ return
+ unless defined $shebang
+ && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
+ return $1;
+}
+
sub _switches {
my $self = shift;
my $file = $self->source_file;
@@ -196,15 +254,11 @@ sub _switches {
$self->switches,
);
- local *TEST;
- open( TEST, $file ) or print "can't open $file. $!\n";
- my $shebang = <TEST>;
- close(TEST) or print "can't close $file. $!\n";
-
+ my $shebang = $self->shebang($file);
return unless defined $shebang;
- my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
- push @switches, "-$1" if $taint;
+ my $taint = $self->get_taint($shebang);
+ push @switches, "-$taint" if defined $taint;
# Quote the argument if there's any whitespace in it, or if
# we're VMS, since VMS requires all parms quoted. Also, don't quote
21 lib/Test/Harness.pm
View
@@ -7,8 +7,9 @@ use strict;
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
use constant IS_VMS => ( $^O eq 'VMS' );
-use TAP::Harness ();
-use TAP::Parser::Aggregator ();
+use TAP::Harness ();
+use TAP::Parser::Aggregator ();
+use TAP::Parser::Source::Perl ();
use Config;
use Exporter;
@@ -108,6 +109,12 @@ one of the messages in the DIAGNOSTICS section.
=cut
+sub _has_taint {
+ my $test = shift;
+ return TAP::Parser::Source::Perl->get_taint(
+ TAP::Parser::Source::Perl->shebang($test) );
+}
+
sub _aggregate {
my ( $harness, $aggregate, @tests ) = @_;
@@ -125,6 +132,16 @@ sub _aggregate {
my $path_pat = qr{$path_sep};
my @extra_inc = _filtered_inc();
+ # Supply -I switches in taint mode
+ $harness->callback(
+ parser_args => sub {
+ my ( $test, $args ) = @_;
+ if ( _has_taint($test) ) {
+ push @{ $args->{switches} }, map {"-I$_"} _filtered_inc();
+ }
+ }
+ );
+
my $previous = $ENV{PERL5LIB};
local $ENV{PERL5LIB};
4 t/harness.t
View
@@ -299,7 +299,7 @@ foreach my $test_args ( get_arg_sets() ) {
my @callback_log = ();
- for my $evt (qw(made_parser before_runtests after_runtests)) {
+ for my $evt (qw(parser_args made_parser before_runtests after_runtests)) {
$harness->callback(
$evt => sub {
push @callback_log, $evt;
@@ -363,7 +363,7 @@ foreach my $test_args ( get_arg_sets() ) {
cmp_ok( $callback_count, '==', 1, 'callback called once' );
is_deeply(
\@callback_log,
- [ 'before_runtests', 'made_parser', 'after_runtests' ],
+ [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ],
'callback log matches'
);
isa_ok $parser, 'TAP::Parser';
2  t/parse.t
View
@@ -519,7 +519,7 @@ END_TAP
is @die, 1, 'coverage testing for _initialize';
- like pop @die, qr/PANIC: could not determine stream at/,
+ like pop @die, qr/PANIC:\s+could not determine stream at/,
'...and it failed as expected';
@die = ();
Please sign in to comment.
Something went wrong with that request. Please try again.