This repository has been archived by the owner on Jun 14, 2021. It is now read-only.
forked from squeak-smalltalk/squeak-ci
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathHudsonBuildTools.st
175 lines (140 loc) · 6.92 KB
/
HudsonBuildTools.st
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
Object subclass: #HDReport
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'HudsonBuildTools'!
!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: '&')
copyReplaceAll: '"' with: '"')
copyReplaceAll: '<' with: '<'! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
HDReport class
instanceVariableNames: ''!
!HDReport class methodsFor: 'running' stamp: 'ul 9/5/2012 23:18'!
runCategories: aCollectionOfStrings
^ aCollectionOfStrings collect: [ :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: 'ul 9/5/2012 23:17'!
runPackages: aCollectionOfStrings
^ aCollectionOfStrings collect: [ :each |
self runPackage: each ]! !
HDReport subclass: #HDTestReport
instanceVariableNames: 'suite stream suitePosition suiteTime suiteFailures suiteErrors originalInitials'
classVariableNames: ''
poolDictionaries: ''
category: 'HudsonBuildTools'!
!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: '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 method selector == #runCase ] ] ] whileFalse: [
str print: context; nextPut: Character lf.
context := context sender ] ] ! !
!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! !
!HDTestReport methodsFor: 'initialization' stamp: 'lr 1/10/2010 10:22'!
initializeOn: aTestSuite
suite := aTestSuite.
suitePosition := suiteTime := suiteFailures := suiteErrors := 0! !
!HDTestReport methodsFor: 'running' stamp: 'ul 9/20/2012 19:31'!
run
[
self setUp.
suiteTime := [ self runAll ]
timeToRun ]
ensure: [ self tearDown ]! !
!HDTestReport methodsFor: 'running' stamp: 'JohanBrichau 10/25/2010 23:05'!
runAll
suite tests do: [ :each |
each run: self ]! !
!HDTestReport methodsFor: 'running' stamp: 'lr 11/24/2010 20:44'!
runCase: aTestCase
| error time stack |
time := [ [ aTestCase runCase ]
on: Halt , 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: 'ul 9/20/2012 19:31'!
setUp
originalInitials := Utilities authorInitialsPerSe.
Utilities setAuthorInitials: 'TestRunner'.
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: 'running' stamp: 'ul 9/20/2012 19:32'!
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.
Utilities setAuthorInitials: originalInitials! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
HDTestReport class
instanceVariableNames: ''!
!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! !