SystemOrganization addCategory: #HudsonBuildTools!

Object subclass: #HDReport
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'HudsonBuildTools'!

HDReport subclass: #HDLintReport
	instanceVariableNames: 'environment rules'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'HudsonBuildTools'!

!HDLintReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:19'!
runClasses: aCollectionOfClasses named: aString
	| classEnvironment |
	classEnvironment := BrowserEnvironment new
		forClasses: aCollectionOfClasses.
	classEnvironment label: aString.
	^ self runEnvironment: classEnvironment! !

!HDLintReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:20'!
runEnvironment: anEnvironment
	^ self new 
		initializeOn: anEnvironment; 
		run! !

!HDLintReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:19'!
runPackage: aString
	| packageEnvironment |
	packageEnvironment := BrowserEnvironment new
		forPackageNames: (Array with: aString).
	packageEnvironment label: aString.
	^ self runEnvironment: packageEnvironment! !

!HDLintReport methodsFor: 'generating' stamp: 'lr 7/4/2010 19:59'!
generateClass: aClass on: aStream
	| sourceStream sourceName |
	sourceStream := WriteStream on: String new.
	sourceName := environment name , '-' , aClass name , '.st'.
	aStream tab; nextPutAll: '<file name="'; nextPutAll: (self encode: sourceName); nextPutAll: '">'; nextPut: Character cr.
	self generateClass: aClass source: sourceStream on: aStream.
	self generateClass: aClass class source: sourceStream on: aStream.
	aStream  tab; nextPutAll: '</file>'; nextPut: Character cr.
	FileDirectory default 
		forceNewFileNamed: sourceName
		do: [ :stream | stream nextPutAll: sourceStream contents ]! !

!HDLintReport methodsFor: 'generating' stamp: 'lr 7/4/2010 20:28'!
generateClass: aClass selector: aSelector source: sourceStream on: aStream
	| offset source matching |
	offset := self
		lineAndColumn: sourceStream contents
		at: sourceStream position.
	sourceStream
		nextPutAll: (source := self convert: (aClass sourceCodeAt: aSelector));
		nextPut: Character cr; nextPut: Character cr.
	matching := rules select: [ :each | 
		(self isSelectorEnvironment: each result)
			and: [ each result includesSelector: aSelector in: aClass ] ].
	self generateViolations: matching source: source offset: offset on: aStream! !

!HDLintReport methodsFor: 'generating' stamp: 'lr 7/4/2010 20:18'!
generateClass: aClass source: sourceStream on: aStream
	| offset source matching |
	offset := self
		lineAndColumn: sourceStream contents
		at: sourceStream position.
	sourceStream
		nextPutAll: (source := self convert: aClass definition);
		nextPut: Character cr; nextPut: Character cr.
	(environment definesClass: aClass) ifTrue: [
		matching := rules select: [ :rule |
			(self isClassEnvironment: rule result)
				and: [ rule result includesClass: aClass ] ].
		self generateViolations: matching source: source offset: offset on: aStream ].
	environment
		selectorsForClass: aClass
		do: [ :selector | self generateClass: aClass selector: selector source: sourceStream on: aStream ]! !

!HDLintReport methodsFor: 'generating' stamp: 'lr 7/4/2010 20:21'!
generateOn: aStream
	aStream nextPutAll: '<?xml version="1.0" encoding="UTF-8"?>'; nextPut: Character lf.
	aStream nextPutAll: '<checkstyle version="5.2">'; nextPut: Character lf.
	environment allClasses do: [ :class | self generateClass: class on: aStream ].
	aStream nextPutAll: '</checkstyle>'! !

!HDLintReport methodsFor: 'generating' stamp: 'lr 7/4/2010 20:24'!
generateViolations: aCollection source: aString offset: aPoint on: aStream
	aCollection do: [ :rule |
		| interval start |
		interval := (rule result selectionIntervalFor: aString)
			ifNil: [ 1 to: aString size ].
		start := self lineAndColumn: aString at: interval first.
		aStream tab; tab; nextPutAll: '<error'.
		aStream nextPutAll: ' source="'; nextPutAll: (self encode: rule class name); nextPut: $".
		aStream nextPutAll: ' message="'; nextPutAll: (self encode: rule name); nextPut: $".
		aStream nextPutAll: ' severity="'; nextPutAll: (rule
			severity = #information 
				ifTrue: [ 'info' ]
				ifFalse: [ 
					rule severity = #warning
						ifTrue: [ 'warning' ]
						ifFalse: [ 'error' ] ]); nextPut: $".
		aStream nextPutAll: ' line="'; print: aPoint x + start x; nextPut: $".
		aStream nextPutAll: ' column="'; print: aPoint y + start y; nextPut: $".
		aStream nextPutAll: '/>'; nextPut: Character lf ]! !

!HDLintReport methodsFor: 'initialization' stamp: 'lr 5/20/2010 23:24'!
initializeOn: anEnvironment
	environment := anEnvironment.
	rules := RBCompositeLintRule rulesFor: RBBasicLintRule! !

!HDLintReport methodsFor: 'testing' stamp: 'lr 5/15/2010 14:05'!
isClassEnvironment: anEnvironment
	^ #(CategoryEnvironment ClassEnvironment VariableEnvironment) includes: anEnvironment class name! !

!HDLintReport methodsFor: 'testing' stamp: 'lr 5/15/2010 14:05'!
isSelectorEnvironment: anEnvironment
	^ #(SelectorEnvironment ParseTreeEnvironment VariableEnvironment) includes: anEnvironment class name! !

!HDLintReport methodsFor: 'private' stamp: 'lr 5/14/2010 22:29'!
lineAndColumn: aString at: anInteger
	| line last stream |
	line := 1.
	last := 0.
	stream := aString readStream.
	[ (stream nextLine isNil or: [ anInteger <= stream position ])
		ifTrue: [ ^ line @ (anInteger - last) ].
	last := stream position.
	line := line + 1 ]
		repeat! !

!HDLintReport methodsFor: 'running' stamp: 'lr 7/4/2010 19:56'!
run
	| stream |
	SmalllintChecker 
		runRule: (RBCompositeLintRule rules: rules)
		onEnvironment: environment.
	stream := FileDirectory default
		forceNewFileNamed: environment name , '-Lint.xml'.
	[ self generateOn: stream ]
		ensure: [ stream close ]! !

!HDReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:17'!
runCategories: aCollectionOfStrings
	^ aCollectionOfStrings do: [ :each | self runCategory: each ]! !

!HDReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:17'!
runCategory: aString
	^ self runClasses: (Smalltalk organization classesInCategory: aString) named: aString! !

!HDReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:15'!
runClasses: aCollectionOfClasses named: aString
	self subclassResponsibility! !

!HDReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:16'!
runPackage: aString
	self subclassResponsibility! !

!HDReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:17'!
runPackages: aCollectionOfStrings
	^ aCollectionOfStrings do: [ :each | self runPackage: each ]! !

!HDReport methodsFor: 'private' stamp: 'lr 5/15/2010 14:27'!
convert: aString
	^ (aString asString 
		copyReplaceAll: (String with: Character cr with: Character lf) with: (String with: Character lf))
		copyReplaceAll: (String with: Character cr) with: (String with: Character lf)! !

!HDReport methodsFor: 'private' stamp: 'lr 5/14/2010 08:36'!
encode: aString
	^ ((aString asString 
		copyReplaceAll: '&' with: '&amp;') 
		copyReplaceAll: '"' with: '&quot;') 
		copyReplaceAll: '<' with: '&lt;'! !

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

HDTestReport subclass: #HDCoverageReport
	instanceVariableNames: 'packages wrappers'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'HudsonBuildTools'!

!HDCoverageReport methodsFor: 'private' stamp: 'lr 6/9/2010 11:04'!
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: (PackageInfo named: each) ] ] ].
	^ aSet! !

!HDCoverageReport methodsFor: 'generating' stamp: 'lr 6/9/2010 19:32'!
generateCoverage
	stream := StandardFileStream forceNewFileNamed: suite name , '-Coverage.xml'.
	stream nextPutAll: '<?xml version="1.0" encoding="UTF-8"?>'; nextPut: Character lf.
	stream nextPutAll: '<report>'; nextPut: Character lf.
	stream tab; nextPutAll: '<data>'; nextPut: Character lf.
	stream tab; tab; nextPutAll: '<all name="all classes">'; nextPut: Character lf.
	packages do: [ :each | self generateCoveragePackage: each ].	
	stream tab; tab; nextPutAll: '</all>'; nextPut: Character lf.
	stream tab; nextPutAll: '</data>'; nextPut: Character lf.
	stream nextPutAll: '</report>'; nextPut: Character lf.
	stream close! !

!HDCoverageReport methodsFor: 'generating' stamp: 'lr 6/9/2010 19:37'!
generateCoveragePackage: aPackageInfo
	aPackageInfo classesAndMetaClasses do: [ :class |
		stream tab; tab; tab; nextPutAll: '<all name="all classes">'; nextPut: Character lf ]! !

!HDCoverageReport methodsFor: 'private' stamp: 'lr 6/9/2010 10:58'!
ignoredSelectors
	^ #(packageNamesUnderTest classNamesNotUnderTest)! !

!HDCoverageReport methodsFor: 'private' stamp: 'lr 6/9/2010 11:01'!
methodsIn: aPackage
	aPackage isNil ifTrue: [ ^ #() ].
	^ aPackage methods reject: [ :method | 
		(self ignoredSelectors includes: method methodSymbol)
			or: [ method compiledMethod isAbstract
			or: [ method compiledMethod refersToLiteral: #ignoreForCoverage ] ] ]! !

!HDCoverageReport methodsFor: 'private' stamp: 'lr 6/9/2010 10:51'!
packagesIn: aTestAsserter
	^ self addTestsIn: aTestAsserter to: Set new! !

!HDCoverageReport methodsFor: 'running' stamp: 'lr 6/9/2010 19:20'!
run
	super run.
	self generateEmma! !

!HDCoverageReport methodsFor: 'running' stamp: 'lr 6/9/2010 19:30'!
setUp
	super setUp.
	wrappers := ((packages := self packagesIn: suite)
		gather: [ :package | self methodsIn: package ])
		collect: [ :each | HDTestCoverage on: each ].
	wrappers do: [ :each | each install ]! !

!HDCoverageReport methodsFor: 'running' stamp: 'lr 6/9/2010 11:16'!
tearDown
	wrappers do: [ :each | each uninstall ].
	super tearDown! !

!HDTestReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:16'!
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 isEmpty
		ifTrue: [ ^ self ].
	classes
		do: [ :each | each addToSuiteFromSelectors: suite ].
	^ self runSuite: suite! !

!HDTestReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:16'!
runPackage: aString
	^ self runClasses: (PackageInfo named: aString) classes named: aString! !

!HDTestReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:16'!
runSuite: aTestSuite
	^ self new 
		initializeOn: aTestSuite; 
		run! !

!HDTestReport methodsFor: 'private' stamp: 'lr 6/6/2010 18:44'!
beginTestCase: aTestCase time: time
	stream tab; nextPutAll: '<testcase classname="'; nextPutAll: (self encode: (aTestCase class category copyReplaceAll: '-' with: '.')); nextPut: $.; nextPutAll: (self encode: aTestCase class name); nextPutAll: '" name="'; nextPutAll: (self encode: aTestCase selector); nextPutAll: '" time="'; print: time / 1000.0; nextPutAll: '">'; nextPut: Character lf! !

!HDTestReport methodsFor: 'private' stamp: 'lr 6/6/2010 18:45'!
endTestCase
	stream tab; nextPutAll: '</testcase>'; nextPut: Character lf! !

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

!HDTestReport methodsFor: 'running' stamp: 'lr 6/9/2010 20:01'!
run
	Author uniqueInstance
		ifUnknownAuthorUse: 'hudson'
		during: [ [ 
			self setUp.
			suiteTime := [ self runAll ]
				timeToRun ]
					ensure: [ self tearDown ] ]! !

!HDTestReport methodsFor: 'running' stamp: 'pmm 6/6/2010 18:13'!
run: aTestCase
	| error time stack |
	time := [ [ aTestCase runCase ] 
		on: Error, TestFailure
		do: [ :err |
			error := err.
			stack := self stackTraceString: err of: aTestCase ] ]
			timeToRun.
	self beginTestCase: aTestCase time: time.
	(error isNil or: [ aTestCase expectedFailures includes: aTestCase selector ]) ifFalse: [
		(error isKindOf: TestFailure)
			ifTrue: [ self writeError: error stack: stack ]
			ifFalse: [ self writeError: error stack: stack ] ].
	self endTestCase! !

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

!HDTestReport methodsFor: 'running' stamp: 'lr 5/15/2010 14:47'!
setUp
	stream := StandardFileStream forceNewFileNamed: suite name , '-Test.xml'.
	stream nextPutAll: '<?xml version="1.0" encoding="UTF-8"?>'; nextPut: Character lf.
	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: $ ); nextPut: Character lf.
	
	"Initialize the test resources."
	suite resources do: [ :each |
		each isAvailable
			ifFalse: [ each signalInitializationError ] ]! !

!HDTestReport methodsFor: 'private' stamp: 'pmm 6/6/2010 18:13'!
stackTraceString: err of: aTestCase
	^ String streamContents: [ :str | 
		| context |
		context := err signalerContext.
		[ context isNil or: [ context receiver == aTestCase and: [ context methodSelector == #runCase ] ] ] whileFalse: [
			str print: context; nextPut: Character lf.
			context := context sender ] ] ! !

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

!HDTestReport methodsFor: 'private' stamp: 'lr 6/9/2010 10:32'!
writeError: error stack: stack
	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>'; nextPut: Character lf! !

!HDTestReport methodsFor: 'private' stamp: 'lr 6/9/2010 10:33'!
writeFailure: error stack: stack
	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>'; nextPut: Character lf! !

ProtoObject subclass: #HDTestCoverage
	instanceVariableNames: 'counter reference method'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'HudsonBuildTools'!

!HDTestCoverage class methodsFor: 'instance creation' stamp: 'lr 6/9/2010 11:05'!
on: aMethodReference
	^ self new initializeOn: aMethodReference! !

!HDTestCoverage methodsFor: 'accessing' stamp: 'lr 6/9/2010 11:05'!
counter
	^ counter! !

!HDTestCoverage methodsFor: 'private' stamp: 'lr 6/9/2010 11:05'!
doesNotUnderstand: aMessage
	^ method perform: aMessage selector withArguments: aMessage arguments! !

!HDTestCoverage methodsFor: 'private' stamp: 'lr 6/9/2010 11:05'!
flushCache! !

!HDTestCoverage methodsFor: 'testing' stamp: 'lr 6/9/2010 11:12'!
hasRun
	^ self counter > 0! !

!HDTestCoverage methodsFor: 'initialization' stamp: 'lr 6/9/2010 11:05'!
initializeOn: aMethodReference
	counter := 0.
	reference := aMethodReference.
	method := reference compiledMethod! !

!HDTestCoverage methodsFor: 'actions' stamp: 'lr 6/9/2010 11:10'!
install
	reference actualClass methodDictionary
		at: reference methodSymbol
		put: self.
	counter := 0! !

!HDTestCoverage methodsFor: 'private' stamp: 'lr 6/9/2010 11:06'!
mark
	counter := counter + 1! !

!HDTestCoverage methodsFor: 'private' stamp: 'lr 6/9/2010 11:05'!
reference
	^ reference! !

!HDTestCoverage methodsFor: 'evaluation' stamp: 'lr 6/9/2010 11:06'!
run: aSelector with: anArray in: aReceiver
	self mark.
	^ aReceiver withArgs: anArray executeMethod: method! !

!HDTestCoverage methodsFor: 'actions' stamp: 'lr 6/9/2010 11:05'!
uninstall
	reference actualClass methodDictionary
		at: reference methodSymbol
		put: method! !