2009-03-25 17:40:39 +03:00
# Simple Perl module for parsing the Subunit protocol
# Copyright (C) 2008 Jelmer Vernooij <jelmer@samba.org>
#
# This program 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 3 of the License, or
# (at your option) any later version.
# This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
2007-08-27 19:15:38 +04:00
package Subunit ;
2009-06-03 19:39:54 +04:00
use POSIX ;
2007-08-27 19:15:38 +04:00
require Exporter ;
@ ISA = qw( Exporter ) ;
@ EXPORT_OK = qw( parse_results ) ;
use strict ;
2009-06-03 20:19:01 +04:00
sub parse_results ($$$$)
2007-08-27 19:15:38 +04:00
{
2009-06-03 20:19:01 +04:00
my ( $ msg_ops , $ statistics , $ fh , $ open_tests ) = @ _ ;
2007-10-02 19:54:26 +04:00
my $ unexpected_ok = 0 ;
my $ expected_fail = 0 ;
my $ unexpected_fail = 0 ;
my $ unexpected_err = 0 ;
2007-12-20 17:54:02 +03:00
my $ orig_open_len = $#$ open_tests ;
2007-08-27 19:15:38 +04:00
2008-03-18 17:36:03 +03:00
while ( <$fh> ) {
2007-08-27 19:15:38 +04:00
if ( /^test: (.+)\n/ ) {
2007-12-20 19:07:21 +03:00
$ msg_ops - > control_msg ( $ _ ) ;
$ msg_ops - > start_test ( $ open_tests , $ 1 ) ;
2007-12-20 17:54:02 +03:00
push ( @$ open_tests , $ 1 ) ;
2009-06-03 19:39:54 +04:00
} elsif ( /^time: (\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)Z\n/ ) {
$ msg_ops - > report_time ( mktime ( $ 6 , $ 5 , $ 4 , $ 3 , $ 2 , $ 1 ) ) ;
2009-06-03 20:19:01 +04:00
} elsif ( /^(success|successful|failure|fail|skip|knownfail|error|xfail): (.*?)( \[)?([ \t]*)\n/ ) {
2007-12-20 19:07:21 +03:00
$ msg_ops - > control_msg ( $ _ ) ;
2009-06-04 15:49:11 +04:00
my $ result = $ 1 ;
my $ testname = $ 2 ;
2007-08-27 19:15:38 +04:00
my $ reason = undef ;
if ( $ 3 ) {
$ reason = "" ;
# reason may be specified in next lines
2008-04-16 02:03:00 +04:00
my $ terminated = 0 ;
2007-08-27 19:15:38 +04:00
while ( <$fh> ) {
2007-12-20 19:07:21 +03:00
$ msg_ops - > control_msg ( $ _ ) ;
2008-04-16 02:03:00 +04:00
if ( $ _ eq "]\n" ) { $ terminated = 1 ; last ; } else { $ reason . = $ _ ; }
}
unless ( $ terminated ) {
$ statistics - > { TESTS_ERROR } + + ;
2009-06-04 15:49:11 +04:00
$ msg_ops - > end_test ( $ open_tests , $ testname , $ result , 1 , "reason interrupted" ) ;
2008-04-16 02:03:00 +04:00
return 1 ;
2007-08-27 19:15:38 +04:00
}
}
2009-06-04 15:49:11 +04:00
if ( $ result eq "success" or $ result eq "successful" ) {
pop ( @$ open_tests ) ; #FIXME: Check that popped value == $testname
2009-06-03 20:19:01 +04:00
$ statistics - > { TESTS_EXPECTED_OK } + + ;
2009-06-04 15:49:11 +04:00
$ msg_ops - > end_test ( $ open_tests , $ testname , $ result , 0 , $ reason ) ;
} elsif ( $ result eq "xfail" or $ result eq "knownfail" ) {
pop ( @$ open_tests ) ; #FIXME: Check that popped value == $testname
2008-04-16 02:03:00 +04:00
$ statistics - > { TESTS_EXPECTED_FAIL } + + ;
2009-06-04 15:49:11 +04:00
$ msg_ops - > end_test ( $ open_tests , $ testname , $ result , 0 , $ reason ) ;
2009-06-03 20:19:01 +04:00
$ expected_fail + + ;
2009-06-04 15:49:11 +04:00
} elsif ( $ result eq "failure" or $ result eq "fail" ) {
pop ( @$ open_tests ) ; #FIXME: Check that popped value == $testname
2009-06-03 20:19:01 +04:00
$ statistics - > { TESTS_UNEXPECTED_FAIL } + + ;
2009-06-04 15:49:11 +04:00
$ msg_ops - > end_test ( $ open_tests , $ testname , $ result , 1 , $ reason ) ;
2009-06-03 20:19:01 +04:00
$ unexpected_fail + + ;
2009-06-04 15:49:11 +04:00
} elsif ( $ result eq "skip" ) {
2007-08-27 19:15:38 +04:00
$ statistics - > { TESTS_SKIP } + + ;
2009-06-04 15:49:11 +04:00
my $ last = pop ( @$ open_tests ) ;
if ( defined ( $ last ) and $ last ne $ testname ) {
push ( @$ open_tests , $ testname ) ;
}
$ msg_ops - > end_test ( $ open_tests , $ testname , $ result , 0 , $ reason ) ;
} elsif ( $ result eq "error" ) {
2007-08-27 19:15:38 +04:00
$ statistics - > { TESTS_ERROR } + + ;
2009-06-04 15:49:11 +04:00
pop ( @$ open_tests ) ; #FIXME: Check that popped value == $testname
$ msg_ops - > end_test ( $ open_tests , $ testname , $ result , 1 , $ reason ) ;
2007-10-02 19:54:26 +04:00
$ unexpected_err + + ;
2007-08-27 19:15:38 +04:00
}
} else {
2007-12-20 19:07:21 +03:00
$ msg_ops - > output_msg ( $ _ ) ;
2007-08-27 19:15:38 +04:00
}
}
2007-12-20 17:54:02 +03:00
while ( $#$ open_tests > $ orig_open_len ) {
2007-12-20 19:07:21 +03:00
$ msg_ops - > end_test ( $ open_tests , pop ( @$ open_tests ) , "error" , 1 ,
2007-10-02 19:54:26 +04:00
"was started but never finished!" ) ;
2007-08-27 19:15:38 +04:00
$ statistics - > { TESTS_ERROR } + + ;
2007-10-02 19:54:26 +04:00
$ unexpected_err + + ;
2007-08-27 19:15:38 +04:00
}
2007-10-02 19:54:26 +04:00
return 1 if $ unexpected_err > 0 ;
return 1 if $ unexpected_fail > 0 ;
return 1 if $ unexpected_ok > 0 and $ expected_fail > 0 ;
return 0 if $ unexpected_ok > 0 and $ expected_fail == 0 ;
return 0 if $ expected_fail > 0 ;
return 1 ;
2007-08-27 19:15:38 +04:00
}
2009-06-03 20:03:45 +04:00
sub start_test ($)
{
my ( $ testname ) = @ _ ;
print "test: $testname\n" ;
}
sub end_test ( $ $ ; $ )
{
my $ name = shift ;
my $ result = shift ;
my $ reason = shift ;
if ( $ reason ) {
2009-06-04 15:49:11 +04:00
print "$result: $name [" ;
print "$reason" ;
print "]\n" ;
2009-06-03 20:03:45 +04:00
} else {
print "$result: $name\n" ;
}
}
sub report_time ($)
{
my ( $ time ) = @ _ ;
my ( $ sec , $ min , $ hour , $ mday , $ mon , $ year , $ wday , $ yday , $ isdst ) = localtime ( $ time ) ;
printf "time: %04d-%02d-%02d %02d:%02d:%02dZ\n" , $ year + 1900 , $ mon , $ mday , $ hour , $ min , $ sec ;
}
2007-08-27 19:15:38 +04:00
1 ;