[squeak-dev] Squeak 4.5: SUnitGUI-fbs.59.mcz

commits at source.squeak.org commits at source.squeak.org
Fri Jan 24 20:11:32 UTC 2014


Chris Muller uploaded a new version of SUnitGUI to project Squeak 4.5:
http://source.squeak.org/squeak45/SUnitGUI-fbs.59.mcz

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

Name: SUnitGUI-fbs.59
Author: fbs
Time: 9 January 2014, 2:54:26.088 pm
UUID: 0bfcf308-0d02-a749-9930-6229492cca48
Ancestors: SUnitGUI-fbs.58

Move ToolBuilder's SUnit "extensions" - the stubs we use to test ToolBuilder-built components - back to ToolBuilder-SUnit. Otherwise we break the modularity between SUnit('s GUI) and ToolBuilder.

==================== 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 pluggableInputFieldSpec 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 + 25!

----- 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 + 4!

----- 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 + 4!

----- 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 + 4!

----- 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!



More information about the Squeak-dev mailing list