Anonymous avatar Anonymous committed 665d628

Implemented all the output in Test::Shlomif::Harnes::Output, where it is located in
a central place.

Comments (0)

Files changed (4)

modules/Test-Shlomif-Harness/MANIFEST

 Changes
 examples/mini_harness.plx
 lib/Test/Shlomif/Harness/Obj.pm
+lib/Test/Shlomif/Harness/Output.pm
 lib/Test/Shlomif/Harness/Straps.pm
 Makefile.PL
 MANIFEST

modules/Test-Shlomif-Harness/lib/Test/Shlomif/Harness/Obj.pm

 
 require 5.00405;
 use Test::Shlomif::Harness::Straps;
+use Test::Shlomif::Harness::Output;
 use Test::Harness::Assert;
 use Exporter;
 use Benchmark;
     $Curtest
     $Columns 
     $Timer
-    $ML
     $has_time_hires
 );
 
     Verbose
     dir_files
     failed_tests
+    output
     test_files
     tot
     width
     }
 }
 
+sub _get_new_output
+{
+    my $self = shift;
+    my $args = shift;
+    return Test::Shlomif::Harness::Output->new(
+        %$args,
+    );
+}
+
 sub _initialize
 {
     my $self = shift;
     my (%args) = (@_);
     $self->_init_simple_params(\%args);
     $self->dir_files([]);
-    $self->Strap(Test::Shlomif::Harness::Straps->new());
+    $self->output($self->_get_new_output(\%args));
+    $self->Strap(
+        Test::Shlomif::Harness::Straps->new(
+            output => $self->output(),
+        )
+    );
     $self->Strap()->{callback} = \&strap_callback;
     return 0;
 }
 {
     my ($self, $files) = (@_);
     my @f = sort @$files;
-    print "LEAKED FILES: @f\n";
+    $self->_print_message("LEAKED FILES: @f");
 }
 
 sub _recheck_dir_files
                 $test->{skipped},
                 $test->{failed}
             );
-        print "$test->{ml}$txt";
+        $self->_print_message("$test->{ml}$txt");
         return 
             +{
                 canon   => $canon,
             };
     }
     else {
-        print "Don't know which tests failed: got $test->{ok} ok, ".
-              "expected $test->{max}\n";
+        $self->_print_message("Don't know which tests failed: got $test->{ok} ok, ".
+              "expected $test->{max}");
         return
             +{
                 canon   => '??',
     my ($self, %args) = @_;
     my $tfile = $args{'filename'};
 
-    print "FAILED before any test output arrived\n";
+    $self->_print_message("FAILED before any test output arrived");
     $self->_tot_inc('bad');
     return 
         +{ 
     my ($self, %args) = @_;
     my $tfile = $args{'test_file'};
 
-    $self->Strap()->last_test_print(0); # so each test prints at least once
-    my($leader, $ml) = $self->_mk_leader($tfile, $self->width());
-    local $ML = $ml;
-
-    print $leader;
+    $self->output()->last_test_print(0); # so each test prints at least once
+    $self->output()->print_leader(
+        filename => $tfile,
+        width => $self->width(),
+    );
 
     $self->_tot_inc('files');
 
     $self->Strap()->{_seen_header} = 0;
     if ( $self->Debug() ) {
-        print "# Running: ", $self->Strap()->_command_line($tfile), "\n";
+        $self->_print_message("# Running: " . $self->Strap()->_command_line($tfile));
     }
     my $test_start_time = $Timer ? time : 0;
     $self->Strap()->Verbose($self->Verbose());
                 skipped     => $results{skip},
                 skip_reason => $results{skip_reason},
                 skip_all    => $self->Strap()->{skip_all},
-                ml          => $ml,
+                ml          => $self->output()->ml(),
                );
 
     foreach my $type (qw(bonus max ok todo))
                 if $test{skipped};
             push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded")
                 if $test{bonus};
-            print "$test{ml}ok$elapsed\n        ".join(', ', @msg)."\n";
+            $self->_print_message("$test{ml}ok$elapsed\n        ".join(', ', @msg));
         }
         elsif ( $test{max} ) {
-            print "$test{ml}ok$elapsed\n";
+            $self->_print_message("$test{ml}ok$elapsed");
         }
         else {
-            print "skipped\n        all skipped: " . 
+            $self->_print_message("skipped\n        all skipped: " .
                 ((defined($test{skip_all}) && length($test{skip_all})) ?
                     $test{skip_all} :
-                    "no reason given") .
-                    "\n";
+                    "no reason given")
+                );
             $self->_tot_inc('skipped');
         }
         $self->_tot_inc('good');
 sub _report_success
 {
     my $self = shift;
-    print "All tests successful" . $self->_get_bonusmsg() . ".\n";
+    $self->_print_message("All tests successful" . $self->_get_bonusmsg() . ".");
 }
 
 sub _fail_no_tests_run
     if ($tot->{bad}) {
         my $bonusmsg = $self->_bonusmsg();
         $bonusmsg =~ s/^,\s*//;
-        print "$bonusmsg.\n" if $bonusmsg;
+        if ($bonusmsg)
+        {
+            $self->_print_message("$bonusmsg.");
+        }
         die "Failed $tot->{bad}/$tot->{tests} test scripts, " . 
             $self->_get_tests_good_percent() . "% okay.".
             "$subpct\n";
     my $detail = $totals->{details}[-1];
 
     if( $detail->{ok} ) {
-        _print_ml_less($self, "ok $curr/$max");
+        $self->output()->print_ml_less("ok $curr/$max");
 
         if( $detail->{type} eq 'skip' ) {
             $totals->{skip_reason} = $detail->{reason}
         }
     }
     else {
-        _print_ml("NOK $curr");
+        $self->output()->print_ml("NOK $curr");
     }
 
     if( $curr > $next ) {
-        print "Test output counter mismatch [test $curr]\n";
+        $self->output()->print_message("Test output counter mismatch [test $curr]");
     }
     elsif( $curr < $next ) {
-        print "Confused test output: test $curr answered after ".
-              "test ", $next - 1, "\n";
+        $self->output()->print_message("Confused test output: test $curr answered after ".
+              "test ", $next - 1);
     }
 
 };
 
 
 sub _print_ml {
-    print join '', $ML, @_ if $ML;
+    my $self = shift;
+    $self->output()->print_ml(@_);
+    print 
 }
 
 
-# Print updates only once per second.
-sub _print_ml_less {
-    my $self = shift;
-    my $now = CORE::time;
-    if ( $self->last_test_print() != $now ) {
-        _print_ml(@_);
-        $self->last_test_print($now);
-    }
-}
 
 sub _get_bonusmsg {
     my($self) = @_;
     return $bonusmsg;
 }
 
+sub _print_message
+{
+    my $self = shift;
+    $self->output()->print_message(@_);
+}
+
+sub _print_dubious
+{
+    my $self = shift;
+    my (%args) = @_;
+    my $test = $args{test_struct};
+    my $estatus = $args{estatus};
+    $self->_print_message(
+        sprintf("$test->{ml}dubious\n\tTest returned status $estatus ".
+            "(wstat %d, 0x%x)",
+            (($args{'wstatus'}) x 2))
+        );
+    if ($^O eq "VMS")
+    {
+        $self->_print_message("\t\t(VMS status is $estatus)");
+    }        
+}
+
 # Test program go boom.
 sub _dubious_return {
     my ($self,%args) = @_;
     
     my ($failed, $canon, $percent) = ('??', '??');
 
-    printf "$test->{ml}dubious\n\tTest returned status $estatus ".
-           "(wstat %d, 0x%x)\n",
-           $wstatus,$wstatus;
-    print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
+    $self->_print_dubious(%args);
 
     $tot->{bad}++;
 
     if ($test->{max}) {
         if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) {
-            print "\tafter all the subtests completed successfully\n";
+            $self->_print_message("\tafter all the subtests completed successfully");
             $percent = 0;
             $failed = 0;        # But we do not set $canon!
         }
                     $test->{failed}
                 );
             $percent = 100*(scalar @{$test->{failed}})/$test->{max};
-            print "DIED. ",$txt;
+            $self->_print_message("DIED. ", $txt);
         }
     }
 
         }
         push @result, $skipmsg;
     }
-    push @result, "\n";
     my $txt = join "", @result;
     return ($txt, $canon);
 }

modules/Test-Shlomif-Harness/lib/Test/Shlomif/Harness/Output.pm

+package Test::Shlomif::Harness::Output;
+
+use strict;
+use warnings;
+
+use base 'Class::Accessor';
+
+__PACKAGE__->mk_accessors(qw(Verbose last_test_print ml));
+
+sub new
+{
+    my $class = shift;
+    my $self = {};
+    bless $self, $class;
+    $self->_initialize(@_);
+    return $self;
+}
+
+sub _initialize
+{
+    my $self = shift;
+    my (%args) = @_;
+    $self->Verbose($args{Verbose});
+    return 0;
+}
+
+sub _print_message_raw
+{
+    my ($self, $msg) = @_;
+    print $msg;
+}
+
+sub print_message
+{
+    my ($self, $msg) = @_;
+    $self->_print_message_raw($msg);
+    print "\n";
+}
+
+sub print_leader
+{
+    my $self = shift;
+    my (%args) = @_;
+    my ($leader, $ml) =
+        $self->_mk_leader(
+            $args{filename},
+            $args{width},
+        );
+    $self->ml($ml);
+    $self->_print_message_raw(
+        $leader,
+    );
+}
+
+sub print_ml
+{
+    my $self = shift;
+    my $msg = shift;
+    if ($self->ml())
+    {
+        $self->_print_message_raw($self->ml(). $msg);
+    }
+}
+
+# Print updates only once per second.
+sub print_ml_less {
+    my $self = shift;
+    my $now = CORE::time;
+    if ( $self->last_test_print() != $now ) {
+        $self->print_ml(@_);
+        $self->last_test_print($now);
+    }
+}
+
+sub _mk_leader {
+    my ($self, $te, $width) = @_;
+    chomp($te);
+    $te =~ s/\.\w+$/./;
+
+    if ($^O eq 'VMS') {
+        $te =~ s/^.*\.t\./\[.t./s;
+    }
+    my $leader = "$te" . '.' x ($width - length($te));
+    my $ml = "";
+
+    if ( -t STDOUT and not $ENV{HARNESS_NOTTY} and not $self->Verbose()) {
+        $ml = "\r" . (' ' x 77) . "\r$leader"
+    }
+
+    return($leader, $ml);
+}
+
+1;
+

modules/Test-Shlomif-Harness/lib/Test/Shlomif/Harness/Straps.pm

 
 @ISA = (qw(Class::Accessor));
 
-__PACKAGE__->mk_accessors(qw(Verbose last_test_print));
+__PACKAGE__->mk_accessors(qw(Verbose last_test_print output));
 
 # Flags used as return values from our methods.  Just for internal 
 # clarification.
     my $class = shift;
     my $self  = bless {}, $class;
 
-    $self->_init;
+    $self->_init(@_);
 
     return $self;
 }
 
 sub _init {
     my($self) = shift;
+    my (%args) = @_;
 
     $self->{_is_vms}   = ( $^O eq 'VMS' );
     $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ );
     $self->{_is_macos} = ( $^O eq 'MacOS' );
+
+    $self->output($args{output}); 
 }
 
 =head1 ANALYSIS
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.