"{ Package: 'stx:goodies/builder/reports' }"

"{ NameSpace: Builder }"

Report subclass:#TestReport
	instanceVariableNames:'suite coverage instrument'
	classVariableNames:''
	poolDictionaries:''
	category:'Builder-Reports'
!

TestResult subclass:#Result
	instanceVariableNames:'format time npassed nfailed nerror nskipped'
	classVariableNames:''
	poolDictionaries:''
	privateIn:TestReport
!


!TestReport methodsFor:'accessing'!

suite
    ^ suite

    "Created: / 07-11-2011 / 09:41:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestReport methodsFor:'accessing - defaults'!

defaultFileSuffix

    ^'Test'

    "Created: / 04-08-2011 / 12:56:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

defaultFormat
    "superclass HDReport says that I am responsible to implement this method"

    ^ Builder::TestReportFormat::JUnit new

    "Created: / 04-08-2011 / 11:54:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

defaultName

    ^String streamContents:[:s|
        suite tests do:[:suite|
            s nextPutAll: suite name
        ] separatedBy:[
            s nextPut:$,;space
        ]
    ]

    "Created: / 07-11-2011 / 09:47:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestReport methodsFor:'command line options'!

cmdlineOptionCoverage

    ^CmdLineOption new
        short: $c;
        long: 'coverage';
        description: 'collect code coverage when running tests';
        action:[
            coverage := CoverageReport new.
        ]

    "Created: / 25-06-2013 / 15:36:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 27-05-2014 / 16:54:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

cmdlineOptionInstrument

    ^CmdLineOption new
        short: $I;
        long: 'instrument';
        description: 'extra package to instrument for coverage (implies --coverage)';
        action:[:package |
            instrument isNil ifTrue:[ 
                instrument := Set new.
            ].
            instrument add: package.
            coverage isNil ifTrue:[ 
                coverage := CoverageReport new.
            ].

        ]

    "Created: / 27-05-2014 / 16:34:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestReport methodsFor:'initialization'!

initialize

    suite := TestSuite new.
    coverage := nil.

    "Modified: / 25-06-2013 / 15:37:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

setupForClasses:classes
    "Setup the report to run given classes"

    | suiteFromClasses |

    suiteFromClasses := TestSuite named:name.
    classes do:
            [:cls | 
            |tc|

            cls isTestCaseLike 
                ifTrue:
                    [ tc := cls asTestCase.
                    tc isAbstract ifFalse:[ suiteFromClasses addTest:tc suite ] ] ].

    self setupForSuite: suiteFromClasses.

    "Created: / 04-08-2011 / 14:34:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

setupForPackages:pkgs 

    pkgs do: [:pkg | 
        |def |

        self loadPackageIfNotAlready: pkg.
        def := ProjectDefinition definitionClassForPackage:pkg.

        (def respondsTo:#testSuite) ifTrue:[ 
            suite addTest:def testSuite 
        ] ifFalse:[ 
            | classes psuite |
            psuite := TestSuite named:pkg.

            classes := def notNil 
                        ifTrue:[ def classes ]
                        ifFalse:[ ProjectDefinition searchForClassesWithProject:pkg asSymbol ].
            classes do: [:cls | 
                |tc|

                cls isTestCaseLike ifTrue: [ 
                    tc := cls asTestCase.
                    tc isAbstract ifFalse:[ 
                        psuite addTest:tc suite
                    ]
                ]
            ].
            suite addTest: psuite.
        ]
    ].
    coverage notNil ifTrue:[
        coverage setupForPackages: packages.
        instrument notNil ifTrue:[ 
            coverage setupForPackages: instrument.
        ].
    ]

    "Modified: / 27-05-2014 / 16:35:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

setupForSuite: suiteToAdd

    suite addTest: suiteToAdd.

    "Created: / 06-11-2011 / 18:27:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestReport methodsFor:'private'!

print: anObject on: aStream

    [ anObject printOn: aStream ]
        on: Error do:
            [aStream 
                nextPutAll: '** error when prining instance of ';
                nextPutAll: anObject class name;
                nextPutAll: '**']

    "Created: / 15-03-2011 / 22:09:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestReport methodsFor:'running'!

runReport

    | result |
    result := Result new format:format.
    coverage notNil ifTrue:[
        InstrumentationContext  run:[
            suite run:result.
        ].
        Transcript cr; cr.
        Transcript show: 'COLLECTING COVERAGE...'.
        coverage name: self name.
        coverage run.
    ] ifFalse:[
        suite run:result.
    ].
    Transcript cr; cr.

    result failureOutcomes do:[:failureOutcome |
        Transcript show: 'FAILED '.
        failureOutcome testCase printOn: Transcript.
        Transcript cr.
    ].
    result errorOutcomes do:[:errorOutcome |
        Transcript show: 'ERROR  '.
        errorOutcome testCase printOn: Transcript.
        Transcript cr.
    ].
    Transcript cr; cr.
    Transcript show: 'SUMMARY: '.
    result printOn: Transcript.
    Transcript cr.

    "Created: / 04-08-2011 / 12:39:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 23-10-2013 / 11:48:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestReport::Result methodsFor:'accessing'!

errorCount

    ^nerror

    "Created: / 31-01-2013 / 13:54:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

exceptions

    ^super exceptions , HaltInterrupt

    "Created: / 03-08-2011 / 14:59:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

failureCount

    ^nfailed

    "Created: / 31-01-2013 / 13:53:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

format
    ^ format
!

format:aFormat
    format := aFormat.
!

passedCount

    ^npassed

    "Created: / 31-01-2013 / 13:54:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

skippedCount

    ^nskipped

    "Created: / 31-01-2013 / 13:54:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestReport::Result methodsFor:'adding'!

addError: testcase detail: exception

    outcome result: (TestResult stateError).
    format writeTestCase: testcase outcome: outcome time: time exception: exception.
    Transcript show:'ERROR'.
    self errorOutcomes add:outcome.      
    nerror := nerror + 1.

    "Created: / 03-08-2011 / 15:00:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 06-06-2014 / 01:00:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

addFailure: testcase detail: exception

    outcome result: (TestResult stateFail).
    format writeTestCase: testcase outcome: outcome time: time exception: exception.
    Transcript show:'FAILED'.
    self failureOutcomes add: outcome.
    nfailed := nfailed + 1.

    "Created: / 03-08-2011 / 15:00:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 06-06-2014 / 01:00:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

addPass: testcase

    outcome result: TestResult statePass.
    format writeTestCase: testcase outcome: outcome time: time exception: nil.
    Transcript show:'OK'.
    npassed := npassed + 1.

    "Created: / 03-08-2011 / 15:19:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 06-06-2014 / 01:00:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

addSkipped: testcase

    outcome result: TestResult stateSkip.
    format writeTestCase: testcase outcome: outcome time: time exception: nil.
    Transcript show:'SKIPPED'.
    nskipped := nskipped + 1.

    "Created: / 21-11-2012 / 15:35:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 06-06-2014 / 00:59:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestReport::Result methodsFor:'initialization'!

initialize
    super initialize.

    npassed := nfailed := nerror := nskipped := 0

    "Created: / 31-01-2013 / 13:52:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestReport::Result methodsFor:'running'!

performCase:aTestCase 
    | savedStdout savedStderr savedTranscript collector|

    savedStdout := Stdout.
    savedStderr := Stdout.
    savedTranscript := Transcript.
    collector := WriteStream on:(String new:100).
    [
        Stdout := SplittingWriteStream on:collector and: Stdout.
        Stderr := SplittingWriteStream on:collector and: Stderr.
        Transcript := SplittingWriteStream on:collector and: Transcript.
        time := Time millisecondsToRun: [ super performCase: aTestCase ]
    ] ensure:[
        Stdout := savedStdout.
        Stderr := savedStderr.
        Transcript := savedTranscript.
        outcome collectedOutput: collector contents.
    ].

    "Created: / 03-08-2011 / 18:40:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 05-06-2014 / 16:25:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

runCase:aTestCase debugged: debugged 

    | timeout |
    timeout := aTestCase timeout.

    self runCase: aTestCase debugged: debugged 
         fork:  (aTestCase shouldFork or:[timeout notNil])
         timeout: timeout ? 60"sec"

    "Created: / 22-08-2011 / 14:37:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

runCase:aTestCase debugged: debugged fork:doFork

    ^self runCase:aTestCase debugged: debugged 
          fork:doFork timeout: aTestCase timeout ? 60"sec"

    "Created: / 22-08-2011 / 14:38:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

runCase:aTestCase debugged: debugged fork:doFork timeout: tout
    | nm sel |

    (aTestCase perform: #shouldSkip ifNotUnderstood:[false]) ifTrue:[
        self addSkipped: aTestCase.
        ^self.
    ].

    nm := aTestCase nameForHDTestReport.
    nm size > 20 ifTrue:[
        nm := (nm copyTo: 17) , '...'
    ].
    sel := aTestCase selectorForHDTestReport.
    sel size > 20 ifTrue:[
        sel := '...' , (sel copyFrom: sel size - 16 to: sel size)
    ].
    Transcript showCR:('%1 >> #%2' bindWith: aTestCase nameForHDTestReport with: aTestCase selectorForHDTestReport).
    Transcript show:('%-20s >> %-20s : ' printfWith: nm with: sel). 


    outcome := self createOutcome.
    outcome testCase: aTestCase.

    doFork ifFalse:[ 
        super runCase:aTestCase debugged: debugged.
        Transcript cr.
        ^self.
    ].

    OperatingSystem isUNIXlike ifTrue:[
"/        self unixForkCase: aTestCase debugged: debugged.
"/      Use lightweight forking
        self lightForkCase: aTestCase debugged: debugged timeout: tout.
        ^ self.
    ].
    OperatingSystem isMSWINDOWSlike ifTrue:[
        self lightForkCase: aTestCase debugged: debugged timeout: tout.
        ^ self.
    ].

    self error:'Unssuported platform'

    "Created: / 12-01-2012 / 17:52:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 28-11-2012 / 18:04:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestReport::Result methodsFor:'running-private'!

lightForkCase:aTestCase debugged: debugged timeout: timeout
    | thread sema stime etime timeouted error stack log logPos |

    Transcript show:'forking...'.
    sema := Semaphore new.
    stime := OperatingSystem getMillisecondTime.
    log := false.
    logPos := format stream stream position.
    timeouted := false.
    thread := [ super runCase:aTestCase debugged: debugged ] newProcess.
    thread addExitAction:[sema signal].
    thread name: ('Testcase execution thread (%1)' bindWith: aTestCase).
    thread resume.

    Transcript show: 'waiting for child...'.
    (sema waitWithTimeout:timeout) isNil ifTrue: [
        Transcript show: 'timeout...'.
        stack := String streamContents:[:s |  ReportRunner dumpProcessesOn:s ].
        thread terminate.
        timeouted := true.
        Transcript show: 'killed...'.
    ].

    etime := OperatingSystem getMillisecondTime.
    timeouted ifTrue:[
        error := TimeoutError new messageText: 'Timed out'.
        outcome result: TestResult stateError.
        format 
            writeTestCase: aTestCase outcome: outcome 
                     time: etime - stime
                exception: error
               stacktrace: stack.
         Transcript show:'ERROR'
    ].

    outcome := nil.
    Transcript cr.

    "Created: / 12-01-2012 / 17:42:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 06-06-2014 / 09:19:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

unixForkCase:aTestCase debugged: debugged timeout: timeout
    | pid status sema stime etime error stack suiteFailuresBefore suiteErrorsBefore log logPos |

    Transcript show:'forking...'.
    sema := Semaphore new.
    stime := OperatingSystem getMillisecondTime.
    log := false.
    logPos := format stream stream position.
    Processor monitor:
            [ pid := OperatingSystem fork.
            pid == 0 ifTrue:[ nil ] ifFalse:[ pid ] ]
        action:
            [:s | 
            Transcript show:'child finished...'.
            status := s.
            sema signal ].
    pid == 0 
        ifTrue:
            [ "Child, exit codes:
             0...PASSED
             1...FAILED
             2...ERROR
           >64...got signal <code>-64"
            
            [ suiteFailuresBefore := failures.
            suiteErrorsBefore := errors.
            super runCase:aTestCase debugged: debugged.
            suiteErrorsBefore ~~ errors ifTrue:[ Smalltalk exit:2 ].
            suiteFailuresBefore ~~ failures ifTrue:[ Smalltalk exit:1 ].
            format streamClose.
            Smalltalk exit:0. ] on:OSSignalInterrupt
                    do:[:ex | format streamClose. Smalltalk exit:64 + ex parameter ] ]
        ifFalse:
            [ "Parent"
            format streamClose.
            Transcript show: 'waiting for child...'.
            (sema waitWithTimeout:timeout) isNil 
                ifTrue:
                    [Transcript show: 'timeout...'.
                    OperatingSystem terminateProcess:pid.
                    OperatingSystem childProcessWait:true pid:pid.
                    Transcript show: 'killed...'.
                    ].
            etime := OperatingSystem getMillisecondTime.
            (status isNil or:[ status success not ]) 
                ifFalse:[
                    "/child finished, result is pass. However, it is not in my passed collection
                    "/since addPass: has been called in child process
                   super addPass: aTestCase.
                ] ifTrue:
                    [ log := true.
                    status isNil 
                        ifTrue:
                            [ error := TimeoutError new parameter:timeout.
                            stack := 'Oops, timed out!! (timeout was ' , timeout printString , ' sec)'. ]
                        ifFalse:
                            [ status status == #signal 
                                ifTrue:
                                    [ error := OSSignalInterrupt new parameter:status code.
                                    stack := 'Oops, VM terminated on signal ' , status code printString, ' (stactrace not awailable)' ].
                            status status == #exit 
                                ifTrue:
                                    [ status code == 1 
                                        ifTrue:
                                            [super addFailure: aTestCase detail: nil.
                                            log := false ].
                                    status code == 2 
                                        ifTrue:
                                            [super addError: aTestCase detail: nil.
                                            log := false ].
                                    status code > 64 
                                        ifTrue:
                                            [ error := OSSignalInterrupt new parameter:status code - 64.
                                            stack := 'Oops, VM terminated on signal ' , status code p ] ] ]. ].
            format streamOpenForAppend.
            log ifTrue:[
                     outcome result: TestResult stateError.
                     format stream stream position: logPos.
                     format 
                        writeTestCase: aTestCase outcome: outcome 
                                 time: etime - stime
                            exception: error
                           stacktrace: stack.
                     Transcript show:'ERROR'
            ]
    ].
    outcome := nil.
    Transcript cr.

    "Created: / 12-01-2012 / 17:43:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 06-06-2014 / 00:54:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!TestReport class methodsFor:'documentation'!

version
    ^ '$Header$'
!

version_CVS
    ^ '$Header$'
!

version_SVN
    ^ '$Id$'
! !