--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/reports/Builder__TestReport.st Fri Jan 13 11:08:28 2012 +0100
@@ -0,0 +1,408 @@
+"{ Package: 'stx:goodies/builder/reports' }"
+
+"{ NameSpace: Builder }"
+
+Report subclass:#TestReport
+ instanceVariableNames:'suite'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Builder-Reports'
+!
+
+TestResult subclass:#Result
+ instanceVariableNames:'format time'
+ 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:'initialization'!
+
+initialize
+
+ suite := TestSuite new.
+
+ "Modified: / 07-11-2011 / 09:40:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+setupForClasses:classes
+
+ | suite |
+
+ suite := TestSuite named:name.
+ classes do:
+ [:cls |
+ |tc|
+
+ cls isTestCaseLike
+ ifTrue:
+ [ tc := cls asTestCase.
+ tc isAbstract ifFalse:[ suite addTest:tc suite ] ] ].
+
+ self setupForSuite: suite.
+
+ "Created: / 04-08-2011 / 14:34:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+setupForPackages:packages
+
+ packages do: [:pkg |
+ |def |
+
+ def := ProjectDefinition definitionClassForPackage:pkg.
+ def isNil ifTrue:[
+ Smalltalk loadPackage:pkg asSymbol.
+ 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.
+ ]
+ ].
+
+ "Modified: / 07-11-2011 / 09:43:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+setupForSuite: suite
+
+ suite addTest: suite.
+
+ "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.
+ suite run:result.
+
+ "Created: / 04-08-2011 / 12:39:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!TestReport::Result methodsFor:'accessing'!
+
+exceptions
+
+ ^super exceptions , HaltInterrupt
+
+ "Created: / 03-08-2011 / 14:59:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+format
+ ^ format
+!
+
+format:aFormat
+ format := aFormat.
+! !
+
+!TestReport::Result methodsFor:'adding'!
+
+addError: testcase detail: exception
+
+ format writeTestCase: testcase outcome: #error time: time exception: exception.
+ Transcript show:'ERROR'
+
+ "Created: / 03-08-2011 / 15:00:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+addFailure: testcase detail: exception
+
+ format writeTestCase: testcase outcome: #failure time: time exception: exception.
+ Transcript show:'FAILED'
+
+ "Created: / 03-08-2011 / 15:00:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+addPass: testcase
+
+ format writeTestCase: testcase outcome: #pass time: time exception: nil.
+ Transcript show:'OK'
+
+ "Created: / 03-08-2011 / 15:19:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!TestReport::Result methodsFor:'running'!
+
+performCase:aTestCase
+
+ time := Time millisecondsToRun: [ super performCase: aTestCase ]
+
+ "Created: / 03-08-2011 / 18:40:18 / 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 |
+
+ 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 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>"
+! !
+
+!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 resume.
+
+ Transcript show: 'waiting for child...'.
+ (sema waitWithTimeout:timeout) isNil ifTrue: [
+ Transcript show: 'timeout...'.
+ thread terminate.
+ timeouted := true.
+ Transcript show: 'killed...'.
+ ].
+
+ etime := OperatingSystem getMillisecondTime.
+ timeouted ifTrue:[
+ error := TimeoutError new messageText: 'Timed out'.
+ stack := 'Timed out'.
+ format
+ writeTestCase: aTestCase outcome: #error
+ 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>"
+!
+
+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:[
+ format stream stream position: logPos.
+ format
+ writeTestCase: aTestCase outcome: #error
+ 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>"
+! !
+
+!TestReport class methodsFor:'documentation'!
+
+version
+ ^ '$Header$'
+!
+
+version_CVS
+ ^ '$Header$'
+!
+
+version_SVN
+ ^ '§Id: Builder__TestReport.st 300 2012-01-12 17:53:04Z vranyj1 §'
+! !