--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/RegressionTests__VMSpawningTestCase.st Thu Jan 05 23:36:28 2017 +0000
@@ -0,0 +1,262 @@
+"{ 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] fork].
+ '
+ 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: / 06-01-2017 / 23:27:12 / 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.
+ args := { exe } , argv.
+ 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>"
+ "Modified: / 06-01-2017 / 23:36:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!VMSpawningTestCase class methodsFor:'documentation'!
+
+version_HG
+
+ ^ '$Changeset: <not expanded> $'
+! !
+
+
+VMSpawningTestCase initialize!