From: Gurusamy Sarathy <gsar@cpan.org>
Date: Sun, 28 May 2000 08:17:50 +0000 (+0000)
Subject: enable Test::Harness to dynamically determine column width etc.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0a931e4af3dba6f23d436823d4526d6b7bdc2249;p=p5sagit%2Fp5-mst-13.2.git

enable Test::Harness to dynamically determine column width etc.
(from Rob Napier <rnapier@employees.org>)

p4raw-id: //depot/perl@6135
---

diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm
index 5b444f9..6d4e8b9 100644
--- a/lib/Test/Harness.pm
+++ b/lib/Test/Harness.pm
@@ -8,7 +8,7 @@ use FileHandle;
 use strict;
 
 our($VERSION, $verbose, $switches, $have_devel_corestack, $curtest,
-    @ISA, @EXPORT, @EXPORT_OK);
+    $columns, @ISA, @EXPORT, @EXPORT_OK);
 $have_devel_corestack = 0;
 
 $VERSION = "1.1604";
@@ -27,36 +27,18 @@ my $subtests_skipped = 0;
 @EXPORT= qw(&runtests);
 @EXPORT_OK= qw($verbose $switches);
 
-format STDOUT_TOP =
-Failed Test  Status Wstat Total Fail  Failed  List of failed
--------------------------------------------------------------------------------
-.
-
-format STDOUT =
-@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##%  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-{ $curtest->{name},
-                $curtest->{estat},
-                    $curtest->{wstat},
-                          $curtest->{max},
-                                $curtest->{failed},
-                                     $curtest->{percent},
-                                              $curtest->{canon}
-}
-~~                                            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-                                              $curtest->{canon}
-.
-
-
 $verbose = 0;
 $switches = "-w";
+$columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
 
 sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f }
 
 sub runtests {
     my(@tests) = @_;
     local($|) = 1;
-    my($test,$te,$ok,$next,$max,$pct,$totok,$totbonus,@failed,%failedtests);
+    my($test,$te,$ok,$next,$max,$pct,$totbonus,@failed,%failedtests);
     my $totmax = 0;
+    my $totok = 0;
     my $files = 0;
     my $bad = 0;
     my $good = 0;
@@ -304,7 +286,54 @@ sub runtests {
 	$pct = sprintf("%.2f", $good / $total * 100);
 	my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
 	$totmax - $totok, $totmax, 100*$totok/$totmax;
+	# Create formats
+	#    First, figure out max length of test names
+	my $failed_str = "Failed Test";
+	my $middle_str = " Status Wstat Total Fail  Failed  ";
+	my $list_str = "List of Failed";
+	my $max_namelen = length($failed_str);
 	my $script;
+	foreach $script (keys %failedtests) {
+	    $max_namelen =
+		(length $failedtests{$script}->{name} > $max_namelen) ?
+		    length $failedtests{$script}->{name} : $max_namelen;
+	}
+	my $list_len = $columns - length($middle_str) - $max_namelen;
+	if ($list_len < length($list_str)) {
+	    $list_len = length($list_str);
+	    $max_namelen = $columns - length($middle_str) - $list_len;
+	    if ($max_namelen < length($failed_str)) {
+		$max_namelen = length($failed_str);
+		$columns = $max_namelen + length($middle_str) + $list_len;
+	    }
+	}
+
+	my $fmt_top = "format STDOUT_TOP =\n"
+		      . sprintf("%-${max_namelen}s", $failed_str)
+		      . $middle_str
+		      . $list_str . "\n"
+		      . "-" x $columns
+		      . "\n.\n";
+	my $fmt = "format STDOUT =\n"
+		  . "@" . "<" x ($max_namelen - 1)
+		  . "	 @>> @>>>> @>>>> @>>> ^##.##%  "
+		  . "^" . "<" x ($list_len - 1) . "\n"
+		  . '{ $curtest->{name}, $curtest->{estat},'
+		  . '  $curtest->{wstat}, $curtest->{max},'
+		  . '  $curtest->{failed}, $curtest->{percent},'
+		  . '  $curtest->{canon}'
+		  . "\n}\n"
+		  . "~~" . " " x ($columns - $list_len - 2) . "^"
+		  . "<" x ($list_len - 1) . "\n"
+		  . '$curtest->{canon}'
+		  . "\n.\n";
+
+	eval $fmt_top;
+	die $@ if $@;
+	eval $fmt;
+	die $@ if $@;
+
+	# Now write to formats
 	for $script (sort keys %failedtests) {
 	  $curtest = $failedtests{$script};
 	  write;
@@ -509,6 +538,12 @@ switches used to invoke perl on each test.  For example, setting
 C<HARNESS_PERL_SWITCHES> to "-W" will run all tests with all
 warnings enabled.
 
+If C<HARNESS_COLUMNS> is set, then this value will be used for the
+width of the terminal. If it is not set then it will default to
+C<COLUMNS>. If this is not set, it will default to 80. Note that users
+of Bourne-sh based shells will need to C<export COLUMNS> for this
+module to use that variable.
+
 Harness sets C<HARNESS_ACTIVE> before executing the individual tests.
 This allows the tests to determine if they are being executed through the
 harness or by any other means.