Smalltalk › Squeak › Squeak - Dev

Squeak 4.6: SUnitGUI-mt.62.mcz

_‹ Previous Topic Next Topic _›

Classic

List

Threaded

1 message

commits-2

Squeak 4.6: SUnitGUI-mt.62.mcz

Chris Muller uploaded a new version of SUnitGUI to project Squeak 4.6:
http://source.squeak.org/squeak46/SUnitGUI-mt.62.mcz

==================== Summary ====================

Name: SUnitGUI-mt.62
Author: mt
Time: 10 May 2015, 12:18:33.708 pm
UUID: 23278a70-3219-2542-bdb0-1e42b35989a6
Ancestors: SUnitGUI-topa.61

Upper spacing of button bar in test runner fixed by removing some magic numbers.

==================== Snapshot ====================

SystemOrganization addCategory: #SUnitGUI!

ProtoObject subclass: #TestCoverage
instanceVariableNames: 'hasRun reference method'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnitGUI'!

----- Method: TestCoverage class>>on: (in category 'instance creation') -----
on: aMethodReference
^ self new initializeOn: aMethodReference!

----- Method: TestCoverage>>doesNotUnderstand: (in category 'private') -----
doesNotUnderstand: aMessage
^ method perform: aMessage selector withArguments: aMessage arguments!

----- Method: TestCoverage>>flushCache (in category 'private') -----
flushCache!

----- Method: TestCoverage>>hasRun (in category 'testing') -----
hasRun
^ hasRun!

----- Method: TestCoverage>>initializeOn: (in category 'initialization') -----
initializeOn: aMethodReference
hasRun := false.
reference := aMethodReference.
method := reference compiledMethod!

----- Method: TestCoverage>>install (in category 'actions') -----
install
reference actualClass methodDictionary
at: reference methodSymbol
put: self!

----- Method: TestCoverage>>mark (in category 'private') -----
mark
hasRun := true!

----- Method: TestCoverage>>reference (in category 'private') -----
reference
^ reference!

----- Method: TestCoverage>>run:with:in: (in category 'evaluation') -----
run: aSelector with: anArray in: aReceiver
self mark; uninstall.
^ aReceiver withArgs: anArray executeMethod: method!

----- Method: TestCoverage>>uninstall (in category 'actions') -----
uninstall
reference actualClass methodDictionary
at: reference methodSymbol
put: method!

----- Method: TestCase class>>packageNamesUnderTest (in category '*sunitgui') -----
packageNamesUnderTest
"Answer a collection of package names under test. This is used by the test runner to automatically instrument the code in these packages when checking for test coverage."

^ #()!

Object subclass: #TestRunner
instanceVariableNames: 'categories categoriesSelected classes classIndex classesSelected failedList failedSelected errorList errorSelected lastUpdate result previousRun categoryPattern classPattern'
classVariableNames: ''
poolDictionaries: ''
category: 'SUnitGUI'!

!TestRunner commentStamp: '<historical>' prior: 0!
<lint: #ignore rule: #classNotReferenced rational: 'this view is only accessed from menus'>

!

----- Method: TestRunner class>>build (in category 'instance-creation') -----
build
^ ToolBuilder build: self new.!

----- Method: TestRunner class>>initialize (in category 'initialization') -----
initialize
self registerInWorldMenu; registerInToolsFlap.!

----- Method: TestRunner class>>open (in category 'instance-creation') -----
open
^ ToolBuilder open: self new.!

----- Method: TestRunner class>>registerInToolsFlap (in category 'initialization') -----
registerInToolsFlap
self environment at: #Flaps ifPresent: [ :class |
class
registerQuad: #( TestRunner build 'SUnit Runner' 'A production scale test-runner.' ) forFlapNamed: 'Tools';
replaceToolsFlap ].!

----- Method: TestRunner class>>registerInWorldMenu (in category 'initialization') -----
registerInWorldMenu
self environment at: #TheWorldMenu ifPresent: [ :class |
class registerOpenCommand: (Array
with: 'Test Runner'
with: (Array
with: self
with: #open)) ].!

----- Method: TestRunner class>>windowColorSpecification (in category 'window color') -----
windowColorSpecification

^ WindowColorSpec
classSymbol: self name
wording: 'Test Runner'
brightColor: Color orange
pastelColor: (Color r: 0.65 g: 0.753 b: 0.976)
helpMessage: 'The Camp Smalltalk TestRunner tool for SUnit'!

----- Method: TestRunner>>addDeclaredPackagesUnderTestTo: (in category 'actions') -----
addDeclaredPackagesUnderTestTo: packages
classesSelected do:
[ :class |
(class class includesSelector: #packageNamesUnderTest) ifTrue:
[ class packageNamesUnderTest do: [ :name | packages add: (PackageInfo named: name) ] ] ]!

----- Method: TestRunner>>addMethodsUnderTestIn:to: (in category 'actions') -----
addMethodsUnderTestIn: packages to: methods
packages
do: [:package | package isNil
ifFalse: [package methods
do: [:method | ((#(#packageNamesUnderTest #classNamesNotUnderTest ) includes: method methodSymbol)
or: [method compiledMethod isAbstract
or: [method compiledMethod refersToLiteral: #ignoreForCoverage]])
ifFalse: [methods add: method]]]]!

----- Method: TestRunner>>baseClass (in category 'accessing') -----
baseClass
^ TestCase!

----- Method: TestRunner>>basicRunSuite:do: (in category 'processing') -----
basicRunSuite: aTestSuite do: aBlock

self basicSetUpSuite: aTestSuite.
[
| prefix |
prefix := aTestSuite name isEmptyOrNil
ifTrue: [ '' ]
ifFalse: [ aTestSuite name, ' - ' ].
aTestSuite tests
do: aBlock
displayingProgress: [ :test | prefix, test printString ]
every: 0 "Update the label for all tests" ]
ensure: [ self basicTearDownSuite: aTestSuite ].
!

----- Method: TestRunner>>basicSetUpSuite: (in category 'processing') -----
basicSetUpSuite: aTestSuite
aTestSuite resources do: [ :each |
each isAvailable
ifFalse: [ each signalInitializationError ] ].!

----- Method: TestRunner>>basicTearDownSuite: (in category 'processing') -----
basicTearDownSuite: aTestSuite
aTestSuite resources do: [ :each | each reset ].!

----- Method: TestRunner>>browseClass (in category 'accessing-classes') -----
browseClass
(classes at: classIndex ifAbsent: [ ^ self ]) browse!

----- Method: TestRunner>>browserEnvironment (in category 'private') -----
browserEnvironment
^ Smalltalk classNamed: #BrowserEnvironment.!

----- Method: TestRunner>>buildButtonsWith: (in category 'building') -----
buildButtonsWith: aBuilder
^ aBuilder pluggablePanelSpec new
model: self;
layout: #horizontal;
children: (self buttons collect: [ :each |
aBuilder pluggableButtonSpec new
model: self;
label: each first;
action: each second;
enabled: each third;
yourself ]);
yourself.!

----- Method: TestRunner>>buildCategoriesWith: (in category 'building') -----
buildCategoriesWith: aBuilder
^ aBuilder pluggableMultiSelectionListSpec new
model: self;
list: #categoryList;
menu: #categoryMenu:;
getIndex: #categorySelected;
setIndex: #categorySelected:;
getSelectionList: #categoryAt:;
setSelectionList: #categoryAt:put:;
yourself.!

----- Method: TestRunner>>buildClassesWith: (in category 'building') -----
buildClassesWith: aBuilder
^ aBuilder pluggableMultiSelectionListSpec new
model: self;
list: #classList;
menu: #classMenu:;
getIndex: #classSelected;
setIndex: #classSelected:;
getSelectionList: #classAt:;
setSelectionList: #classAt:put:;
yourself.!

----- Method: TestRunner>>buildErrorListWith: (in category 'building') -----
buildErrorListWith: aBuilder
^ aBuilder pluggableListSpec new
model: self;
name: 'Error List';
list: #errorList;
menu: #errorMenu:;
getIndex: #errorSelected;
setIndex: #errorSelected:;
yourself.!

----- Method: TestRunner>>buildFailureListWith: (in category 'building') -----
buildFailureListWith: aBuilder
^ aBuilder pluggableListSpec new
model: self;
name: 'Failure List';
list: #failedList;
menu: #failureMenu:;
getIndex: #failedSelected;
setIndex: #failedSelected:;
yourself.!

----- Method: TestRunner>>buildStatusWith: (in category 'building') -----
buildStatusWith: aBuilder
^ aBuilder pluggableTextSpec new
model: self;
menu: #statusMenu:;
color: #statusColor;
getText: #statusText;
yourself.!

----- Method: TestRunner>>buildWith: (in category 'building') -----
buildWith: aBuilder
| window |
window := aBuilder pluggableWindowSpec new
model: self; label: self label; extent: self extent;
children: (OrderedCollection new
add: ((self buildCategoriesWith: aBuilder)
frame: self categoriesFrame;
yourself);
add: ((self buildClassesWith: aBuilder)
frame: self classesFrame;
yourself);
add: ((self buildStatusWith: aBuilder)
frame: self statusFrame;
yourself);
add: ((self buildFailureListWith: aBuilder)
frame: self failureListFrame;
yourself);
add: ((self buildErrorListWith: aBuilder)
frame: self errorListFrame;
yourself);
add: ((self buildButtonsWith: aBuilder)
frame: self buttonsFrame;
yourself);
yourself);
yourself.
^ aBuilder build: window.!

----- Method: TestRunner>>buttonHeight (in category 'building') -----
buttonHeight
^ Preferences standardButtonFont height * 3!

----- Method: TestRunner>>buttons (in category 'accessing-ui') -----
buttons
^ #(( 'Run Selected' #runAll #hasRunnable )
( 'Run Profiled' #runProfiled #hasRunnable )
( 'Run Coverage' #runCoverage #hasRunnable )
( 'Run Failures' #runFailures #hasFailures )
( 'Run Errors' #runErrors #hasErrors ))!

----- Method: TestRunner>>buttonsFrame (in category 'building') -----
buttonsFrame
^LayoutFrame new
leftFraction: 0 offset: 0;
topFraction: 1 offset: self buttonHeight negated;
rightFraction: 1 offset: 0;
bottomFraction: 1 offset: 0!

----- Method: TestRunner>>categoriesFrame (in category 'building') -----
categoriesFrame
^LayoutFrame new
leftFraction: 0 offset: 0;
topFraction: 0 offset: 0;
rightFraction: 0.25 offset: 0;
bottomFraction: 1 offset: self buttonHeight negated!

----- Method: TestRunner>>categoryAt: (in category 'accessing-categories') -----
categoryAt: anIndex
^ categoriesSelected includes: (categories at: anIndex ifAbsent: [ ^ false ]).!

----- Method: TestRunner>>categoryAt:put: (in category 'accessing-categories') -----
categoryAt: anInteger put: aBoolean
categoriesSelected := categoriesSelected
perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ])
with: (categories at: anInteger ifAbsent: [ ^ self ]).
self changed: #categorySelected; updateClasses.!

----- Method: TestRunner>>categoryList (in category 'accessing-categories') -----
categoryList
^ categories!

----- Method: TestRunner>>categoryMenu: (in category 'accessing-categories') -----
categoryMenu: aMenu
^ aMenu
title: 'Categories';
add: 'Select all' action: #selectAllCategories;
add: 'Select inversion' action: #selectInverseCategories;
add: 'Select none' action: #selectNoCategories;
addLine;
add: 'Filter...' action: #filterCategories;
addLine;
add: 'Refresh' action: #updateCategories;
yourself.!

----- Method: TestRunner>>categorySelected (in category 'accessing-categories') -----
categorySelected
^ 0!

----- Method: TestRunner>>categorySelected: (in category 'accessing-categories') -----
categorySelected: anInteger
self changed: #categorySelected.!

----- Method: TestRunner>>classAt: (in category 'accessing-classes') -----
classAt: anInteger
^ classesSelected includes: (classes at: anInteger ifAbsent: [ ^ false ]).!

----- Method: TestRunner>>classAt:put: (in category 'accessing-classes') -----
classAt: anInteger put: aBoolean
classesSelected := classesSelected
perform: (aBoolean ifTrue: [ #copyWith: ] ifFalse: [ #copyWithout: ])
with: (classes at: anInteger ifAbsent: [ ^ self ]).
self changed: #classSelected; changed: #hasRunnable.!

----- Method: TestRunner>>classList (in category 'accessing-classes') -----
classList
| offset |
classes isEmpty ifTrue: [ ^ classes ].
offset := classes first allSuperclasses size.
^ classes collect: [ :each | | ident |
ident := String
new: 2 * (0 max: each allSuperclasses size - offset)
withAll: $ .
each isAbstract
ifFalse: [ ident , each name ]
ifTrue: [
ident asText , each name asText
addAttribute: TextEmphasis italic;
yourself ] ].!

----- Method: TestRunner>>classMenu: (in category 'accessing-classes') -----
classMenu: aMenu
^ aMenu
title: 'Classes';
add: 'Browse' action: #browseClass;
addLine;
add: 'Select all' action: #selectAllClasses;
add: 'Select subclasses' action: #selectSubclasses;
add: 'Select inversion' action: #selectInverseClasses;
add: 'Select none' action: #selectNoClasses;
addLine;
add: 'Filter...' action: #filterClasses;
addLine;
add: 'Refresh' action: #updateClasses;
yourself.!

----- Method: TestRunner>>classSelected (in category 'accessing-classes') -----
classSelected
^ classIndex!

----- Method: TestRunner>>classSelected: (in category 'accessing-classes') -----
classSelected: anInteger
classIndex := anInteger.
self changed: #classSelected!

----- Method: TestRunner>>classesFrame (in category 'building') -----
classesFrame
^LayoutFrame new
leftFraction: 0.25 offset: 0;
topFraction: 0 offset: 0;
rightFraction: 0.5 offset: 0;
bottomFraction: 1 offset: self buttonHeight negated!

----- Method: TestRunner>>classesSelected (in category 'accessing') -----
classesSelected
^ classesSelected!

----- Method: TestRunner>>collectCoverageFor: (in category 'actions') -----
collectCoverageFor: methods
| wrappers suite |
wrappers := methods collect: [ :each | TestCoverage on: each ].
suite := self
reset;
suiteAll.

[ wrappers do: [ :each | each install ].
[ self runSuite: suite ] ensure: [ wrappers do: [ :each | each uninstall ] ] ] valueUnpreemptively.
wrappers := wrappers reject: [ :each | each hasRun ].
wrappers isEmpty
ifTrue:
[ UIManager default inform: 'Congratulations. Your tests cover all code under analysis.' ]
ifFalse:
[ ToolSet
browseMessageSet: (wrappers collect: [ :each | each reference ])
name: 'Not Covered Code (' , (100 - (100 * wrappers size // methods size)) printString , '% Code Coverage)'
autoSelect: nil ].
self saveResultInHistory!

----- Method: TestRunner>>debug: (in category 'actions') -----
debug: aTestCase
self debugSuite: (TestSuite new
addTest: aTestCase;
yourself).!

----- Method: TestRunner>>debugSuite: (in category 'actions') -----
debugSuite: aTestSuite
self basicRunSuite: aTestSuite do: [ :each | each debug ].!

----- Method: TestRunner>>defaultBackgroundColor (in category 'private') -----
defaultBackgroundColor
"<lint: #expect rule: #overridesSuper rational: 'we want a different color than the parent'>"

^ Preferences testRunnerWindowColor!

----- Method: TestRunner>>errorList (in category 'accessing-testing') -----
errorList
^ errorList collect: [ :each | each printString ].!

----- Method: TestRunner>>errorListFrame (in category 'building') -----
errorListFrame
^LayoutFrame new
leftFraction: 0.5 offset: 0;
topFraction: 0.5 offset: 0;
rightFraction: 1 offset: 0;
bottomFraction: 1 offset: self buttonHeight negated!

----- Method: TestRunner>>errorMenu: (in category 'accessing-menu') -----
errorMenu: aMenu
^ self statusMenu: aMenu!

----- Method: TestRunner>>errorSelected (in category 'accessing-testing') -----
errorSelected
^ errorList indexOf: errorSelected.!

----- Method: TestRunner>>errorSelected: (in category 'accessing-testing') -----
errorSelected: anInteger
errorSelected := errorList at: anInteger ifAbsent: nil.
self changed: #errorSelected.
errorSelected ifNotNil: [ self debug: errorSelected ].!

----- Method: TestRunner>>excludeClassesNotUnderTestFrom: (in category 'actions') -----
excludeClassesNotUnderTestFrom: methods

classesSelected do:
[ :class |
(class class includesSelector: #classNamesNotUnderTest) ifTrue:
[ class classNamesNotUnderTest do:
[ :className | | theClass |
theClass := Smalltalk classNamed: className.
theClass ifNotNil:[
theClass methods do:
[ :each |
methods
remove: each methodReference
ifAbsent: [ ] ].
theClass class methods do:
[ :each |
methods
remove: each methodReference
ifAbsent: [ ] ]] ] ] ]!

----- Method: TestRunner>>extent (in category 'accessing-ui') -----
extent
^ 640 @ 480!

----- Method: TestRunner>>failedList (in category 'accessing-testing') -----
failedList
^ failedList collect: [ :each | each printString ].!

----- Method: TestRunner>>failedSelected (in category 'accessing-testing') -----
failedSelected
^ failedList indexOf: failedSelected.!

----- Method: TestRunner>>failedSelected: (in category 'accessing-testing') -----
failedSelected: anInteger
failedSelected := failedList at: anInteger ifAbsent: nil.
self changed: #failedSelected.
failedSelected ifNotNil: [ self debug: failedSelected ].!

----- Method: TestRunner>>failureListFrame (in category 'building') -----
failureListFrame
^LayoutFrame new
leftFraction: 0.5 offset: 0;
topFraction: 0 offset: self statusHeight;
rightFraction: 1 offset: 0;
bottomFraction: 0.5 offset: 0!

----- Method: TestRunner>>failureMenu: (in category 'accessing-menu') -----
failureMenu: aMenu
^ aMenu!

----- Method: TestRunner>>filterCategories (in category 'accessing-categories') -----
filterCategories
| pattern |
pattern := UIManager default
request: 'Pattern(s) to select categories:\ (separate patterns with '';'')' withCRs
initialAnswer: (categoryPattern ifNil: ['*']).
(pattern isNil or: [pattern isEmpty]) ifTrue:
[^self].
categoriesSelected := ((categoryPattern := pattern) subStrings: ';')
inject: Set new
into: [:matches :subPattern|
matches
addAll: (categories select: [ :each | subPattern match: each]);
yourself].
self changed: #allSelections; changed: #categorySelected; updateClasses!

----- Method: TestRunner>>filterClasses (in category 'accessing-classes') -----
filterClasses
| pattern |
pattern := UIManager default
request: 'Pattern(s) to select tests:\ (separate patterns with '';'')' withCRs
initialAnswer: (classPattern ifNil: '*').
(pattern isNil or: [pattern isEmpty]) ifTrue:
[^self].
classesSelected := ((classPattern := pattern) subStrings: ';')
inject: Set new
into: [:matches :subPattern|
matches
addAll: (classes select: [ :each | subPattern match: each name]);
yourself].
self
changed: #allSelections;
changed: #classSelected;
changed: #hasRunnable!

----- Method: TestRunner>>findCategories (in category 'utilities') -----
findCategories
| visible |
visible := Set new.
self baseClass withAllSubclassesDo: [ :each |
each category ifNotNil: [ :category |
visible add: category ] ].
^ Array streamContents: [ :stream |
Smalltalk organization categories do: [ :each |
(visible includes: each)
ifTrue: [ stream nextPut: each ] ] ].!

----- Method: TestRunner>>findClassesForCategories: (in category 'utilities') -----
findClassesForCategories: aCollection

| items |
aCollection isEmpty
ifTrue: [ ^ self baseClass withAllSubclasses asSet ].
items := aCollection gather: [ :category |
((Smalltalk organization listAtCategoryNamed: category)
collect: [ :each | Smalltalk at: each ])
select: [ :each | each includesBehavior: self baseClass ] ].
^ items asSet.!

----- Method: TestRunner>>hasErrors (in category 'testing') -----
hasErrors
^ result hasErrors.!

----- Method: TestRunner>>hasFailures (in category 'testing') -----
hasFailures
^ result hasFailures.!

----- Method: TestRunner>>hasHistory (in category 'history saving') -----
hasHistory

self flag: #Useless. "No Senders?"
^ true!

----- Method: TestRunner>>hasProgress (in category 'history saving') -----
hasProgress

result classesTested do: [:cls |
(cls class methodDictionary includesKey: #lastStoredRun)
ifTrue: [^ true]].
^ false!

----- Method: TestRunner>>hasResults (in category 'history saving') -----
hasResults

^ result notNil!

----- Method: TestRunner>>hasRunnable (in category 'testing') -----
hasRunnable
^ classesSelected notEmpty.!

----- Method: TestRunner>>historyMenuList (in category 'history saving') -----
historyMenuList
^ {'** save current result **'}, (self previousRun collect: [:ts | ts printString])!

----- Method: TestRunner>>initialize (in category 'initialization') -----
initialize
super initialize.
failedList := errorList := Array new.
SystemChangeNotifier uniqueInstance
notify: self ofSystemChangesOfItem: #class change: #Added using: #update;
notify: self ofSystemChangesOfItem: #category change: #Added using: #update;
notify: self ofSystemChangesOfItem: #class change: #Removed using: #update;
notify: self ofSystemChangesOfItem: #category change: #Removed using: #update;
notify: self ofSystemChangesOfItem: #class change: #Renamed using: #update;
notify: self ofSystemChangesOfItem: #category change: #Renamed using: #update;
notify: self ofSystemChangesOfItem: #class change: #Recategorized using: #update;
notify: self ofSystemChangesOfItem: #category change: #Recategorized using: #update.
self update; reset!

----- Method: TestRunner>>label (in category 'accessing-ui') -----
label
^ 'Test Runner' !

----- Method: TestRunner>>label:forSuite: (in category 'private') -----
label: aString forSuite: aTestSuite
^ String streamContents: [ :stream |
stream nextPutAll: 'Running '; print: aTestSuite tests size; space; nextPutAll: aString.
aTestSuite tests size > 1 ifTrue: [ stream nextPut: $s ] ]. !

----- Method: TestRunner>>perform:orSendTo: (in category 'private') -----
perform: selector orSendTo: otherTarget
"<lint: #expect rule: #badMessage rational: 'this is a common morphic pattern'>"

^ (self respondsTo: selector)
ifTrue: [ self perform: selector ]
ifFalse: [ super perform: selector orSendTo: otherTarget ].!

----- Method: TestRunner>>postAcceptBrowseFor: (in category 'accessing-ui') -----
postAcceptBrowseFor: aModel
"Nothing to do."!

----- Method: TestRunner>>previousRun (in category 'history saving') -----
previousRun

^ previousRun ifNil: [ previousRun := OrderedCollection new ]!

----- Method: TestRunner>>promptForPackages (in category 'actions') -----
promptForPackages
| packages |
packages := (PackageOrganizer default packages
reject: [:package | (package packageName beginsWith: 'Kernel')
or: [(package packageName beginsWith: 'Collections')
or: [(package packageName beginsWith: 'Exceptions')
or: [(package packageName beginsWith: 'SUnit')
or: [(package packageName beginsWith: 'System')
or: [package packageName includesSubstring: 'Test' caseSensitive: false]]]]]])
sort: [:a :b | a packageName < b packageName].
packages := Array
with: (UIManager default
chooseFrom: (packages
collect: [:package | package packageName])
values: packages
title: 'Select Package').
^ packages!

----- Method: TestRunner>>representsSameBrowseeAs: (in category 'accessing-ui') -----
representsSameBrowseeAs: anotherModel
^ self class = anotherModel class
and: [ classesSelected = anotherModel classesSelected ]!

----- Method: TestRunner>>reset (in category 'actions') -----
reset
self result: TestResult new; updateResults.!

----- Method: TestRunner>>result (in category 'accessing-testing') -----
result
^ result!

----- Method: TestRunner>>result: (in category 'accessing-testing') -----
result: aResult
result := aResult!

----- Method: TestRunner>>runAll (in category 'actions') -----
runAll
self reset; runSuite: self suiteAll.
self saveResultInHistory!

----- Method: TestRunner>>runCoverage (in category 'actions') -----
runCoverage
| packages methods |
packages := Set new.
self addDeclaredPackagesUnderTestTo: packages.
packages isEmpty ifTrue:
[ packages := self promptForPackages ].
methods := OrderedCollection new.
self
addMethodsUnderTestIn: packages
to: methods.
self excludeClassesNotUnderTestFrom: methods.
methods isEmpty ifTrue:
[ ^ UIManager default inform: 'No methods found for coverage analysis.' ].
self collectCoverageFor: methods
!

----- Method: TestRunner>>runErrors (in category 'actions') -----
runErrors
self result instVarNamed: 'errors' put: OrderedCollection new.
self runSuite: self suiteErrors.!

----- Method: TestRunner>>runFailures (in category 'actions') -----
runFailures
self result instVarNamed: 'failures' put: Set new.
self runSuite: self suiteFailures.!

----- Method: TestRunner>>runProfiled (in category 'actions') -----
runProfiled
MessageTally spyOn: [ self runAll ].!

----- Method: TestRunner>>runSuite: (in category 'actions') -----
runSuite: aTestSuite
self basicRunSuite: aTestSuite do: [ :each | self runTest: each ].
self updateResults

!

----- Method: TestRunner>>runTest: (in category 'actions') -----
runTest: aTestCase
aTestCase run: result.
self updateStatus: true.!

----- Method: TestRunner>>saveResultInHistory (in category 'history saving') -----
saveResultInHistory
result dispatchResultsIntoHistory!

----- Method: TestRunner>>selectAllCategories (in category 'accessing-categories') -----
selectAllCategories
categoriesSelected := categories asSet.
self changed: #allSelections; changed: #categorySelected; updateClasses!

----- Method: TestRunner>>selectAllClasses (in category 'accessing-classes') -----
selectAllClasses
"Fixed to update all selections now that the
selection invalidation has been optimised."

classesSelected := classes asSet.
self
changed: #allSelections;
changed: #classSelected;
changed: #hasRunnable!

----- Method: TestRunner>>selectInverseCategories (in category 'accessing-categories') -----
selectInverseCategories
categoriesSelected := categories asSet
removeAll: categoriesSelected;
yourself.
self changed: #allSelections; changed: #categorySelected; updateClasses!

----- Method: TestRunner>>selectInverseClasses (in category 'accessing-classes') -----
selectInverseClasses
"Fixed to update all selections now that the
selection invalidation has been optimised."

classesSelected := classes asSet
removeAll: classesSelected;
yourself.
self
changed: #allSelections;
changed: #classSelected;
changed: #hasRunnable!

----- Method: TestRunner>>selectNoCategories (in category 'accessing-categories') -----
selectNoCategories
categoriesSelected := Set new.
self changed: #allSelections; changed: #categorySelected; updateClasses!

----- Method: TestRunner>>selectNoClasses (in category 'accessing-classes') -----
selectNoClasses
"Fixed to update all selections now that the
selection invalidation has been optimised."

classesSelected := Set new.
self
changed: #allSelections;
changed: #classSelected;
changed: #hasRunnable!

----- Method: TestRunner>>selectSubclasses (in category 'accessing-classes') -----
selectSubclasses
"Fixed to update all selections now that the
selection invalidation has been optimised."

| classesForPackages |
classesForPackages := self findClassesForCategories: categoriesSelected.
classesSelected := (classesSelected gather: [ :class |
class withAllSubclasses select: [ :each |
classesForPackages includes: each ] ])
asSet.
self
changed: #allSelections;
changed: #classSelected;
changed: #hasRunnable!

----- Method: TestRunner>>showDiffWith: (in category 'history saving') -----
showDiffWith: aTestResult
| string diff |

diff := result diff: aTestResult.
string := String streamContents: [:str|
str nextPutAll: '----------------'; cr.
str nextPutAll: 'Diff between current result with: ', aTestResult asString; cr.
str nextPutAll: 'New passed: '.
diff first do: [:s| str nextPutAll: s printString, ' '].
str cr.
str nextPutAll: 'New failures: '.
diff second do: [:s| str nextPutAll: s printString, ' '].
str cr.

str nextPutAll: 'New errors: '.
diff third do: [:s| str nextPutAll: s printString, ' '].
str cr].

Workspace new contents: string; openLabel: 'SUnit Progress'
!

----- Method: TestRunner>>showHistoryMenu (in category 'history saving') -----
showHistoryMenu
| selectionIndex selectedPreviousResult actionIndex |
selectionIndex := UIManager default chooseFrom: self historyMenuList title: 'History:'.

"We pressed outside the menu"
selectionIndex isZero ifTrue: [ ^ self ].

"save current result is selected"
selectionIndex = 1 ifTrue: [ self previousRun addFirst: result. ^ self ].

selectedPreviousResult := self previousRun at: (selectionIndex - 1).
actionIndex := (UIManager default chooseFrom: #('delete' 'show diff') title: 'Action:').
actionIndex = 1 ifTrue: [ self previousRun remove: selectedPreviousResult. ^ self ].
actionIndex = 2 ifTrue: [ self showDiffWith: selectedPreviousResult]. !

----- Method: TestRunner>>showProgress (in category 'history saving') -----
showProgress
| testCaseClasses d string |
testCaseClasses := (self suiteAll tests collect: [:testCase | testCase class]) asSet.

"At the end of the algorithm, d will contains all the diff between what was saved and the current result"
d := Dictionary new.
d at: #passed put: OrderedCollection new.
d at: #failures put: OrderedCollection new.
d at: #errors put: OrderedCollection new.

testCaseClasses do: [ :cls | | t |
(cls class methodDict includesKey: #lastStoredRun)
ifTrue: [t := cls lastStoredRun.
(t at: #passed) do: [:s |
(result isErrorFor: cls selector: s)
ifTrue: [(d at: #errors) add: {cls . s}].
(result isFailureFor: cls selector: s)
ifTrue: [(d at: #failures) add: {cls . s}] ].

(t at: #failures) do: [:s | (result isPassedFor: cls selector: s)
ifTrue: [(d at: #passed) add: {cls . s}].
(result isErrorFor: cls selector: s)
ifTrue: [(d at: #errors) add: {cls . s}]].

(t at: #errors) do: [:s | (result isPassedFor: cls selector: s)
ifTrue: [(d at: #passed) add: {cls . s}].
(result isFailureFor: cls selector: s)
ifTrue: [(d at: #failures) add: {cls . s}]]]].

string := String streamContents: [:str|
str nextPutAll: '----------------'; cr.
str nextPutAll: 'Diff between current result and saved result'; cr.
str nextPutAll: 'New passed: '.
(d at: #passed) do: [:s| str nextPutAll: s printString, ' '].
str cr.
str nextPutAll: 'New failures: '.
(d at: #failures) do: [:s| str nextPutAll: s printString, ' '].
str cr.

str nextPutAll: 'New errors: '.
(d at: #errors) do: [:s| str nextPutAll: s printString, ' '].
str cr].

Workspace new contents: string; openLabel: 'SUnit Progress' string.

!

----- Method: TestRunner>>sortClass:before: (in category 'utilities') -----
sortClass: aFirstClass before: aSecondClass
| first second |
first := aFirstClass withAllSuperclasses reversed.
second := aSecondClass withAllSuperclasses reversed.
1 to: (first size min: second size) do: [ :index |
(first at: index) == (second at: index)
ifFalse: [ ^ (first at: index) name <= (second at: index) name ] ].
^ second includes: aFirstClass.!

----- Method: TestRunner>>statusColor (in category 'accessing-testing') -----
statusColor
result hasErrors
ifTrue: [ ^ Color red ].
result hasFailures
ifTrue:[ ^ Color yellow ].
^ Color green!

----- Method: TestRunner>>statusFrame (in category 'building') -----
statusFrame
^LayoutFrame new
leftFraction: 0.5 offset: 0;
topFraction: 0 offset: 0;
rightFraction: 1 offset: 0;
bottomFraction: 0 offset: self statusHeight!

----- Method: TestRunner>>statusHeight (in category 'building') -----
statusHeight
^Preferences standardCodeFont height * 2 + 12!

----- Method: TestRunner>>statusMenu: (in category 'accessing-menu') -----
statusMenu: aMenu
^ aMenu
add: 'History' action: #showHistoryMenu;
add: 'Store result as progress reference' action: #storeResultIntoTestCases;
add: 'Show progress' action: #showProgress;
yourself!

----- Method: TestRunner>>statusText (in category 'accessing-testing') -----
statusText
^ result printString.!

----- Method: TestRunner>>storeResultIntoTestCases (in category 'history saving') -----
storeResultIntoTestCases

result classesTested do: [:testCaseCls | testCaseCls generateLastStoredRunMethod ]
!

----- Method: TestRunner>>suiteAll (in category 'accessing') -----
suiteAll
^ TestSuite new in: [ :suite |
classesSelected do: [ :each |
each isAbstract
ifFalse: [ each addToSuiteFromSelectors: suite ] ].
suite name: (self label: 'Test' forSuite: suite) ].!

----- Method: TestRunner>>suiteErrors (in category 'accessing') -----
suiteErrors
^ TestSuite new in: [ :suite |
suite
addTests: errorList;
name: (self label: 'Error' forSuite: suite) ].!

----- Method: TestRunner>>suiteFailures (in category 'accessing') -----
suiteFailures
^ TestSuite new in: [ :suite |
suite
addTests: failedList;
name: (self label: 'Failure' forSuite: suite) ].!

----- Method: TestRunner>>update (in category 'updating') -----
update
self updateCategories; updateClasses!

----- Method: TestRunner>>updateCategories (in category 'updating') -----
updateCategories
categories := self findCategories.
categoriesSelected := categoriesSelected isNil
ifTrue: [ Set new ]
ifFalse: [
categoriesSelected
select: [ :each | categories includes: each ] ].
self changed: #categoryList; changed: #categorySelected.!

----- Method: TestRunner>>updateClasses (in category 'updating') -----
updateClasses
| classesForCategories |
classesForCategories := self findClassesForCategories: categoriesSelected.
classes := classesForCategories asArray
sort: [ :a :b | self sortClass: a before: b ].
classIndex := 0.
classesSelected := classesSelected isNil
ifTrue: [ classesForCategories ]
ifFalse: [
classesSelected
select: [ :each | classesForCategories includes: each ] ].
self changed: #classList; changed: #classSelected; changed: #hasRunnable.!

----- Method: TestRunner>>updateResults (in category 'updating') -----
updateResults
"<lint: #expect rule: #guardingClause>"
"<lint: #expect rule: #longMethods>"

self updateStatus: false.
failedList size = result failures size ifFalse: [
failedList := result failures asArray
sort: [ :a :b | a printString <= b printString ].
failedSelected := nil.
self
changed: #failedList;
changed: #failedSelected;
changed: #hasFailures;
changed: #hasProgress ].
errorList size = result errors size ifFalse: [
errorList := result errors asArray
sort: [ :a :b | a printString <= b printString ].
errorSelected := nil.
self
changed: #errorList;
changed: #errorSelected;
changed: #hasErrors;
changed: #hasProgress ].!

----- Method: TestRunner>>updateStatus: (in category 'updating') -----
updateStatus: aBoolean
"Update the status display, at most once a second if aBoolean is true."

(aBoolean and: [ lastUpdate = Time totalSeconds ])
ifTrue: [ ^ self ].
self changed: #statusText; changed: #statusColor.
lastUpdate := Time totalSeconds.!

----- Method: TestRunner>>windowIsClosing (in category 'private') -----
windowIsClosing
SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self!