--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/reports/Builder__CoverageReport.st	Fri Jan 13 11:06:51 2012 +0100
@@ -0,0 +1,172 @@
+"{ Package: 'stx:goodies/builder/reports' }"
+
+"{ NameSpace: Builder }"
+
+TestReport subclass:#CoverageReport
+	instanceVariableNames:'packages wrappers covered'
+	classVariableNames:''
+	poolDictionaries:''
+	category:'Builder-Reports-Unfinished'
+!
+
+
+!CoverageReport methodsFor:'generating'!
+
+generate
+	| coverage |
+	covered := (wrappers select: [ :each | each hasRun ])
+		collect: [ :each | each reference ].
+	coverage := StandardFileStream 
+		forceNewFileNamed: suite name , '-Coverage.xml'.
+	[ self generateOn: coverage ]
+		ensure: [ coverage close ]
+!
+
+generateDataOn: aStream
+	| items |
+	aStream tab; nextPutAll: '<data>'; nextPut: Character lf.
+	aStream tab; tab; nextPutAll: '<all name="all classes">'; nextPut: Character lf.
+	self
+		generateType: 'class' indent: 3
+		total: (items := (packages gather: [ :each | each classes ]) asSet) size
+		actual: ((covered collect: [ :each | each actualClass theNonMetaClass ]) asSet
+			count: [ :each | items includes: each ])
+		on: aStream.
+	self
+		generateType: 'method' indent: 3
+		total: (items := (packages gather: [ :each | each methods ]) asSet) size 
+		actual: (covered count: [ :each | items includes: each ])
+		on: aStream.
+	packages do: [ :each | self generatePackage: each on: aStream ].
+	aStream tab; tab; nextPutAll: '</all>'; nextPut: Character lf.
+	aStream tab; nextPutAll: '</data>'; nextPut: Character lf
+!
+
+generateOn: aStream
+	aStream nextPutAll: '<?xml version="1.0" encoding="UTF-8"?>'; nextPut: Character lf.
+	aStream nextPutAll: '<report>'; nextPut: Character lf.
+	self generateStatsOn: aStream.
+	self generateDataOn: aStream.
+	aStream nextPutAll: '</report>'; nextPut: Character lf
+!
+
+generatePackage: aPackage class: aClass on: aStream
+	| items |
+	aStream tab: 4; nextPutAll: '<class name="'; nextPutAll: (self encode: aClass name); nextPutAll: '">'; nextPut: Character lf.
+	self
+		generateType: 'class' indent: 5
+		total: 1
+		actual: ((covered anySatisfy: [ :each | each actualClass theNonMetaClass = aClass ])
+			ifTrue: [ 1 ] ifFalse: [ 0 ])
+		on: aStream.
+	self
+		generateType: 'method' indent: 5
+		total: (items := aPackage coreMethodsForClass: aClass) size
+		actual: (covered count: [ :each | items includes: each ])
+		on: aStream.
+	items do: [ :each | self generatePackage: each method: each on: aStream ].	
+	aStream tab: 4; nextPutAll: '</class>'; nextPut: Character lf
+!
+
+generatePackage: aPackage method: aReference on: aStream
+	| items |
+	aStream tab: 5; nextPutAll: '<method name="'; nextPutAll: (self encode: aReference selector); nextPutAll: '">'; nextPut: Character lf.
+	self
+		generateType: 'method' indent: 6
+		total: 1
+		actual: ((covered includes: aReference) ifTrue: [ 1 ] ifFalse: [ 0 ])
+		on: aStream.
+	aStream tab: 5; nextPutAll: '</method>'; nextPut: Character lf
+!
+
+generatePackage: aPackage on: aStream
+	| items |
+	aStream tab: 3; nextPutAll: '<package name="'; nextPutAll: (self encode: (aPackage packageName copyReplaceAll: '-' with: '.')); nextPutAll: '">'; nextPut: Character lf.
+	self
+		generateType: 'class' indent: 4
+		total: (items := aPackage classes asSet) size
+		actual: ((covered collect: [ :each | each actualClass theNonMetaClass ]) asSet
+			count: [ :each | items includes: each ])
+		on: aStream.
+	self
+		generateType: 'method' indent: 4
+		total: (items := aPackage methods asSet) size
+		actual: (covered count: [ :each | items includes: each ])
+		on: aStream.
+	aPackage classes 
+		do: [ :class | self generatePackage: aPackage class: class on: aStream ].
+	aStream tab: 3; nextPutAll: '</package>'; nextPut: Character lf
+!
+
+generateStatsOn: aStream
+	aStream tab; nextPutAll: '<stats>'; nextPut: Character lf.
+	aStream tab; tab; nextPutAll: '<packages value="'; print: (packages size); nextPutAll: '"/>'; nextPut: Character lf.
+	aStream tab; tab; nextPutAll: '<classes value="'; print: (packages detectSum: [ :each | each classes size ]); nextPutAll: '"/>'; nextPut: Character lf.
+	aStream tab; tab; nextPutAll: '<methods value="'; print: (packages detectSum: [ :each | each methods size ]); nextPutAll: '"/>'; nextPut: Character lf.
+	aStream tab; nextPutAll: '</stats>'; nextPut: Character lf.
+!
+
+generateType: aString indent: anInteger total: totalInteger actual: actualInteger on: aStream
+	aStream tab: anInteger; nextPutAll: '<coverage type="'; nextPutAll: aString; nextPutAll: ', %" value="'; print: (totalInteger = 0 ifTrue: [ 0 ] ifFalse: [ (100.0 * actualInteger / totalInteger) rounded ]); nextPutAll: '% ('; print: actualInteger; nextPut: $/; print: totalInteger; nextPutAll: ')"/>'; nextPut: Character lf
+! !
+
+!CoverageReport methodsFor:'private'!
+
+addTestsIn: aTestAsserter to: aSet
+        (aTestAsserter isKindOf: TestSuite) ifTrue: [
+                aTestAsserter tests
+                        do: [ :each | self addTestsIn: each to: aSet ] ].
+        (aTestAsserter isKindOf: TestCase) ifTrue: [
+                (aTestAsserter class respondsTo: #packageNamesUnderTest) ifTrue: [
+                        aTestAsserter class packageNamesUnderTest
+                                do: [ :each | aSet add: (self halt:'Not ported')"(PackageInfo named: each)" ] ] ].
+        ^ aSet
+
+    "Modified: / 08-03-2011 / 22:12:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+ignoredSelectors
+	^ #(packageNamesUnderTest classNamesNotUnderTest)
+!
+
+methodsIn: aPackage
+	aPackage isNil ifTrue: [ ^ #() ].
+	^ aPackage methods reject: [ :method | 
+		(self ignoredSelectors includes: method methodSymbol)
+			or: [ method compiledMethod isAbstract
+			or: [ method compiledMethod refersToLiteral: #ignoreForCoverage ] ] ]
+!
+
+packagesIn: aTestAsserter
+	^ self addTestsIn: aTestAsserter to: Set new
+! !
+
+!CoverageReport methodsFor:'running'!
+
+setUp
+	super setUp.
+	wrappers := ((packages := self packagesIn: suite)
+		gather: [ :package | self methodsIn: package ])
+		collect: [ :each | HDTestCoverage on: each ].
+	wrappers do: [ :each | each install ]
+!
+
+tearDown
+	wrappers do: [ :each | each uninstall ].
+	super tearDown.
+	self generate
+! !
+
+!CoverageReport class methodsFor:'documentation'!
+
+version
+    ^ '$Header$'
+!
+
+version_CVS
+    ^ '$Header$'
+!
+
+version_SVN
+    ^ '§Id: Builder__CoverageReport.st 283 2011-11-07 08:54:02Z vranyj1 §'
+! !