added first pass of source code

.project

@@ -0,0 +1,3 @@
+{
+#srcDirectory : 'source'
+}

source/.configmaps

@@ -0,0 +1,12 @@
+[
+	{
+		#applications : [
+			'VastSUnitExtensionsApp' : '1.0',
+			'VastSUnitExtensionsExamplesApp' : '1.0'
+		],
+		#conditions : [ ],
+		#name : 'VastSUnitExtensions',
+		#versionName : '1.0',
+		#comment : ''
+	}
+]

source/.properties

@@ -1,3 +1,3 @@
 {
-	#format : #tonel
-}
+#format : 'tonel'
+}

source/VastSUnitExtensionsApp/EsRandom.extension.st

@@ -0,0 +1,25 @@
+Extension {
+	#name : 'EsRandom'
+}
+
+{ #category : '*VastSUnitExtensionsApp',
+ #vaCategories : ['Vast-SUnit'] }
+EsRandom class >> seed: aFloat [
+	"Use linear congruential generator, with a shuffling array.
+
+	 Reference: Numerical Recipes in C, The Art of Scientific Computing
+				Press et al., Cambridge University Press 1990, pp. 211, 212"
+
+	| randomStream |
+	randomStream := super new.
+	randomStream
+		seed2: aFloat;
+		basicNext;
+		shuffleArray: (Array new: randomStream shuffleSize).
+	1 to: randomStream shuffleSize do: [ :index |
+		randomStream shuffleArray at: index put: randomStream basicNext].
+
+	randomStream seed1: randomStream seed2.
+
+	^randomStream
+]

source/VastSUnitExtensionsApp/SequenceableCollection.extension.st

@@ -0,0 +1,12 @@
+Extension {
+	#name : 'SequenceableCollection'
+}
+
+{ #category : '*VastSUnitExtensionsApp',
+ #vaCategories : ['Not categorized'] }
+SequenceableCollection >> vaShuffleBy: aRandom [
+	"Durstenfeld's version of the Fisher-Yates shuffle"
+
+	self size to: 2 by: -1 do: [ :i | 
+		self swap: i with: (aRandom nextInt: i) ]
+]

source/VastSUnitExtensionsApp/TestCase.extension.st

@@ -0,0 +1,20 @@
+Extension {
+	#name : 'TestCase'
+}
+
+{ #category : '*VastSUnitExtensionsApp',
+ #vaCategories : ['Not categorized'] }
+TestCase >> <= aTestCase [
+
+	"used to sort Ctest output"
+
+	^(self  class name, self selector) <= (aTestCase class name, aTestCase selector).
+]
+
+{ #category : '*VastSUnitExtensionsApp',
+ #vaCategories : ['Not categorized'] }
+TestCase >> randomRun: random result: aResult [
+	"Run normally"
+
+	aResult runCase: self
+]

source/VastSUnitExtensionsApp/TestPackagingRules.class.st

@@ -0,0 +1,213 @@
+Class {
+	#name : 'TestPackagingRules',
+	#superclass : 'TestCase',
+	#instVars : [
+		'packagingRuleMethod',
+		'packagingRuleSource',
+		'packagingRuleParseTree'
+	],
+	#category : 'VastSUnitExtensionsApp'
+}
+
+{ #category : 'SUnit' }
+TestPackagingRules class >> isAbstract [
+
+	^self sunitName = #TestPackagingRules
+
+]
+
+{ #category : 'Assertions' }
+TestPackagingRules >> assertDoNotReduceAnySubApplications: anAppOrAppName [
+	"The ability for this assertion to work depends on the common pattern seen in #packagingRulesFor:
+	 Pattern Expected:   aRuleCollector doNotReduceSubApplicationNamed: #ApplicationName.
+	 There is some detection in here to keep false positives from happening"
+
+	| theApp |
+
+	theApp :=
+		anAppOrAppName isString
+			ifTrue: [anAppOrAppName asGlobalKey asClass]
+			ifFalse: [anAppOrAppName].
+	self assertDoNotReduceSubApplication: theApp.
+	theApp allSubApplications do: [:subApp | self assertDoNotReduceSubApplication: subApp].
+	self assert: true
+]
+
+{ #category : 'Assertions' }
+TestPackagingRules >> assertDoNotReduceClass: aClassOrClassName [
+	"Check for #doNotReduceClassNamed: rule.  Use the defining application from the packagingRuleMethod compiledMethod
+	 as the subapplication to use"
+
+	self assertDoNotReduceClass: aClassOrClassName inSubApplication: self packagingRuleMethod methodClass primaryInstance
+]
+
+{ #category : 'Assertions' }
+TestPackagingRules >> assertDoNotReduceClass: aClassOrClassName inSubApplication: anAppOrAppName [
+
+	| className subAppName ruleCollector isTopLevel description |
+
+	className :=
+		(aClassOrClassName isString ifTrue: [aClassOrClassName] ifFalse: [aClassOrClassName name])
+			asGlobalKey.
+	subAppName :=
+		(anAppOrAppName isString ifTrue: [aClassOrClassName] ifFalse: [anAppOrAppName name])
+			asGlobalKey.
+	isTopLevel := self packagingRuleMethod methodClass primaryInstance name asGlobalKey = subAppName.
+	ruleCollector := self packagingRuleCollector.
+	self packagingRuleParseTree allNodesDo: [:node |
+		node isMessageExpression
+			ifTrue: [
+				(isTopLevel and: [node selector = #doNotReduceClassNamed:])
+					ifTrue: [
+						(node receiver isVariable and: [
+							node receiver local == ruleCollector
+								and: [node arguments first contents asGlobalKey = className]])
+									ifTrue: [ "assertion passed" ^true]].
+				(node selector = #doNotReduceClassNamed:inSubApplicationNamed:)
+					ifTrue: [
+						(node receiver isVariable and: [
+							node receiver local == ruleCollector and: [
+								node arguments first contents asGlobalKey = className
+									and: [node arguments second contents asGlobalKey = subAppName]]])
+										ifTrue: [ "assertion passed" ^true]]]].
+
+	description :=
+		isTopLevel
+			ifTrue: [
+				'Never found doNotReduceClassNamed: or doNotReduceClassNamed:inSubApplicationNamed: rule for ' ,
+					className]
+			ifFalse: ['Never found doNotReduceClassNamed: rule for ' , className].
+	self assert: false description: description
+
+
+]
+
+{ #category : 'Assertions' }
+TestPackagingRules >> assertDoNotReduceSubApplication: anAppOrAppName [
+	"The ability for this assertion to work depends on the common pattern seen in #packagingRulesFor:
+	 Pattern Expected:   aRuleCollector doNotReduceSubApplicationNamed: #ApplicationName.
+	 There is some detection in here to keep false positives from happening"
+
+	| subAppName ruleCollector selectorToFind |
+
+	selectorToFind := #doNotReduceSubApplicationNamed:.
+	subAppName :=
+		(anAppOrAppName isString ifTrue: [anAppOrAppName] ifFalse: [anAppOrAppName name]) asGlobalKey.
+	ruleCollector := self packagingRuleCollector.
+	self packagingRuleParseTree allNodesDo: [:node |
+		node isMessageExpression
+			ifTrue: [
+				(node selector = selectorToFind and: [
+					node receiver isVariable and: [
+						node receiver local == ruleCollector
+							and: [node arguments first contents asGlobalKey = subAppName]]])
+								ifTrue: [ "assertion passed" ^true]]].
+
+	self assert: false description: 'Never found doNotReduceSubApplication rule for ' , subAppName
+
+
+]
+
+{ #category : 'Assertions' }
+TestPackagingRules >> assertInitializeToNilClassVariable: aClassVariableName inClass: aClassOrClassName [
+	"The ability for this assertion to work depends on the common pattern seen in #packagingRulesFor:
+	 Pattern Expected:   aRuleCollector doNotReduceSubApplicationNamed: #ApplicationName.
+	 There is some detection in here to keep false positives from happening"
+
+	| className ruleCollector selectorToFind |
+
+	selectorToFind := #initializeToNilClassVariable:inClassNamed:.
+	className :=
+		(aClassOrClassName isString ifTrue: [aClassOrClassName] ifFalse: [aClassOrClassName name])
+			asGlobalKey.
+	ruleCollector := self packagingRuleCollector.
+	self packagingRuleParseTree allNodesDo: [:node |
+		node isMessageExpression
+			ifTrue: [
+				(node selector = selectorToFind and: [
+					node receiver isVariable and: [
+						node receiver local == ruleCollector and: [
+							node arguments first contents asReducedString = aClassVariableName
+								and: [node arguments second contents asGlobalKey = className]]]])
+									ifTrue: [ "assertion passed" ^true]]].
+
+	self assert: false description: 'Never found initializeToNilClassVariable:inClassNamed: rule for ' , (aClassVariableName -> className) asString
+
+
+]
+
+{ #category : 'Accessing' }
+TestPackagingRules >> packagingRuleCollector [
+	"Answer the actual name <String> of the rule collector argument"
+
+	| argIdx args |
+
+	argIdx := self packagingRuleCollectorArgumentIndex.
+	args := self packagingRuleParseTree arguments.
+	args size < argIdx
+		ifTrue: [
+			self signalFailure:
+				'Rule Collector argument location out of sync with packager method specification'].
+	^args at: argIdx
+]
+
+{ #category : 'Accessing' }
+TestPackagingRules >> packagingRuleCollectorArgumentIndex [
+	"Assuming a layout like #packagingRulesFor:...then the default
+	 is that the first argument is the rule collector"
+
+	^1
+]
+
+{ #category : 'Accessing' }
+TestPackagingRules >> packagingRuleMethod [
+
+	^packagingRuleMethod
+]
+
+{ #category : 'Accessing' }
+TestPackagingRules >> packagingRuleMethod: anObject [
+
+	packagingRuleMethod := anObject
+]
+
+{ #category : 'Accessing' }
+TestPackagingRules >> packagingRuleParseTree [
+
+	packagingRuleParseTree isNil
+		ifTrue: [
+			packagingRuleParseTree :=
+				EsParser
+					parse: self packagingRuleSource
+					class: self packagingRuleMethod methodClass
+					scanComments: false
+					errorHandler: nil
+					ifFail: [nil]].
+	^packagingRuleParseTree
+]
+
+{ #category : 'Accessing' }
+TestPackagingRules >> packagingRuleSource [
+	"Answer the source code of the packagingRuleMethod <CompiledMethod>"
+
+	packagingRuleSource isNil
+		ifTrue: [
+			self packagingRuleMethod isNil
+				ifTrue: [self signalFailure: 'packagingRuleMethod not set'].
+			packagingRuleSource := self packagingRuleMethod sourceString].
+
+	^packagingRuleSource
+]
+
+{ #category : 'Setup/Teardown',
+  #vaVisibility : 'private' }
+TestPackagingRules >> tearDown [
+	"Remove method and cached source.
+	 While this requires each test case to reconstitute this information, it keeps
+	 us from having to deal with test cases that are accidently running other
+	 test case packaging rule methods"
+
+	packagingRuleMethod := nil.
+	packagingRuleSource := nil.
+	packagingRuleParseTree := nil
+]

source/VastSUnitExtensionsApp/TestResult.extension.st

@@ -0,0 +1,11 @@
+Extension {
+	#name : 'TestResult'
+}
+
+{ #category : '*VastSUnitExtensionsApp',
+ #vaCategories : ['Not categorized'] }
+TestResult >> allExpectedTestsPassed [
+
+	^(self hasUnexpectedErrors not and: [self hasUnexpectedFailures not])
+		and: [self hasUnexpectedPasses not]
+]

source/VastSUnitExtensionsApp/TestSuite.extension.st

@@ -0,0 +1,32 @@
+Extension {
+	#name : 'TestSuite'
+}
+
+{ #category : '*VastSUnitExtensionsApp',
+ #vaCategories : ['Vast-SUnit'] }
+TestSuite >> randomRun: seed [
+	"Run the tests in the test suite in a pseudo-random order
+	 which can be reconstituted using the @seed <Number>"
+
+	| result random |
+
+	result := TestResult new.
+	random := EsRandom seed: seed asFloat.
+	[self randomRun: random result: result]
+		sunitEnsure: [TestResource resetResources: self resources].
+	^result
+]
+
+{ #category : '*VastSUnitExtensionsApp',
+ #vaCategories : ['Vast-SUnit'] }
+TestSuite >> randomRun: random result: aResult [
+	"Run the tests in the test suite in a random order
+	 using the @random RNG"
+
+	| shuffledTests |
+
+	shuffledTests := self tests asArray vaShuffleBy: random.
+	shuffledTests do: [:each |
+		self sunitChanged: each.
+		each randomRun: random result: aResult]
+]