"{ Package: 'stx:goodies/sunit' }"

Object subclass:#TestResultReporter
	instanceVariableNames:'result stream'
	classVariableNames:''
	poolDictionaries:''
	category:'SUnit-Report'
!

!TestResultReporter class methodsFor:'documentation'!

documentation
"
    Currently supported formats are:
        #xml    - a junit-like format
        #tap    - perl TAP unit test format; very naive and simple,
                  but there are tools for it...

    public API entry:
        |aTestResult|

        aTestResult := aUnitTest suite run.
        TestResultReporter report:aTestResult format:#xml on: aStream

    [author:]
        Jan Vranji
        documentation & tap format added by Claus Gittinger
"
!

examples
"
    |testResult|

    testResult := RegressionTests::IntegerTest suite run.
    TestResultReporter report:testResult format:#xml on:Transcript.
    TestResultReporter report:testResult format:#tap on:Transcript.
"
! !

!TestResultReporter class methodsFor:'queries'!

supportedFormats
    ^ #(
        (#'xml'   'a junit-like format')
        (#'tap'   'perl TAP unit test format')
    )

    "Created: / 30-07-2011 / 10:18:18 / cg"
! !

!TestResultReporter class methodsFor:'reporting'!

report: aTestResult format: format as: stringOrFilename

    self new report: aTestResult format: format as: stringOrFilename
!

report: aTestResult format: format on: stream

    self new report: aTestResult format: format on: stream

    "
     self report:(RegressionTests::IntegerTest runTests) format:#xml on:Transcript
    "

    "Modified (comment): / 30-07-2011 / 09:37:53 / cg"
! !

!TestResultReporter methodsFor:'reporting'!

report:formatSymbol
    "currently supported formatSymbols:
            xml"

    |reportFormatSelector|

    reportFormatSelector := self reportFormatSelector:formatSymbol.
    (self respondsTo: reportFormatSelector)
        ifTrue:[self perform: reportFormatSelector]
        ifFalse:[self error:'Unsupported format: ', formatSymbol].

    "Modified (comment): / 30-07-2011 / 09:37:31 / cg"
!

report: aTestResult format: format as: stringOrFilename

    | s |
    s := stringOrFilename asFilename writeStream.
    [ self report: aTestResult format: format on: s]
	ensure:[s close].
!

report: aTestResult format: aSymbol on: aStream

    result := aTestResult.
    stream := aStream.
    self report: aSymbol
!

reportFormatSelector:format
    ^ ('report' , format asString capitalized) asSymbol
! !

!TestResultReporter methodsFor:'reporting - tap'!

reportTap
    "TAP (perl unit test) report format"

    |idx reportWith|

    "example:
        1..4
        ok 1 - Input file opened
        not ok 2 - First line of the input valid
        ok 3 - Read the rest of the file
        not ok 4 - Summarized correctly # TODO Not written yet
    "

    "/ what about not-executed tests - why only runCount ?
    stream nextPutLine: ('1..%1' bindWith:result runCount).

    reportWith := 
        [:tests :status |
            tests do:[:each | self reportTapTest: each index: idx result: status. idx := idx + 1 ]
        ].

    idx := 1.
    reportWith value:result passed value:#success.
    reportWith value:result failures value:#failure.
    reportWith value:result errors value:#error.

    "Created: / 30-07-2011 / 10:12:31 / cg"
!

reportTapTest: test index:index result: testResult
    | testClassName executionTime  testDescription statusString|

    testClassName := self sunitNameOf: test class.

    "most tests do not know, and return nil here!!"
    executionTime := test executionTime ? 0.0.

    testDescription := '%1-%2 (%3ms)'
                            bindWith:testClassName
                            with:test selector
                            with:executionTime.

    statusString := (testResult == #success)
                        ifTrue:['ok']
                        ifFalse:['not ok'].

    stream nextPutLine:('%1 %2 - %3'
                            bindWith:statusString
                            with:index
                            with:testDescription).

    "Created: / 30-07-2011 / 10:28:06 / cg"
! !

!TestResultReporter methodsFor:'reporting - xml'!

reportXml
    "JUnit-like XML unittest report format"

    stream
        nextPutLine: '<?xml version="1.0"?>';
        nextPutLine: '<unittest-results>'.

    result passed   do:[:each|self reportXmlTest: each result: #success].
    result failures do:[:each|self reportXmlTest: each result: #failure].
    result errors   do:[:each|self reportXmlTest: each result: #error].

    stream
        nextPutLine: '</unittest-results>'

    "Modified (format): / 30-07-2011 / 09:54:16 / cg"
!

reportXmlTest: test result: testResult

    "
    Example:
    <test
        duration='0.0188629627228'
        status='error'
        fixture='bitten.tests.web_ui.SourceFileLinkFormatterTestCase'
        name='test_format_link_not_in_repos_with_line'
        file='/usr/src/trac-bitten-0.6b2.dfsg/bitten/tests/web_ui.py'>
    "

    | testClassName executionTime |

    testClassName := self sunitNameOf: test class.

    "most tests do not know, and return nil here!!"
    executionTime := test executionTime ? 0.0.

    stream
        nextPutAll:'<test duration="'; nextPutAll:executionTime; nextPutLine:'"'; 
        tab; nextPutAll:'status="'; nextPutAll: testResult; nextPutLine:'"';
        tab; nextPutAll:'ficture="'; nextPutAll: testClassName; nextPutLine:'"';
        tab; nextPutAll:'name="'; nextPutAll: test selector; nextPutLine:'"';
        "It seems that some tools requires the file attributes. So we supply one :-)"
        tab; nextPutAll:'file="'; nextPutAll: testClassName , '.st'; nextPutLine:'">'.

    testResult ~= #success ifTrue:[self reportXmlTraceback: test].

    stream nextPutLine:'</test>'.

    "Modified: / 30-07-2011 / 10:10:02 / cg"
!

reportXmlTraceback: test

    "
	Prints a traceback to the stream.
	This is dialect-specific, so we have to check...
    "

    "Smalltalk/X dialect detection..."
    ((Smalltalk respondsTo: #isSmalltalkX) and:[Smalltalk isSmalltalkX])
	ifTrue:[^self reportXmlTracebackStX: test]
!

reportXmlTracebackStX: test

    stream nextPutLine:'<traceback><!![CDATA['.

    [ test debug ]
	on: GenericException
	do: [:ex|
	    ex suspendedContext fullPrintAllOn: stream].

    stream nextPutLine:']]></traceback>'.

    "Modified: / 07-12-2009 / 14:06:48 / Jan Vrany <jan.vrant@fit.cvut.cz>"
! !

!TestResultReporter methodsFor:'utilities'!

sunitNameOf: aClass

    "No all SUnit versions comes with sunitName
     (at least Smalltalk/X 3.1)"

    ^(aClass respondsTo:#sunitName)
	ifTrue:[aClass sunitName]
	ifFalse:[aClass printString]
! !

!TestResultReporter class methodsFor:'documentation'!

version
    ^ '$Header: /cvs/stx/stx/goodies/sunit/TestResultReporter.st,v 1.3 2011-07-30 08:32:26 cg Exp $'
!

version_CVS
    ^ '$Header: /cvs/stx/stx/goodies/sunit/TestResultReporter.st,v 1.3 2011-07-30 08:32:26 cg Exp $'
!

version_SVN
    ^ '§Id§'
! !