Perl-Toolchain-Gang · Leont · Nov 12, 2024 · Mar 28, 2015 · Apr 15, 2015 · Apr 15, 2015
diff --git 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/Formatter/Console/Session.pm b/lib/TAP/Formatter/Console/Session.pm
@@ -128,17 +128,17 @@ 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.
                 # We will always get the first number as a side effect of
                 # $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;
                 }

diff --git 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<undef> 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<undef> 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/Object.pm b/lib/TAP/Object.pm
@@ -50,9 +50,7 @@ L</_initialize> 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

diff --git 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};
                 }
             }

diff --git 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<exit> 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/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);

diff --git 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
@@ -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'
 

diff --git 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;