2009-06-04 19:30:23 +04:00
# Perl module for parsing and generating the Subunit protocol
# Copyright (C) 2008-2009 Jelmer Vernooij <jelmer@samba.org>
2009-03-25 17:40:39 +03:00
#
# 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-05 18:36:10 +04:00
sub parse_results ($$$)
2007-08-27 19:15:38 +04:00
{
2009-06-05 18:36:10 +04:00
my ( $ msg_ops , $ statistics , $ fh ) = @ _ ;
2007-10-02 19:54:26 +04:00
my $ expected_fail = 0 ;
my $ unexpected_fail = 0 ;
my $ unexpected_err = 0 ;
2009-06-05 18:36:10 +04:00
my $ 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 ( $ _ ) ;
2009-06-05 18:10:12 +04:00
$ msg_ops - > start_test ( $ 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/ ) {
2009-06-05 18:32:52 +04:00
$ msg_ops - > report_time ( mktime ( $ 6 , $ 5 , $ 4 , $ 3 , $ 2 , $ 1 - 1900 ) ) ;
2009-06-05 18:55:45 +04:00
} elsif ( /^(success|successful|failure|fail|skip|knownfail|error|xfail|skip-testsuite|testsuite-failure|testsuite-xfail|testsuite-success|testsuite-error): (.*?)( \[)?([ \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-05 18:10:12 +04:00
$ msg_ops - > end_test ( $ testname , "error" , 1 , "reason ($result) 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-05 16:06:32 +04:00
$ msg_ops - > end_test ( $ testname , $ result , 0 , $ reason ) ;
2009-06-04 15:49:11 +04:00
} 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-05 16:06:32 +04:00
$ msg_ops - > end_test ( $ 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-05 16:06:32 +04:00
$ msg_ops - > end_test ( $ 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 ) ;
}
2009-06-05 16:06:32 +04:00
$ msg_ops - > end_test ( $ testname , $ result , 0 , $ reason ) ;
2009-06-04 15:49:11 +04:00
} 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
2009-06-05 16:06:32 +04:00
$ msg_ops - > end_test ( $ testname , $ result , 1 , $ reason ) ;
2007-10-02 19:54:26 +04:00
$ unexpected_err + + ;
2009-06-05 18:10:12 +04:00
} elsif ( $ result eq "skip-testsuite" ) {
$ msg_ops - > skip_testsuite ( $ testname ) ;
} elsif ( $ result eq "testsuite-success" ) {
$ msg_ops - > end_testsuite ( $ testname , "success" , $ reason ) ;
} elsif ( $ result eq "testsuite-failure" ) {
$ msg_ops - > end_testsuite ( $ testname , "failure" , $ reason ) ;
2009-06-05 18:55:45 +04:00
} elsif ( $ result eq "testsuite-xfail" ) {
$ msg_ops - > end_testsuite ( $ testname , "xfail" , $ reason ) ;
2009-06-05 18:10:12 +04:00
} elsif ( $ result eq "testsuite-error" ) {
$ msg_ops - > end_testsuite ( $ testname , "error" , $ reason ) ;
}
} elsif ( /^testsuite: (.*)\n/ ) {
$ msg_ops - > start_testsuite ( $ 1 ) ;
} elsif ( /^testsuite-count: (\d+)\n/ ) {
$ msg_ops - > testsuite_count ( $ 1 ) ;
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
}
}
2009-06-05 18:36:10 +04:00
while ( $#$ open_tests + 1 > 0 ) {
2009-06-05 18:10:12 +04:00
$ msg_ops - > end_test ( 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 ;
2009-06-11 21:59:26 +04:00
return 0 ;
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-05 18:10:12 +04:00
print "$result: $name [\n" ;
2009-06-04 15:49:11 +04:00
print "$reason" ;
print "]\n" ;
2009-06-03 20:03:45 +04:00
} else {
print "$result: $name\n" ;
}
}
2009-06-05 18:10:12 +04:00
sub skip_test ( $ ; $ )
{
my $ name = shift ;
my $ reason = shift ;
end_test ( $ name , "skip" , $ reason ) ;
}
sub fail_test ( $ ; $ )
{
my $ name = shift ;
my $ reason = shift ;
end_test ( $ name , "fail" , $ reason ) ;
}
sub success_test ( $ ; $ )
{
my $ name = shift ;
my $ reason = shift ;
end_test ( $ name , "success" , $ reason ) ;
}
sub xfail_test ( $ ; $ )
{
my $ name = shift ;
my $ reason = shift ;
end_test ( $ name , "xfail" , $ reason ) ;
}
2009-06-03 20:03:45 +04:00
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 ;
}
2009-06-05 18:10:12 +04:00
# The following are Samba extensions:
sub start_testsuite ($)
{
my ( $ name ) = @ _ ;
print "testsuite: $name\n" ;
}
sub skip_testsuite ( $ ; $ )
{
my ( $ name , $ reason ) = @ _ ;
if ( $ reason ) {
2009-06-05 19:25:42 +04:00
print "skip-testsuite: $name [\n$reason\n]\n" ;
2009-06-05 18:10:12 +04:00
} else {
print "skip-testsuite: $name\n" ;
}
}
sub end_testsuite ( $ $ ; $ )
{
my $ name = shift ;
my $ result = shift ;
my $ reason = shift ;
if ( $ reason ) {
2009-06-05 18:32:52 +04:00
print "testsuite-$result: $name [\n" ;
print "$reason\n" ;
2009-06-05 18:10:12 +04:00
print "]\n" ;
} else {
2009-06-05 18:32:52 +04:00
print "testsuite-$result: $name\n" ;
2009-06-05 18:10:12 +04:00
}
}
sub testsuite_count ($)
{
my ( $ count ) = @ _ ;
print "testsuite-count: $count\n" ;
}
2007-08-27 19:15:38 +04:00
1 ;