VMSpawningTestCase: Kill the spawned VM on timeout and report its output
...when run under test report harness. Useful for debugging runaway
tests on CI server.
"{ Package: 'stx:goodies/regression' }"
"{ NameSpace: RegressionTests }"
TestCase subclass:#VMSpawningTestCase
instanceVariableNames:''
classVariableNames:'EXIT_CODE_SUCCESS EXIT_CODE_FAILURE EXIT_CODE_ERROR
EXIT_CODE_SKIPPED'
poolDictionaries:''
category:'tests-Regression-Abstract'
!
!VMSpawningTestCase class methodsFor:'initialization'!
initialize
"Invoked at system start or when the class is dynamically loaded."
"/ please change as required (and remove this comment)
EXIT_CODE_SUCCESS := 0.
EXIT_CODE_FAILURE := 1.
EXIT_CODE_ERROR := 2.
"/ Never define EXIT_CODE_SKIPPED as 3. On Windows,
"/ 3 is used by abort() so then we'd not be able to
"/ tell between skip and crash!! Sigh.
EXIT_CODE_SKIPPED := 97.
"Modified: / 03-09-2016 / 08:23:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 08-09-2016 / 12:44:05 / jv"
! !
!VMSpawningTestCase class methodsFor:'queries'!
isAbstract
"Return if this class is an abstract class.
True is returned here for myself only; false for subclasses.
Abstract subclasses must redefine this again."
^ self == RegressionTests::VMSpawningTestCase.
! !
!VMSpawningTestCase methodsFor:'private'!
spawnSelector:selector
"Perform selector in freshly spawned Smalltalk."
| tempDir |
[
tempDir := Filename newTemporary.
tempDir makeDirectory.
self spawnSelector:selector inDirectory:tempDir.
] ensure:[
(tempDir notNil and:[ tempDir exists ]) ifTrue:[
[
tempDir recursiveRemove.
] on:Error
do:[:ex |
OperatingSystem isMSWINDOWSlike ifFalse:[
ex reject.
].
]
].
].
"Created: / 05-01-2017 / 23:08:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 06-01-2017 / 22:07:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
spawnSelector:selector inDirectory:directory
"Perform `selector` in new smalltalk process. Set new process's working directory to `directory`"
| testcaseFile script |
directory makeDirectory.
testcaseFile := directory
/ ((Smalltalk fileNameForClass:self class) , '.st').
self class fileOutAs:testcaseFile.
script := 'NoHandlerError emergencyHandler:[:ex |
ex suspendedContext fullPrintAllOn: Stdout.
Stdout nextPutAll: ''ERROR (unhandled) '', ex printString.
Smalltalk exit: %7
].
Smalltalk packagePath: %1.
Smalltalk loadPackage:%2.
Smalltalk fileIn: %3.
Smalltalk addStartBlock:[
Processor exitWhenNoMoreUserProcesses: false.
[
(%4 selector: %5) spawnSelectorInternal: %6.
] ensure:[
Smalltalk exit: %7
]
].
'
bindWith:Smalltalk packagePath asArray storeString
with:self class package storeString
with:testcaseFile pathName storeString
with:self class name
with:testSelector storeString
with:selector storeString
with:EXIT_CODE_ERROR storeString.
(directory / 'run.st') writingFileDo:[:f | f nextPutAll:script. ].
self spawnSmalltalk: { '--abortOnSEGV'. '-I'. '--quick'. '--load'. (directory / 'run.st') pathName } inDirectory: directory
"Created: / 06-01-2017 / 22:06:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 26-01-2017 / 19:29:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
spawnSelectorInternal:selector
[
[
self perform:selector.
Stdout
cr;
nextPutAll:'PASSED';
cr.
Smalltalk exit:EXIT_CODE_SUCCESS
] on:TestResult skipped
do:[:skip |
Stdout
cr;
nextPutAll:'SKIPPED';
cr.
Smalltalk exit:EXIT_CODE_SKIPPED.
]
] on:TestResult failure
do:[:failure |
Stdout
cr;
nextPutAll:'FAILURE: ';
nextPutAll:failure description;
cr.
Smalltalk exit:EXIT_CODE_FAILURE.
]
on:TestResult exError
do:[:error |
Stdout
cr;
nextPutAll:'ERROR: ';
nextPutAll:error description;
cr.
Smalltalk exit:EXIT_CODE_ERROR.
].
"Created: / 05-01-2017 / 23:02:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
spawnSmalltalk:argv inDirectory:directory
"
A helper method to spawn a new smalltalk process using current executable and
given arguments (in `argv`). Set initial working copy of freskly spawned process
to `directory`. Wait until spawned smalltalk finishes and then if process exit status
* is EXIT_CODE_SUCCESS do nothing and return
* is EXIT_CODE_SKIPPED then signal skipped test by means of #skipIf:description:
* is EXIT_CODE_FAILURE then signal test failure by means of failed #assert:
* is anything else then signal test error by means of #error:"
| exe args environment outputFile output pid blocker status |
exe := OperatingSystem pathOfSTXExecutable.
args := { exe } , #('--abortOnSEGV') , argv.
OperatingSystem isMSWINDOWSlike ifTrue:[
args := String
streamContents:[:s |
args
do:[:each |
s
nextPut:$";
nextPutAll:each;
nextPut:$"
]
separatedBy:[ s space ]
]
].
outputFile := directory / 'output.txt'.
output := outputFile writeStream.
environment := OperatingSystem isUNIXlike ifTrue:[
OperatingSystem getEnvironment copy
] ifFalse:[
environment := Dictionary new
].
blocker := Semaphore new.
Processor
monitor:[
pid := OperatingSystem
exec:exe
withArguments:args
environment:environment
fileDescriptors:{
0.
output fileDescriptor.
output fileDescriptor
}
fork:true
newPgrp:false
inDirectory:directory pathName
showWindow:true
]
action:[:s |
status := s.
blocker signal.
].
output close.
pid isNil ifTrue:[
self error:'Failed to spawn test'.
^ self.
].
[
blocker wait.
status code == EXIT_CODE_SUCCESS ifFalse:[
status code == EXIT_CODE_SKIPPED ifTrue:[
self skipIf:true description:'Skipped'.
] ifFalse:[
status code == EXIT_CODE_FAILURE ifTrue:[
"
directory inspect
"
self writeFile: outputFile to: Stdout labeled: 'TEST FAILED'.
self assert:false description:'Assertion failed, see log'.
] ifFalse:[
"
directory inspect
"
self writeFile: outputFile to: Stdout labeled: 'TEST ERROR'.
self error:'Error occured'.
].
].
].
] on: TerminateProcessRequest do:[:ex|
pid notNil ifTrue:[ OperatingSystem killProcess: pid ].
self writeFile: outputFile to: Stdout labeled: 'TEST TERMINATED'.
ex pass.
].
"Created: / 06-01-2017 / 11:25:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 28-07-2017 / 10:55:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
writeFile: aFilename to: aStream labeled: aString
"
Write contents of given `aFilename` to given `aStream` with given label (`aString`).
Utility method for spawnSmalltalk:inDirectory: to ease the debugging.
"
aStream
nextPutAll: '== ';
nextPutAll: aString;
nextPutAll: ' (testcase ';
nextPutAll: self printString;
nextPutLine:') =='.
aFilename isNil ifTrue:[
aStream nextPutLine: 'No file given!!'
] ifFalse:[ aFilename exists ifFalse:[
aStream nextPutAll: 'File does not exist: '; nextPutLine: aFilename pathName
] ifTrue:[
aFilename readingFileDo:[:s |
[ s atEnd ] whileFalse:[ aStream nextPutLine:s nextLine.].
].
]].
"Created: / 28-07-2017 / 10:48:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!VMSpawningTestCase class methodsFor:'documentation'!
version_HG
^ '$Changeset: <not expanded> $'
! !
VMSpawningTestCase initialize!