jan@74: "{ Package: 'stx:goodies/builder/reports' }" jan@74: jan@74: "{ NameSpace: Builder }" jan@74: jan@74: Report subclass:#TestReport jan@241: instanceVariableNames:'suite coverage instrument keepStdout' jan@241: classVariableNames:'' jan@241: poolDictionaries:'' jan@241: category:'Builder-Reports' jan@74: ! jan@74: jan@74: TestResult subclass:#Result jan@247: instanceVariableNames:'format time npassed nfailed nerror nskipped collector' jan@241: classVariableNames:'' jan@241: poolDictionaries:'' jan@241: privateIn:TestReport jan@74: ! jan@74: jan@74: jan@74: !TestReport methodsFor:'accessing'! jan@74: jan@241: keepStdout jan@241: ^ keepStdout jan@241: ! jan@241: jan@241: keepStdout:aBoolean jan@241: keepStdout := aBoolean. jan@241: ! jan@241: jan@74: suite jan@74: ^ suite jan@74: jan@74: "Created: / 07-11-2011 / 09:41:21 / Jan Vrany " jan@74: ! ! jan@74: jan@74: !TestReport methodsFor:'accessing - defaults'! jan@74: jan@74: defaultFileSuffix jan@74: jan@74: ^'Test' jan@74: jan@74: "Created: / 04-08-2011 / 12:56:37 / Jan Vrany " jan@74: ! jan@74: jan@74: defaultFormat jan@74: "superclass HDReport says that I am responsible to implement this method" jan@74: jan@74: ^ Builder::TestReportFormat::JUnit new jan@74: jan@74: "Created: / 04-08-2011 / 11:54:13 / Jan Vrany " jan@74: ! jan@74: jan@74: defaultName jan@74: jan@74: ^String streamContents:[:s| jan@74: suite tests do:[:suite| jan@74: s nextPutAll: suite name jan@74: ] separatedBy:[ jan@74: s nextPut:$,;space jan@74: ] jan@74: ] jan@74: jan@74: "Created: / 07-11-2011 / 09:47:02 / Jan Vrany " jan@74: ! ! jan@74: jan@164: !TestReport methodsFor:'command line options'! jan@164: jan@164: cmdlineOptionCoverage jan@164: jan@164: ^CmdLineOption new jan@164: short: $c; jan@164: long: 'coverage'; jan@234: description: 'collect code coverage when running tests'; jan@164: action:[ jan@164: coverage := CoverageReport new. jan@164: ] jan@164: jan@164: "Created: / 25-06-2013 / 15:36:46 / Jan Vrany " jan@234: "Modified: / 27-05-2014 / 16:54:32 / Jan Vrany " jan@234: ! jan@234: jan@246: cmdlineOptionDropStdout jan@246: jan@246: ^CmdLineOption new jan@246: long: 'drop-stdout'; jan@246: description: 'Do not include stdout in report'; jan@246: action:[ jan@246: keepStdout := false jan@246: ] jan@246: jan@246: "Created: / 08-08-2014 / 11:48:32 / Jan Vrany " jan@246: ! jan@246: jan@234: cmdlineOptionInstrument jan@234: jan@234: ^CmdLineOption new jan@234: short: $I; jan@234: long: 'instrument'; jan@234: description: 'extra package to instrument for coverage (implies --coverage)'; jan@234: action:[:package | jan@234: instrument isNil ifTrue:[ jan@234: instrument := Set new. jan@234: ]. jan@234: instrument add: package. jan@234: coverage isNil ifTrue:[ jan@234: coverage := CoverageReport new. jan@234: ]. jan@234: jan@234: ] jan@234: jan@234: "Created: / 27-05-2014 / 16:34:24 / Jan Vrany " jan@241: ! jan@241: jan@241: cmdlineOptionKeepStdout jan@241: jan@241: ^CmdLineOption new jan@241: long: 'keep-stdout'; jan@241: description: 'Keep stdout and include it in report (may generate huge report!!)'; jan@241: action:[ jan@241: keepStdout := true jan@241: ] jan@241: jan@241: "Created: / 16-06-2014 / 10:42:00 / Jan Vrany " jan@164: ! ! jan@164: jan@74: !TestReport methodsFor:'initialization'! jan@74: jan@74: initialize jan@74: jan@74: suite := TestSuite new. jan@164: coverage := nil. jan@246: keepStdout := true. jan@74: jan@246: "Modified: / 08-08-2014 / 11:45:36 / Jan Vrany " jan@74: ! jan@74: jan@74: setupForClasses:classes jan@90: "Setup the report to run given classes" jan@74: jan@90: | suiteFromClasses | jan@74: jan@90: suiteFromClasses := TestSuite named:name. jan@74: classes do: jan@74: [:cls | jan@74: |tc| jan@74: jan@74: cls isTestCaseLike jan@74: ifTrue: jan@74: [ tc := cls asTestCase. jan@90: tc isAbstract ifFalse:[ suiteFromClasses addTest:tc suite ] ] ]. jan@74: jan@90: self setupForSuite: suiteFromClasses. jan@74: jan@74: "Created: / 04-08-2011 / 14:34:50 / Jan Vrany " jan@74: ! jan@74: jan@164: setupForPackages:pkgs jan@74: jan@164: pkgs do: [:pkg | jan@74: |def | jan@74: jan@80: self loadPackageIfNotAlready: pkg. jan@74: def := ProjectDefinition definitionClassForPackage:pkg. jan@80: jan@74: (def respondsTo:#testSuite) ifTrue:[ jan@74: suite addTest:def testSuite jan@74: ] ifFalse:[ jan@74: | classes psuite | jan@74: psuite := TestSuite named:pkg. jan@74: jan@74: classes := def notNil jan@74: ifTrue:[ def classes ] jan@74: ifFalse:[ ProjectDefinition searchForClassesWithProject:pkg asSymbol ]. jan@74: classes do: [:cls | jan@74: |tc| jan@74: jan@74: cls isTestCaseLike ifTrue: [ jan@74: tc := cls asTestCase. jan@74: tc isAbstract ifFalse:[ jan@74: psuite addTest:tc suite jan@74: ] jan@74: ] jan@74: ]. jan@74: suite addTest: psuite. jan@74: ] jan@74: ]. jan@164: coverage notNil ifTrue:[ jan@164: coverage setupForPackages: packages. jan@234: instrument notNil ifTrue:[ jan@234: coverage setupForPackages: instrument. jan@234: ]. jan@164: ] jan@74: jan@234: "Modified: / 27-05-2014 / 16:35:52 / Jan Vrany " jan@74: ! jan@74: jan@90: setupForSuite: suiteToAdd jan@74: jan@90: suite addTest: suiteToAdd. jan@74: jan@74: "Created: / 06-11-2011 / 18:27:04 / Jan Vrany " jan@74: ! ! jan@74: jan@74: !TestReport methodsFor:'private'! jan@74: jan@74: print: anObject on: aStream jan@74: jan@74: [ anObject printOn: aStream ] jan@74: on: Error do: jan@74: [aStream jan@74: nextPutAll: '** error when prining instance of '; jan@74: nextPutAll: anObject class name; jan@74: nextPutAll: '**'] jan@74: jan@74: "Created: / 15-03-2011 / 22:09:13 / Jan Vrany " jan@74: ! ! jan@74: jan@74: !TestReport methodsFor:'running'! jan@74: jan@74: runReport jan@74: jan@164: | result | jan@74: result := Result new format:format. jan@164: coverage notNil ifTrue:[ jan@164: InstrumentationContext run:[ jan@164: suite run:result. jan@164: ]. jan@164: Transcript cr; cr. jan@164: Transcript show: 'COLLECTING COVERAGE...'. jan@164: coverage name: self name. jan@164: coverage run. jan@164: ] ifFalse:[ jan@164: suite run:result. jan@164: ]. jan@111: Transcript cr; cr. jan@215: jan@215: result failureOutcomes do:[:failureOutcome | jan@215: Transcript show: 'FAILED '. jan@215: failureOutcome testCase printOn: Transcript. jan@215: Transcript cr. jan@215: ]. jan@215: result errorOutcomes do:[:errorOutcome | jan@215: Transcript show: 'ERROR '. jan@215: errorOutcome testCase printOn: Transcript. jan@215: Transcript cr. jan@215: ]. jan@215: Transcript cr; cr. jan@111: Transcript show: 'SUMMARY: '. jan@111: result printOn: Transcript. jan@111: Transcript cr. jan@74: jan@74: "Created: / 04-08-2011 / 12:39:56 / Jan Vrany " jan@215: "Modified: / 23-10-2013 / 11:48:27 / Jan Vrany " jan@74: ! ! jan@74: jan@74: !TestReport::Result methodsFor:'accessing'! jan@74: jan@111: errorCount jan@111: jan@111: ^nerror jan@111: jan@111: "Created: / 31-01-2013 / 13:54:19 / Jan Vrany " jan@111: ! jan@111: jan@74: exceptions jan@74: jan@74: ^super exceptions , HaltInterrupt jan@74: jan@74: "Created: / 03-08-2011 / 14:59:31 / Jan Vrany " jan@74: ! jan@74: jan@111: failureCount jan@111: jan@111: ^nfailed jan@111: jan@111: "Created: / 31-01-2013 / 13:53:52 / Jan Vrany " jan@111: ! jan@111: jan@74: format jan@74: ^ format jan@74: ! jan@74: jan@74: format:aFormat jan@74: format := aFormat. jan@111: ! jan@111: jan@111: passedCount jan@111: jan@111: ^npassed jan@111: jan@111: "Created: / 31-01-2013 / 13:54:34 / Jan Vrany " jan@111: ! jan@111: jan@111: skippedCount jan@111: jan@111: ^nskipped jan@111: jan@111: "Created: / 31-01-2013 / 13:54:42 / Jan Vrany " jan@74: ! ! jan@74: jan@74: !TestReport::Result methodsFor:'adding'! jan@74: jan@74: addError: testcase detail: exception jan@74: jan@236: outcome result: (TestResult stateError). jan@247: outcome collectedOutput: collector contents. jan@236: format writeTestCase: testcase outcome: outcome time: time exception: exception. jan@239: Transcript show:'...ERROR'. jan@250: Logger trace: 'Finised %1>>%2, result ERROR' with: testcase nameForHDTestReport with: testcase selectorForHDTestReport. jan@215: self errorOutcomes add:outcome. jan@111: nerror := nerror + 1. jan@74: jan@74: "Created: / 03-08-2011 / 15:00:31 / Jan Vrany " jan@250: "Modified: / 29-10-2014 / 14:02:04 / Jan Vrany " jan@74: ! jan@74: jan@74: addFailure: testcase detail: exception jan@74: jan@236: outcome result: (TestResult stateFail). jan@247: outcome collectedOutput: collector contents. jan@236: format writeTestCase: testcase outcome: outcome time: time exception: exception. jan@239: Transcript show:'...FAILED'. jan@250: Logger trace: 'Finised %1>>%2, result FAILED' with: testcase nameForHDTestReport with: testcase selectorForHDTestReport. jan@215: self failureOutcomes add: outcome. jan@111: nfailed := nfailed + 1. jan@74: jan@74: "Created: / 03-08-2011 / 15:00:41 / Jan Vrany " jan@250: "Modified: / 29-10-2014 / 14:01:50 / Jan Vrany " jan@74: ! jan@74: jan@74: addPass: testcase jan@74: jan@236: outcome result: TestResult statePass. jan@236: format writeTestCase: testcase outcome: outcome time: time exception: nil. jan@239: Transcript show:'...OK'. jan@250: Logger trace: 'Finised %1>>%2, result PASSED' with: testcase nameForHDTestReport with: testcase selectorForHDTestReport. jan@111: npassed := npassed + 1. jan@74: jan@74: "Created: / 03-08-2011 / 15:19:54 / Jan Vrany " jan@250: "Modified: / 29-10-2014 / 14:01:06 / Jan Vrany " jan@105: ! jan@105: jan@105: addSkipped: testcase jan@105: jan@240: outcome := self createOutcome. jan@240: outcome testCase: testcase. jan@236: outcome result: TestResult stateSkip. jan@236: format writeTestCase: testcase outcome: outcome time: time exception: nil. jan@239: Transcript show:'...SKIPPED'. jan@250: Logger trace: 'Finised %1>>%2, result SKIPPED' with: testcase nameForHDTestReport with: testcase selectorForHDTestReport. jan@111: nskipped := nskipped + 1. jan@105: jan@105: "Created: / 21-11-2012 / 15:35:58 / Jan Vrany " jan@250: "Modified: / 29-10-2014 / 14:01:36 / Jan Vrany " jan@111: ! ! jan@111: jan@111: !TestReport::Result methodsFor:'initialization'! jan@111: jan@111: initialize jan@111: super initialize. jan@111: jan@111: npassed := nfailed := nerror := nskipped := 0 jan@111: jan@111: "Created: / 31-01-2013 / 13:52:33 / Jan Vrany " jan@74: ! ! jan@74: jan@74: !TestReport::Result methodsFor:'running'! jan@74: jan@74: performCase:aTestCase jan@251: | savedStdout savedStderr savedTranscript encoder | jan@74: jan@236: savedStdout := Stdout. jan@236: savedStderr := Stdout. jan@236: savedTranscript := Transcript. jan@251: encoder := OperatingSystem isMSWINDOWSlike jan@251: ifTrue:[ CharacterEncoder encoderForUTF8 ] jan@251: ifFalse:[ CharacterEncoder encoderFor: OperatingSystem getCodeset ]. jan@236: collector := WriteStream on:(String new:100). jan@236: [ jan@251: Stdout := SplittingWriteStream on:collector and: (EncodedStream stream: Stdout encoder: encoder). jan@251: Stderr := SplittingWriteStream on:collector and: (EncodedStream stream: Stderr encoder: encoder). jan@236: Transcript := SplittingWriteStream on:collector and: Transcript. jan@236: time := Time millisecondsToRun: [ super performCase: aTestCase ] jan@236: ] ensure:[ jan@236: Stdout := savedStdout. jan@236: Stderr := savedStderr. jan@236: Transcript := savedTranscript. jan@247: outcome collectedOutput: nil. "/ flush it, it has been written to output already jan@247: collector := nil. jan@236: ]. jan@74: jan@74: "Created: / 03-08-2011 / 18:40:18 / Jan Vrany " jan@251: "Modified: / 07-12-2014 / 01:12:08 / Jan Vrany " jan@74: ! jan@74: jan@74: runCase:aTestCase debugged: debugged jan@74: jan@74: | timeout | jan@74: timeout := aTestCase timeout. jan@74: jan@74: self runCase: aTestCase debugged: debugged jan@74: fork: (aTestCase shouldFork or:[timeout notNil]) jan@74: timeout: timeout ? 60"sec" jan@74: jan@74: "Created: / 22-08-2011 / 14:37:14 / Jan Vrany " jan@74: ! jan@74: jan@74: runCase:aTestCase debugged: debugged fork:doFork jan@74: jan@74: ^self runCase:aTestCase debugged: debugged jan@74: fork:doFork timeout: aTestCase timeout ? 60"sec" jan@74: jan@74: "Created: / 22-08-2011 / 14:38:11 / Jan Vrany " jan@74: ! jan@74: jan@74: runCase:aTestCase debugged: debugged fork:doFork timeout: tout jan@109: | nm sel | jan@105: jan@189: (aTestCase perform: #shouldSkip ifNotUnderstood:[false]) ifTrue:[ jan@105: self addSkipped: aTestCase. jan@105: ^self. jan@105: ]. jan@74: jan@74: nm := aTestCase nameForHDTestReport. jan@74: nm size > 20 ifTrue:[ jan@74: nm := (nm copyTo: 17) , '...' jan@74: ]. jan@74: sel := aTestCase selectorForHDTestReport. jan@74: sel size > 20 ifTrue:[ jan@74: sel := '...' , (sel copyFrom: sel size - 16 to: sel size) jan@74: ]. jan@234: Transcript showCR:('%1 >> #%2' bindWith: aTestCase nameForHDTestReport with: aTestCase selectorForHDTestReport). jan@250: Transcript show:('%-20s >> %-20s : ' printfWith: nm with: sel). jan@234: jan@74: outcome := self createOutcome. jan@74: outcome testCase: aTestCase. jan@74: jan@74: doFork ifFalse:[ jan@74: super runCase:aTestCase debugged: debugged. jan@74: Transcript cr. jan@74: ^self. jan@74: ]. jan@74: jan@74: OperatingSystem isUNIXlike ifTrue:[ jan@74: "/ self unixForkCase: aTestCase debugged: debugged. jan@74: "/ Use lightweight forking jan@74: self lightForkCase: aTestCase debugged: debugged timeout: tout. jan@74: ^ self. jan@74: ]. jan@74: OperatingSystem isMSWINDOWSlike ifTrue:[ jan@74: self lightForkCase: aTestCase debugged: debugged timeout: tout. jan@74: ^ self. jan@74: ]. jan@74: jan@74: self error:'Unssuported platform' jan@74: jan@74: "Created: / 12-01-2012 / 17:52:22 / Jan Vrany " jan@250: "Modified: / 29-10-2014 / 13:57:47 / Jan Vrany " jan@74: ! ! jan@74: jan@74: !TestReport::Result methodsFor:'running-private'! jan@74: jan@74: lightForkCase:aTestCase debugged: debugged timeout: timeout jan@74: | thread sema stime etime timeouted error stack log logPos | jan@74: jan@250: Logger trace: 'Running %1>>%2' with: aTestCase nameForHDTestReport with: aTestCase selectorForHDTestReport. jan@239: Transcript show:'F'. jan@74: sema := Semaphore new. jan@74: stime := OperatingSystem getMillisecondTime. jan@74: log := false. jan@74: logPos := format stream stream position. jan@74: timeouted := false. jan@74: thread := [ super runCase:aTestCase debugged: debugged ] newProcess. jan@74: thread addExitAction:[sema signal]. jan@237: thread name: ('Testcase execution thread (%1)' bindWith: aTestCase). jan@74: thread resume. jan@74: jan@239: Transcript show: 'W'. jan@74: (sema waitWithTimeout:timeout) isNil ifTrue: [ jan@239: Transcript show: 'T'. jan@237: stack := String streamContents:[:s | ReportRunner dumpProcessesOn:s ]. jan@74: thread terminate. jan@74: timeouted := true. jan@239: Transcript show: 'K'. jan@74: ]. jan@74: jan@74: etime := OperatingSystem getMillisecondTime. jan@74: timeouted ifTrue:[ jan@74: error := TimeoutError new messageText: 'Timed out'. jan@236: outcome result: TestResult stateError. jan@74: format jan@236: writeTestCase: aTestCase outcome: outcome jan@74: time: etime - stime jan@74: exception: error jan@74: stacktrace: stack. jan@250: Transcript show:'...ERROR'. jan@250: Logger trace: 'Finised %1>>%2, result ERROR (timeout)' with: aTestCase nameForHDTestReport with: aTestCase selectorForHDTestReport. jan@74: ]. jan@74: jan@74: outcome := nil. jan@74: Transcript cr. jan@74: jan@74: "Created: / 12-01-2012 / 17:42:12 / Jan Vrany " jan@250: "Modified: / 29-10-2014 / 13:59:54 / Jan Vrany " jan@74: ! jan@74: jan@74: unixForkCase:aTestCase debugged: debugged timeout: timeout jan@74: | pid status sema stime etime error stack suiteFailuresBefore suiteErrorsBefore log logPos | jan@74: jan@74: Transcript show:'forking...'. jan@74: sema := Semaphore new. jan@74: stime := OperatingSystem getMillisecondTime. jan@74: log := false. jan@74: logPos := format stream stream position. jan@74: Processor monitor: jan@74: [ pid := OperatingSystem fork. jan@74: pid == 0 ifTrue:[ nil ] ifFalse:[ pid ] ] jan@74: action: jan@74: [:s | jan@74: Transcript show:'child finished...'. jan@74: status := s. jan@74: sema signal ]. jan@74: pid == 0 jan@74: ifTrue: jan@74: [ "Child, exit codes: jan@74: 0...PASSED jan@74: 1...FAILED jan@74: 2...ERROR jan@74: >64...got signal -64" jan@74: jan@74: [ suiteFailuresBefore := failures. jan@74: suiteErrorsBefore := errors. jan@74: super runCase:aTestCase debugged: debugged. jan@74: suiteErrorsBefore ~~ errors ifTrue:[ Smalltalk exit:2 ]. jan@74: suiteFailuresBefore ~~ failures ifTrue:[ Smalltalk exit:1 ]. jan@74: format streamClose. jan@74: Smalltalk exit:0. ] on:OSSignalInterrupt jan@74: do:[:ex | format streamClose. Smalltalk exit:64 + ex parameter ] ] jan@74: ifFalse: jan@74: [ "Parent" jan@74: format streamClose. jan@74: Transcript show: 'waiting for child...'. jan@74: (sema waitWithTimeout:timeout) isNil jan@74: ifTrue: jan@74: [Transcript show: 'timeout...'. jan@74: OperatingSystem terminateProcess:pid. jan@74: OperatingSystem childProcessWait:true pid:pid. jan@74: Transcript show: 'killed...'. jan@74: ]. jan@74: etime := OperatingSystem getMillisecondTime. jan@74: (status isNil or:[ status success not ]) jan@74: ifFalse:[ jan@74: "/child finished, result is pass. However, it is not in my passed collection jan@74: "/since addPass: has been called in child process jan@74: super addPass: aTestCase. jan@74: ] ifTrue: jan@74: [ log := true. jan@74: status isNil jan@74: ifTrue: jan@74: [ error := TimeoutError new parameter:timeout. jan@74: stack := 'Oops, timed out!! (timeout was ' , timeout printString , ' sec)'. ] jan@74: ifFalse: jan@74: [ status status == #signal jan@74: ifTrue: jan@74: [ error := OSSignalInterrupt new parameter:status code. jan@74: stack := 'Oops, VM terminated on signal ' , status code printString, ' (stactrace not awailable)' ]. jan@74: status status == #exit jan@74: ifTrue: jan@74: [ status code == 1 jan@74: ifTrue: jan@74: [super addFailure: aTestCase detail: nil. jan@74: log := false ]. jan@74: status code == 2 jan@74: ifTrue: jan@74: [super addError: aTestCase detail: nil. jan@74: log := false ]. jan@74: status code > 64 jan@74: ifTrue: jan@74: [ error := OSSignalInterrupt new parameter:status code - 64. jan@74: stack := 'Oops, VM terminated on signal ' , status code p ] ] ]. ]. jan@74: format streamOpenForAppend. jan@74: log ifTrue:[ jan@236: outcome result: TestResult stateError. jan@74: format stream stream position: logPos. jan@74: format jan@236: writeTestCase: aTestCase outcome: outcome jan@74: time: etime - stime jan@74: exception: error jan@74: stacktrace: stack. jan@74: Transcript show:'ERROR' jan@74: ] jan@74: ]. jan@74: outcome := nil. jan@74: Transcript cr. jan@74: jan@74: "Created: / 12-01-2012 / 17:43:07 / Jan Vrany " jan@236: "Modified: / 06-06-2014 / 00:54:14 / Jan Vrany " jan@74: ! ! jan@74: jan@74: !TestReport class methodsFor:'documentation'! jan@74: jan@74: version jan@74: ^ '$Header$' jan@74: ! jan@74: jan@74: version_CVS jan@74: ^ '$Header$' jan@74: ! jan@74: jan@74: version_SVN jan@164: ^ '$Id$' jan@74: ! ! jan@111: