#FEATURE by cg
class: TestCase
added: #invokeTestMethod
changed: #performTest
support timeout annotation
"{ Package: 'stx:goodies/sunit' }"
ApplicationModel subclass:#TestTester
instanceVariableNames:'currentSource testCaseClassListApp testCaseMethodListApp
testeeClassListApp testeeMethodListApp selectedTesteeClasses
selectedTesteeMethods selectedTestCaseClasses
selectedTestCaseMethods testeeMethodListHolder
testCaseSourceHolder mutatedMethodSourceHolder
originalMethodSourceHolder testCaseClassGeneratorHolder
selectedTesteeMethod selectedTestCaseClass infoLabelHolder
diffTextView numberOfTriedMutations maxTestExecutionTime'
classVariableNames:''
poolDictionaries:''
category:'SUnit-UI'
!
Object subclass:#Mutator
instanceVariableNames:'blockToCall treeTop'
classVariableNames:''
poolDictionaries:''
privateIn:TestTester
!
Error subclass:#TestSuiteIncompleteError
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:TestTester
!
Error subclass:#TimeoutError
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:TestTester
!
!TestTester class methodsFor:'interface specs'!
windowSpec
"This resource specification was automatically generated
by the UIPainter of ST/X."
"Do not manually edit this!! If it is corrupted,
the UIPainter may not be able to read the specification."
"
UIPainter new openOnClass:TestTester andSelector:#windowSpec
TestTester new openInterface:#windowSpec
TestTester open
"
<resource: #canvas>
^
#(FullSpec
name: windowSpec
window:
(WindowSpec
label: 'TestTester'
name: 'TestTester'
min: (Point 10 10)
max: (Point 1024 768)
bounds: (Rectangle 0 0 554 504)
menu: mainMenu
)
component:
(SpecCollection
collection: (
(MenuPanelSpec
name: 'ToolBar1'
layout: (LayoutFrame 0 0.0 0 0 0 1.0 36 0)
menu: toolbarMenu
textDefault: true
)
(ViewSpec
name: 'Box4'
layout: (LayoutFrame 0 0 36 0 0 1 -26 1)
component:
(SpecCollection
collection: (
(ViewSpec
name: 'TestedMethodSelectionBox'
layout: (LayoutFrame 0 0 0 0 0 0.4 0 0.5)
component:
(SpecCollection
collection: (
(LabelSpec
label: 'Tested Method'
name: 'Label4'
layout: (LayoutFrame 0 0.0 0 0 0 1.0 22 0)
translateLabel: true
)
(SubCanvasSpec
name: 'TestedMethodClassList'
layout: (LayoutFrame 0 0 22 0 0 0.5 0 1)
hasHorizontalScrollBar: false
hasVerticalScrollBar: false
majorKey: #'Tools::ClassList'
subAspectHolders:
(Array
(SubChannelInfoSpec
subAspect: selectedClasses
aspect: selectedTesteeClasses
)
)
createNewApplication: true
createNewBuilder: true
postBuildCallback: postBuildTestedClassList:
)
(SubCanvasSpec
name: 'TestedMethodMethodList'
layout: (LayoutFrame 0 0.5 22 0 0 1 0 1)
hasHorizontalScrollBar: false
hasVerticalScrollBar: false
majorKey: #'Tools::MethodList'
subAspectHolders:
(Array
(SubChannelInfoSpec
subAspect: inGeneratorHolder
aspect: testeeMethodListHolder
)
(SubChannelInfoSpec
subAspect: selectedMethods
aspect: selectedTesteeMethods
)
)
createNewApplication: true
createNewBuilder: true
postBuildCallback: postBuildTestedMethodList:
)
)
)
)
(LabelSpec
label: 'Original'
name: 'Label5'
layout: (LayoutFrame 0 0.4 0 0 0 0.7 22 0)
translateLabel: true
)
(TextEditorSpec
name: 'OriginalMethodEditor'
layout: (LayoutFrame 0 0.4 22 0 0 0.7 0 0.5)
model: originalMethodSourceHolder
hasHorizontalScrollBar: true
hasVerticalScrollBar: true
hasKeyboardFocusInitially: false
)
(LabelSpec
label: 'Mutation'
name: 'Label6'
layout: (LayoutFrame 0 0.7 0 0 0 1 22 0)
translateLabel: true
)
(TextEditorSpec
name: 'MutatedMethodEditor'
layout: (LayoutFrame 0 0.7 22 0 0 1 0 0.5)
model: mutatedMethodSourceHolder
hasHorizontalScrollBar: true
hasVerticalScrollBar: true
hasKeyboardFocusInitially: false
)
(ViewSpec
name: 'TestSuiteSelectionBox'
layout: (LayoutFrame 0 0 0 0.5 0 0.4 0 1)
component:
(SpecCollection
collection: (
(LabelSpec
label: 'TestCase'
name: 'Label3'
layout: (LayoutFrame 0 0.0 0 0 0 1.0 22 0)
translateLabel: true
)
(SubCanvasSpec
name: 'TestCaseClassList'
layout: (LayoutFrame 0 0 22 0 0 1 0 1)
hasHorizontalScrollBar: false
hasVerticalScrollBar: false
majorKey: #'Tools::ClassList'
subAspectHolders:
(Array
(SubChannelInfoSpec
subAspect: inGeneratorHolder
aspect: testCaseClassGeneratorHolder
)
(SubChannelInfoSpec
subAspect: selectedClasses
aspect: selectedTestCaseClasses
)
)
createNewApplication: true
createNewBuilder: true
postBuildCallback: postBuildTestCaseClassList:
)
)
)
)
(LabelSpec
name: 'Label7'
layout: (LayoutFrame 0 0.5 0 0.5 0 1 22 0.5)
translateLabel: true
)
(TextEditorSpec
name: 'TextCaseEditor1'
layout: (LayoutFrame 0 0.4 22 0.5 0 1 0 1)
model: testCaseSourceHolder
hasHorizontalScrollBar: true
hasVerticalScrollBar: true
hasKeyboardFocusInitially: false
)
(ArbitraryComponentSpec
name: 'ArbitraryComponent1'
layout: (LayoutFrame 0 0.4 0 0 0 1 0 0.5)
hasHorizontalScrollBar: true
hasVerticalScrollBar: true
miniScrollerHorizontal: true
component: DiffTextView
postBuildCallback: postBuildDiffTextView:
)
)
)
)
(ViewSpec
name: 'Box2'
layout: (LayoutFrame 0 0 -26 1 0 1 0 1)
level: 1
component:
(SpecCollection
collection: (
(LabelSpec
label: 'InfoLabel'
name: 'Label2'
layout: (LayoutFrame 0 0 -26 1 -1 1 0 1)
level: -1
translateLabel: true
labelChannel: infoLabelHolder
adjust: left
)
)
)
)
)
)
)
! !
!TestTester class methodsFor:'menu specs'!
mainMenu
"This resource specification was automatically generated
by the MenuEditor of ST/X."
"Do not manually edit this!! If it is corrupted,
the MenuEditor may not be able to read the specification."
"
MenuEditor new openOnClass:TestTester andSelector:#mainMenu
(Menu new fromLiteralArrayEncoding:(TestTester mainMenu)) startUp
"
<resource: #menu>
^
#(Menu
(
(MenuItem
label: 'File'
translateLabel: true
submenu:
(Menu
(
(MenuItem
label: 'Exit'
itemValue: closeRequest
translateLabel: true
)
)
nil
nil
)
)
(MenuItem
label: 'Help'
translateLabel: true
startGroup: right
submenu:
(Menu
(
(MenuItem
label: 'Documentation'
itemValue: openDocumentation
translateLabel: true
)
(MenuItem
label: '-'
)
(MenuItem
label: 'About this Application...'
itemValue: openAboutThisApplication
translateLabel: true
)
)
nil
nil
)
)
)
nil
nil
)
!
toolbarMenu
"This resource specification was automatically generated
by the MenuEditor of ST/X."
"Do not manually edit this!! If it is corrupted,
the MenuEditor may not be able to read the specification."
"
MenuEditor new openOnClass:TestTester andSelector:#toolbarMenu
(Menu new fromLiteralArrayEncoding:(TestTester toolbarMenu)) startUp
"
<resource: #menu>
^
#(Menu
(
(MenuItem
label: 'RunCheck'
itemValue: menuRunCheck
translateLabel: true
isButton: true
labelImage: (ResourceRetriever ToolbarIconLibrary make22x22Icon)
)
)
nil
nil
)
! !
!TestTester methodsFor:'aspects'!
infoLabelHolder
infoLabelHolder isNil ifTrue:[
infoLabelHolder := ValueHolder new.
].
^ infoLabelHolder
"Created: / 25-04-2010 / 21:01:00 / cg"
!
mutatedMethodSourceHolder
mutatedMethodSourceHolder isNil ifTrue:[
mutatedMethodSourceHolder := ValueHolder new.
].
^ mutatedMethodSourceHolder
"Created: / 25-04-2010 / 15:53:44 / cg"
!
originalMethodSourceHolder
originalMethodSourceHolder isNil ifTrue:[
originalMethodSourceHolder := ValueHolder new.
].
^ originalMethodSourceHolder
"Created: / 25-04-2010 / 15:53:58 / cg"
!
selectedTestCaseClasses
selectedTestCaseClasses isNil ifTrue:[
selectedTestCaseClasses := ValueHolder new.
selectedTestCaseClasses onChangeSend:#selectedTestCaseClassesChanged to:self.
].
^ selectedTestCaseClasses
"Created: / 25-04-2010 / 16:23:56 / cg"
!
selectedTesteeClasses
selectedTesteeClasses isNil ifTrue:[
selectedTesteeClasses := ValueHolder new.
selectedTesteeClasses onChangeSend:#selectedTesteeClassesChanged to:self.
].
^ selectedTesteeClasses
"Created: / 25-04-2010 / 14:00:14 / cg"
!
selectedTesteeMethods
selectedTesteeMethods isNil ifTrue:[
selectedTesteeMethods := ValueHolder new.
selectedTesteeMethods onChangeSend:#selectedTesteeMethodsChanged to:self.
].
^ selectedTesteeMethods
"Created: / 25-04-2010 / 15:50:10 / cg"
!
testCaseClassGeneratorHolder
testCaseClassGeneratorHolder isNil ifTrue:[
testCaseClassGeneratorHolder := ValueHolder new.
].
^ testCaseClassGeneratorHolder
"Created: / 25-04-2010 / 16:01:28 / cg"
!
testCaseSourceHolder
testCaseSourceHolder isNil ifTrue:[
testCaseSourceHolder := ValueHolder new.
].
^ testCaseSourceHolder
"Created: / 25-04-2010 / 15:53:07 / cg"
!
testeeMethodListHolder
testeeMethodListHolder isNil ifTrue:[
testeeMethodListHolder := ValueHolder new.
].
^ testeeMethodListHolder
"Created: / 25-04-2010 / 14:05:25 / cg"
! !
!TestTester methodsFor:'initialization'!
postBuildDiffTextView:aView
diffTextView := aView
"Created: / 26-04-2010 / 10:36:42 / cg"
!
postBuildTestCaseClassList:aSubCanvas
|classGenerator|
classGenerator :=
Iterator
on:[:whatToDo |
TestCase allSubclasses
select:[:cls | cls isAbstract not]
thenDo:[:cls |
whatToDo
value:cls
].
].
self testCaseClassGeneratorHolder value:classGenerator
"Modified: / 25-04-2010 / 16:04:44 / cg"
!
postBuildTestCaseMethodList:aSubCanvas
testCaseMethodListApp := aSubCanvas
"Created: / 25-04-2010 / 13:51:42 / cg"
!
postBuildTestedClassList:aSubCanvas
testeeClassListApp := aSubCanvas
"Modified: / 25-04-2010 / 13:50:41 / cg"
!
postBuildTestedMethodList:aSubCanvas
testeeMethodListApp := aSubCanvas
"Created: / 25-04-2010 / 13:50:58 / cg"
!
postBuildWith:aBuilder
"/ testCaseClassListApp inGeneratorHolder:[ Smalltalk allClasses ]
"Created: / 25-04-2010 / 13:47:59 / cg"
! !
!TestTester methodsFor:'menu actions'!
menuRunCheck
selectedTestCaseClass isNil ifTrue:[
Dialog information:'No TestCase class selected'.
^ self.
].
(AbortOperationRequest , TestSuiteIncompleteError) handle:[:ex |
ex signal == TestSuiteIncompleteError ifTrue:[
self mutatedMethodSourceHolder value:ex parameter.
].
self infoLabelHolder value:ex errorString.
] do:[
self withWaitCursorDo:[
self infoLabelHolder value:'Running Suite...'.
self
testMethod:(selectedTesteeMethod)
usingTest:selectedTestCaseClass.
self infoLabelHolder value:nil.
].
self mutatedMethodSourceHolder value:nil.
].
self updateDiffTextView.
"Modified: / 27-04-2010 / 09:46:09 / cg"
!
openAboutThisApplication
"This method was generated by the Browser/CodeGeneratorTool.
It will be invoked when the menu-item 'help-about' is selected."
"/ could open a customized aboutBox here ...
super openAboutThisApplication
!
openDocumentation
"This method was generated by the Browser/CodeGeneratorTool.
It will be invoked when the menu-item 'help-documentation' is selected."
"/ change below as required ...
"/ to open an HTML viewer on some document (under 'doc/online/<language>/' ):
self openDocumentationFile:'TOP.html'.
"/ add application-specific help files under the 'doc/online/<language>/help/appName'
"/ directory, and open a viewer with:
"/ self openDocumentationFile:'help/<MyApplication>/TOP.html'.
! !
!TestTester methodsFor:'misc'!
showAllClassesInNameSpaceOrganisation
^ true
"Created: / 25-04-2010 / 13:56:24 / cg"
! !
!TestTester methodsFor:'testing methods'!
testMethod:aMethod using:selector fromTest:aTestCaseClass
"motivation:
assuming that aTestCase is a good test for aMethod,
any change in aMethod should be rewarded by a failing testRun."
^ self
testMethod:aMethod
usingTest:aTestCaseClass
selectors:(aTestCaseClass testSelectors)
"Modified: / 24-04-2010 / 14:03:57 / cg"
!
testMethod:aMethod usingSuite:aTestSuite
|tree newSource methodClass methodSelector|
numberOfTriedMutations := 0.
maxTestExecutionTime := nil.
methodClass := aMethod mclass.
methodSelector := aMethod selector.
self mutatedMethodSourceHolder value:nil.
AssertionFailedError handle:[:ex |
TestSuiteIncompleteError
raiseWith:aMethod source
errorString:'Test failed for original'.
] do:[
self infoLabelHolder value:'Running Suite on original code...'.
self runSuiteExpectingSuccess:aTestSuite.
].
tree := RBParser parseMethod:(aMethod source) onError:[:str :pos | nil ].
tree isNil ifTrue:[
self error:'cannot parse method'.
].
tree source:nil.
"/ just to make sure: check if compiled method behaves the same
newSource := tree formattedCode.
self withCode:newSource installedAs:methodSelector inClass:methodClass do:[:newMethod |
AssertionFailedError handle:[:ex |
TestSuiteIncompleteError
raiseWith:aMethod source
errorString:'Test failed for original'.
] do:[
self infoLabelHolder value:'Running Suite on original code again...'.
self runSuiteExpectingSuccess:aTestSuite.
]
].
self originalMethodSourceHolder value:newSource.
self mutatedMethodSourceHolder value:newSource.
self updateDiffTextView.
"/ start to fiddle with the code; the tests MUST detect each !!
self mutationsOf:tree do:[:modifiedTree |
newSource := modifiedTree formattedCode.
self mutatedMethodSourceHolder value:newSource.
self updateDiffTextView.
self withCode:newSource installedAs:methodSelector inClass:methodClass do:[:newMethod |
AssertionFailedError handle:[:ex |
TestSuiteIncompleteError
raiseWith:newSource
errorString:ex errorString.
] do:[
numberOfTriedMutations := numberOfTriedMutations + 1.
self infoLabelHolder value:('Running Suite on mutation %1...' bindWith:numberOfTriedMutations).
self runSuiteExpectingFailure:aTestSuite.
]
].
].
"
self new
testMethod:(Integer >> #factorial)
usingTest:RegressionTests::IntegerTest
selector:#testFactorial
"
"Created: / 24-04-2010 / 14:06:07 / cg"
"Modified: / 27-04-2010 / 09:41:14 / cg"
!
testMethod:aMethod usingTest:aTestCaseClass
"motivation:
assuming that aTestCase is a good test for aMethod,
any change in aMethod should be rewarded by a failing testRun."
^ self
testMethod:aMethod
usingTest:aTestCaseClass
selectors:(aTestCaseClass testSelectors)
"
self new
testMethod:(Integer >> #factorial)
usingTest:RegressionTests::IntegerTest
"
"Created: / 25-04-2010 / 16:29:22 / cg"
!
testMethod:aMethod usingTest:aTestCaseClass selector:selector
"motivation:
assuming that aTestCase is a good test for aMethod,
any change in aMethod should be rewarded by a failing testRun."
^ self
testMethod:aMethod
usingTest:aTestCaseClass
selectors:(Array with:selector)
"
self new
testMethod:(Integer >> #factorial)
usingTest:RegressionTests::IntegerTest
selector:#testFactorial
"
"Created: / 24-04-2010 / 13:59:18 / cg"
!
testMethod:aMethod usingTest:aTestCaseClass selectors:collectionOfSelectors
"motivation:
assuming that aTestCase is a good test for aMethod,
any change in aMethod should be rewarded by a failing testRun."
|suite|
suite := TestSuite new.
collectionOfSelectors do:[:selector |
suite
addTest: (aTestCaseClass selector: selector).
].
^ self testMethod:aMethod usingSuite:suite
"
self new
testMethod:(Integer >> #factorial)
usingTest:RegressionTests::IntegerTest
selector:#testFactorial
"
"Created: / 24-04-2010 / 14:03:09 / cg"
! !
!TestTester methodsFor:'testing-helpers'!
mutationsOf:aTree do:aBlock
(Mutator new) mutationsOf:aTree do:aBlock
"/ aTree acceptVisitor:(Mutator forBlock:aBlock).
"
self new
testMethod:(Integer >> #factorial)
usingTest:RegressionTests::IntegerTest
selector:#testFactorial
"
"Created: / 24-04-2010 / 16:22:51 / cg"
"Modified: / 24-04-2010 / 18:12:48 / cg"
!
runSuite:aTestSuite
|t timedOut result|
timedOut := false.
t := Time millisecondsToRun:[
maxTestExecutionTime isNil ifTrue:[
result := aTestSuite run.
] ifFalse:[
[
result := aTestSuite run.
] valueWithWatchDog:[ timedOut := true ] afterMilliseconds:(maxTestExecutionTime * 5).
].
].
timedOut ifTrue:[ TimeoutError raiseErrorString:'Timeout - code possibly ran into endless loop ?'].
maxTestExecutionTime := (maxTestExecutionTime ? t) max:t.
^ result
"Created: / 27-04-2010 / 01:37:42 / cg"
"Modified: / 27-04-2010 / 09:31:56 / cg"
!
runSuiteExpectingFailure:aTestSuite
|result|
TimeoutError handle:[:ex |
Transcript showCR:ex description.
^ self
] do:[
result := self runSuite:aTestSuite.
].
self
assert:result runCount > 0;
"/ assert:(result passedCount = 0) message:'test should not have passed';
assert:((result failureCount + result errorCount) > 0)
message:'Some test should have failed'.
"Created: / 24-04-2010 / 16:17:47 / cg"
"Modified: / 27-04-2010 / 09:46:27 / cg"
!
runSuiteExpectingSuccess:aTestSuite
|result|
result := self runSuite:aTestSuite.
result errorCount > 0 ifTrue:[self halt].
self
assert:result runCount > 0;
assert:(result passedCount > 0) message:'All tests should have passed';
assert:(result failureCount = 0) message:'No test should have failed';
assert:(result errorCount = 0) message:'No test should have errors'.
"Modified: / 27-04-2010 / 09:46:40 / cg"
!
withCode:newSource installedAs:selector inClass:aClass do:aBlock
|oldMethod newMethod|
oldMethod := aClass compiledMethodAt:selector.
newMethod := Compiler compile:newSource forClass:aClass install:false.
[
"/ install new method
aClass basicAddSelector:selector withMethod:newMethod.
aBlock value:newMethod
] ensure:[
"/ restore original method
aClass basicAddSelector:selector withMethod:oldMethod.
].
"Created: / 24-04-2010 / 16:26:00 / cg"
! !
!TestTester methodsFor:'user actions'!
selectedTestCaseClassesChanged
selectedTestCaseClass := selectedTestCaseClasses value firstIfEmpty:nil.
"Created: / 25-04-2010 / 16:25:18 / cg"
!
selectedTesteeClassesChanged
|methodGenerator|
methodGenerator :=
Iterator
on:[:whatToDo |
|methodClass|
methodClass := self selectedTesteeClasses value first.
methodClass methodDictionary
keysAndValuesDo:[:methodSelector :method |
whatToDo
value:methodClass
value:method category
value:methodSelector
value:method.
].
].
self testeeMethodListHolder value:methodGenerator
"Modified: / 25-04-2010 / 15:48:04 / cg"
!
selectedTesteeMethodsChanged
|methods method source|
methods := self selectedTesteeMethods value.
methods notEmpty ifTrue:[
method := methods first.
source := method source.
].
selectedTesteeMethod ~~ method ifTrue:[
(self originalMethodSourceHolder value) ~= source ifTrue:[
selectedTesteeMethod := method.
"/ self halt.
self originalMethodSourceHolder value:source.
self mutatedMethodSourceHolder value:nil.
self updateDiffTextView.
].
].
"Created: / 25-04-2010 / 15:51:03 / cg"
"Modified: / 27-04-2010 / 09:54:19 / cg"
!
updateDiffTextView
diffTextView
text1:(self originalMethodSourceHolder value ? '')
text2:(self mutatedMethodSourceHolder value ? '').
self windowGroup repairDamage.
"Created: / 26-04-2010 / 10:38:39 / cg"
"Modified: / 26-04-2010 / 12:19:26 / cg"
! !
!TestTester::Mutator class methodsFor:'instance creation'!
forBlock:aBlock
^ self new blockToCall:aBlock
"Created: / 24-04-2010 / 16:55:24 / cg"
! !
!TestTester::Mutator methodsFor:'accessing'!
blockToCall:something
blockToCall := something.
! !
!TestTester::Mutator methodsFor:'mutating'!
mutationsOf:aTree do:aBlock
blockToCall := aBlock.
treeTop := aTree.
aTree acceptVisitor:self.
"Created: / 24-04-2010 / 17:12:19 / cg"
"Modified: / 24-04-2010 / 19:02:24 / cg"
! !
!TestTester::Mutator methodsFor:'visiting'!
acceptAssignmentNode:anAssignmentNode
|oldExpr|
oldExpr := anAssignmentNode value.
[
(self class new) mutationsOf:oldExpr do:[:newExpr |
anAssignmentNode value:newExpr.
blockToCall value:treeTop.
].
] ensure:[
anAssignmentNode value:oldExpr
].
"Created: / 27-04-2010 / 00:32:14 / cg"
!
acceptBlockNode:aBlockNode
self acceptMethodOrBlockNode:aBlockNode
"Modified: / 24-04-2010 / 19:06:49 / cg"
!
acceptLiteralNode:aLiteralNode
|oldValue|
oldValue := aLiteralNode value.
oldValue isInteger ifTrue:[
[
Transcript showCR:('Replacing value %1 with: %2' bindWith:oldValue with:oldValue+1).
aLiteralNode token value:oldValue + 1.
blockToCall value:treeTop.
Transcript showCR:('Replacing value %1 with: %2' bindWith:oldValue with:oldValue-1).
aLiteralNode token value:oldValue - 1.
blockToCall value:treeTop.
((oldValue ~= 1) and:[oldValue ~= -1 and:[oldValue ~= 0]]) ifTrue:[
Transcript showCR:('Replacing value %1 with: %2' bindWith:oldValue with:0).
aLiteralNode token value:0.
blockToCall value:treeTop.
].
] ensure:[
aLiteralNode token value:oldValue.
].
^ self.
].
oldValue isFloat ifTrue:[
self halt.
^ self.
].
oldValue isSymbol ifTrue:[
^ self.
].
oldValue isString ifTrue:[
^ self.
].
oldValue isArray ifTrue:[
^ self.
].
oldValue isByteArray ifTrue:[
self halt.
^ self.
].
self halt.
"Created: / 25-04-2010 / 21:32:12 / cg"
"Modified: / 27-04-2010 / 09:45:18 / cg"
!
acceptMessageNode:aMessageNode
|selector arguments|
selector := aMessageNode selector.
( #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:) includes:selector) ifTrue:[
self tryWithNegatedCondition:aMessageNode.
].
arguments := aMessageNode arguments.
1 to:arguments size do:[:idx |
|oldArg|
oldArg := arguments at:idx.
[
(self class new) mutationsOf:oldArg do:[:newArg |
arguments at:idx put:newArg.
blockToCall value:treeTop.
].
] ensure:[
arguments at:idx put:oldArg
].
].
"Modified: / 24-04-2010 / 19:07:22 / cg"
!
acceptMethodNode:aMethodNode
self acceptMethodOrBlockNode:aMethodNode
"Modified: / 24-04-2010 / 19:06:44 / cg"
!
acceptMethodOrBlockNode:aMethodOrBlockNode
|oldBody|
oldBody := aMethodOrBlockNode body.
oldBody notNil ifTrue:[
[
(self class new) mutationsOf:oldBody do:[:newBody |
aMethodOrBlockNode body:newBody.
blockToCall value:treeTop.
].
] ensure:[
aMethodOrBlockNode body:oldBody
].
].
"Created: / 24-04-2010 / 19:06:33 / cg"
!
acceptReturnNode:aReturnNode
|oldExpr|
oldExpr := aReturnNode value.
[
(self class new) mutationsOf:oldExpr do:[:newExpr |
aReturnNode value:newExpr.
blockToCall value:treeTop.
].
] ensure:[
aReturnNode value:oldExpr
].
"Modified: / 25-04-2010 / 21:30:13 / cg"
!
acceptSequenceNode:aSequenceNode
|statements|
statements := aSequenceNode statements.
1 to:statements size do:[:idx |
|oldStat|
oldStat := statements at:idx.
[
(self class new) mutationsOf:oldStat do:[:newStat |
statements at:idx put:newStat.
blockToCall value:treeTop.
].
] ensure:[
statements at:idx put:oldStat
].
].
"/ |oldBody|
"/
"/ oldBody := aMethodNode body.
"/ oldBody notNil ifTrue:[
"/ [
"/ (self class new) mutationsOf:oldBody do:[:newBody |
"/self halt.
"/ ].
"/ ] ensure:[
"/ aMethodNode body:oldBody
"/ ].
"/ ].
"/
"/ "Created: / 24-04-2010 / 16:56:12 / cg"
"/
"Created: / 24-04-2010 / 18:23:35 / cg"
!
acceptVariableNode:aVariableNode
"Created: / 25-04-2010 / 21:35:26 / cg"
!
tryWithNegatedCondition:aMessageNode
|sel repl|
sel := aMessageNode selector.
repl := (Dictionary new
at: #ifTrue: put: #ifFalse: ;
at: #ifFalse: put: #ifTrue: ;
at: #ifTrue:ifFalse: put: #ifFalse:ifTrue: ;
at: #ifFalse:ifTrue: put: #ifTrue:ifFalse: ;
yourself)
at:sel.
[
aMessageNode selector:repl.
blockToCall value:treeTop.
] ensure:[
aMessageNode selector:sel.
].
"Modified: / 24-04-2010 / 19:03:44 / cg"
! !
!TestTester class methodsFor:'documentation'!
version_CVS
^ '$Header: /cvs/stx/stx/goodies/sunit/TestTester.st,v 1.4 2010-04-27 08:48:09 cg Exp $'
! !