"{ Package: 'stx:goodies/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.

    Each test case *must* be annotated by one <spawn:> annotation,

    argument must be either `true` of `false`. If `true` then the

    test is run in a freshly started VM. If `false`, test is run

    in the same VM.

    As this is meant as a base class for regression tests that used to

    kill the VM, normally you should annotate tests with <spawn: true>

    [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:'accessing'!

timeout

    "Returns a default timeout (sec) for the test.

     If nil is returned, no timeout enforced.

    Note that the timeout is set only when running under

    report runner, interactive tools does not use it"

    | method |

    method := self class lookupMethodFor: testSelector.

    method annotationsAt:#timeout: do:[:annotation|

	 ^annotation arguments first

    ].

    ^60"sec - default timeout"

    "Created: / 08-09-2014 / 13:00:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!VMCrashTestCase methodsFor:'running'!

runCase

    "Perform the testcase.

     If testcase is annotated by <spawn: false> the test is run in the

     very same VM. If <spawn: true>, a new VM is started and the testcase

     in run in that new VM"

    | tempDir testcaseFile exe args script environment outputFile output pid blocker status spawn |

    spawn := (self class lookupMethodFor: testSelector) annotationAt: #spawn:.

    spawn isNil ifTrue:[

    ].

    (spawn argumentAt: 1) == false ifTrue:[

    ] ifFalse:[

    ].

    [

    ] ensure:[

    ].

    "

    VMCrashTestCase run:#test_infrastructure

    "

    "Created: / 04-09-2014 / 18:13:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 19-09-2014 / 16:43:09 / 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

    "

    <spawn: false>

    | 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>"

    "Modified: / 08-09-2014 / 12:26:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

tst_crash

    <spawn: true>

    | bytes |

    Stdout nextPutLine: 'Going to crash now!!'.

    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>"

    "Modified: / 16-09-2014 / 20:30:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

tst_error

    <spawn: true>

    self error:'Error'

    "Created: / 05-09-2014 / 18:20:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 08-09-2014 / 12:26:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

tst_fail

    <spawn: true>

    self assert: false.

    "Created: / 05-09-2014 / 18:20:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 08-09-2014 / 12:26:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

tst_pass

    <spawn: true>

    "Created: / 05-09-2014 / 18:20:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 08-09-2014 / 12:26:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!VMCrashTestCase class methodsFor:'documentation'!

version

    ^ '$Header$'

!

version_CVS

    ^ '$Header$'

! !

VMCrashTestCase initialize!