# New Ticket Created by Mark Glines
# Please include the string: [perl #51718]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=51718 >
There's a lot of common code in the tests in these directories, for
looping across a bunch of files, doing tests, and collating results.
Also, there's no consistency in the output of these tests at all.
(Some of them have a count of total errors afterwards, most don't.
Some of them list line numbers in parens, most don't.)
I've got a start at consolidating this into a helper module; I've
attached my current diff. I'm posting it to RT in case someone wants
to take it and run with it, or in case someone can think of a better
way.
Mark
Index: lib/Parrot/Test/Util/Runloop.pm
===================================================================
--- lib/Parrot/Test/Util/Runloop.pm (revision 0)
+++ lib/Parrot/Test/Util/Runloop.pm (revision 0)
@@ -0,0 +1,127 @@
+# Copyright (C) 2008, The Perl Foundation.
+# $Id$
+
+=head1 NAME
+
+Parrot::Test::Util::Runloop - consolidated test for lots of files
+
+=head1 SYNOPSIS
+
+ use Parrot::Test::Util::Runloop;
+
+ Parrot::Test::Util::Runloop->testloop(
+ name => 'No trailing spaces or tabs',
+ files => [ $DIST->get_c_language_files() ],
+ skips => { 'lib/Parrot/Test/Util/Runloop.pm' => 'devel' },
+ per_line => sub { !/.?[ \t]+$/ };
+
+
+=head1 DESCRIPTION
+
+This module provides a basic runloop for test scripts which perform the same
+test, over and over, on lots of files. It is intended to consolidate some code
+to handle loops, skips etc, replicated many times in the t/distro/ and
+t/codingstd/ test directories.
+
+You can specify a callback routine to get called back once per line (with the
+per_line attribute), or once per file (with the per_file attribute). The
+per_line callback gets passed the line as a text string. The per_file callback
+gets passed the whole file as a text string. If the callback function returns
+positive, the test passed, otherwise the test failed. Failures are tallied,
+and later reported to the test harness once, as a single test. On failure,
+some informational diagnostics are also generated, showing the user which
+file(s) and which line(s) (if applicable) had the failure.
+
+
+=head1 AUTHOR
+
+Written by Mark Glines, based on an idea (and lots of enthusiasm) from
+Jerry Gay and Will Coleda.
+
+
+=cut
+
+package Parrot::Test::Util::Runloop;
+
+use strict;
+use warnings;
+
+use Carp;
+use Test::More;
+use IO::File;
+
+sub testloop {
+ my ($self, %args) = @_;
+ # sanity
+ my $usage = "Usage: Parrot::Test::Util::Runloop->testloop(\n"
+ ." name => 'foo',\n"
+ ." files => [ ... ],\n"
+ ." per_line => sub { ... });\n";
+ croak $usage unless exists $args{name};
+ croak $usage unless exists $args{files};
+ croak "'files' is not an array reference!" unless ref($args{files}) eq 'ARRAY';
+ croak "no per_file or per_line test callback was provided!"
+ unless exists($args{per_file}) || exists($args{per_line});
+
+ my @failures;
+ my $failed_files = 0;
+
+ foreach my $path (sort @{$args{files}}) {
+ $path = $path->path if ref $path;
+ next if exists($args{skips}) && exists($args{skips}{$path});
+
+ my $file = IO::File->new("<$path")
+ or die "Cannot open '$path' for reading: $!\n";
+
+ my @lines = $file->getlines();
+ my $error_line = "$path";
+ my $have_errors = 0;
+
+ if(exists($args{per_file})) {
+ my $cb = $args{per_file};
+ my $buf = join('', @lines);
+ # do the per-file test
+ unless($cb->($buf)) {
+ push(@failures, $error_line);
+ }
+ }
+
+ if(exists($args{per_line})) {
+ my $cb = $args{per_line};
+
+ # do the test, once for each line
+ foreach my $n ([EMAIL PROTECTED]) {
+ my $line = $lines[$n];
+ unless($cb->($line)) {
+ $error_line .= "," if $have_errors;
+ $error_line .= " " . ($n+1);
+ $have_errors = 1;
+ }
+ }
+
+ push(@failures, $error_line) if $have_errors;
+ $failed_files++ if $have_errors;
+ }
+ }
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ ok(!scalar @failures, $args{name});
+ if(scalar @failures) {
+ diag($args{diag_prefix} . " in the following files:")
+ if exists $args{diag_prefix};
+ foreach my $failure (@failures) {
+ diag($failure);
+ }
+ my $failures = scalar @failures;
+ my $total_files = scalar @{$args{files}};
+ diag("That's $failures failed files out of $total_files files total.");
+ }
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Index: t/codingstd/c_cuddled_else.t
===================================================================
--- t/codingstd/c_cuddled_else.t (revision 26353)
+++ t/codingstd/c_cuddled_else.t (working copy)
@@ -7,6 +7,7 @@
use lib qw( . lib ../lib ../../lib );
use Test::More tests => 1;
use Parrot::Distribution;
+use Parrot::Test::Util::Runloop;
=head1 NAME
@@ -32,32 +33,15 @@
my $DIST = Parrot::Distribution->new;
my @files = @ARGV ? @ARGV : $DIST->get_c_language_files();
-my @else;
-foreach my $file (@files) {
- # if we have command line arguments, the file is the full path
- # otherwise, use the relevant Parrot:: path method
- my $path = @ARGV ? $file : $file->path;
+Parrot::Test::Util::Runloop->testloop(
+ name => 'no cuddled elses',
+ files => [EMAIL PROTECTED],
+ per_line => sub { shift !~ /}\s*else\s*{/ },
+ diag_prefix => 'Cuddled else found'
+);
- open my $fh, '<', $path
- or die "Cannot open '$path' for reading: $!\n";
-
- my $tabcount;
- my $message = qq< $path:>;
- while (<$fh>) {
- next unless /}\s*else\s*{/;
- $message .= " $.";
- $tabcount++;
- }
- push @else => "$message\n"
- if $tabcount;
- close $fh;
-}
-
-ok( !scalar(@else), "cuddled else" )
- or diag( "cuddled else found in " . scalar @else . " files:[EMAIL PROTECTED]" );
-
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
Index: t/codingstd/check_isxxx.t
===================================================================
--- t/codingstd/check_isxxx.t (revision 26353)
+++ t/codingstd/check_isxxx.t (working copy)
@@ -8,6 +8,8 @@
use lib qw( . lib ../lib ../../lib );
use Test::More tests => 1;
use Parrot::Distribution;
+use Parrot::Test::Util::Runloop;
+use Carp;
=head1 NAME
@@ -54,35 +56,23 @@
my $isxxx_functions = join '|', @isxxx_functions_list;
-foreach my $file (@files) {
+sub check_isxxx {
+ my $line = shift;
- # if we have command line arguments, the file is the full path
- # otherwise, use the relevant Parrot:: path method
- my $path = @ARGV ? $file : $file->path;
- my $buf = $DIST->slurp($path);
- my @buffer_lines = split( /\n/, $buf );
- my $i = 1;
-
- # get the lines just matching isxxx
- my @isxxx_lines = grep { $_->[0] =~ /[^_]($isxxx_functions)\(/ }
- map { [ $_, $i++ ] } @buffer_lines;
-
- next unless @isxxx_lines;
-
- # find the instances without the explicit cast
- my @no_cast =
- grep { $_->[0] !~ /[^_]($isxxx_functions)\(\(unsigned char\)/ }
- @isxxx_lines;
-
- push @no_explicit_cast, $path . ' (' . join( ", ",
- map { $_->[1] } @no_cast ) . ")\n"
- if @no_cast;
+ # does the line contain an isxxx call?
+ return 1 unless $line =~ /[^_]($isxxx_functions)\(/;
+ # is the line missing a cast?
+ return 1 unless $line !~ /[^_]($isxxx_functions)\(\(unsigned char\)/;
+ # yes! fail.
+ return 0;
}
-ok( [EMAIL PROTECTED], 'isxxx() functions cast correctly' )
- or diag( "isxxx() function not cast to unsigned char "
- . @no_explicit_cast
- . " files:[EMAIL PROTECTED]" );
+Parrot::Test::Util::Runloop->testloop(
+ name => 'isxxx() functions cast correctly',
+ files => [EMAIL PROTECTED],
+ per_line => \&check_isxxx,
+ diag_prefix => 'isxxx() function not cast to unsigned char'
+);
# Local Variables:
# mode: cperl
Index: t/codingstd/trailing_space.t
===================================================================
--- t/codingstd/trailing_space.t (revision 26353)
+++ t/codingstd/trailing_space.t (working copy)
@@ -8,6 +8,7 @@
use lib qw( . lib ../lib ../../lib );
use Parrot::Distribution;
use Test::More tests => 1;
+use Parrot::Test::Util::Runloop;
=head1 NAME
@@ -39,40 +40,15 @@
$DIST->get_c_language_files(),
$DIST->get_perl_language_files(),
);
-my @failed_files;
-foreach my $file (@files) {
+Parrot::Test::Util::Runloop->testloop(
+ name => 'no trailing whitespace',
+ files => [EMAIL PROTECTED],
+ skips => $skip_files,
+ per_line => sub { shift !~ m{.?[ \t]+$}m },
+ diag_prefix => 'Trailing space or tab char found'
+);
- # if we have command line arguments, the file is the full path
- # otherwise, use the relevant Parrot:: path method
- my $path = @ARGV ? $file : $file->path;
-
- next if exists $skip_files->{$path};
-
- open my $fh, '<', $path
- or die "Cannot open '$path' for reading: $!\n";
-
- my $spacecount = 0;
-
- my $message = qq< $path:>;
- while (<$fh>) {
- next unless m{.?[ \t]+$}m;
- $message .= " $.";
- $spacecount++;
- }
- push @failed_files => "$message\n"
- if $spacecount;
-
-}
-
-# check the file
-ok( !scalar(@failed_files), 'No trailing spaces or tabs' )
- or diag(
- join
- $/ => "Trailing space or tab char found in " . scalar @failed_files . " files:",
- @failed_files
- );
-
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
Index: t/codingstd/c_cppcomments.t
===================================================================
--- t/codingstd/c_cppcomments.t (revision 26353)
+++ t/codingstd/c_cppcomments.t (working copy)
@@ -8,6 +8,7 @@
use lib qw( . lib ../lib ../../lib );
use Test::More tests => 1;
use Parrot::Distribution;
+use Parrot::Test::Util::Runloop;
=head1 NAME
@@ -34,29 +35,24 @@
my $DIST = Parrot::Distribution->new();
my @files = @ARGV ? @ARGV : $DIST->get_c_language_files();
-check_cppcomments(@files);
+Parrot::Test::Util::Runloop->testloop(
+ name => 'no cuddled elses',
+ files => [EMAIL PROTECTED],
+ per_file => \&check_cppcomments,
+ diag_prefix => 'Cuddled else found'
+);
+
sub check_cppcomments {
- my @files = @_;
+ my $buf = shift;
+ $buf =~ s{ (?:
+ (?: ' (?: \\\\ | \\' | [^'] )* ' ) # remove ' string
+ | (?: " (?: \\\\ | \\" | [^"] )* " ) # remove " string
+ | /\* .*? \*/ # remove C comment
+ )
+ }{}gsx;
- my @comments;
- foreach my $file (@files) {
- my $path = @ARGV ? $file : $file->path();
- my $buf = $DIST->slurp($path);
- $buf =~ s{ (?:
- (?: ' (?: \\\\ | \\' | [^'] )* ' ) # remove ' string
- | (?: " (?: \\\\ | \\" | [^"] )* " ) # remove " string
- | /\* .*? \*/ # remove C comment
- )
- }{}gsx;
-
- if ( $buf =~ m{ ( .*? // .* ) }x ) {
- push( @comments, "$path: $1\n" );
- }
- }
-
- ok( !scalar(@comments), 'C++ comments' )
- or diag( "C++ comments found in " . scalar @comments . " files:[EMAIL PROTECTED]" );
+ return $buf !~ m{ ( .*? // .* ) }x;
}
# Local Variables:
Index: t/codingstd/c_code_coda.t
===================================================================
--- t/codingstd/c_code_coda.t (revision 26353)
+++ t/codingstd/c_code_coda.t (working copy)
@@ -8,6 +8,7 @@
use lib qw( . lib ../lib ../../lib );
use Test::More tests => 2;
use Parrot::Distribution;
+use Parrot::Test::Util::Runloop;
=head1 NAME
@@ -45,36 +46,32 @@
my $DIST = Parrot::Distribution->new;
my @files = @ARGV ? @ARGV : $DIST->get_c_language_files();
-my @no_coda;
-my @extra_coda;
-foreach my $file (@files) {
+Parrot::Test::Util::Runloop->testloop(
+ name => 'every file has a coda',
+ files => [EMAIL PROTECTED],
+ per_file => sub { shift =~ m{\Q$coda\E\n*\z} },
+ diag_prefix => 'No coda found'
+);
- # if we have command line arguments, the file is the full path
- # otherwise, use the relevant Parrot:: path method
- my $path = @ARGV ? $file : $file->path;
+Parrot::Test::Util::Runloop->testloop(
+ name => 'only one coda per file',
+ files => [EMAIL PROTECTED],
+ per_file => \&check_duplicates,
+ diag_prefix => 'Duplicate coda found'
+);
- my $buf = $DIST->slurp($path);
+sub check_duplicates {
+ my $buf = shift;
- # append to the no_coda array if the code doesn't match
- push @no_coda => "$path\n"
- unless $buf =~ m{\Q$coda\E\n*\z};
-
# append to the extra_coda array if coda-like text appears more than once
my $vim_many = 0;
$vim_many++ while $buf =~ m{^ [* \t]* vim: }gmx;
my $emacs_many = 0;
$emacs_many++ while $buf =~ m{^ [* \t]* Local \s variables: }gmx;
- push @extra_coda => "$path\n"
- if $vim_many > 1 || $emacs_many > 1;
+ return ($vim_many <= 1 && $emacs_many <= 1);
}
-ok( !scalar(@no_coda), 'C code coda present' )
- or diag( "C code coda missing in " . scalar @no_coda . " files:[EMAIL PROTECTED]" );
-
-ok( !scalar(@extra_coda), 'C code coda appears only once' )
- or diag( "C code coda repeating in " . scalar @extra_coda . " files:[EMAIL PROTECTED]" );
-
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
