SystemOrganization addCategory: #HudsonBuildTools!

Object subclass: #HDTestReport
	instanceVariableNames: 'suite stream'
	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: 'TestRunner 1/10/2010 00:57'!
runClasses: aCollectionOfClasses named: aString
	| suite classes |
	suite := TestSuite named: aString.
	classes := aCollectionOfClasses
		select: [ :each | (each includesBehavior: TestCase) and: [ each isAbstract not ] ].
	classes := classes 
		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 01:03'!
initializeOn: aTestSuite
	suite := aTestSuite! !

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

!HDTestReport methodsFor: 'running' stamp: 'lr 1/10/2010 01:58'!
run: aTestCase
	| error time stack |
	time := [ [ aTestCase runCase ] 
		on: Error , TestFailure
		do: [ :err |
			error := err.
			stack := String streamContents: [ :str | 
				| context |
				context := err signalerContext.
				[ context notNil ] whileTrue: [ 
					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: [
		stream tab; tab; nextPutAll: '<failure message="'; nextPutAll: (self encode: (error messageText ifNil: [ error description ])); nextPutAll: '">'; nextPutAll: (self encode: stack); nextPutAll: '</failure>'; 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 01:24'!
setUp
	suite resources do: [ :each |
		each isAvailable
			ifFalse: [ each signalInitializationError ] ].
	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: '">'; cr! !

!HDTestReport methodsFor: 'running' stamp: 'lr 1/10/2010 01:05'!
tearDown
	suite resources 
		do: [ :each | each reset ].
	stream nextPutAll: '</testsuite>'! !