--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/RegressionTests__VMCrashTestCase.st Fri Sep 05 20:04:50 2014 +0200
@@ -0,0 +1,243 @@
+"{ Package: 'exept:regression' }"
+
+"{ NameSpace: RegressionTests }"
+
+TestCase subclass:#VMCrashTestCase
+ instanceVariableNames:''
+ classVariableNames:'EXIT_CODE_SUCCESS EXIT_CODE_FAILURE EXIT_CODE_ERROR'
+ poolDictionaries:''
+ category:'tests-Regression-Abstract'
+!
+
+!VMCrashTestCase class methodsFor:'documentation'!
+
+documentation
+"
+ A specialized abstract test case class for writing
+ VM crash tests. The test is run in separate process
+ if it eventually crashes the VM, it won't take whole test
+ suite with it.
+
+ [author:]
+ Jan Vrany <jan.vrany@fit.cvut.cz>
+
+ [instance variables:]
+
+ [class variables:]
+
+ [see also:]
+
+"
+! !
+
+!VMCrashTestCase 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.
+
+ "Modified: / 05-09-2014 / 18:17:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!VMCrashTestCase class methodsFor:'testing'!
+
+isAbstract
+ ^ self == RegressionTests::VMCrashTestCase
+! !
+
+!VMCrashTestCase methodsFor:'running'!
+
+runCase
+ "Actually peform the testcase in a separate process"
+
+ | testcaseFile exe args script environment outputFile output pid blocker status |
+
+ "/ A hack to run infrastructure test...
+ (testSelector == #test_infrastructure) ifTrue:[
+ ^ super runCase.
+ ].
+
+ [
+ testcaseFile := Filename newTemporary.
+ self class fileOutAs: testcaseFile.
+
+ script := 'Smalltalk packagePath: %1.
+ Smalltalk loadPackage:%2.
+ Smalltalk fileIn: %3.
+ (%4 selector: %5) runCaseInternal.'
+ bindWith: Smalltalk packagePath asArray storeString
+ with: self class package storeString
+ with: testcaseFile pathName storeString
+ with: self class name
+ with: testSelector storeString.
+
+ exe := OperatingSystem pathOfSTXExecutable.
+ args := { exe . '--abortOnSEGV' . '--eval' . script }.
+
+ OperatingSystem isMSWINDOWSlike ifTrue:[
+ args := String streamContents:[:s|
+ args
+ do:[:each | s nextPut:$"; nextPutAll: each; nextPut: $"]
+ separatedBy: [ s space ]
+ ]
+ ].
+
+ outputFile := Filename newTemporary.
+ 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: Filename currentDirectory pathName
+ ] action: [ :s |
+ status := s.
+ blocker signal.
+ ].
+
+ output close.
+
+ pid isNil ifTrue:[
+ self error: 'Failed to spawn test'.
+ ^ self.
+ ].
+
+ blocker wait.
+
+ status code == EXIT_CODE_FAILURE ifTrue:[
+ (outputFile notNil and:[ outputFile exists ]) ifTrue:[
+ Stdout nextPutAll: '== TEST FAILED: '; nextPutAll: testSelector; nextPutLine:' =='.
+ outputFile readingFileDo:[:s|
+ [ s atEnd ] whileFalse:[
+ Stdout nextPutLine: s nextLine.
+ ].
+ ].
+ ].
+ self assert: false description: 'Assertion failed, see log'.
+ ].
+ (status code == EXIT_CODE_ERROR or:[status status == #signal]) ifTrue:[
+ (outputFile notNil and:[ outputFile exists ]) ifTrue:[
+ Stdout nextPutAll: '== TEST ERROR: '; nextPutAll: testSelector; nextPutLine:' =='.
+ outputFile readingFileDo:[:s|
+ [ s atEnd ] whileFalse:[
+ Stdout nextPutLine: s nextLine.
+ ].
+ ].
+ ].
+ self error: 'Error occured'.
+ ].
+ ] ensure:[
+ (testcaseFile notNil and:[testcaseFile exists]) ifTrue:[
+ testcaseFile remove.
+ ].
+ outputFile
+ ].
+
+ "Created: / 04-09-2014 / 18:13:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 05-09-2014 / 19:03:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+runCaseInternal
+ [
+ super runCase.
+ Stdout cr;
+ nextPutAll: 'PASSED'; cr.
+ ] 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: / 04-09-2014 / 17:41:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 05-09-2014 / 18:37:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!VMCrashTestCase methodsFor:'tests - infrastructure'!
+
+test_infrastructure
+ "
+ VMCrashTestCase run:#test_infrastructure
+ "
+
+ | result |
+
+ result := self class run: #tst_pass.
+ self assert: result passedCount = 1.
+ self assert: result failureCount = 0.
+ self assert: result errorCount = 0.
+
+ result := self class run: #tst_fail.
+ self assert: result passedCount = 0.
+ self assert: result failureCount = 1.
+ self assert: result errorCount = 0.
+
+ result := self class run: #tst_error.
+ self assert: result passedCount = 0.
+ self assert: result failureCount = 0.
+ self assert: result errorCount = 1.
+
+ "
+ VMCrashTestCase run: #tst_crash.
+ "
+ result := self class run: #tst_crash.
+ self assert: result passedCount = 0.
+ self assert: result failureCount = 0.
+ self assert: result errorCount = 1.
+
+ "Created: / 05-09-2014 / 18:22:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+tst_crash
+ | bytes |
+
+ bytes := ExternalBytes address: 16r10 size: 100.
+ bytes byteAt: 1 put: 10.
+
+ "Created: / 05-09-2014 / 18:24:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+tst_error
+ self error:'Error'
+
+ "Created: / 05-09-2014 / 18:20:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+tst_fail
+ self assert: false.
+
+ "Created: / 05-09-2014 / 18:20:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+tst_pass
+
+ "Created: / 05-09-2014 / 18:20:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!VMCrashTestCase class methodsFor:'documentation'!
+
+version
+ ^ '$Header$'
+!
+
+version_CVS
+ ^ '$Header$'
+! !
+
+
+VMCrashTestCase initialize!