source: A2P/a2p/test/a2p-test.pl

#! /usr/bin/perl -w
#
# Copyright (c) 2004-2007 - Consultas, PKG.fr
#
# This file is part of A2P.
#
# A2P is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# A2P is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with A2P; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
#
# $Id: a2p-test.pl 3 2007-10-18 16:20:19Z guillaume $
#
# Unit tests launcher
#

use Carp qw(longmess);

$quiet = defined($ENV{DEBUG}) ? $ENV{DEBUG} == 0 : 1 ;

die "Environment A2P_PATH not set\n"
    unless (defined($ENV{A2P_PATH}));

die "A2P_PATH not set to a valid folder\n"
    unless ( -d $ENV{A2P_PATH} );

$| = 1 ;

chdir $ENV{A2P_PATH} ;
$folder = `pwd` ;
chomp $folder ;
die "Specified A2P_PATH ($folder) not contains the required 'test' folder\n"
    unless ( -d $folder .'/test' );

print "PID=$$\nScript=$0\nFolder=$folder\n" unless $quiet ;
$0 = '__A2P_TEST__' ;

%scripts = () ;

# 1. Scan test folders
# 1.1. Scan base test folder
opendir TEST, $folder . '/test'
    or die "Can't opendir 'test'\n" ;

foreach ( readdir TEST ) {
    if ( -d $_ and /\w+/ ) {
        push @test_folders, $_ ;
    } elsif ( /\.pl$/ and ! m|a2p-test\.pl$| and -x $_ ) {
        push @test_scripts, $folder . '/test/' . $_  ;
    }
}
close TEST ;

# 1.2. Sort base test scripts
@test_scripts = sort(@test_scripts) ;

# 1.3. Scan sub test folder
for $dir (sort(@test_folders)) {
    @scripts = () ;
    $clean = "" ;
    $thisfolder = "$folder/test/$dir" ;
    opendir TEST, $thisfolder
        or die "Can't opendir '$thisfolder'\n" ;
    foreach ( readdir TEST ) {
        next if /Defaults\.pm$/ ;
        next unless /\.p[lm]$/ ;
        $thisfile = $thisfolder . '/' . $_ ;
        next unless ( ! -d $thisfile and -x $thisfile );
        if (m|test-init.pl$|) {
            push @test_scripts , $thisfile ;
        } elsif (m|test-clean.pl$|) {
            $clean = $thisfile ;
        } else {
            push @scripts, $thisfile ;
        }
    }
    close TEST ;
    push @test_scripts, sort(@scripts);
    push @test_scripts, $clean if $clean ;
}

print "Found ".(@test_scripts)." scripts to run: " ;
print join( ", ", map { m|([^/]+)$| } @test_scripts ), "\n" unless ($quiet) ;

$stdout = "" ;

sub head {
    return "=" x 80 , "\n", "=== UNIT TEST @_: ",
        $script =~ m|^$folder/(test/.*)$|, "\n",
        "=" x 80 , "\n",
}

my @checks_re = (
    "^untie attempted while"
);
@checks_re = map { qr/$_/ } @checks_re ;

sub known_warns {
    my $ref = shift ;
    my @warn = () ;
    foreach my $line (@{$ref}) {
        push @warn, $line if ( grep { $line =~ $_ } @checks_re );
    }
    $quiet = 0 if @warn ;
    return @warn ;
}

@warns = () ;
$count = 0 ;

$SIG{__WARN__} = $SIG{__DIE__} =sub {
    $quiet = 0 ;
    my $mesg = &longmesg(@_) ;
    push @{$warns[$count]}, $mesg ;
    print "$mesg\n" ;
    } ;

# 2. Do tests
@scripts = () ;
@failed = () ;
foreach $script (@test_scripts) {
    $count ++ ;
    $scripts[$count] = $script ;
    $quiet = defined($ENV{DEBUG}) ? $ENV{DEBUG} == 0 : 1 ;
    @stdout = qx( perl -W $script 2>&1 ) ;
    push @{$warns[$count]}, &known_warns(\@stdout) ;
    if ($?) {
        $quiet = 0 ;
        print "unit test #$count failed\n" ;
        my @KOs = map { /(\d+)/ } grep { /^not ok \d+$/ } @stdout ;
        $" = ', ' ;
        push @{$warns[$count]}, "KO tests: @KOs" if @KOs ;
        push @failed, $count ;
    }

    $" = "\n" ;
    print $quiet ? "." : ( &head($count), "@stdout\n" ) ;
}

print "\nGood: ".($count-@failed)."/$count\nKO: ".@failed."\n" ;

$" = "\n" ;
map {
    print "Failed: $scripts[$_]\n" ;
    print "@{$warns[$_]}\n" if (ref($warns[$_]) =~ /^ARRAY/ and @{$warns[$_]}) ;
    $warns[$_] = 0 ;
    } @failed ;
@warns = grep { defined($_) and ref($_) =~ /^ARRAY/ and @{$_} } @warns ;
print "Other warnings:\n" if (@warns);
map { print "@{$_}" } @warns ;

exit(0);