SystemOrganization addCategory: #HudsonBuildTools!

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

HDReport subclass: #HDLintReport
	instanceVariableNames: 'environment rules time'
	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: 'private' stamp: 'lr 5/14/2010 13:56'!
column: aString at: anInteger
	| index |
	index := 1.
	aString lineIndicesDo: [ :start :stop :delim |
		index := anInteger - start + 1.
		(anInteger between: start and: delim)
			ifTrue: [ ^ index ] ].
	^ index! !

!HDLintReport methodsFor: 'running' stamp: 'lr 5/14/2010 14:02'!
generate
	| stream |
	stream := StandardFileStream forceNewFileNamed: environment name , '-lint.xml'.
	[ self generateOn: stream ]	ensure: [ stream close ]! !

!HDLintReport methodsFor: 'running' stamp: 'lr 5/14/2010 15:17'!
generateClass: aClass selector: aSelector on: aStream
	| matching filename source stream |
	matching := rules
		reject: [ :each | each result includesSelector: aSelector in: aClass ].
	matching isEmpty
		ifTrue: [ ^ self ].
	source := aClass sourceCodeAt: aSelector.
	source isNil
		ifTrue: [ ^ self ].
	source := source asString.
	filename := aClass name , '-' , (aSelector copyReplaceAll: ':' with: '_') , '.st'.
	stream :=  StandardFileStream forceNewFileNamed: filename.
	[ stream nextPutAll: source ] ensure: [ stream close ].
	aStream tab; nextPutAll: '<file name="'; nextPutAll: filename; nextPutAll: '">"'; cr.
	rules do: [ :each |
		| interval |
		interval := (each result selectionIntervalFor: source)
			ifNil: [ 1 to: source size ].		
		aStream tab; tab; nextPutAll: '<violation'.
		aStream nextPutAll: ' rule="'; nextPutAll: (self encode: each name); nextPut: $".
		aStream nextPutAll: ' ruleset="'; nextPutAll: (self encode: each group); nextPut: $".
		aStream nextPutAll: ' priority="'; print: 3; nextPut: $".
		aStream nextPutAll: ' package="'; nextPutAll: (self encode: environment label); nextPut: $".
		aStream nextPutAll: ' class="'; nextPutAll: (self encode: aClass name); nextPut: $".
		aStream nextPutAll: ' method="'; nextPutAll: (self encode: aSelector asString); nextPut: $".
		aStream nextPutAll: ' beginline="'; print: (self line: source at: interval first); nextPut: $".
		aStream nextPutAll: ' begincolumn="'; print: (self column: source at: interval first); nextPut: $".
		aStream nextPutAll: ' endline="'; print: (self line: source at: interval last); nextPut: $".
		aStream nextPutAll: ' endcolumn="'; print: (self column: source at: interval last); nextPut: $".
		aStream nextPutAll: '>'; nextPutAll: (self encode: each rationale); nextPutAll: '</violation>'; cr ].
	aStream tab; nextPutAll: '</file>'; cr! !

!HDLintReport methodsFor: 'running' stamp: 'lr 5/14/2010 10:02'!
generateOn: aStream
	aStream nextPutAll: '<?xml version="1.0" encoding="UTF-8"?>'; cr.
	aStream nextPutAll: '<pmd version="4.2.5" timestamp="'; print: DateAndTime now; nextPutAll: '" elapsedTime="'; print: time; nextPutAll: '">'; cr.
	environment classesAndSelectorsDo: [ :class :selector |
		self generateClass: class selector: selector on: aStream ].
	aStream nextPutAll: '</pmd>'! !

!HDLintReport methodsFor: 'initialization' stamp: 'lr 5/14/2010 12:11'!
initializeOn: anEnvironment
	environment := anEnvironment.
	rules := RBCompositeLintRule rulesFor: RBLintRule! !

!HDLintReport methodsFor: 'private' stamp: 'lr 5/14/2010 13:57'!
line: aString at: anInteger
	| index |
	index := 0.
	aString lineIndicesDo: [ :start :stop :delim |
		index := index + 1.
		(anInteger between: start and: delim)
			ifTrue: [ ^ index ] ].
	^ index! !

!HDLintReport methodsFor: 'running' stamp: 'lr 5/14/2010 12:12'!
run
	time := [ 
		SmalllintChecker 
			runRule: (RBCompositeLintRule rules: rules)
			onEnvironment: environment ]
				timeToRun.
	self generate! !

!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/14/2010 08:36'!
encode: aString
	^ ((aString asString 
		copyReplaceAll: '&' with: '&amp;') 
		copyReplaceAll: '"' with: '&quot;') 
		copyReplaceAll: '<' with: '&lt;'! !

!HDReport methodsFor: 'initialization' stamp: 'lr 5/14/2010 09:21'!
initializeOn: anObject
	self subclassResponsibility! !

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

!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: 'initialization' stamp: 'lr 1/10/2010 10:22'!
initializeOn: aTestSuite
	suite := aTestSuite.
	suitePosition := suiteTime := suiteFailures := suiteErrors := 0! !

!HDTestReport methodsFor: 'running' stamp: 'lr 5/14/2010 14:05'!
run
	Author uniqueInstance 
		ifUnknownAuthorUse: 'hudson'
		during: [
			[ self setUp.
		 	 suiteTime := [ self runAll ]
				timeToRun ]
					ensure: [ self tearDown ] ]! !

!HDTestReport methodsFor: 'running' stamp: 'lr 1/10/2010 15:22'!
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 methodSelector == #runCase ] ] ] 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 5/14/2010 14:03'!
setUp
	stream := StandardFileStream forceNewFileNamed: suite name , '-sunit.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.
	
	"Initialize the test resources."
	suite resources do: [ :each |
		each isAvailable
			ifFalse: [ each signalInitializationError ] ]! !

!HDTestReport methodsFor: 'running' stamp: 'lr 1/10/2010 15:22'!
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! !