"

 COPYRIGHT (c) Claus Gittinger / eXept Software AG

 COPYRIGHT (c) 2017-2018 Jan Vrany

              All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

"{ 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:'documentation'!

copyright

"

 COPYRIGHT (c) Claus Gittinger / eXept Software AG

 COPYRIGHT (c) 2017-2018 Jan Vrany

              All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

! !

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

               STCCompilerInterface verbose: true.

               Smalltalk addStartBlock:[

                   ParserFlags stcModulePath: Filename currentDirectory.

                   ParserFlags stcKeepCIntermediate: true.

                   ParserFlags stcKeepSTIntermediate: true.  

                   Processor exitWhenNoMoreUserProcesses: false.                   

                   [

                       (%4 selector: %5) spawnSelectorInternal: %6.                   

                   ] ensure:[

                       Smalltalk exit: %7

                   ]

               ].

               ' 

            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: / 04-02-2019 / 17:57:53 / 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

    | tempDir |

    [

        tempDir := Filename newTemporary.

        tempDir makeDirectory.

        self spawnSmalltalk:argv inDirectory:tempDir.

    ] ensure:[

        (tempDir notNil and:[ tempDir exists ]) ifTrue:[

            [

                tempDir recursiveRemove.

            ] on:Error

                    do:[:ex | 

                OperatingSystem isMSWINDOWSlike ifFalse:[

                    ex reject.

                ].

            ]

        ].

    ].

    "Created: / 17-04-2018 / 15:56:06 / 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.

    args := { exe } , #('--abortOnSEGV') , argv , #('--no-preferences').

    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.

    "/ Write a little shell / .cmd script to re-execute the test.

    "/ This script is not used here, but provided for convenience

    "/ when debugging tests (using GDB or alike)

    OperatingSystem isMSWINDOWSlike  ifTrue:[

        (directory / 'run.cmd') writingFileDo:[ :s |

            s nextPutAll: args

        ]

    ] ifFalse:[ 

        (directory / 'run.sh') writingFileDo:[ :s |

            args do:[:e | s nextPut: $"; nextPutAll: e; nextPut: $" ]

                separatedBy: [ s space ]

        ].

    ].

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

                    "

                    (directory / 'output.txt') contents asString

                    "

                    self writeFile: outputFile to: Stdout labeled: 'TEST FAILED'.

                    self assert:false description:'Assertion failed, see log'.

                ] ifFalse:[

                    "

                    directory inspect

                    "

                    self writeFile: outputFile to: Stdout labeled: 'TEST ERROR'.                 

                    self error:'Error occured'.

                ].

            ].

        ].

    ] on: TerminateProcessRequest do:[:ex|

        pid notNil ifTrue:[ OperatingSystem killProcess: pid ].

        self writeFile: outputFile to: Stdout labeled: 'TEST TERMINATED'.

        ex pass.

    ].

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

    "Modified: / 02-01-2018 / 16:26:09 / jv"

    "Modified: / 04-02-2019 / 20:17:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

writeFile: aFilename to: aStream labeled: aString

    "

    Write contents of given `aFilename` to given `aStream` with given label (`aString`).

    Utility method for spawnSmalltalk:inDirectory: to ease the debugging.

    "

    aStream

            nextPutAll: '== ';

            nextPutAll: aString;

            nextPutAll: ' (testcase ';

            nextPutAll: self printString;

            nextPutLine:') =='.

    aFilename isNil ifTrue:[

        aStream nextPutLine: 'No file given!!'

    ] ifFalse:[ aFilename exists ifFalse:[

        aStream nextPutAll: 'File does not exist: '; nextPutLine: aFilename pathName

    ] ifTrue:[

        aFilename readingFileDo:[:s | 

            [ s atEnd ] whileFalse:[ aStream nextPutLine:s nextLine.].

        ].

    ]].

    "Created: / 28-07-2017 / 10:48:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!VMSpawningTestCase class methodsFor:'documentation'!

version_HG

    ^ '$Changeset: <not expanded> $'

! !

VMSpawningTestCase initialize!