SystemOrganization addCategory: #HudsonBuildTools!

Object subclass: #HDTestReport
	instanceVariableNames: 'suite stream suitePosition suiteTime suiteFailures suiteErrors'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'HudsonBuildTools'!

!HDTestReport class methodsFor: 'running' stamp: 'lr 1/10/2010 01:30'!
runCategories: aCollectionOfStrings
	aCollectionOfStrings do: [ :each | self runCategory: each ]! !

!HDTestReport class methodsFor: 'running' stamp: 'lr 1/10/2010 01:30'!
runCategory: aString
	self runClasses: (Smalltalk organization classesInCategory: aString) named: aString! !

!HDTestReport class methodsFor: 'running' stamp: 'lr 1/10/2010 02:15'!
runClasses: aCollectionOfClasses named: aString
	| suite classes |
	suite := TestSuite named: aString.
	classes := (aCollectionOfClasses
		select: [ :each | (each includesBehavior: TestCase) and: [ each isAbstract not ] ])
			asSortedCollection: [ :a :b | a name <= b name ].
	classes
		do: [ :each | each addToSuiteFromSelectors: suite ].
	self runSuite: suite! !

!HDTestReport class methodsFor: 'running' stamp: 'lr 1/10/2010 01:31'!
runPackage: aString
	^ self runClasses: (PackageInfo named: aString) classes named: aString! !

!HDTestReport class methodsFor: 'running' stamp: 'lr 1/10/2010 01:31'!
runPackages: aCollectionOfStrings
	aCollectionOfStrings do: [ :each | self runPackage: each ]! !

!HDTestReport class methodsFor: 'running' stamp: 'TestRunner 1/10/2010 00:58'!
runSuite: aTestSuite
	self new 
		initializeOn: aTestSuite; 
		run! !

!HDTestReport methodsFor: 'private' stamp: 'lr 1/10/2010 01:07'!
encode: aString
	^ ((aString asString 
		copyReplaceAll: '&' with: '&amp;') 
		copyReplaceAll: '"' with: '&quot;') 
		copyReplaceAll: '<' with: '&lt;'! !

!HDTestReport methodsFor: 'initialization' stamp: 'lr 1/10/2010 10:22'!
initializeOn: aTestSuite
	suite := aTestSuite.
	suitePosition := suiteTime := suiteFailures := suiteErrors := 0! !

!HDTestReport methodsFor: 'running' stamp: 'lr 1/10/2010 10:15'!
run
	[ self setUp.
	  suiteTime := [ self runAll ]
		timeToRun ]
			ensure: [ self tearDown ]! !

!HDTestReport methodsFor: 'running' stamp: 'lr 1/10/2010 14:56'!
run: aTestCase
	| error time stack |
	time := [ [ aTestCase runCase ] 
		on: Error , TestFailure
		do: [ :err |
			error := err.
			stack := String streamContents: [ :str | 
				| context |
				context := err signalerContext.
				[ context isNil or: [ context receiver == aTestCase and: [ context selector == #performTestperformTest ] ] ] whileFalse: [
					str print: context; cr.
					context := context sender ] ] ] ]
			timeToRun.
	stream tab; nextPutAll: '<testcase classname="'; nextPutAll: (self encode: aTestCase class name); nextPutAll: '" name="'; nextPutAll: (self encode: aTestCase selector); nextPutAll: '" time="'; print: time / 1000.0; nextPutAll: '">'; cr.
	(error isNil or: [ aTestCase expectedFailures includes: aTestCase selector ]) ifFalse: [
		(error isKindOf: TestFailure)
			ifTrue: [ 
				suiteFailures := suiteFailures + 1.
				stream tab; tab; nextPutAll: '<failure type="'; nextPutAll: (self encode: error class name); nextPutAll: '" message="'; nextPutAll: (self encode: (error messageText ifNil: [ error description ])); nextPutAll: '">'; nextPutAll: (self encode: stack); nextPutAll: '</failure>'; cr ]
			ifFalse: [ 
				suiteErrors := suiteErrors + 1.
				stream tab; tab; nextPutAll: '<error type="'; nextPutAll: (self encode: error class name); nextPutAll: '" message="'; nextPutAll: (self encode: (error messageText ifNil: [ error description ])); nextPutAll: '">'; nextPutAll: (self encode: stack); nextPutAll: '</error>'; cr ] ].
	stream tab; nextPutAll: '</testcase>'; cr! !

!HDTestReport methodsFor: 'running' stamp: 'lr 1/10/2010 01:27'!
runAll
	suite tests do: [ :each | self run: each ]! !

!HDTestReport methodsFor: 'running' stamp: 'lr 1/10/2010 10:23'!
setUp
	stream := StandardFileStream forceNewFileNamed: suite name , '.xml'.
	stream nextPutAll: '<?xml version="1.0" encoding="UTF-8"?>'; cr.
	stream nextPutAll: '<testsuite name="'; nextPutAll: (self encode: suite name); nextPutAll: '" tests="'; print: suite tests size; nextPutAll: '">'.
	"Now this is ugly. We want to update the time and the number of failures and errors, but still at the same time stream a valid XML. So remember this position and add some whitespace, that we can fill later."
	suitePosition := stream position - 1.
	stream nextPutAll: (String new: 100 withAll: $ ); cr! !

!HDTestReport methodsFor: 'running' stamp: 'lr 1/10/2010 10:24'!
tearDown
	suite resources 
		do: [ :each | each reset ].
	stream tab; nextPutAll: '<system-out><!![CDATA[]]></system-out>'; cr.
	stream tab; nextPutAll: '<system-err><!![CDATA[]]></system-err>'; cr.
	stream nextPutAll: '</testsuite>'.
	
	stream position: suitePosition.
	stream nextPutAll: ' failures="'; print: suiteFailures; nextPutAll:'" errors="'; print: suiteErrors; nextPutAll: '" time="'; print: suiteTime / 1000.0; nextPutAll: '">'.
	stream close! !