--- a/Tools__NewSystemBrowser.st Fri Apr 30 17:02:05 2010 +0200
+++ b/Tools__NewSystemBrowser.st Mon May 03 18:04:09 2010 +0200
@@ -7355,6 +7355,14 @@
enabled: hasAnyTestCaseSelectedHolder
showBusyCursorWhilePerforming: true
)
+ (MenuItem
+ label: 'Run Tests for Coverage'
+ itemValue: runTestCasesForCoverage
+ translateLabel: true
+ enabled: hasAnyTestCaseSelectedHolder
+ showBusyCursorWhilePerforming: true
+ "/ enabled: hasAnyClassWithCoverageInfoSelectedHolder
+ )
#(#MenuItem
#label: '-'
)
@@ -21206,8 +21214,7 @@
classMenuRecompileInstrumented
self selectedClassesDo:[:eachClass |
- eachClass theNonMetaclass recompileUsingCompilerClass:InstrumentingCompiler.
- eachClass theMetaclass recompileUsingCompilerClass:InstrumentingCompiler.
+ self recompileWithInstrumentation:eachClass
].
!
@@ -22361,6 +22368,11 @@
]
!
+recompileWithInstrumentation:aClass
+ aClass theNonMetaclass recompileUsingCompilerClass:InstrumentingCompiler.
+ aClass theMetaclass recompileUsingCompilerClass:InstrumentingCompiler.
+!
+
removeClasses:classesToRemove pullUpSubclasses:pullUpSubclasses
"remove the selected classes (and all of its subclasses) without confirmation"
@@ -22399,120 +22411,6 @@
]
!
-runTestCases
- "run selected testcases."
-
- self runTestCasesWithDebug:false
-
- "Modified: / 05-08-2006 / 17:32:19 / cg"
-!
-
-runTestCasesWithDebug
- "run selected testcases."
-
- self runTestCasesWithDebug:true
-
- "Created: / 05-08-2006 / 17:32:24 / cg"
-!
-
-runTestCasesWithDebug:withDebug
- "run selected testcases."
-
- [
- |selectedClasses|
-
- selectedClasses := self selectedClasses value.
- selectedClasses isEmptyOrNil ifTrue:[
- selectedClasses := self selectedCategoryClasses
- ].
-
- selectedClasses do:[:eachClass |
- |cls isCompleteSuite suite result selectors toRun|
-
- cls := eachClass.
- cls isLoaded ifFalse:[
- cls := eachClass autoload.
- ].
- cls := cls theNonMetaclass.
- ((cls isSubclassOf:TestCase)
- and:[cls isAbstract not]) ifTrue:[
- (self selectedProtocolsValue isEmptyOrNil
- or:[self selectedProtocolsValue includes:BrowserList nameListEntryForALL]) ifTrue:[
- isCompleteSuite := true.
- suite := cls buildSuite.
- ] ifFalse:[
- isCompleteSuite := false.
- (selectors := self selectedSelectors) isEmptyOrNil ifTrue:[
- selectors := OrderedCollection new.
- self selectedProtocolMethodsDo:[:cls :category :sel :mthd |
- ((cls isSubclassOf:TestCase) and:[cls isAbstract not]) ifTrue:[
- (cls isTestSelector:sel) ifTrue:[
- selectors add:sel
- ].
- ].
- ].
- ].
- suite := cls buildSuiteFromMethods:selectors.
- ].
-
- self busyLabel:'running test %1 ...' with:cls name.
- toRun := suite tests size.
- result := TestResult new.
- withDebug ifTrue:[
- suite tests do:[:each |
- |errorHappened|
-
- errorHappened := false.
- GenericException handle:[:ex |
- (HaltInterrupt accepts:ex signal) ifFalse:[
- ex signal == NoHandlerError ifFalse:[
- errorHappened := true.
- ]
- ].
- ex reject.
- ] do:[
- each debug
- ].
- errorHappened ifTrue:[
- cls rememberFailedTest:each selector.
- result failures add:each.
- ] ifFalse:[
- cls rememberPassedTest:each selector.
- result passed add:each.
- ]
- ]
- ] ifFalse:[
- suite
- run: result
- beforeEachTestCaseDo:[:case :result |
- self showInfo:('To Run: %1 ; executing %2...' bindWith:toRun with:case printString).
- ]
- afterEachTestCaseDo:[:case :result |
- toRun := toRun - 1.
- ].
-
- cls rememberPassedTestsFromResult:result.
- cls rememberFailedTestsFromResult:result.
- ].
- result hasPassed ifTrue:[
- result passedCount > 0 ifTrue:[
- isCompleteSuite ifTrue:[ cls rememberPassedTestRun ].
- self showInfo:(result printString asText colorizeAllWith:Color black on:Color green).
- ].
- ] ifFalse:[
- isCompleteSuite ifTrue:[ cls rememberFailedTestRun ].
- self showInfo:(result printString asText colorizeAllWith:Color black on:Color red).
- ].
- ]
- ].
- ] ensure:[
- self normalLabel.
- ]
-
- "Created: / 05-08-2006 / 17:32:06 / cg"
- "Modified: / 22-11-2006 / 18:13:42 / cg"
-!
-
saveClassDocumentationFor:aClass
"save a classes documentation to a file"
@@ -26704,6 +26602,163 @@
"set a sender-tracepoint on the selected method(s)"
self commonTraceHelperWith:#setTraceSenderPoint with:nil clear:true.
+!
+
+runTestCases
+ "run selected testcases (not opening a debugger on error)"
+
+ self runTestCasesWithDebug:false
+
+ "Modified: / 05-08-2006 / 17:32:19 / cg"
+!
+
+runTestCasesForCoverage
+ "run selected testcases for coverage tests;
+ First, compile all affected testee-classes with instrumentation,
+ then run the tests, then open a browser on the tested classes."
+
+ |testedClassNames testedClasses browser|
+
+ testedClassNames := Set new.
+ self selectedNonAbstractTestCaseClassesDo:[:eachClass |
+ testedClassNames addAll:(eachClass testedClasses).
+ ].
+ testedClasses := testedClassNames collect:[:eachClassName | Smalltalk at:eachClassName].
+
+ testedClasses do:[:eachClass |
+ self recompileWithInstrumentation:eachClass
+ ].
+
+ self runTestCasesWithDebug:false protocols:nil.
+
+ browser := self class browseClasses:testedClasses.
+ browser showCoverageInformation value:true.
+ browser windowLabel:'Coverage Info after Test Execution'.
+!
+
+runTestCasesWithDebug
+ "run selected testcases (opening a debugger on error)"
+
+ self runTestCasesWithDebug:true
+
+ "Created: / 05-08-2006 / 17:32:24 / cg"
+!
+
+runTestCasesWithDebug:withDebug
+ "run selected testcases"
+
+ ^ self runTestCasesWithDebug:withDebug protocols:self selectedProtocolsValue.
+!
+
+runTestCasesWithDebug:withDebug protocols:protocolsOrNil
+ "run selected testcases"
+
+ [
+ self selectedNonAbstractTestCaseClassesDo:[:cls |
+ |isCompleteSuite suite selectors toRun result|
+
+ (protocolsOrNil isEmptyOrNil
+ or:[protocolsOrNil includes:BrowserList nameListEntryForALL]) ifTrue:[
+ isCompleteSuite := true.
+ suite := cls buildSuite.
+ ] ifFalse:[
+ isCompleteSuite := false.
+ (selectors := self selectedSelectors) isEmptyOrNil ifTrue:[
+ selectors := OrderedCollection new.
+ self selectedProtocolMethodsDo:[:cls :category :sel :mthd |
+ ((cls isSubclassOf:TestCase) and:[cls isAbstract not]) ifTrue:[
+ (cls isTestSelector:sel) ifTrue:[
+ selectors add:sel
+ ].
+ ].
+ ].
+ ].
+ suite := cls buildSuiteFromMethods:selectors.
+ ].
+
+ self busyLabel:'running test %1 ...' with:cls name.
+ toRun := suite tests size.
+ result := TestResult new.
+ withDebug ifTrue:[
+ suite tests do:[:each |
+ |errorHappened|
+
+ errorHappened := false.
+ GenericException handle:[:ex |
+ (HaltInterrupt accepts:ex signal) ifFalse:[
+ ex signal == NoHandlerError ifFalse:[
+ errorHappened := true.
+ ]
+ ].
+ ex reject.
+ ] do:[
+ each debug
+ ].
+ errorHappened ifTrue:[
+ cls rememberFailedTest:each selector.
+ result failures add:each.
+ ] ifFalse:[
+ cls rememberPassedTest:each selector.
+ result passed add:each.
+ ]
+ ]
+ ] ifFalse:[
+ suite
+ run: result
+ beforeEachTestCaseDo:[:case :result |
+ self showInfo:('To Run: %1 ; executing %2...' bindWith:toRun with:case printString).
+ ]
+ afterEachTestCaseDo:[:case :result |
+ toRun := toRun - 1.
+ ].
+
+ cls rememberPassedTestsFromResult:result.
+ cls rememberFailedTestsFromResult:result.
+ ].
+
+ result hasPassed ifTrue:[
+ result passedCount > 0 ifTrue:[
+ isCompleteSuite ifTrue:[ cls rememberPassedTestRun ].
+ self showInfo:(result printString asText colorizeAllWith:Color black on:Color green).
+ ].
+ ] ifFalse:[
+ isCompleteSuite ifTrue:[ cls rememberFailedTestRun ].
+ self showInfo:(result printString asText colorizeAllWith:Color black on:Color red).
+ ].
+ ].
+ ] ensure:[
+ self normalLabel.
+ ]
+
+ "Created: / 05-08-2006 / 17:32:06 / cg"
+ "Modified: / 22-11-2006 / 18:13:42 / cg"
+!
+
+selectedNonAbstractTestCaseClassesDo:aBlock
+ "run selected testcases for coverage tests;
+ First, compile all affected testee-classes with instrumentation,
+ then run the tests, then open a browser on the tested classes."
+
+ |selectedClasses|
+
+ selectedClasses := self selectedClasses value.
+ selectedClasses isEmptyOrNil ifTrue:[
+ selectedClasses := self selectedCategoryClasses
+ ].
+
+ selectedClasses do:[:eachClass |
+ |cls|
+
+ cls := eachClass.
+ cls isLoaded ifFalse:[
+ cls := eachClass autoload.
+ ].
+ cls := cls theNonMetaclass.
+ ((cls isSubclassOf:TestCase)
+ and:[cls isAbstract not]) ifTrue:[
+ aBlock value:cls
+ ]
+ ].
! !
!NewSystemBrowser methodsFor:'menu actions-help'!
@@ -44319,11 +44374,11 @@
!NewSystemBrowser class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libtool/Tools__NewSystemBrowser.st,v 1.1455 2010-04-30 09:59:09 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools__NewSystemBrowser.st,v 1.1456 2010-05-03 16:04:09 cg Exp $'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libtool/Tools__NewSystemBrowser.st,v 1.1455 2010-04-30 09:59:09 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools__NewSystemBrowser.st,v 1.1456 2010-05-03 16:04:09 cg Exp $'
! !
NewSystemBrowser initialize!