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/15/2010 14:10'!
directoryForClass: aClass
	^ ((FileDirectory default 
		directoryNamed: environment name) 
		directoryNamed: aClass name)
		assureExistence! !

!HDLintReport methodsFor: 'private' stamp: 'lr 5/14/2010 15:50'!
directoryForClass: aClass selector: aSymbol
	^ (self directoryForClass: aClass) fullNameFor: (self filenameForSelector: aSymbol)! !

!HDLintReport methodsFor: 'private' stamp: 'lr 5/15/2010 13:43'!
filenameForSelector: aSymbol
	^ String streamContents: [ :stream |
		aSymbol do: [ :char |
			char isAlphaNumeric
				ifTrue: [ stream nextPut: char ]
				ifFalse: [ 
					char = $:
						ifTrue: [ stream nextPut: $_ ]
						ifFalse: [ stream nextPut: $%; nextPutAll: (char codePoint printPaddedWith: $0 to: 2 base: 16) ] ] ].
		stream nextPutAll: '.st' ]! !

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

!HDLintReport methodsFor: 'running' stamp: 'lr 5/15/2010 14:19'!
generateClass: aClass on: aStream
	| matching source directory stream |
	matching := rules select: [ :each |
		(self isClassEnvironment: each result)
			and: [ each result includesClass: aClass ] ].
	matching isEmpty ifTrue: [ ^ self ].
	source := aClass definition ifNil: [ ^ self ].
	directory := self directoryForClass: aClass.
	stream := directory forceNewFileNamed: 'definition.cs'.
	[ stream nextPutAll: source asString ]
		ensure: [ stream close ].
	self 
		generateClass: aClass selector: nil source: source asString
		name: (directory fullNameFor: 'definition.cs')
		matching: matching on: aStream! !

!HDLintReport methodsFor: 'running' stamp: 'lr 5/15/2010 14:19'!
generateClass: aClass selector: aSelector on: aStream
	| matching source directory stream |
	matching := rules select: [ :each | 
		(self isSelectorEnvironment: each result)
			and: [ each result includesSelector: aSelector in: aClass ] ].
	matching isEmpty ifTrue: [ ^ self ].
	source := (aClass sourceCodeAt: aSelector) ifNil: [ ^ self ].
	directory := self directoryForClass: aClass.
	stream := directory forceNewFileNamed: (self filenameForSelector: aSelector).
	[ stream nextPutAll: source asString ] 
		ensure: [ stream close ].
	self
		generateClass: aClass selector: aSelector source: source asString
		name: (self directoryForClass: aClass selector: aSelector)
		matching: matching on: aStream! !

!HDLintReport methodsFor: 'running' stamp: 'lr 5/15/2010 14:16'!
generateClass: aClass selector: aSelector source: aString name: aFilename matching: aCollection on: aStream
	aStream tab; nextPutAll: '<file name="'; nextPutAll: aFilename; nextPutAll: '">'; cr.
	aCollection do: [ :rule |
		| interval begin end |
		interval := (rule result selectionIntervalFor: aString)
			ifNil: [ 1 to: aString size ].
		begin := self lineAndColumn: aString at: interval first.
		end := self lineAndColumn: aString at: interval last. 
		aStream tab; tab; nextPutAll: '<violation'.
		aStream nextPutAll: ' rule="'; nextPutAll: (self encode: rule class name); nextPut: $".
		aStream nextPutAll: ' ruleset="'; nextPutAll: (self encode: rule 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: $".
		aSelector isNil
			ifFalse: [ aStream nextPutAll: ' method="'; nextPutAll: (self encode: aSelector asString); nextPut: $" ].
		aStream nextPutAll: ' beginline="'; print: begin x; nextPut: $".
		aStream nextPutAll: ' begincolumn="'; print: begin y; nextPut: $".
		aStream nextPutAll: ' endline="'; print: end x; nextPut: $".
		aStream nextPutAll: ' endcolumn="'; print: end y; nextPut: $".
		aStream nextPutAll: '>'; nextPutAll: (self encode: rule name); nextPutAll: '</violation>'; cr ].
	aStream tab; nextPutAll: '</file>'; cr! !

!HDLintReport methodsFor: 'running' stamp: 'lr 5/15/2010 13:59'!
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 / 1000.0; nextPutAll: 's">'; cr.
	environment classesAndSelectorsDo: [ :class :selector |
		(environment definesClass: class)
			ifTrue: [ self generateClass: class on: aStream ].
		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: '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 5/15/2010 14:00'!
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 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/15/2010 09:18'!
setUp
	stream := StandardFileStream forceNewFileNamed: suite name , '-Test.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! !