From 0742a875cb39e5866421f54166e5e35beba8fc0d Mon Sep 17 00:00:00 2001 From: bulk88 Date: Sat, 28 Mar 2015 08:27:44 -0400 Subject: [PATCH 1/6] refetch output method only if going to output With 1 million tests processed, NYTProf shows this sub was called once for each test processed, but the print block only executed 1600 times. So dont compute the output method name, and dont fetch the current test number, if we aren't going to use it. --- lib/TAP/Formatter/Console/Session.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/TAP/Formatter/Console/Session.pm b/lib/TAP/Formatter/Console/Session.pm index 6280f857..7e8ff3da 100644 --- a/lib/TAP/Formatter/Console/Session.pm +++ b/lib/TAP/Formatter/Console/Session.pm @@ -128,10 +128,8 @@ sub _closures { my $planned = $parser->tests_planned || '?'; $plan = "/$planned "; } - $output = $formatter->_get_output_method($parser); if ( $show_count and $is_test ) { - my $number = $result->number; my $now = CORE::time; # Print status roughly once per second. @@ -139,6 +137,8 @@ sub _closures { # $last_status_printed starting with the value 0, which $now # will never be. (Unless someone sets their clock to 1970) if ( $last_status_printed != $now ) { + my $number = $result->number; + $output = $formatter->_get_output_method($parser); $formatter->$output("\r$pretty$number$plan"); $last_status_printed = $now; } From 6edcce11e4dbc46df299ba6152b1c7d7389fc1e8 Mon Sep 17 00:00:00 2001 From: bulk88 Date: Wed, 15 Apr 2015 05:16:32 +0200 Subject: [PATCH 2/6] revert "sort keys before iterating over them so we have deterministic behavior between runs" This partially reverts commit 4d4d3f079ca500b14b964f0f2e73606299ef706d. In "Unknown arguments to TAP::Harness::new" croak, sorting was kept, but moved into the branch where it is needed. --- lib/TAP/Harness.pm | 8 ++++---- lib/TAP/Parser.pm | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/TAP/Harness.pm b/lib/TAP/Harness.pm index 90f526de..b9156d45 100644 --- a/lib/TAP/Harness.pm +++ b/lib/TAP/Harness.pm @@ -87,7 +87,7 @@ BEGIN { trap => sub { shift; shift }, ); - for my $method ( sort keys %VALIDATION_FOR ) { + for my $method ( keys %VALIDATION_FOR ) { no strict 'refs'; if ( $method eq 'lib' || $method eq 'switches' ) { *{$method} = sub { @@ -432,7 +432,7 @@ Any keys for which the value is C will be ignored. $self->SUPER::_initialize( $arg_for, \@legal_callback ); my %arg_for = %$arg_for; # force a shallow copy - for my $name ( sort keys %VALIDATION_FOR ) { + for my $name ( keys %VALIDATION_FOR ) { my $property = delete $arg_for{$name}; if ( defined $property ) { my $validate = $VALIDATION_FOR{$name}; @@ -475,8 +475,8 @@ Any keys for which the value is C will be ignored. ); } - if ( my @props = sort keys %arg_for ) { - $self->_croak("Unknown arguments to TAP::Harness::new (@props)"); + if ( my @props = keys %arg_for ) { + $self->_croak('Unknown arguments to TAP::Harness::new ('.join(' ',sort @props).')'); } return $self; diff --git a/lib/TAP/Parser.pm b/lib/TAP/Parser.pm index 1f7ee863..06805f12 100644 --- a/lib/TAP/Parser.pm +++ b/lib/TAP/Parser.pm @@ -1340,9 +1340,9 @@ sub _make_state_table { my $st = { %state_globals, %{ $states{$name} } }; # Add defaults - for my $next ( sort keys %{$st} ) { + for my $next ( keys %$st ) { if ( my $default = $state_defaults{$next} ) { - for my $def ( sort keys %{$default} ) { + for my $def ( keys %$default ) { $st->{$next}->{$def} ||= $default->{$def}; } } From 6a6068105855e429e24c01edfb7c59dfdab7dd77 Mon Sep 17 00:00:00 2001 From: bulk88 Date: Wed, 15 Apr 2015 16:19:08 +0200 Subject: [PATCH 3/6] cut ops from TAP::Object::new and TAP::Formatter::Base new() went from 17.2 seconds (/1000000) exclusive time nytprof to 12.2 seconds after this commit. --- lib/TAP/Formatter/Base.pm | 4 +--- lib/TAP/Object.pm | 4 +--- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/lib/TAP/Formatter/Base.pm b/lib/TAP/Formatter/Base.pm index 3d1272a9..d2ac8869 100644 --- a/lib/TAP/Formatter/Base.pm +++ b/lib/TAP/Formatter/Base.pm @@ -419,9 +419,7 @@ sub _summary_test_header { } sub _output { - my $self = shift; - - print { $self->stdout } @_; + print { shift->stdout } @_; } sub _failure_output { diff --git a/lib/TAP/Object.pm b/lib/TAP/Object.pm index 9a739c29..c5ae4468 100644 --- a/lib/TAP/Object.pm +++ b/lib/TAP/Object.pm @@ -50,9 +50,7 @@ L method. Returns a new object. =cut sub new { - my $class = shift; - my $self = bless {}, $class; - return $self->_initialize(@_); + return bless({}, shift)->_initialize(@_); } =head2 Instance Methods From 1335c908e4f6777f8a73fb1cf6f99edf9fb8446e Mon Sep 17 00:00:00 2001 From: bulk88 Date: Thu, 16 Apr 2015 12:59:14 +0200 Subject: [PATCH 4/6] dont do VMS TAP fixups on any platform but VMS Also combine subs with identical bodies. On Win32, memory usage sampled with "perl -MTAP::Parser::Iterator -E"system 'pause'" caused memory usage to drop from 2,688KB to 2,672KB after this commit for me. next() dropped from 68us inclusive to 44us with nytprof, for comparison next_raw is 39us. next() is called once per test so it is hot. # Conflicts: # t/compat/test-harness-compat.t --- lib/TAP/Parser/Iterator.pm | 20 ++++----- t/compat/test-harness-compat.t | 77 ++++++++++++++++++---------------- t/iterators.t | 18 ++++---- 3 files changed, 62 insertions(+), 53 deletions(-) diff --git a/lib/TAP/Parser/Iterator.pm b/lib/TAP/Parser/Iterator.pm index 87d8de93..7121339e 100644 --- a/lib/TAP/Parser/Iterator.pm +++ b/lib/TAP/Parser/Iterator.pm @@ -61,6 +61,8 @@ Iterate raw input without applying any fixes for quirky input syntax. =cut +if ( $^O eq 'VMS' ) { + eval <<'END' ; sub next { my $self = shift; my $line = $self->next_raw; @@ -75,6 +77,11 @@ sub next { return $line; } +END +} +else { + eval 'sub next { shift->next_raw(@_) }'; +} sub next_raw { require Carp; @@ -125,17 +132,8 @@ Return the C status for this iterator. =cut -sub wait { - require Carp; - my $msg = Carp::longmess('abstract method called directly!'); - $_[0]->_croak($msg); -} - -sub exit { - require Carp; - my $msg = Carp::longmess('abstract method called directly!'); - $_[0]->_croak($msg); -} +#can not call abstract base method, next_raw is a fatal stub +*exit = *wait = *next_raw; 1; diff --git a/t/compat/test-harness-compat.t b/t/compat/test-harness-compat.t index 14309163..7b8f826f 100644 --- a/t/compat/test-harness-compat.t +++ b/t/compat/test-harness-compat.t @@ -150,14 +150,17 @@ if ($NoTaintSupport) { 'name' => "$TEST_DIR/too_many", 'wstat' => '1024' }, - "$TEST_DIR/vms_nit" => { - 'canon' => 1, - 'estat' => '', - 'failed' => 1, - 'max' => 2, - 'name' => "$TEST_DIR/vms_nit", - 'wstat' => '' - } + ( $^O eq 'VMS' ? + ("$TEST_DIR/vms_nit" => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 2, + 'name' => "$TEST_DIR/vms_nit", + 'wstat' => '' + }) + : () + ) }, 'todo' => { "$TEST_DIR/todo_inline" => { @@ -170,12 +173,12 @@ if ($NoTaintSupport) { } }, 'totals' => { - 'bad' => ($NoTaintSupport ? 11 : 12), + 'bad' => ($NoTaintSupport ? 11 : 12)-($^O eq 'VMS' ? 0 : 1), 'bonus' => 1, 'files' => ($NoTaintSupport ? 24 : 27), - 'good' => ($NoTaintSupport ? 13 : 15), + 'good' => ($NoTaintSupport ? 13 : 15)+($^O eq 'VMS' ? 0 : 1), 'max' => ($NoTaintSupport ? 72 : 76), - 'ok' => ($NoTaintSupport ? 75 : 78), + 'ok' => ($NoTaintSupport ? 75 : 78)+($^O eq 'VMS' ? 0 : 1), 'skipped' => 2, 'sub_skipped' => 2, 'tests' => ($NoTaintSupport ? 24 : 27), @@ -739,31 +742,35 @@ if ($NoTaintSupport) { 'todo' => 0 } }, - 'vms_nit' => { - 'failed' => { - "$TEST_DIR/vms_nit" => { - 'canon' => 1, - 'estat' => '', - 'failed' => 1, - 'max' => 2, - 'name' => "$TEST_DIR/vms_nit", - 'wstat' => '' + ( $^O eq 'VMS' ? + ('vms_nit' => { + 'failed' => { + "$TEST_DIR/vms_nit" => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 2, + 'name' => "$TEST_DIR/vms_nit", + 'wstat' => '' + } + }, + 'skip_if' => sub { $^O ne 'VMS' }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 2, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 } - }, - 'todo' => {}, - 'totals' => { - 'bad' => 1, - 'bonus' => 0, - 'files' => 1, - 'good' => 0, - 'max' => 2, - 'ok' => 1, - 'skipped' => 0, - 'sub_skipped' => 0, - 'tests' => 1, - 'todo' => 0 - } - } + }) + : () + ) }; my $num_tests = ( keys %$results ) * $PER_LOOP; diff --git a/t/iterators.t b/t/iterators.t index 57e20401..470b7070 100644 --- a/t/iterators.t +++ b/t/iterators.t @@ -155,16 +155,20 @@ for my $test (@schedule) { { + my $iterator; # coverage test for VMS case - my $iterator = make_iterator( - [ 'not ', - 'ok 1 - I hate VMS', - ] - ); + SKIP : { + skip('Not VMS', 1) if $^O ne 'VMS'; + $iterator = make_iterator( + [ 'not ', + 'ok 1 - I hate VMS', + ] + ); - is $iterator->next, 'not ok 1 - I hate VMS', - 'coverage of VMS line-splitting case'; + is $iterator->next, 'not ok 1 - I hate VMS', + 'coverage of VMS line-splitting case'; + } # coverage test for VMS case - nothing after 'not' From 987fb508e2847d8de48e647937f8e06b2c2237dd Mon Sep 17 00:00:00 2001 From: bulk88 Date: Fri, 17 Apr 2015 15:53:19 +0200 Subject: [PATCH 5/6] TAP::Parser::Iterator::Process cleanup --- lib/TAP/Parser/Iterator/Process.pm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/lib/TAP/Parser/Iterator/Process.pm b/lib/TAP/Parser/Iterator/Process.pm index c360ecdb..a69193ef 100644 --- a/lib/TAP/Parser/Iterator/Process.pm +++ b/lib/TAP/Parser/Iterator/Process.pm @@ -8,7 +8,7 @@ use IO::Handle; use base 'TAP::Parser::Iterator'; -my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ ); +use constant IS_WIN32 => !!( $^O =~ /^(MS)?Win32$/ ); =head1 NAME @@ -91,8 +91,7 @@ Get the exit status for this iterator's process. } sub _use_open3 { - my $self = shift; - return unless $Config{d_fork} || $IS_WIN32; + return unless $Config{d_fork} || IS_WIN32; for my $module (qw( IPC::Open3 IO::Select )) { eval "use $module"; return if $@; @@ -147,7 +146,7 @@ sub _initialize { # }}} - if ($IS_WIN32) { + if (IS_WIN32) { $err = $merge ? '' : '>&STDERR'; eval { $pid = open3( @@ -340,7 +339,7 @@ sub _finish { # Sometimes we get -1 on Windows. Presumably that means status not # available. - $status = 0 if $IS_WIN32 && $status == -1; + $status = 0 if IS_WIN32 && $status == -1; $self->{wait} = $status; $self->{exit} = $self->_wait2exit($status); From 28361bf42aed9538366f2d5c4c52dc1aa4dd7d30 Mon Sep 17 00:00:00 2001 From: bulk88 Date: Tue, 19 Apr 2016 23:40:59 -0400 Subject: [PATCH 6/6] Check for parser errors in multiplexer.t If something is very wrong with the TAP stream, don't silence $@ die errors. --- t/multiplexer.t | 3 +++ 1 file changed, 3 insertions(+) diff --git a/t/multiplexer.t b/t/multiplexer.t index 2e55b12d..ccd1911e 100644 --- a/t/multiplexer.t +++ b/t/multiplexer.t @@ -153,6 +153,9 @@ for my $test (@schedule) { # use Data::Dumper; # diag Dumper( { stash => $stash, result => $result } ); + my @err = $parser->parse_errors(); + ok(!@err, "$name: Parser has no parse errors"); + diag @err if @err; if ( defined $result ) { my $expect = ( shift @$stash ) || ' OOPS '; my $got = $result->raw;