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

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

!

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

!

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