smeserver-test/root/sbin/e-smith/quicktest

#!/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