|
1 "{ Package: 'stx:goodies/regression' }" |
|
2 |
|
3 "{ NameSpace: RegressionTests }" |
|
4 |
|
5 TestCase subclass:#VMSpawningTestCase |
|
6 instanceVariableNames:'' |
|
7 classVariableNames:'EXIT_CODE_SUCCESS EXIT_CODE_FAILURE EXIT_CODE_ERROR |
|
8 EXIT_CODE_SKIPPED' |
|
9 poolDictionaries:'' |
|
10 category:'tests-Regression-Abstract' |
|
11 ! |
|
12 |
|
13 |
|
14 !VMSpawningTestCase class methodsFor:'initialization'! |
|
15 |
|
16 initialize |
|
17 "Invoked at system start or when the class is dynamically loaded." |
|
18 |
|
19 "/ please change as required (and remove this comment) |
|
20 |
|
21 EXIT_CODE_SUCCESS := 0. |
|
22 EXIT_CODE_FAILURE := 1. |
|
23 EXIT_CODE_ERROR := 2. |
|
24 "/ Never define EXIT_CODE_SKIPPED as 3. On Windows, |
|
25 "/ 3 is used by abort() so then we'd not be able to |
|
26 "/ tell between skip and crash!! Sigh. |
|
27 EXIT_CODE_SKIPPED := 97. |
|
28 |
|
29 "Modified: / 03-09-2016 / 08:23:11 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
30 "Modified: / 08-09-2016 / 12:44:05 / jv" |
|
31 ! ! |
|
32 |
|
33 !VMSpawningTestCase class methodsFor:'queries'! |
|
34 |
|
35 isAbstract |
|
36 "Return if this class is an abstract class. |
|
37 True is returned here for myself only; false for subclasses. |
|
38 Abstract subclasses must redefine this again." |
|
39 |
|
40 ^ self == RegressionTests::VMSpawningTestCase. |
|
41 ! ! |
|
42 |
|
43 !VMSpawningTestCase methodsFor:'private'! |
|
44 |
|
45 spawnSelector:selector |
|
46 "Perform selector in freshly spawned Smalltalk." |
|
47 |
|
48 | tempDir | |
|
49 |
|
50 [ |
|
51 tempDir := Filename newTemporary. |
|
52 tempDir makeDirectory. |
|
53 self spawnSelector:selector inDirectory:tempDir. |
|
54 ] ensure:[ |
|
55 (tempDir notNil and:[ tempDir exists ]) ifTrue:[ |
|
56 [ |
|
57 tempDir recursiveRemove. |
|
58 ] on:Error |
|
59 do:[:ex | |
|
60 OperatingSystem isMSWINDOWSlike ifFalse:[ |
|
61 ex reject. |
|
62 ]. |
|
63 ] |
|
64 ]. |
|
65 ]. |
|
66 |
|
67 "Created: / 05-01-2017 / 23:08:38 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
68 "Modified: / 06-01-2017 / 22:07:27 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
69 ! |
|
70 |
|
71 spawnSelector:selector inDirectory:directory |
|
72 "Perform `selector` in new smalltalk process. Set new process's working directory to `directory`" |
|
73 |
|
74 | testcaseFile script | |
|
75 |
|
76 directory makeDirectory. |
|
77 testcaseFile := directory |
|
78 / ((Smalltalk fileNameForClass:self class) , '.st'). |
|
79 self class fileOutAs:testcaseFile. |
|
80 script := 'NoHandlerError emergencyHandler:[:ex | |
|
81 ex suspendedContext fullPrintAllOn: Stdout. |
|
82 Stdout nextPutAll: ''ERROR (unhandled) '', ex printString. |
|
83 Smalltalk exit: %7 |
|
84 ]. |
|
85 Smalltalk packagePath: %1. |
|
86 Smalltalk loadPackage:%2. |
|
87 Smalltalk fileIn: %3. |
|
88 Smalltalk addStartBlock:[[(%4 selector: %5) spawnSelectorInternal: %6] fork]. |
|
89 ' |
|
90 bindWith:Smalltalk packagePath asArray storeString |
|
91 with:self class package storeString |
|
92 with:testcaseFile pathName storeString |
|
93 with:self class name |
|
94 with:testSelector storeString |
|
95 with:selector storeString |
|
96 with:EXIT_CODE_ERROR storeString. |
|
97 (directory / 'run.st') writingFileDo:[:f | f nextPutAll:script. ]. |
|
98 self spawnSmalltalk: { '--abortOnSEGV'. '-I'. '--quick'. '--load'. (directory / 'run.st') pathName } inDirectory: directory |
|
99 |
|
100 "Created: / 06-01-2017 / 22:06:37 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
101 "Modified: / 06-01-2017 / 23:27:12 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
102 ! |
|
103 |
|
104 spawnSelectorInternal:selector |
|
105 [ |
|
106 [ |
|
107 self perform:selector. |
|
108 Stdout |
|
109 cr; |
|
110 nextPutAll:'PASSED'; |
|
111 cr. |
|
112 Smalltalk exit:EXIT_CODE_SUCCESS |
|
113 ] on:TestResult skipped |
|
114 do:[:skip | |
|
115 Stdout |
|
116 cr; |
|
117 nextPutAll:'SKIPPED'; |
|
118 cr. |
|
119 Smalltalk exit:EXIT_CODE_SKIPPED. |
|
120 ] |
|
121 ] on:TestResult failure |
|
122 do:[:failure | |
|
123 Stdout |
|
124 cr; |
|
125 nextPutAll:'FAILURE: '; |
|
126 nextPutAll:failure description; |
|
127 cr. |
|
128 Smalltalk exit:EXIT_CODE_FAILURE. |
|
129 ] |
|
130 on:TestResult exError |
|
131 do:[:error | |
|
132 Stdout |
|
133 cr; |
|
134 nextPutAll:'ERROR: '; |
|
135 nextPutAll:error description; |
|
136 cr. |
|
137 Smalltalk exit:EXIT_CODE_ERROR. |
|
138 ]. |
|
139 |
|
140 "Created: / 05-01-2017 / 23:02:29 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
141 ! |
|
142 |
|
143 spawnSmalltalk:argv inDirectory:directory |
|
144 " |
|
145 A helper method to spawn a new smalltalk process using current executable and |
|
146 given arguments (in `argv`). Set initial working copy of freskly spawned process |
|
147 to `directory`. Wait until spawned smalltalk finishes and then if process exit status |
|
148 |
|
149 * is EXIT_CODE_SUCCESS do nothing and return |
|
150 * is EXIT_CODE_SKIPPED then signal skipped test by means of #skipIf:description: |
|
151 * is EXIT_CODE_FAILURE then signal test failure by means of failed #assert: |
|
152 * is anything else then signal test error by means of #error:" |
|
153 |
|
154 | exe args environment outputFile output pid blocker status | |
|
155 |
|
156 exe := OperatingSystem pathOfSTXExecutable. |
|
157 args := { exe } , argv. |
|
158 OperatingSystem isMSWINDOWSlike ifTrue:[ |
|
159 args := String |
|
160 streamContents:[:s | |
|
161 args |
|
162 do:[:each | |
|
163 s |
|
164 nextPut:$"; |
|
165 nextPutAll:each; |
|
166 nextPut:$" |
|
167 ] |
|
168 separatedBy:[ s space ] |
|
169 ] |
|
170 ]. |
|
171 outputFile := directory / 'output.txt'. |
|
172 output := outputFile writeStream. |
|
173 environment := OperatingSystem isUNIXlike ifTrue:[ |
|
174 OperatingSystem getEnvironment copy |
|
175 ] ifFalse:[ |
|
176 environment := Dictionary new |
|
177 ]. |
|
178 blocker := Semaphore new. |
|
179 Processor |
|
180 monitor:[ |
|
181 pid := OperatingSystem |
|
182 exec:exe |
|
183 withArguments:args |
|
184 environment:environment |
|
185 fileDescriptors:{ |
|
186 0. |
|
187 output fileDescriptor. |
|
188 output fileDescriptor |
|
189 } |
|
190 fork:true |
|
191 newPgrp:false |
|
192 inDirectory:directory pathName |
|
193 showWindow:true |
|
194 ] |
|
195 action:[:s | |
|
196 status := s. |
|
197 blocker signal. |
|
198 ]. |
|
199 output close. |
|
200 pid isNil ifTrue:[ |
|
201 self error:'Failed to spawn test'. |
|
202 ^ self. |
|
203 ]. |
|
204 blocker wait. |
|
205 status code == EXIT_CODE_SUCCESS ifFalse:[ |
|
206 status code == EXIT_CODE_SKIPPED ifTrue:[ |
|
207 self skipIf:true description:'Skipped'. |
|
208 ] ifFalse:[ |
|
209 status code == EXIT_CODE_FAILURE ifTrue:[ |
|
210 (outputFile notNil and:[ outputFile exists ]) ifTrue:[ |
|
211 Stdout |
|
212 nextPutAll:'== TEST FAILED: '; |
|
213 nextPutAll:testSelector; |
|
214 nextPutLine:' =='. |
|
215 outputFile |
|
216 readingFileDo:[:s | |
|
217 [ s atEnd ] whileFalse:[ |
|
218 Stdout nextPutLine:s nextLine. |
|
219 ]. |
|
220 ]. |
|
221 ]. |
|
222 self assert:false description:'Assertion failed, see log'. |
|
223 ] ifFalse:[ |
|
224 (outputFile notNil and:[ outputFile exists ]) ifTrue:[ |
|
225 Stdout |
|
226 nextPutAll:'== TEST ERROR: '; |
|
227 nextPutAll:testSelector; |
|
228 nextPutLine:' =='. |
|
229 outputFile |
|
230 readingFileDo:[:s | |
|
231 [ s atEnd ] whileFalse:[ |
|
232 | l | |
|
233 |
|
234 l := s nextLine. |
|
235 Stdout nextPutLine:l. |
|
236 Transcript ~~ Stdout ifTrue:[ |
|
237 Transcript nextPutLine:l. |
|
238 ]. |
|
239 ]. |
|
240 ]. |
|
241 ]. |
|
242 " |
|
243 directory inspect |
|
244 " |
|
245 self error:'Error occured'. |
|
246 ]. |
|
247 ]. |
|
248 ]. |
|
249 |
|
250 "Created: / 06-01-2017 / 11:25:04 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
251 "Modified: / 06-01-2017 / 23:36:55 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
252 ! ! |
|
253 |
|
254 !VMSpawningTestCase class methodsFor:'documentation'! |
|
255 |
|
256 version_HG |
|
257 |
|
258 ^ '$Changeset: <not expanded> $' |
|
259 ! ! |
|
260 |
|
261 |
|
262 VMSpawningTestCase initialize! |