"{ 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:[(%4 selector: %5) spawnSelectorInternal: %6].

               ' 

            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.

    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:[

                (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:[

                                | l |

                                l := s nextLine.

                                Stdout nextPutLine:l.

                                Transcript ~~ Stdout ifTrue:[

                                    Transcript nextPutLine:l.

                                ].

                            ].

                        ].

                ].

                 "

                 directory inspect

                "

                self error:'Error occured'.

            ].

        ].

    ].

    "Created: / 06-01-2017 / 11:25:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!VMSpawningTestCase class methodsFor:'documentation'!

version_HG

    ^ '$Changeset: <not expanded> $'

! !

VMSpawningTestCase initialize!