1 files changed, 129 insertions, 149 deletions

diff --git a/gnu/usr.bin/perl/lib/Test/Builder/Tester.pm b/gnu/usr.bin/perl/lib/Test/Builder/Tester.pm
index 9e3b9c7b329..c0196355849 100644
--- a/gnu/usr.bin/perl/lib/Test/Builder/Tester.pm
+++ b/gnu/usr.bin/perl/lib/Test/Builder/Tester.pm
@@ -1,8 +1,7 @@
 package Test::Builder::Tester;
 
 use strict;
-use vars qw(@EXPORT $VERSION @ISA);
-$VERSION = "1.02";
+our $VERSION = "1.18";
 
 use Test::Builder;
 use Symbol;
@@ -56,21 +55,20 @@ my $t = Test::Builder->new;
 ###
 
 use Exporter;
-@ISA = qw(Exporter);
+our @ISA = qw(Exporter);
 
-@EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
+our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
 
 # _export_to_level and import stolen directly from Test::More.  I am
 # the king of cargo cult programming ;-)
 
 # 5.004's Exporter doesn't have export_to_level.
-sub _export_to_level
-{
-      my $pkg = shift;
-      my $level = shift;
-      (undef) = shift;                  # XXX redundant arg
-      my $callpkg = caller($level);
-      $pkg->export($callpkg, @_);
+sub _export_to_level {
+    my $pkg   = shift;
+    my $level = shift;
+    (undef) = shift;    # XXX redundant arg
+    my $callpkg = caller($level);
+    $pkg->export( $callpkg, @_ );
 }
 
 sub import {
@@ -83,14 +81,14 @@ sub import {
     $t->plan(@plan);
 
     my @imports = ();
-    foreach my $idx (0..$#plan) {
+    foreach my $idx ( 0 .. $#plan ) {
         if( $plan[$idx] eq 'import' ) {
-            @imports = @{$plan[$idx+1]};
+            @imports = @{ $plan[ $idx + 1 ] };
             last;
         }
     }
 
-    __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
+    __PACKAGE__->_export_to_level( 1, __PACKAGE__, @imports );
 }
 
 ###
@@ -102,8 +100,8 @@ my $output_handle = gensym;
 my $error_handle  = gensym;
 
 # and tie them to this package
-my $out = tie *$output_handle, "Test::Tester::Tie", "STDOUT";
-my $err = tie *$error_handle,  "Test::Tester::Tie", "STDERR";
+my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
+my $err = tie *$error_handle,  "Test::Builder::Tester::Tie", "STDERR";
 
 ####
 # exported functions
@@ -124,8 +122,7 @@ my $original_harness_state;
 my $original_harness_env;
 
 # function that starts testing and redirects the filehandles for now
-sub _start_testing
-{
+sub _start_testing {
     # even if we're running under Test::Harness pretend we're not
     # for now.  This needed so Test::Builder doesn't add extra spaces
     $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
@@ -146,7 +143,7 @@ sub _start_testing
     $err->reset();
 
     # remeber that we're testing
-    $testing = 1;
+    $testing     = 1;
     $testing_num = $t->current_test;
     $t->current_test(0);
 
@@ -154,7 +151,7 @@ sub _start_testing
     $t->no_ending(1);
 }
 
-=head2 Methods
+=head2 Functions
 
 These are the six methods that are exported as default.
 
@@ -188,20 +185,18 @@ output filehandles)
 
 =cut
 
-sub test_out(@)
-{
+sub test_out {
     # do we need to do any setup?
     _start_testing() unless $testing;
 
-    $out->expect(@_)
+    $out->expect(@_);
 }
 
-sub test_err(@)
-{
+sub test_err {
     # do we need to do any setup?
     _start_testing() unless $testing;
 
-    $err->expect(@_)
+    $err->expect(@_);
 }
 
 =item test_fail
@@ -214,7 +209,7 @@ so
 
     test_err("# Failed test ($0 at line ".line_num(+1).")");
 
-C<test_fail> exists as a convenience method that can be called
+C<test_fail> exists as a convenience function that can be called
 instead.  It takes one argument, the offset from the current line that
 the line that causes the fail is on.
 
@@ -230,14 +225,13 @@ more simply as:
 
 =cut
 
-sub test_fail
-{
+sub test_fail {
     # do we need to do any setup?
     _start_testing() unless $testing;
 
     # work out what line we should be on
-    my ($package, $filename, $line) = caller;
-    $line = $line + (shift() || 0); # prevent warnings
+    my( $package, $filename, $line ) = caller;
+    $line = $line + ( shift() || 0 );    # prevent warnings
 
     # expect that on stderr
     $err->expect("#     Failed test ($0 at line $line)");
@@ -273,14 +267,13 @@ without the newlines.
 
 =cut
 
-sub test_diag
-{
+sub test_diag {
     # do we need to do any setup?
     _start_testing() unless $testing;
 
     # expect the same thing, but prepended with "#     "
     local $_;
-    $err->expect(map {"# $_"} @_)
+    $err->expect( map { "# $_" } @_ );
 }
 
 =item test_test
@@ -322,24 +315,23 @@ will function normally and cause success/errors for B<Test::Harness>.
 
 =cut
 
-sub test_test
-{
-   # decode the arguements as described in the pod
-   my $mess;
-   my %args;
-   if (@_ == 1)
-     { $mess = shift }
-   else
-   {
-     %args = @_;
-     $mess = $args{name} if exists($args{name});
-     $mess = $args{title} if exists($args{title});
-     $mess = $args{label} if exists($args{label});
-   }
+sub test_test {
+    # decode the arguements as described in the pod
+    my $mess;
+    my %args;
+    if( @_ == 1 ) {
+        $mess = shift
+    }
+    else {
+        %args = @_;
+        $mess = $args{name} if exists( $args{name} );
+        $mess = $args{title} if exists( $args{title} );
+        $mess = $args{label} if exists( $args{label} );
+    }
 
     # er, are we testing?
     croak "Not testing.  You must declare output with a test function first."
-	unless $testing;
+      unless $testing;
 
     # okay, reconnect the test suite back to the saved handles
     $t->output($original_output_handle);
@@ -354,20 +346,20 @@ sub test_test
     $ENV{HARNESS_ACTIVE} = $original_harness_env;
 
     # check the output we've stashed
-    unless ($t->ok(    ($args{skip_out} || $out->check)
-                    && ($args{skip_err} || $err->check),
-                   $mess))
+    unless( $t->ok( ( $args{skip_out} || $out->check ) &&
+                    ( $args{skip_err} || $err->check ), $mess ) 
+    )
     {
-      # print out the diagnostic information about why this
-      # test failed
+        # print out the diagnostic information about why this
+        # test failed
 
-      local $_;
+        local $_;
 
-      $t->diag(map {"$_\n"} $out->complaint)
-	unless $args{skip_out} || $out->check;
+        $t->diag( map { "$_\n" } $out->complaint )
+          unless $args{skip_out} || $out->check;
 
-      $t->diag(map {"$_\n"} $err->complaint)
-	unless $args{skip_err} || $err->check;
+        $t->diag( map { "$_\n" } $err->complaint )
+          unless $args{skip_err} || $err->check;
     }
 }
 
@@ -376,17 +368,16 @@ sub test_test
 A utility function that returns the line number that the function was
 called on.  You can pass it an offset which will be added to the
 result.  This is very useful for working out the correct text of
-diagnostic methods that contain line numbers.
+diagnostic functions that contain line numbers.
 
 Essentially this is the same as the C<__LINE__> macro, but the
 C<line_num(+3)> idiom is arguably nicer.
 
 =cut
 
-sub line_num
-{
-    my ($package, $filename, $line) = caller;
-    return $line + (shift() || 0); # prevent warnings
+sub line_num {
+    my( $package, $filename, $line ) = caller;
+    return $line + ( shift() || 0 );    # prevent warnings
 }
 
 =back
@@ -432,20 +423,20 @@ the PERL5LIB.
 =cut
 
 my $color;
-sub color
-{
-  $color = shift if @_;
-  $color;
+
+sub color {
+    $color = shift if @_;
+    $color;
 }
 
 =back
 
 =head1 BUGS
 
-Calls B<Test::Builder>'s C<no_ending> method turning off the ending
-tests.  This is needed as otherwise it will trip out because we've run
-more tests than we strictly should have and it'll register any
-failures we had that we were testing for as real failures.
+Calls C<<Test::Builder->no_ending>> turning off the ending tests.
+This is needed as otherwise it will trip out because we've run more
+tests than we strictly should have and it'll register any failures we
+had that we were testing for as real failures.
 
 The color function doesn't work unless B<Term::ANSIColor> is installed
 and is compatible with your terminal.
@@ -485,49 +476,44 @@ L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
 ####################################################################
 # Helper class that is used to remember expected and received data
 
-package Test::Tester::Tie;
+package Test::Builder::Tester::Tie;
 
 ##
 # add line(s) to be expected
 
-sub expect
-{
+sub expect {
     my $self = shift;
 
     my @checks = @_;
     foreach my $check (@checks) {
         $check = $self->_translate_Failed_check($check);
-        push @{$self->[2]}, ref $check ? $check : "$check\n";
+        push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
     }
 }
 
+sub _translate_Failed_check {
+    my( $self, $check ) = @_;
 
-sub _translate_Failed_check 
-{
-    my($self, $check) = @_;
-
-    if( $check =~ /\A(.*)#     (Failed .*test) \((.*?) at line (\d+)\)\z/ ) {
-        $check = qr/\Q$1\E#\s+\Q$2\E.*?\n?.*?\Q$3\E at line \Q$4\E.*\n?/;
+    if( $check =~ /\A(.*)#     (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
+        $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
     }
 
     return $check;
 }
 
-
 ##
 # return true iff the expected data matches the got data
 
-sub check
-{
+sub check {
     my $self = shift;
 
     # turn off warnings as these might be undef
     local $^W = 0;
 
-    my @checks = @{$self->[2]};
-    my $got = $self->[1];
+    my @checks = @{ $self->{wanted} };
+    my $got    = $self->{got};
     foreach my $check (@checks) {
-        $check = qr/^\Q$check\E/ unless ref $check;
+        $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
         return 0 unless $got =~ s/^$check//;
     }
 
@@ -538,103 +524,97 @@ sub check
 # a complaint message about the inputs not matching (to be
 # used for debugging messages)
 
-sub complaint
-{
-    my $self = shift;
+sub complaint {
+    my $self   = shift;
     my $type   = $self->type;
     my $got    = $self->got;
-    my $wanted = join "\n", @{$self->wanted};
+    my $wanted = join "\n", @{ $self->wanted };
 
     # are we running in colour mode?
-    if (Test::Builder::Tester::color)
-    {
-      # get color
-      eval "require Term::ANSIColor";
-      unless ($@)
-      {
-	# colours
-
-	my $green = Term::ANSIColor::color("black").
-	            Term::ANSIColor::color("on_green");
-        my $red   = Term::ANSIColor::color("black").
-                    Term::ANSIColor::color("on_red");
-	my $reset = Term::ANSIColor::color("reset");
-
-	# work out where the two strings start to differ
-	my $char = 0;
-	$char++ while substr($got, $char, 1) eq substr($wanted, $char, 1);
-
-	# get the start string and the two end strings
-	my $start     = $green . substr($wanted, 0,   $char);
-	my $gotend    = $red   . substr($got   , $char) . $reset;
-	my $wantedend = $red   . substr($wanted, $char) . $reset;
-
-	# make the start turn green on and off
-	$start =~ s/\n/$reset\n$green/g;
-
-	# make the ends turn red on and off
-	$gotend    =~ s/\n/$reset\n$red/g;
-	$wantedend =~ s/\n/$reset\n$red/g;
-
-	# rebuild the strings
-	$got    = $start . $gotend;
-	$wanted = $start . $wantedend;
-      }
+    if(Test::Builder::Tester::color) {
+        # get color
+        eval { require Term::ANSIColor };
+        unless($@) {
+            # colours
+
+            my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
+            my $red   = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
+            my $reset = Term::ANSIColor::color("reset");
+
+            # work out where the two strings start to differ
+            my $char = 0;
+            $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
+
+            # get the start string and the two end strings
+            my $start = $green . substr( $wanted, 0, $char );
+            my $gotend    = $red . substr( $got,    $char ) . $reset;
+            my $wantedend = $red . substr( $wanted, $char ) . $reset;
+
+            # make the start turn green on and off
+            $start =~ s/\n/$reset\n$green/g;
+
+            # make the ends turn red on and off
+            $gotend    =~ s/\n/$reset\n$red/g;
+            $wantedend =~ s/\n/$reset\n$red/g;
+
+            # rebuild the strings
+            $got    = $start . $gotend;
+            $wanted = $start . $wantedend;
+        }
     }
 
-    return "$type is:\n" .
-           "$got\nnot:\n$wanted\nas expected"
+    return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
 }
 
 ##
 # forget all expected and got data
 
-sub reset
-{
+sub reset {
     my $self = shift;
-    @$self = ($self->[0], '', []);
+    %$self = (
+        type   => $self->{type},
+        got    => '',
+        wanted => [],
+    );
 }
 
-
-sub got
-{
+sub got {
     my $self = shift;
-    return $self->[1];
+    return $self->{got};
 }
 
-sub wanted
-{
+sub wanted {
     my $self = shift;
-    return $self->[2];
+    return $self->{wanted};
 }
 
-sub type
-{
+sub type {
     my $self = shift;
-    return $self->[0];
+    return $self->{type};
 }
 
 ###
 # tie interface
 ###
 
-sub PRINT  {
+sub PRINT {
     my $self = shift;
-    $self->[1] .= join '', @_;
+    $self->{got} .= join '', @_;
 }
 
 sub TIEHANDLE {
-    my($class, $type) = @_;
+    my( $class, $type ) = @_;
+
+    my $self = bless { type => $type }, $class;
 
-    my $self = bless [$type], $class;
     $self->reset;
 
     return $self;
 }
 
-sub READ {}
-sub READLINE {}
-sub GETC {}
-sub FILENO {}
+sub READ     { }
+sub READLINE { }
+sub GETC     { }
+sub FILENO   { }
 
 1;