"
COPYRIGHT (c) 2006 by eXept Software AG
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:libtool' }"
"{ NameSpace: Tools }"
AbstractTestRunner subclass:#TestRunner2
instanceVariableNames:'classCategoryOrPackageTabIndexHolder classCategoryList
packageList classList classListOutGeneratorHolder
classListInGeneratorHolder modeHolder detailsHolder
failureListHolder failureSelectionHolder errorListHolder
errorSelectionHolder lastPass resultHolder'
classVariableNames:'History'
poolDictionaries:''
category:'Interface-Test Runner 2'
!
ClassList subclass:#ClassList
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:TestRunner2
!
ApplicationModel subclass:#ResultList
instanceVariableNames:'results resultsHolder selectiomHolder listHolder timestampFormat'
classVariableNames:''
poolDictionaries:''
privateIn:TestRunner2
!
HierarchicalItem subclass:#ListEntry
instanceVariableNames:'label realLabel test result'
classVariableNames:'PassedText FailedText ErrorText'
poolDictionaries:''
privateIn:TestRunner2::ResultList
!
!TestRunner2 class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 2006 by eXept Software AG
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.
"
! !
!TestRunner2 class methodsFor:'initialization'!
initialize
self initializeHistory.
Smalltalk addStartBlock:
[self installInLauncher]
"Created: / 09-06-2008 / 11:11:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 26-11-2008 / 09:38:20 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 19-03-2010 / 08:46:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
initializeHistory
History := List new.
"Modified: / 26-11-2008 / 09:38:20 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Created: / 19-03-2010 / 08:46:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
installInLauncher
|menuItem|
"Install in Tools menu"
menuItem := (MenuItem label:'SUnit Test Runner (enhanced)')
nameKey:'TestRunner2';
labelImage:(NewLauncher startSUnitIcon);
value:[ Tools::TestRunner2 open ];
isButton:false.
NewLauncher
addMenuItem:menuItem
from:self
in:'menu.tools.programming'
position:#( #after #startSUnitTestRunner )
space:false.
"Install in Toolbar"
menuItem := (MenuItem new)
nameKey:#'TestRunner2';
"label: 'SUnit Test Runner (enhanced)'" icon:(NewLauncher startSUnitIcon);
value:[ Tools::TestRunner2 open ];
isButton:true.
NewLauncher
addMenuItem:menuItem
from:self
in:'toolbar'
position:#( #before #garbageCollect )
space:false.
"Created: / 09-06-2008 / 11:11:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 26-11-2008 / 09:38:20 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 09-01-2010 / 20:48:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunner2 class methodsFor:'image specs'!
defaultIcon
^ToolbarIconLibrary sUnit28x28Icon
"Created: / 19-08-2009 / 14:32:13 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!TestRunner2 class methodsFor:'interface specs'!
buttonPaneSpec
"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:Tools::TestRunner2 andSelector:#buttonPaneSpec
Tools::TestRunner2 new openInterface:#buttonPaneSpec
"
<resource: #canvas>
^
#(FullSpec
name: buttonPaneSpec
window:
(WindowSpec
label: 'Button Spec'
name: 'Button Spec'
min: (Point 10 10)
bounds: (Rectangle 0 0 492 44)
)
component:
(SpecCollection
collection: (
(HorizontalPanelViewSpec
name: 'ButtonPanel'
layout: (LayoutFrame 0 0 0 0 0 1 0 1)
horizontalLayout: fit
verticalLayout: fit
horizontalSpace: 0
verticalSpace: 0
component:
(SpecCollection
collection: (
(ActionButtonSpec
label: 'Run Selected'
name: 'RunSelected'
translateLabel: true
tabable: true
model: runSelectedAction
enableChannel: hasTestCasesAspect
disabledLogo: 'Run Selected'
extent: (Point 123 44)
)
(ActionButtonSpec
label: 'Run Profiled'
name: 'RunProfiled'
translateLabel: true
tabable: true
model: runProfiledAction
initiallyDisabled: true
disabledLogo: 'Run Profiled'
extent: (Point 123 44)
)
(ActionButtonSpec
label: 'Run Failures'
name: 'RunFailures'
translateLabel: true
tabable: true
model: runFailuresAction
initiallyDisabled: true
enableChannel: hasFailuresAspect
disabledLogo: 'Run Failures'
extent: (Point 123 44)
)
(ActionButtonSpec
label: 'Run Errors'
name: 'RunErrors'
translateLabel: true
tabable: true
model: runErrorsAction
initiallyDisabled: true
enableChannel: hasErrorsAspect
disabledLogo: 'Run Errors'
extent: (Point 123 44)
)
)
)
)
)
)
)
"Modified: / 06-06-2008 / 09:55:25 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
classCategoryListSpec
"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:Tools::TestRunner2 andSelector:#classCategoryListSpec
Tools::TestRunner2 new openInterface:#classCategoryListSpec
"
<resource: #canvas>
^
#(FullSpec
name: classCategoryListSpec
window:
(WindowSpec
label: 'Class Category List'
name: 'Class Category List'
min: (Point 10 10)
bounds: (Rectangle 0 0 300 300)
)
component:
(SpecCollection
collection: (
(SubCanvasSpec
name: 'ClassCategoryList'
layout: (LayoutFrame 0 0 0 0 0 1 0 1)
hasHorizontalScrollBar: false
hasVerticalScrollBar: false
clientKey: classCategoryList
)
)
)
)
"Modified: / 04-06-2008 / 23:57:50 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
classListSpec
"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:Tools::TestRunner2 andSelector:#classCategoryListSpec
Tools::TestRunner2 new openInterface:#classCategoryListSpec
"
<resource: #canvas>
^
#(FullSpec
name: classCategoryListSpec
window:
(WindowSpec
label: 'Class Category List'
name: 'Class Category List'
min: (Point 10 10)
bounds: (Rectangle 0 0 300 300)
)
component:
(SpecCollection
collection: (
(SubCanvasSpec
name: 'ClassList'
layout: (LayoutFrame 0 0 0 0 0 1 0 1)
hasHorizontalScrollBar: false
hasVerticalScrollBar: false
clientKey: classList
)
)
)
)
"Created: / 05-06-2008 / 19:30:38 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
packageListSpec
"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:Tools::TestRunner2 andSelector:#packageListSpec
Tools::TestRunner2 new openInterface:#packageListSpec
"
<resource: #canvas>
^
#(FullSpec
name: packageListSpec
window:
(WindowSpec
label: 'Package List'
name: 'Package List'
min: (Point 10 10)
bounds: (Rectangle 0 0 300 300)
)
component:
(SpecCollection
collection: (
(SubCanvasSpec
name: 'PackageList'
layout: (LayoutFrame 0 0 0 0 0 1 0 1)
hasHorizontalScrollBar: false
hasVerticalScrollBar: false
clientKey: packageList
)
)
)
)
"Modified: / 05-06-2008 / 00:14:06 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
resultPaneSpec
"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:TestRunner2 andSelector:#resultPaneSpec
TestRunner2 new openInterface:#resultPaneSpec
"
<resource: #canvas>
^
#(FullSpec
name: resultPaneSpec
window:
(WindowSpec
label: 'Result spec'
name: 'Result spec'
min: (Point 10 10)
bounds: (Rectangle 0 0 300 300)
)
component:
(SpecCollection
collection: (
(LabelSpec
label: 'N/A'
name: 'Mode'
layout: (LayoutFrame 0 0 0 0 0 1 0 0.6)
style: (FontDescription Arial bold roman 14)
labelChannel: modeHolder
)
(LabelSpec
label: '...'
name: 'Details'
layout: (LayoutFrame 0 0 0 0.6 0 1 0 1)
labelChannel: detailsHolder
)
)
)
)
"Modified: / 18-01-2008 / 18:44:00 / janfrog"
!
testHistoryTabSpec
"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:Tools::TestRunner2 andSelector:#testHistoryTabSpec
Tools::TestRunner2 new openInterface:#testHistoryTabSpec
"
<resource: #canvas>
^
#(FullSpec
name: testHistoryTabSpec
window:
(WindowSpec
label: 'Test History'
name: 'Test History'
min: (Point 10 10)
bounds: (Rectangle 0 0 300 300)
)
component:
(SpecCollection
collection: (
(SubCanvasSpec
name: 'ResultList'
layout: (LayoutFrame 0 0 0 0 0 1 0 1)
hasHorizontalScrollBar: false
hasVerticalScrollBar: false
majorKey: #'Tools::TestRunner2::ResultList'
subAspectHolders:
(Array
(SubChannelInfoSpec
subAspect: resultsHolder
aspect: historyHolder
)
)
createNewApplication: true
createNewBuilder: true
)
)
)
)
!
testResultTabSpec
"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:Tools::TestRunner2 andSelector:#testResultTabSpec
Tools::TestRunner2 new openInterface:#testResultTabSpec
"
<resource: #canvas>
^
#(FullSpec
name: testResultTabSpec
window:
(WindowSpec
label: 'Test Result'
name: 'Test Result'
min: (Point 10 10)
bounds: (Rectangle 0 0 300 300)
)
component:
(SpecCollection
collection: (
(SubCanvasSpec
name: 'ResultList'
layout: (LayoutFrame 0 0 0 0 0 1 0 1)
hasHorizontalScrollBar: false
hasVerticalScrollBar: false
majorKey: #'Tools::TestRunner2::ResultList'
subAspectHolders:
(Array
(SubChannelInfoSpec
subAspect: resultsHolder
aspect: resultHolder
)
)
createNewApplication: true
createNewBuilder: true
)
)
)
)
"Modified: / 19-03-2010 / 08:32:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
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:Tools::TestRunner2 andSelector:#windowSpec
Tools::TestRunner2 new openInterface:#windowSpec
Tools::TestRunner2 open
"
<resource: #canvas>
^
#(FullSpec
name: windowSpec
window:
(WindowSpec
label: 'Test Runner Too'
name: 'Test Runner Too'
min: (Point 0 0)
bounds: (Rectangle 0 0 717 412)
menu: mainMenu
icon: defaultIcon
)
component:
(SpecCollection
collection: (
(UISubSpecification
name: 'ResultPane'
layout: (LayoutFrame 0 0 0 0 0 1 100 0)
minorKey: resultPaneSpec
)
(VariableHorizontalPanelSpec
name: 'ListPane'
layout: (LayoutFrame 0 0 100 0 0 1 -30 1)
showHandle: true
snapMode: both
handlePosition: right
component:
(SpecCollection
collection: (
(NoteBookViewSpec
name: 'ClassOrPackageTab'
model: classCategoryOrPackageTabIndexHolder
menu: classCategoryOrPackageTabList
useIndex: true
fitLastRow: false
)
(TransparentBoxSpec
name: 'ClassListBox'
component:
(SpecCollection
collection: (
(SubCanvasSpec
name: 'ClassList'
layout: (LayoutFrame 0 0 25 0 0 1 0 1)
hasHorizontalScrollBar: false
hasVerticalScrollBar: false
clientKey: classList
createNewBuilder: false
)
)
)
)
(NoteBookViewSpec
name: 'NoteBook2'
menu: resultAndHistoryTabList
)
)
)
handles: (Any 0.33333333333333 0.66666666666667 1.0)
)
(UISubSpecification
name: 'ButtonPane'
layout: (LayoutFrame 0 0 -30 1 0 1 0 1)
minorKey: buttonPaneSpec
)
)
)
)
!
windowSpec_old
"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:Tools::TestRunner2 andSelector:#windowSpec
Tools::TestRunner2 new openInterface:#windowSpec
Tools::TestRunner2 open
"
<resource: #canvas>
^
#(FullSpec
name: windowSpec
window:
(WindowSpec
label: 'Test Runner Too'
name: 'Test Runner Too'
min: (Point 0 0)
bounds: (Rectangle 0 0 717 412)
icon: defaultIcon
)
component:
(SpecCollection
collection: (
(UISubSpecification
name: 'ResultPane'
layout: (LayoutFrame 0 0 0 0 0 1 100 0)
minorKey: resultPaneSpec
)
(VariableHorizontalPanelSpec
name: 'ListPane'
layout: (LayoutFrame 0 0 100 0 0 1 -30 1)
showHandle: true
snapMode: both
component:
(SpecCollection
collection: (
(NoteBookViewSpec
name: 'ClassOrPackageTab'
model: classCategoryOrPackageTabIndexHolder
menu: classCategoryOrPackageTabList
direction: left
useIndex: true
fitLastRow: false
)
(SubCanvasSpec
name: 'ClassList'
hasHorizontalScrollBar: false
hasVerticalScrollBar: false
clientKey: classList
createNewBuilder: false
)
(VariableVerticalPanelSpec
name: 'VariableVerticalPanel1'
component:
(SpecCollection
collection: (
(SequenceViewSpec
name: 'FailuresList'
model: failureSelectionHolder
hasHorizontalScrollBar: true
hasVerticalScrollBar: true
doubleClickSelector: debugFailure:
useIndex: false
sequenceList: failureListHolder
)
(SequenceViewSpec
name: 'ErrorsList'
model: errorSelectionHolder
hasHorizontalScrollBar: true
hasVerticalScrollBar: true
doubleClickSelector: debugError:
useIndex: false
sequenceList: errorListHolder
)
)
)
handles: (Any 0.5 1.0)
)
)
)
handles: (Any 0.33333333333333 0.66666666666667 1.0)
)
(UISubSpecification
name: 'ButtonPane'
layout: (LayoutFrame 0 0 -30 1 0 1 0 1)
minorKey: buttonPaneSpec
)
)
)
)
"Created: / 07-02-2010 / 14:48:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunner2 class methodsFor:'list specs'!
classCategoryOrPackageTabList
"This resource specification was automatically generated
by the TabListEditor of ST/X."
"Do not manually edit this!! If it is corrupted,
the TabListEditor may not be able to read the specification."
"
TabListEditor new openOnClass: self andSelector:#classCategoryOrPackageTabList
"
<resource: #tabList>
^ #(
(TabItem
label: 'Categories'
minorKey: classCategoryListSpec
createNewBuilder: false
)
(TabItem
label: 'Packages'
minorKey: packageListSpec
createNewBuilder: false
)
)
collect:[:aTab| TabItem new fromLiteralArrayEncoding:aTab ]
"Modified: / 05-06-2008 / 00:15:05 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
resultAndHistoryTabList
"This resource specification was automatically generated
by the TabListEditor of ST/X."
"Do not manually edit this!! If it is corrupted,
the TabListEditor may not be able to read the specification."
"
TabListEditor new openOnClass: self andSelector:#resultAndHistoryTabList
"
<resource: #tabList>
^ #(
(TabItem
label: 'Result'
minorKey: testResultTabSpec
createNewBuilder: false
)
(TabItem
label: 'History'
minorKey: testHistoryTabSpec
createNewBuilder: false
)
)
collect:[:aTab| TabItem new fromLiteralArrayEncoding:aTab ]
! !
!TestRunner2 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:Tools::TestRunner2 andSelector:#mainMenu
(Menu new fromLiteralArrayEncoding:(Tools::TestRunner2 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: conditionalRight
submenu:
(Menu
(
(MenuItem
label: 'Documentation'
itemValue: openDocumentation
translateLabel: true
)
(MenuItem
label: '-'
)
(MenuItem
label: 'About this Application...'
itemValue: openAboutThisApplication
translateLabel: true
)
)
nil
nil
)
)
)
nil
nil
)
!
packageListMenu
"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:Tools::TestRunner2 andSelector:#packageListMenu
(Menu new fromLiteralArrayEncoding:(Tools::TestRunner2 packageListMenu)) startUp
"
<resource: #menu>
^
#(Menu
(
(MenuItem
label: 'Select prerequisites'
itemValue: packageListMenuSelectPrerequisites
translateLabel: true
)
(MenuItem
label: 'Select prerequisites (recursive)'
itemValue: packageListMenuSelectPrerequisitesAll
translateLabel: true
)
(MenuItem
label: 'Select dependents'
itemValue: packageListMenuSelectDependents
translateLabel: true
)
(MenuItem
label: 'Select dependents (recursively)'
itemValue: packageListMenuSelectDependentsAll
translateLabel: true
)
)
nil
nil
)
"Modified: / 06-06-2008 / 20:04:49 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!TestRunner2 methodsFor:'accessing'!
errorColor
^ self class
errorColor
"Modified: / 08-02-2010 / 13:57:26 / Jan Vrany <jan,vrany@fit.cvut.cz>"
!
errorTestSuite
| testSuite |
testSuite := TestSuite new.
errorListHolder value do:
[:test|
testSuite addTest: test].
^testSuite
"Created: / 06-06-2008 / 09:08:40 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
failedColor
^ self class failedColor
!
failureTestSuite
| testSuite |
testSuite := TestSuite new.
failureListHolder value do:
[:test|
testSuite addTest: test].
^testSuite
"Created: / 06-06-2008 / 09:03:55 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
passedColor
^ self class passedColor
!
selectedPackages: packages
self packageList selectedProjects value: packages.
"/self packageList updateTreeSelection.
"Created: / 06-06-2008 / 20:02:46 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
selectedTestCases
| testCases |
testCases := self classList selectionHolder value.
testCases isNilOrEmptyCollection ifTrue:
[testCases := self classList listOfClasses].
^testCases reject:[:cls|cls isAbstract]
"Created: / 05-06-2008 / 22:02:24 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 27-11-2008 / 17:16:52 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
selectedTestSuite
|testCases testSuite|
testCases := self selectedTestCases.
testSuite := TestSuite named:(self suiteNameFromClasses:testCases).
testCases
do:[:testCaseCls | testSuite addTests:((self buildSuiteFromClass:testCaseCls) tests) ].
^ testSuite
"Created: / 05-06-2008 / 22:13:25 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 06-06-2008 / 19:28:29 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 19-03-2010 / 08:06:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
theSingleSelectedProject
| selection |
selection := self packageList selectionHolder value.
^selection size = 1
ifTrue:[selection anyOne]
ifFalse:[nil]
"Created: / 06-06-2008 / 20:08:07 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
theSingleSelectedProjectDefinition
|package|
package := self theSingleSelectedProject.
package ifNil:[^nil].
^Smalltalk at:(ProjectDefinition initialClassNameForDefinitionOf:package) asSymbol
"Created: / 06-06-2008 / 20:08:41 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!TestRunner2 methodsFor:'accessing - lists'!
allTestCategories
| categories |
categories := Set new.
Smalltalk allClassesDo:
[:cls|
(self isTestCaseLike: cls) ifTrue:
[categories add: cls category]].
^categories
"Modified: / 28-02-2011 / 21:25:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
allTestPackages
| packages |
packages := Set new.
Smalltalk allClassesDo:
[:cls|
(self isTestCaseLike: cls) ifTrue:
[packages add: cls package]].
^packages
"Modified: / 28-02-2011 / 21:25:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
classCategoryList
classCategoryList ifNil:
[ classCategoryList := Tools::ClassCategoryList new.
classCategoryList inGeneratorHolder:self allTestCategories asSet asValue.
classCategoryList outGeneratorHolder:self classListOutGeneratorHolder.
classCategoryList doubleClickChannel:
[:category |
self classList selectionHolder value:#().
self runSelectedAction ] ].
^ classCategoryList
"Created: / 04-06-2008 / 23:56:03 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 06-06-2008 / 09:51:42 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 01-02-2010 / 09:48:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
classList
classList ifNil:
[classList := Tools::TestRunner2::ClassList new.
classList immediateUpdate: true.
classList inGeneratorHolder: self classListInGeneratorHolder.
classList doubleClickChannel:[:testCase|self runSelectedAction]].
^classList
"Created: / 05-06-2008 / 19:28:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 27-11-2008 / 17:22:30 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 09-01-2010 / 20:30:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
packageList
packageList ifNil:
[ packageList := Tools::ProjectList new.
packageList
inGeneratorHolder:(Iterator
on:[:whatToDo | self allTestPackages do:[:p | whatToDo value:p ]])
asValue.
packageList outGeneratorHolder:self classListOutGeneratorHolder.
packageList doubleClickChannel:
[:category |
self classList selectionHolder value:#().
self runSelectedAction ].
packageList menuHolder:[ self menuFor:#packageListMenu ] ].
^ packageList
"Created: / 05-06-2008 / 00:12:54 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 19-08-2009 / 08:46:43 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 28-02-2011 / 21:13:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunner2 methodsFor:'accessing - menus'!
packageListMenu
^self class packageListMenu
"Created: / 06-06-2008 / 19:16:28 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!TestRunner2 methodsFor:'actions'!
debugError: test
| caughtEx |
caughtEx := nil.
[
test debug
] on: GenericException do:[:ex|
caughtEx := ex.
ex pass
].
caughtEx ifNil:
[errorListHolder value remove: test.
errorListHolder changed].
((caughtEx isKindOf: TestResult resumableFailure)
or:[caughtEx isKindOf: TestResult failure]) ifTrue:
[errorListHolder value remove: test.
errorListHolder changed.
failureListHolder value add: test.
failureListHolder changed].
"Created: / 06-06-2008 / 09:19:53 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
debugFailure: test
| caughtEx |
caughtEx := nil.
[
test debug
] on: GenericException do:[:ex|
caughtEx := ex.
ex pass
].
caughtEx ifNil:
[failureListHolder value remove: test.
failureListHolder changed].
"Created: / 06-06-2008 / 09:20:00 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
runErrorsAction
"akce na tlacitku Run Errors"
self runSuite: self errorTestSuite keepFailures: true keepErrors: false
"Modified: / 18-01-2008 / 18:38:33 / janfrog"
"Modified: / 06-06-2008 / 09:13:30 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
runFailuresAction
"akce na tlacitku Run Failures"
self runSuite: self failureTestSuite keepFailures: false keepErrors: true
"Modified: / 18-01-2008 / 18:38:40 / janfrog"
"Modified: / 06-06-2008 / 09:13:57 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
runProfiledAction
"akce na tlacitku Run Profiled"
self shouldImplement.
!
runSelectedAction
| result |
result := self runSuite: self selectedTestSuite.
History add: result.
"Modified: / 18-01-2008 / 18:38:08 / janfrog"
"Modified: / 06-06-2008 / 08:51:42 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 19-03-2010 / 08:44:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
runSuite: aTestSuite
^self runSuite: aTestSuite keepFailures: false keepErrors: false
"Modified: / 18-01-2008 / 18:38:08 / janfrog"
"Modified: / 06-06-2008 / 09:12:17 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 19-03-2010 / 08:44:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
runSuite: aTestSuite keepFailures: keepFailures keepErrors: keepErrors
| testResult testCases |
testResult := TestResult new.
testCases := Set new.
aTestSuite
run: testResult
beforeEachDo:
[:test :result|
self displayRunning: result test: test total: aTestSuite tests size]
afterEachDo:
[:test :result|
testCases add: test class name].
testCases do:
[:clsName| | cls |
(cls := Smalltalk classNamed:clsName) notNil ifTrue:
[cls rememberFailedTestRunWithResult:testResult]].
self displayResult: testResult keepFailures: keepFailures keepErrors: keepErrors.
^testResult
"Modified: / 18-01-2008 / 18:38:08 / janfrog"
"Created: / 06-06-2008 / 09:11:57 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 06-06-2008 / 19:40:53 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 19-03-2010 / 08:44:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunner2 methodsFor:'actions - menu'!
packageListMenuSelectDependents
|prjDef|
prjDef := self theSingleSelectedProjectDefinition.
prjDef ifNil:[^self].
self selectedPackages:
(prjDef dependentProjects copy add: prjDef package; yourself)
"Created: / 06-06-2008 / 20:12:02 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
packageListMenuSelectDependentsAll
|prjDef|
prjDef := self theSingleSelectedProjectDefinition.
prjDef ifNil:[^self].
self selectedPackages:
(prjDef allDependentProjects copy add: prjDef package; yourself)
"Created: / 06-06-2008 / 20:12:11 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
packageListMenuSelectPrerequisites
|prjDef|
prjDef := self theSingleSelectedProjectDefinition.
prjDef ifNil:[^self].
self selectedPackages:
(prjDef preRequisites copy add: prjDef package; yourself)
"Created: / 06-06-2008 / 20:06:47 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
packageListMenuSelectPrerequisitesAll
|prjDef|
prjDef := self theSingleSelectedProjectDefinition.
prjDef ifNil:[^self].
self selectedPackages:
(prjDef allPreRequisites copy add: prjDef package; yourself)
"Created: / 06-06-2008 / 20:11:22 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!TestRunner2 methodsFor:'aspects'!
classCategoryOrPackageTabIndexHolder
classCategoryOrPackageTabIndexHolder ifNil:
[classCategoryOrPackageTabIndexHolder := nil asValue.
classCategoryOrPackageTabIndexHolder onChangeEvaluate:
[classCategoryOrPackageTabIndexHolder value = 1
ifTrue:[self classCategoryList selectionChanged].
classCategoryOrPackageTabIndexHolder value = 2
ifTrue:[self packageList selectionChanged]]].
^classCategoryOrPackageTabIndexHolder
"Created: / 05-06-2008 / 21:59:14 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 06-06-2008 / 12:29:09 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
classCategoryOrPackageTabList
"Generated by the TabListEditor"
|list|
(list := builder bindingAt:#classCategoryOrPackageTabList) isNil ifTrue:[
builder aspectAt:#classCategoryOrPackageTabList put:(list := self class classCategoryOrPackageTabList).
].
^ list
"Created: / 05-06-2008 / 00:00:26 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
classListInGeneratorHolder
classListInGeneratorHolder ifNil:
[ classListInGeneratorHolder := BlockValue with:
[:gen |
|testCases|
testCases := OrderedCollection new:8.
gen do:[:cls | (self isTestCaseLike:cls) ifTrue:[ testCases add:cls ] ].
testCases ]
argument:self classListOutGeneratorHolder ].
^ classListInGeneratorHolder
"Created: / 01-02-2010 / 09:50:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
classListOutGeneratorHolder
classListOutGeneratorHolder ifNil:
[classListOutGeneratorHolder := ValueHolder with:#()].
^classListOutGeneratorHolder
"Created: / 01-02-2010 / 09:46:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
detailsHolder
"return/create the 'detailsHolder' value holder (automatically generated)"
detailsHolder isNil ifTrue:[
detailsHolder := ValueHolder new.
].
^ detailsHolder
"Created: / 18-01-2008 / 18:44:29 / janfrog"
!
errorListHolder
"return/create the 'errorListHolder' value holder (automatically generated)"
errorListHolder isNil ifTrue:[
errorListHolder := ValueHolder new.
].
^ errorListHolder
"Created: / 06-06-2008 / 08:55:43 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
errorSelectionHolder
"return/create the 'errorSelectionHolder' value holder (automatically generated)"
errorSelectionHolder isNil ifTrue:[
errorSelectionHolder := ValueHolder new.
].
^ errorSelectionHolder
"Created: / 06-06-2008 / 08:55:43 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
failureListHolder
"return/create the 'failureListHolder' value holder (automatically generated)"
failureListHolder isNil ifTrue:[
failureListHolder := ValueHolder new.
].
^ failureListHolder
"Created: / 06-06-2008 / 08:55:43 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
failureSelectionHolder
"return/create the 'failureSelectionHolder' value holder (automatically generated)"
failureSelectionHolder isNil ifTrue:[
failureSelectionHolder := ValueHolder new.
].
^ failureSelectionHolder
"Created: / 06-06-2008 / 08:55:43 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
hasErrorsAspect
^(AspectAdaptor forAspect:#notEmpty)
subjectChannel: self errorListHolder
"Created: / 06-06-2008 / 09:17:04 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
hasFailuresAspect
^(AspectAdaptor forAspect:#notEmpty)
subjectChannel: self failureListHolder
"Created: / 06-06-2008 / 09:17:14 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
hasTestCasesAspect
^(AspectAdaptor forAspect:#notEmpty)
subjectChannel: self classListInGeneratorHolder
"Created: / 06-06-2008 / 09:54:09 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 01-02-2010 / 09:53:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
historyHolder
"return/create the 'resultHolder' value holder (automatically generated)"
History ifNil:[self class initializeHistory].
^History
"Created: / 19-03-2010 / 08:43:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
modeHolder
"return/create the 'modeHolder' value holder (automatically generated)"
modeHolder isNil ifTrue:[
modeHolder := ValueHolder new.
].
^ modeHolder
"Created: / 18-01-2008 / 18:44:29 / janfrog"
!
resultAndHistoryTabList
"Generated by the TabListEditor"
|list|
(list := builder bindingAt:#resultAndHistoryTabList) isNil ifTrue:[
builder aspectAt:#resultAndHistoryTabList put:(list := self class resultAndHistoryTabList).
].
^ list
!
resultHolder
"return/create the 'resultHolder' value holder (automatically generated)"
resultHolder isNil ifTrue:[
resultHolder := ValueHolder new.
].
^ resultHolder
! !
!TestRunner2 methodsFor:'displaying'!
displayColor: aColorValue
(builder componentAt: #Mode) widget insideColor: aColorValue.
(builder componentAt: #Details) widget insideColor: aColorValue.
"Modified: / 02-04-2000 / 14:21:42 / Sames"
"Created: / 18-01-2008 / 20:22:39 / janfrog"
!
displayDetails: details
self detailsHolder value: details
"Modified: / 02-04-2000 / 14:21:42 / Sames"
"Created: / 18-01-2008 / 20:33:51 / janfrog"
!
displayFail:result
self displayColor:self errorColor.
self displayMode:'Fail'.
self displayDetails:result printString.
"Created: / 06-06-2008 / 08:49:25 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 07-02-2010 / 14:43:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
displayMode: mode
self modeHolder value: mode
"Modified: / 02-04-2000 / 14:21:42 / Sames"
"Created: / 18-01-2008 / 20:33:35 / janfrog"
!
displayPass:result
self displayColor:self passedColor.
self displayMode:'Pass '.
self
displayDetails:result printString , ' ' , (self timeSinceLastPassAsString)
!
displayResult: aTestResult
self displayResult: aTestResult keepFailures: false keepErrors: false.
"Modified: / 21-06-2000 / 12:14:52 / Sames"
"Created: / 06-06-2008 / 08:49:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 06-06-2008 / 19:24:47 / Jan Vrany <vranyj1@fel.cvut.cz>"
!
displayResult: aTestResult keepFailures: keepFailures keepErrors: keepErrors
self resultHolder value: (Array with: aTestResult).
aTestResult hasPassed
ifTrue:[self displayPass: aTestResult]
ifFalse:[self displayFail: aTestResult].
keepFailures ifFalse:
[failureListHolder value: (aTestResult failures
asSortedCollection:[:a :b|a printString < b printString])].
keepErrors ifFalse:
[errorListHolder value: (aTestResult errors
asSortedCollection:[:a :b|a printString < b printString])].
self repairDamage
"Modified: / 21-06-2000 / 12:14:52 / Sames"
"Created: / 06-06-2008 / 09:12:49 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 19-03-2010 / 08:33:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
displayRunning: result test: test total: total
self displayColor: (result hasPassed ifTrue:[Color yellow] ifFalse:[Color orange]).
self displayMode: 'Running ' , test printString.
self displayDetails: total printString , ' total, ' , result printString
"Modified: / 21-06-2000 / 12:14:52 / Sames"
"Created: / 06-06-2008 / 19:38:48 / Jan Vrany <vranyj1@fel.cvut.cz>"
! !
!TestRunner2 methodsFor:'hooks'!
commonPostOpen
self
displayMode:'SUnit Test Runner Tool';
displayDetails:'Select tests and press ''Run Selected'''.
self classCategoryOrPackageTabIndexHolder value:2
"Created: / 05-06-2008 / 21:58:09 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 08-06-2008 / 10:06:57 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 30-06-2011 / 20:20:40 / cg"
! !
!TestRunner2 methodsFor:'private'!
buildSuiteFromClass: testCaseCls
"Bit hackish, but no time to redesign sUnit from
scratch"
^ testCaseCls buildSuite.
"Modified: / 01-03-2011 / 22:53:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 30-05-2011 / 21:03:06 / Marcel Hlopko <hlopkmar@fel.cvut.cz>"
!
formatTime: aTime
aTime hours > 0 ifTrue: [^aTime hours printString , 'h'].
aTime minutes > 0 ifTrue: [^aTime minutes printString , 'min'].
^aTime seconds printString , ' sec'
"Created: / 18-01-2008 / 18:57:08 / janfrog"
!
isTestCaseLike:cls
^cls isTestCaseLike
"Modified: / 28-02-2011 / 21:31:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
repairDamage
|wg|
(wg := self windowGroup) notNil ifTrue:[wg repairDamage].
"Created: / 18-01-2008 / 18:45:39 / janfrog"
!
timeSinceLastPassAsString
lastPass isNil ifTrue: [^''].
^', ' , (self formatTime: (Time now subtractTime: lastPass getSeconds)) , ' since last Pass'
"Modified: / 03-04-2000 / 19:17:11 / Sames"
"Created: / 18-01-2008 / 18:51:21 / janfrog"
! !
!TestRunner2::ClassList class methodsFor:'documentation'!
version
^'$Id: Tools__TestRunner2.st,v 1.1 2011-06-30 19:51:51 cg Exp $'
! !
!TestRunner2::ClassList methodsFor:'private'!
nameListEntryFor:aClass withNameSpace:useFullName
| nm |
nm := super nameListEntryFor:aClass withNameSpace:useFullName.
(aClass isTestCaseLike) ifFalse:
[self breakPoint: #jv.
^nm].
aClass isAbstract ifTrue:[nm := nm colorizeAllWith:Color gray].
^nm
"Created: / 27-11-2008 / 17:24:18 / Jan Vrany <vranyj1@fel.cvut.cz>"
"Modified: / 28-02-2011 / 21:42:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunner2::ResultList 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:Tools::TestRunner2::ResultList andSelector:#windowSpec
Tools::TestRunner2::ResultList new openInterface:#windowSpec
Tools::TestRunner2::ResultList open
"
<resource: #canvas>
^
#(FullSpec
name: windowSpec
window:
(WindowSpec
label: 'Test Result List'
name: 'Test Result List'
min: (Point 10 10)
bounds: (Rectangle 0 0 300 300)
)
component:
(SpecCollection
collection: (
(HierarchicalListViewSpec
name: 'List'
layout: (LayoutFrame 0 0 0 0 0 1 0 1)
model: selectionHolder
hasHorizontalScrollBar: true
hasVerticalScrollBar: true
listModel: listHolder
useIndex: false
highlightMode: line
doubleClickSelector: debugTest:
showLines: false
useDefaultIcons: false
)
)
)
)
"Modified: / 08-02-2010 / 10:08:09 / Jan Vrany <jan,vrany@fit.cvut.cz>"
! !
!TestRunner2::ResultList class methodsFor:'plugIn spec'!
aspectSelectors
"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."
"Return a description of exported aspects;
these can be connected to aspects of an embedding application
(if this app is embedded in a subCanvas)."
^ #(
#resultsHolder
#selectionHolder
).
"Modified: / 19-03-2010 / 08:32:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunner2::ResultList methodsFor:'actions'!
debugTest:entryIndex
|entry test caughtEx|
test := (entry := listHolder value at:entryIndex) test.
test ifNil:[ ^ self ].
[
caughtEx := nil.
[test debug] on:GenericException do:[:ex | caughtEx := ex. ex pass].
caughtEx
ifNil:
[self setResult: #passed in: entry]
ifNotNil:
[((caughtEx isKindOf:TestResult resumableFailure)
or:[ caughtEx isKindOf:TestResult failure ])
ifTrue:
[self setResult: #failed in: entry]
ifFalse:
[self setResult: #error in: entry]].
] fork
"Modified: / 07-02-2010 / 18:59:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Created: / 08-02-2010 / 10:08:30 / Jan Vrany <jan,vrany@fit.cvut.cz>"
! !
!TestRunner2::ResultList methodsFor:'aspects'!
listHolder
"return/create the 'listHolder' value holder (automatically generated)"
listHolder isNil ifTrue:[
listHolder := ValueHolder new.
].
^ listHolder
!
resultsHolder
"return/create the 'resultHolder' value holder (automatically generated)"
resultsHolder isNil ifTrue:[
resultsHolder := ValueHolder new.
resultsHolder addDependent:self.
].
^ resultsHolder
"Created: / 19-03-2010 / 08:31:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
resultsHolder:aValueModel
"set the 'resultHolder' value holder (automatically generated)"
|oldValue newValue|
resultsHolder notNil ifTrue:[
oldValue := resultsHolder value.
resultsHolder removeDependent:self.
].
resultsHolder := aValueModel.
resultsHolder notNil ifTrue:[
resultsHolder addDependent:self.
].
newValue := resultsHolder value.
oldValue ~~ newValue ifTrue:[
self update:#value with:newValue from:resultsHolder.
].
"Created: / 19-03-2010 / 08:32:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
selectiomHolder
"return/create the 'selectiomHolder' value holder (automatically generated)"
selectiomHolder isNil ifTrue:[
selectiomHolder := ValueHolder new.
].
^ selectiomHolder
!
selectiomHolder:something
"set the 'selectiomHolder' value holder (automatically generated)"
selectiomHolder := something.
! !
!TestRunner2::ResultList methodsFor:'change & update'!
update:aspect with:param from:sender
sender == resultsHolder ifTrue:
[results := self resultsHolder value.
self updateTimestampFormat.
self updateList.
^self].
super update:aspect with:param from:sender
"Modified: / 19-03-2010 / 08:50:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
updateList
| list |
list := HierarchicalList new.
list root: self makeRootEntry.
list showRoot: false.
self listHolder value: list.
"Created: / 07-02-2010 / 11:03:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 07-02-2010 / 13:41:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
updateTimestampFormat
(results isNilOrEmptyCollection or:[results size = 1])
ifTrue:[timestampFormat := nil].
((results collect:[:each|each timestamp]) asSet size = 1)
ifTrue: [timestampFormat := ' (%h:%m)']
ifFalse:[timestampFormat := ' (%(month)-%(day) %h:%m)']
"Created: / 19-03-2010 / 08:50:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 12-09-2010 / 09:50:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunner2::ResultList methodsFor:'private'!
invalidate
^(self componentAt: #List) scrolledView redraw
"Created: / 07-02-2010 / 18:57:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
setResult: testResult in: entry
entry result ~= testResult ifTrue:
[entry result: testResult.
self invalidate].
"Created: / 08-02-2010 / 10:28:53 / Jan Vrany <jan,vrany@fit.cvut.cz>"
! !
!TestRunner2::ResultList methodsFor:'private-list'!
makeClassEntryFor: class result: result tests: tests
| entry children |
entry := ListEntry labeled: class name.
children := (tests asSortedCollection: [:a :b|a selector < b selector])
collect:[:test|self makeTestEntryFor: test result: result].
entry setChildren: children.
(entry result ~= #passed and:[results size = 1]) ifTrue:[entry expand].
^entry
"Created: / 19-03-2010 / 08:41:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
makeResultEntryFor: result
| entry children classes label |
label := result name.
result timestamp ifNotNil:
[label := label , (result timestamp printStringFormat: timestampFormat)].
entry := ListEntry labeled: label.
classes := Dictionary new.
result tests do:
[:test|
(classes at: test class ifAbsentPut:[OrderedCollection new:1])
add: test].
children := classes keysAndValuesCollect:
[:class :tests|
self makeClassEntryFor: class result: result tests: tests].
entry setChildren: children.
^entry.
"Created: / 19-03-2010 / 08:36:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
makeRootEntry
| entry children |
entry := ListEntry labeled: 'Test Results'.
results isNilOrEmptyCollection ifTrue:[^entry].
children := results size = 1
ifTrue:
[(self makeResultEntryFor: results anyOne) getChildren]
ifFalse:
[results collect:[:result|self makeResultEntryFor:result]].
entry setChildren: children.
^entry.
"Created: / 07-02-2010 / 13:39:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 19-03-2010 / 08:39:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
makeTestEntryFor: test result: result
| entry |
entry := ListEntry labeled: test selector.
entry test: test.
(result errors includes: test)
ifTrue:
[entry result: #error]
ifFalse:
[(result failures includes: test)
ifTrue:
[entry result: #failed]
ifFalse:
[entry result: #passed]].
^entry
"Created: / 19-03-2010 / 08:41:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunner2::ResultList::ListEntry class methodsFor:'initialization'!
initialize
"Invoked at system start or when the class is dynamically loaded."
"/ please change as required (and remove this comment)
PassedText := ' [passed]' asText colorizeAllWith: Tools::TestRunner2 passedColor darker.
FailedText := ' [failed]' asText colorizeAllWith: Tools::TestRunner2 failedColor darker.
ErrorText := ' [error]' asText colorizeAllWith: Tools::TestRunner2 errorColor darker.
"Modified: / 07-02-2010 / 15:06:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunner2::ResultList::ListEntry class methodsFor:'instance creation'!
labeled: aStringOrText
^self new label: aStringOrText
"Created: / 07-02-2010 / 13:31:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunner2::ResultList::ListEntry methodsFor:'accessing'!
icon
^self result == #passed
ifTrue:[SystemBrowser greenThumbUpSmallIcon]
ifFalse:[SystemBrowser redThumbDownSmallIcon]
"Created: / 07-02-2010 / 18:34:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
label
| result |
result := self result.
realLabel ifNil:
[realLabel := label.
test ifNotNil:[
result == #passed ifTrue:[realLabel := realLabel , PassedText].
result == #error ifTrue:[realLabel := realLabel , ErrorText].
result == #failed ifTrue:[realLabel := realLabel , FailedText].
] ifNil: [
realLabel := realLabel , self summary.
]
].
^ realLabel
"Modified: / 07-02-2010 / 18:28:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 08-02-2010 / 10:15:35 / Jan Vrany <jan,vrany@fit.cvut.cz>"
!
label:aText
label := aText.
realLabel := nil.
"Modified: / 07-02-2010 / 14:36:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
result
result ifNil:
[result := self computeResult].
^ result
"Modified: / 07-02-2010 / 18:30:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
result:aSymbol
result := aSymbol.
self reset.
result := aSymbol.
"Modified: / 07-02-2010 / 18:55:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
test
^ test
!
test:aTestCase
test := aTestCase.
! !
!TestRunner2::ResultList::ListEntry methodsFor:'enumeration'!
leafsDo: aBlock
self isLeafEntry ifTrue:[^aBlock value: self].
children do:[:each|each leafsDo: aBlock]
"Created: / 08-02-2010 / 10:17:32 / Jan Vrany <jan,vrany@fit.cvut.cz>"
!
testsDo: aBlock
test ifNotNil:[aBlock value: test].
children do:[:each|each testsDo: aBlock]
"Created: / 08-02-2010 / 10:10:36 / Jan Vrany <jan,vrany@fit.cvut.cz>"
! !
!TestRunner2::ResultList::ListEntry methodsFor:'initialization'!
reset
realLabel := result := nil.
(parent notNil and:[parent class == self class])
ifTrue:[parent reset]
"Created: / 07-02-2010 / 18:44:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
setChildren: aCollection
children := aCollection.
children do:[:e|e parent: self].
"Created: / 07-02-2010 / 11:41:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunner2::ResultList::ListEntry methodsFor:'private'!
computeResult
| result |
result := #passed.
(children ? #()) do:
[:entry|
entry result == #error ifTrue:[^#error].
entry result == #failed ifTrue:[result := #failed]].
^result
"Created: / 07-02-2010 / 18:30:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
summary
| passed failed error |
passed := failed := error := 0.
self leafsDo:
[:entry|
entry isPassed ifTrue:[passed := passed + 1].
entry isFailed ifTrue:[failed := failed + 1].
entry isError ifTrue:[error := error + 1]].
^' [ ' , passed printString , ' / ' , failed printString , ' / ', error printString , ' ]'
"Created: / 08-02-2010 / 10:16:52 / Jan Vrany <jan,vrany@fit.cvut.cz>"
! !
!TestRunner2::ResultList::ListEntry methodsFor:'testing'!
isError
^self result == #error
"Created: / 08-02-2010 / 10:18:26 / Jan Vrany <jan,vrany@fit.cvut.cz>"
!
isFailed
^self result == #failed
"Created: / 08-02-2010 / 10:18:21 / Jan Vrany <jan,vrany@fit.cvut.cz>"
!
isLeafEntry
^children isNilOrEmptyCollection
"Created: / 08-02-2010 / 10:11:06 / Jan Vrany <jan,vrany@fit.cvut.cz>"
!
isPassed
^self result == #passed
"Created: / 08-02-2010 / 10:18:15 / Jan Vrany <jan,vrany@fit.cvut.cz>"
! !
!TestRunner2 class methodsFor:'documentation'!
version_CVS
^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunner2.st,v 1.1 2011-06-30 19:51:51 cg Exp $'
!
version_SVN
^ '§Id: Tools__TestRunner2.st 7486 2009-10-26 22:06:24Z vranyj1 §'
! !
TestRunner2 initialize!