326 lines
7.5 KiB
Plaintext
326 lines
7.5 KiB
Plaintext
|
#!/usr/bin/perl -w
|
||
|
|
#----------------------------------------------------------------------
|
||
|
|
# Copyright 1999-2003 Mitel Networks Corporation
|
||
|
|
# This program is free software; you can redistribute it and/or
|
||
|
|
# modify it under the same terms as Perl itself.
|
||
|
|
#----------------------------------------------------------------------
|
||
|
|
|
||
|
|
=head1 NAME
|
||
|
|
|
||
|
|
quicktest - quickly run all tests in the current CVS project
|
||
|
|
|
||
|
|
=head1 SYNOPSIS
|
||
|
|
|
||
|
|
quicktest
|
||
|
|
quicktest [files ...] [--verbose]
|
||
|
|
|
||
|
|
quicktest [-d] [--verbose] file
|
||
|
|
|
||
|
|
|
||
|
|
=head1 DESCRIPTION
|
||
|
|
|
||
|
|
This is a little script to let you quickly run your tests while making
|
||
|
|
changes to an existing e-smith RPM project.
|
||
|
|
|
||
|
|
Unless given a specific set of files to run, it will run all .t files
|
||
|
|
and embedded tests in the current CVS project. It allows you to do a
|
||
|
|
quick test of the RPM without having to do much figuring or typing.
|
||
|
|
|
||
|
|
It will also use any perl libraries located in the current CVS
|
||
|
|
project.
|
||
|
|
|
||
|
|
The "current CVS project" is defined by whatever CVS project you're
|
||
|
|
current working directory is in. So if you're sitting in
|
||
|
|
~/devel/e-smith-base/root/usr/ it will assume your project is
|
||
|
|
e-smith-base.
|
||
|
|
|
||
|
|
Emacs backup files, CVS backup files and other temporary and backup
|
||
|
|
files will be automatically skipped.
|
||
|
|
|
||
|
|
All tests will be run with warnings on.
|
||
|
|
|
||
|
|
=head2 Switches
|
||
|
|
|
||
|
|
=over 4
|
||
|
|
|
||
|
|
=item B<-d>
|
||
|
|
|
||
|
|
Tells quicktest to run the test in the debugger. It will gracefully
|
||
|
|
handle embedded tests.
|
||
|
|
|
||
|
|
quicktest -d lib/some/module.pm
|
||
|
|
|
||
|
|
=item B<--verbose>
|
||
|
|
|
||
|
|
With --verbose quicktest will print out all the lines received from
|
||
|
|
the test.
|
||
|
|
|
||
|
|
=back
|
||
|
|
|
||
|
|
=head1 FILES
|
||
|
|
|
||
|
|
CVS/Repository
|
||
|
|
|
||
|
|
=head1 AUTHOR
|
||
|
|
|
||
|
|
Mitel Networks Corporation.
|
||
|
|
|
||
|
|
For more information, see http://www.e-smith.org/
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use File::Find;
|
||
|
|
use File::Spec;
|
||
|
|
|
||
|
|
$| = 1;
|
||
|
|
|
||
|
|
open(my $repository, 'CVS/Repository') ||
|
||
|
|
die "Can't find a CVS/Repository to look at: $!";
|
||
|
|
my $path = <$repository>;
|
||
|
|
close $repository;
|
||
|
|
|
||
|
|
my($project) = $path =~ m{^([^/]+)};
|
||
|
|
chomp $project;
|
||
|
|
print STDERR "Testing '$project'\n";
|
||
|
|
|
||
|
|
|
||
|
|
use Getopt::Long;
|
||
|
|
|
||
|
|
my %Opts = ();
|
||
|
|
GetOptions(\%Opts, 'd', 'verbose');
|
||
|
|
|
||
|
|
my $Verbose = $ENV{HARNESS_VERBOSE} || $Opts{verbose};
|
||
|
|
|
||
|
|
my @names = @ARGV;
|
||
|
|
my @files = map File::Spec->rel2abs($_), @ARGV;
|
||
|
|
|
||
|
|
|
||
|
|
# Go to the top of the project.
|
||
|
|
chomp $path;
|
||
|
|
my $updir = join '/', ('..') x $path =~ tr|/||;
|
||
|
|
chdir $updir if length $updir;
|
||
|
|
|
||
|
|
my $test_dir = 'root/etc/e-smith/tests';
|
||
|
|
die "Can't find $test_dir" unless -d $test_dir;
|
||
|
|
|
||
|
|
chdir $test_dir;
|
||
|
|
@files = map File::Spec->abs2rel($_), @files;
|
||
|
|
|
||
|
|
|
||
|
|
# Use any libraries in this CVS repository. Test::Harness will
|
||
|
|
# automatically apply this to the tests.
|
||
|
|
our $This_Lib =
|
||
|
|
File::Spec->rel2abs('../../../../root/usr/lib/perl5/site_perl');
|
||
|
|
unshift @INC, $This_Lib;
|
||
|
|
|
||
|
|
|
||
|
|
if($Opts{d}) { # debugging
|
||
|
|
die "I need a file to debug.\n" unless @files;
|
||
|
|
die "You can only debug a single program at a time.\n" unless @files == 1;
|
||
|
|
|
||
|
|
my $file = $files[0];
|
||
|
|
my $name = $names[0];
|
||
|
|
warn "Debugging $file\n";
|
||
|
|
my $test_file = _test_file($file);
|
||
|
|
die "There are no tests in $name\n" unless $test_file;
|
||
|
|
system("PERL5LIB=$This_Lib $^X -d $test_file");
|
||
|
|
exit;
|
||
|
|
}
|
||
|
|
|
||
|
|
unless( @files ) {
|
||
|
|
find(sub {
|
||
|
|
if( -d $_ and $_ eq 'CVS' ) {
|
||
|
|
$File::Find::prune = 1;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
return if /~$/ || /^\.#/;
|
||
|
|
push @files, $File::Find::name if -f $_
|
||
|
|
}, '../../../..'
|
||
|
|
);
|
||
|
|
|
||
|
|
@names = map { (my $name = $_) =~ s[(\.\./){4}root/][]g; $name } @files;
|
||
|
|
}
|
||
|
|
|
||
|
|
{
|
||
|
|
package My::Strap;
|
||
|
|
use Test::Harness::Straps;
|
||
|
|
our @ISA = qw(Test::Harness::Straps);
|
||
|
|
|
||
|
|
sub _display {
|
||
|
|
my($self, $out) = @_;
|
||
|
|
print $self->{_ml}."$out";
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _print {
|
||
|
|
my($self) = shift;
|
||
|
|
print @_;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
### This is using an experimental callback interface in
|
||
|
|
### Test::Harness::Straps so it can print out test results as they
|
||
|
|
### happen. As the interface is experimental, check the changelog
|
||
|
|
### before upgrading Test::Harness::Straps.
|
||
|
|
|
||
|
|
my $s = My::Strap->new;
|
||
|
|
|
||
|
|
my %handlers = (
|
||
|
|
bailout => sub {
|
||
|
|
my($self, $line, $type, $totals) = @_;
|
||
|
|
|
||
|
|
die sprintf "FAILED--Further testing stopped%s\n",
|
||
|
|
$self->{bailout_reason} ? ": $self->{bailout_reason}" : '';
|
||
|
|
},
|
||
|
|
test => sub {
|
||
|
|
my($self, $line, $type, $totals) = @_;
|
||
|
|
my $curr = $totals->{seen};
|
||
|
|
|
||
|
|
if( $totals->{details}[-1]{ok} ) {
|
||
|
|
$self->_display("ok $curr/$totals->{max}") unless $Verbose;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$self->_display("NOK $curr") unless $Verbose;
|
||
|
|
}
|
||
|
|
|
||
|
|
if( $curr > $self->{'next'} ) {
|
||
|
|
$self->_print("Test output counter mismatch [test $curr]\n");
|
||
|
|
}
|
||
|
|
elsif( $curr < $self->{'next'} ) {
|
||
|
|
$self->_print("Confused test output: test $curr answered after ".
|
||
|
|
"test ", $self->{next} - 1, "\n");
|
||
|
|
# $self->{'next'} = $curr;
|
||
|
|
}
|
||
|
|
},
|
||
|
|
);
|
||
|
|
|
||
|
|
$s->{callback} = sub {
|
||
|
|
my($self, $line, $type, $totals) = @_;
|
||
|
|
print $line if $Verbose;
|
||
|
|
|
||
|
|
$handlers{$type}->($self, $line, $type, $totals) if $handlers{$type};
|
||
|
|
};
|
||
|
|
|
||
|
|
|
||
|
|
close STDIN; # else tests might hang waiting for input.
|
||
|
|
|
||
|
|
|
||
|
|
# Iterate through each test or file and run that test.
|
||
|
|
# Most of the code herein is for nice formatting.
|
||
|
|
my $all_passing = 1;
|
||
|
|
my $width = _leader_width(@names);
|
||
|
|
$width = 70 if $width > 70;
|
||
|
|
foreach my $idx (0..$#files) {
|
||
|
|
my($file, $name) = ($files[$idx], $names[$idx]);
|
||
|
|
my %result = ();
|
||
|
|
|
||
|
|
my $test_file = _test_file($file);
|
||
|
|
next unless $test_file;
|
||
|
|
|
||
|
|
my($leader, $ml) = _mk_leader($name, $width);
|
||
|
|
print $leader;
|
||
|
|
print "\n" if $Verbose;
|
||
|
|
$s->{_ml} = $ml;
|
||
|
|
|
||
|
|
local $ENV{HARNESS_PERL_SWITCHES} = '-w';
|
||
|
|
%result = $s->analyze_file($test_file);
|
||
|
|
|
||
|
|
$all_passing = 0 unless $result{passing};
|
||
|
|
$s->_display($result{passing} ? 'ok' : 'FAILED');
|
||
|
|
print "\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
if( $all_passing ) {
|
||
|
|
print "All tests successful!\n"
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
print "SOME TESTS FAILED!\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=begin private
|
||
|
|
|
||
|
|
=over 4
|
||
|
|
|
||
|
|
=item B<_test_file>
|
||
|
|
|
||
|
|
my $test_file = _test_file($file);
|
||
|
|
|
||
|
|
Determines this $file is a test or has embedded tests and generates
|
||
|
|
a runable $test_file based on this.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub _test_file {
|
||
|
|
my $file = shift;
|
||
|
|
|
||
|
|
my $test_file;
|
||
|
|
if( $file =~ /\.t$/ ) {
|
||
|
|
$test_file = $file;
|
||
|
|
}
|
||
|
|
elsif( system("pod2test '$file' > /tmp/embedded$$.t") == 0 ) {
|
||
|
|
$test_file = "/tmp/embedded$$.t";
|
||
|
|
}
|
||
|
|
|
||
|
|
return $test_file;
|
||
|
|
}
|
||
|
|
|
||
|
|
=item B<_mk_leader>
|
||
|
|
|
||
|
|
my($leader, $ml) = _mk_leader($test_file, $width);
|
||
|
|
|
||
|
|
Generates the 't/foo........' $leader for the given $test_file as well
|
||
|
|
as a similar version which will overwrite the current line (by use of
|
||
|
|
\r and such). $ml may be empty if Test::Harness doesn't think you're
|
||
|
|
on TTY.
|
||
|
|
|
||
|
|
The $width is the width of the "yada/blah.." string.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub _mk_leader {
|
||
|
|
my($te, $width) = @_;
|
||
|
|
chomp($te);
|
||
|
|
$te =~ s/\.\w+$/./;
|
||
|
|
|
||
|
|
if ($^O eq 'VMS') { $te =~ s/^.*\.t\./\[.t./s; }
|
||
|
|
my $blank = (' ' x 77);
|
||
|
|
my $leader = "$te" . '.' x ($width - length($te));
|
||
|
|
my $ml = "";
|
||
|
|
|
||
|
|
$ml = "\r$blank\r$leader"
|
||
|
|
if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $ENV{HARNESS_VERBOSE};
|
||
|
|
|
||
|
|
return($leader, $ml);
|
||
|
|
}
|
||
|
|
|
||
|
|
=item B<_leader_width>
|
||
|
|
|
||
|
|
my($width) = _leader_width(@test_files);
|
||
|
|
|
||
|
|
Calculates how wide the leader should be based on the length of the
|
||
|
|
longest test name.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub _leader_width {
|
||
|
|
my $maxlen = 0;
|
||
|
|
my $maxsuflen = 0;
|
||
|
|
foreach (@_) {
|
||
|
|
my $suf = /\.(\w+)$/ ? $1 : '';
|
||
|
|
my $len = length;
|
||
|
|
my $suflen = length $suf;
|
||
|
|
$maxlen = $len if $len > $maxlen;
|
||
|
|
$maxsuflen = $suflen if $suflen > $maxsuflen;
|
||
|
|
}
|
||
|
|
# + 3 : we want three dots between the test name and the "ok"
|
||
|
|
return $maxlen + 3 - $maxsuflen;
|
||
|
|
}
|
||
|
|
|
||
|
|
=back
|
||
|
|
|
||
|
|
=end private
|
||
|
|
|
||
|
|
|