"{ Package: 'stx:goodies/regression' }"

"{ NameSpace: RegressionTests }"

TestCase subclass:#VMCrashTestCase
	instanceVariableNames:''
	classVariableNames:'EXIT_CODE_SUCCESS EXIT_CODE_FAILURE EXIT_CODE_ERROR
		EXIT_CODE_SKIPPED'
	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.
    "/ 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"
! !

!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:[
        self error: 'No <spawn:> annotation'.
    ].
    (spawn argumentAt: 1) == false ifTrue:[
        ^ super runCase.
    ] ifFalse:[
        (spawn argumentAt: 1) ~~ true ifTrue:[
            self error: 'Argument to <spawn:> must be either `true` or `false`'.
        ]
    ].

    [
        tempDir := Filename newTemporary.
        tempDir makeDirectory.
        testcaseFile := tempDir / ((Smalltalk fileNameForClass: self class) , '.st').
        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' . '--execute' . ( tempDir / 'run.st' ) pathName }.

        OperatingSystem isMSWINDOWSlike ifTrue:[
            args := String streamContents:[:s|
                args
                    do:[:each | s nextPut:$"; nextPutAll: each; nextPut: $"]
                    separatedBy: [ s space ]
            ]
        ].

        outputFile := tempDir / 'output.txt'.
        output := outputFile writeStream.

        "/ Now, spit out some helper files that for debugging.
        ( tempDir / 'run.st' ) writingFileDo:[ :f |
            f nextPutAll: script.
        ].
        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_SUCCESS ifFalse:[ 
            status code == EXIT_CODE_SKIPPED ifTrue:[ 
                self skipIf: true description: 'Skipped'.
            ] ifFalse:[ 
                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'.
                ] ifFalse:[
                    (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:[
        (tempDir notNil and:[tempDir exists]) ifTrue:[
            [
                tempDir recursiveRemove.
            ] on: Error do:[:ex |
                OperatingSystem isMSWINDOWSlike ifFalse:[
                    ex reject.
                ].
            ]
        ].
    ].

    "
    VMCrashTestCase run:#test_infrastructure
    "

    "Created: / 04-09-2014 / 18:13:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 03-09-2016 / 07:56:21 / jv"
    "Modified (format): / 03-09-2016 / 08:22:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

runCaseInternal
    [
        [     
        super runCase.
        Stdout cr;
            nextPutAll: 'PASSED'; cr.
        ] 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: / 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>"
    "Modified: / 03-09-2016 / 07:53:15 / jv"
! !

!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.
    self assert: result skippedCount = 0.

    result := self class run: #tst_fail.
    self assert: result passedCount = 0.
    self assert: result failureCount = 1.
    self assert: result errorCount = 0.
    self assert: result skippedCount = 0.

    result := self class run: #tst_error.
    self assert: result passedCount = 0.
    self assert: result failureCount = 0.
    self assert: result errorCount = 1.
    self assert: result skippedCount = 0.

    result := self class run: #tst_skip.
    self assert: result passedCount = 0.
    self assert: result failureCount = 0.
    self assert: result errorCount = 0.
    self assert: result skippedCount = 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.
    self assert: result skippedCount = 0.

    "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>"
    "Modified: / 03-09-2016 / 07:44:57 / jv"
!

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

tst_skip
    <spawn: true>
    self skipIf: true description: 'Skip the test to test skipping'

    "Created: / 03-09-2016 / 07:42:55 / jv"
! !

!VMCrashTestCase class methodsFor:'documentation'!

version
    ^ '$Header$'
!

version_CVS
    ^ '$Header$'
!

version_HG

    ^ '$Changeset: <not expanded> $'
! !


VMCrashTestCase initialize!