[ENH] Browser support for unit test

rrobbes rrobbes at etu.info.unicaen.fr
Sun Feb 16 22:36:58 UTC 2003


Hi everyone 

Here is a changeset which modifies the class browsers in order to have
a better integration of unit testing. It adds buttons to the browser to
efficiently go back and forth between a class and it's test, between a
method and it's test method, and to run the classe's test case. 

This allows a much easier use of the tests, and a better synchronisation 
with
the code, as they are only one click away from their counterpart.
Moreover, the presence of a 'test' button on the browser might incitate
people to code more tests, and might help the "squeak documentation project 
with unit tests" 

I'll put that on SqueakMap soon. 

   Romain Robbes
-------------- next part --------------
'From Squeak3.4gamma of ''7 January 2003'' [latest update: #5169] on 16 February 2003 at 11:19:05 pm'!
"Change Set:		BrowserUnitTestSupport
Date:			15 February 2003
Author:			Romain Robbes

Adds some support in the Browser for unit tests. Specifically:

- Adds a 'test' button which allows you to go back and forth between
a class and it's test case.
- Adds a 'test' button on the browser button tool bar, which allows you to
do the same thing as the former button at the method level.
- Adds a 'run' button on the tool bar, running the classe's test case,
  giving feedback to the user and changing it's color according to
  the last run.

Both 'test' buttons asks you if you want to create a test case/test method
if it doesn't exists yet.
"!

TestCase subclass: #BrowserTest
	instanceVariableNames: 'browser '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser-Tests'!

!Browser methodsFor: 'initialize-release' stamp: 'rr 2/16/2003 15:40'!
buildMorphicSwitches
	"Creates the four buttons under the class list pane :
	instance, comment/hierarchy, class, test.
	Modified to add the fourth button"
	| instanceSwitch divider1 divider2 divider3 commentSwitch classSwitch testSwitch row aColor |

	instanceSwitch _ PluggableButtonMorph
		on: self
		getState: #instanceMessagesIndicated
		action: #indicateInstanceMessages.
	instanceSwitch
		label: 'instance';
		askBeforeChanging: true;
		setBalloonText: 'view instance side methods';
		borderWidth: 0.
	commentSwitch _ PluggableButtonMorph
		on: self
		getState: #classCommentIndicated
		action: #plusButtonHit.
	commentSwitch
		label: '?' asText allBold;
		askBeforeChanging: true;
		setBalloonText: 'class comment';
		borderWidth: 0.
	classSwitch _ PluggableButtonMorph
		on: self
		getState: #classMessagesIndicated
		action: #indicateClassMessages.
	classSwitch
		label: 'class';
		askBeforeChanging: true;
		setBalloonText: 'view class side methods';
		borderWidth: 0.
	testSwitch _ PluggableButtonMorph
		on: self
		getState: #testClassBrowsed
		action: #browseTestClass.
	testSwitch
		label: 'test';
		askBeforeChanging: true;
		setBalloonText: 'browse class/test class';
		borderWidth: 0.
	divider1 := BorderedSubpaneDividerMorph vertical.
	divider2 := BorderedSubpaneDividerMorph vertical.
	divider3 := BorderedSubpaneDividerMorph vertical.
	Preferences alternativeWindowLook ifTrue:[
		{divider1. divider2. divider3.} do: [:each | 
			each extent: 4 at 4; borderWidth: 2; borderRaised; color: Color transparent.]
	].
	row _ AlignmentMorph newRow
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 0;
		addMorphBack: instanceSwitch;
		addMorphBack: divider1;
		addMorphBack: commentSwitch;
		addMorphBack: divider2;
		addMorphBack: classSwitch;
		addMorphBack: divider3;
		addMorphBack: testSwitch.

	aColor _ Color colorFrom: self defaultBackgroundColor.
	row color: aColor duller.  "ensure matching button divider color. (see #paneColor)"
	Preferences alternativeWindowLook ifTrue:[aColor _ aColor muchLighter].
	{instanceSwitch. commentSwitch. classSwitch. testSwitch.} do: [:m | 
		m 
			color: aColor;
			onColor: aColor twiceDarker offColor: aColor;
			hResizing: #spaceFill;
			vResizing: #spaceFill.
	].

	^ row
! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 15:27'!
browseTestClass
	"go automagically back and forth between the class and the test class"
	" The next line is commented so that the button works in ClassBrowsers
	 (without categories), for example in the StarBrowser"
	"self couldBrowseAnyClass ifFalse: [^self halt]."
	(self isTestCase: self selectedClass) 
		ifTrue: [self goToClass ] 
		ifFalse: [self goToTestCase ].
	self changed: #classSelectionChanged.! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 19:26'!
browseTests
	"choose between browsing a method and its tests method if it exists. 
	If the test method doesn't exist yet, ask the user if he wants to create it."

	| msg newMsg oldClass newClass |
	msg := self selectedMessageName.
	oldClass := self selectedClass.
	self browseTestClass.
	msg = 'Definition' ifTrue: [^self].
	newClass := self selectedClass.
	newClass == oldClass ifTrue: [^self].
	"we have changed class. we must now select the correct method"
	(self isTestCase: newClass) 
		ifTrue: [newMsg := self testCaseSelector: msg forClass: newClass]
		ifFalse: [newMsg := self messageForTest: msg. 
				newMsg ifNil: [self inform: 'Could not find a message corresponding to test :', msg]].
	self selectedMessageName: newMsg.
	self selectMessageCategoryNamed:  self categoryOfCurrentMethod .
	"yes, it is ugly"
	self selectedMessageName: newMsg.! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 15:50'!
classNameFor: aClass prefix: prefix
	^(prefix, aClass asString) asSymbol! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 15:50'!
classNameFor: aClass sufix: sufix 
	^(aClass asString , sufix) asSymbol! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/15/2003 13:22'!
classNameForTestCase: aTestClass 
	" Returns the name of the class corresponding to this test case class.
	The following patterns for the name of the class are searched (examples
	found in TestCase allSubclasses):
		- ClassTest
		- ClassTests
		- ClassTestCase
		- TestClass. 
	Feel free to add more patterns if you want. You could either name your test cases in a 
	more standard way. :-) "

	| testName size |
	testName := aTestClass name asString.
	size := testName size.
	('*Test' match: testName) ifTrue: [^(testName first: size - 4) asSymbol ].
	('*Tests' match: testName) ifTrue: [^(testName first: size - 5) asSymbol ].
	('*TestCase' match: testName) ifTrue: [^(testName first: size - 8) asSymbol].
	('Test*' match: testName) ifTrue: [^(testName last: size - 4) asSymbol].
	"uh oh. The class name wasn't found. What should I do?"
	^nil! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 23:17'!
createTestFor: aClass
	"Creates the TestCase case for the selected class, in a separate testing category"
	TestCase subclass: (self testCaseNameForClass: aClass) instanceVariableNames: ' ' classVariableNames: ' ' poolDictionaries: ' ' category: (aClass category, '-Tests').
	(self testCaseNameForClass: aClass) sunitAsClass comment: 
	'This is the unit test for the class ', aClass asString, '. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- http://minnow.cc.gatech.edu/squeak/1547
	- the sunit class category
'.
	! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 15:32'!
goTo: aClass
	"Positions the browser on the corresponding class"
	self systemCategoryListIndex: (self systemCategoryList indexOf: aClass category).
	self classListIndex: (self classList indexOf: aClass name).! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 15:38'!
goToClass
	"We are on a TestCase subclass. Therefore we try to go on the class
	tested by this test, if it exists"
	| theClassName |
	theClassName _ self classNameForTestCase: self selectedClass.
	theClassName ifNil: [self inform: 'Could not find the name of the class tested by : ', self selectedClass].
	theClassName sunitAsClass ifNotNilDo: [:class | self goTo: class. ^self].
	PopUpMenu inform: 'class ', theClassName, ' does not exist yet.'
! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 15:33'!
goToTestCase
	"Attempt to go to the test case corresponding to the class. 
	If it doesn't exists, ask the user if we should create if"
	| testCaseNames testCaseClasses testCase |
	testCaseNames _ self possibleTestCaseNamesForClass: self selectedClass.
	testCaseClasses _ testCaseNames collect: [:test | test sunitAsClass].
	testCase  _ testCaseClasses detect: [:each | each notNil] 
				ifNone: [(PopUpMenu confirm: 
				'No test cases were found for class ', self selectedClass name asString, '. Create it?' )
					ifTrue:[self createTestFor: self selectedClass. ^self goToTestCase] 
					ifFalse:[^self]].
	self goTo: testCase.! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 13:23'!
isTestCase: aClass 
	"tests wheter the given class is a subclass of testCase or not. Answers false
	for TestCase itself."
	aClass ifNil: [^false].
	^ aClass inheritsFrom: TestCase! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 19:51'!
messageForTest: selector
	"returns the appropriate message selector for the given test.
	There might be ambiguities, but we assume all messages starting with
	the same first keyword are more or less tested by the same test method"
	| matchSel selectors |
	"trim the 'test'"
	matchSel _ (selector asString last: (selector size - 4)) withFirstCharacterDownshifted, '*'.
	"find the first selector starting like matchSel"
	0 to: 6 do: [:n | 
		selectors _ (self selectedClass selectorsWithArgs: n) select: [:each | matchSel match: each].
		selectors notEmpty ifTrue: [^ selectors first]].
	^ nil! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 15:36'!
optionalButtonPairs 
	" Overriden to add the two buttons "
	^ super optionalButtonPairs, 
		#(
			('test'	 browseTests	 'test of this method')
			('run'	 runTests	 'run tests of this class')
		)! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/15/2003 13:15'!
possibleTestCaseNamesForClass: aClass 
	"returns the possible names of the test class given it's name,
	in order to find the correct class."
	^{
		self classNameFor: aClass sufix: 'Test'. 
		self classNameFor: aClass sufix: 'Tests'.
		self classNameFor: aClass sufix: 'TestCase'.
		self classNameFor: aClass prefix: 'Test'.  
	}! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 15:23'!
runTests
	" Runs the test case associated with this class, and displays the result.
		Colorize the run button according to the result"
	| res btn |
	res _ self testCase ifNotNilDo: [:testCase | testCase suite run].
	res ifNil: [^self].
	self inform: res asString.
	(btn _ self testButton) ifNil: [^self].
	res hasErrors ifTrue: [^btn offColor: Color red].
	res hasFailures ifTrue: [^btn offColor: Color yellow].
	btn offColor: Color green.
	! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 15:12'!
testButton
		^ self buttonWithSelector: #runTests! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 13:28'!
testCase
	"returns selectedClass or it's test case, whichever one is the test"
	| testCaseNames testCaseClasses class |
	class _ self selectedClass.
	(self isTestCase: class) ifTrue: [^class].
	testCaseNames _ self possibleTestCaseNamesForClass: self selectedClass.
	testCaseClasses _ testCaseNames collect: [:test | test sunitAsClass].
	^ testCaseClasses detect: [:each | each notNil] 
				ifNone: [(PopUpMenu confirm: 
				'No test cases were found for class ', self selectedClass name asString, '. Create it?' )
					ifTrue:[self createTestFor: self selectedClass. self testCase]].! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/15/2003 14:31'!
testCaseNameForClass: aClass 
	"returns the name of the test class for the class given"

	^self classNameFor: aClass sufix: 'Test'! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 15:36'!
testCaseSelector: msg forClass: newClass 
	"Find the test case selector for msg, optionaly creating it"
	| newMsg |
	newMsg := self testForMessage: msg.
	(newClass includesSelector: newMsg) 
		ifFalse: 
			[(PopUpMenu 
				confirm: newClass asString , ' does not have selector : ' , newMsg 
						, ' compile it?') 
					ifTrue: 
						[newClass compile: newMsg , '
 self assert: false' classified: 'testing']].
	^newMsg! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/15/2003 12:29'!
testClassBrowsed
	"Answers wether we are browsing a Test Class, ie a subclass of TestCase"
	^self isTestCase: self selectedClass! !

!Browser methodsFor: 'unit test support' stamp: 'rr 2/16/2003 12:12'!
testForMessage: selector
	"returns the same test for every message starting with the same first keyword :
		'selector', 'selector:','selector:with:' will all return the same message, 'testSelector' "
	| testSel |
	testSel _ (selector findTokens: ':') first asSymbol.
	testSel isInfix ifTrue: [^ nil]. "#+ et al. won't work"
	^ ('test', testSel asString capitalized) asSymbol! !


!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 15:46'!
setUp
	browser _ Browser new.! !

!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 19:42'!
testBrowseTestClass
	browser goTo: Browser.
	browser browseTestClass.
	self assert: (browser selectedClass = BrowserTest).
	"other way round"
	browser goTo: BrowserTest.
	browser browseTestClass.
	self assert: (browser selectedClass = Browser).

	"other patterns"
	browser goTo: Interval.
	browser browseTestClass.
	self assert: (browser selectedClass = IntervalTestCase).
	browser browseTestClass.
	self assert: (browser selectedClass = Interval).

	browser goTo: FileDirectory.
	browser browseTestClass.
	self assert: (browser selectedClass = FileDirectoryTests).
	browser browseTestClass.
	self assert: (browser selectedClass = FileDirectory).

	"no example for the Test* pattern in the base image "! !

!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 19:35'!
testBrowseTests
	browser goTo: Browser.
	browser selectMessageCategoryNamed:  'unit test support'.
	browser selectedMessageName: #browseTests.
	browser browseTests.
	self assert: (browser selectedClass = BrowserTest).
	self assert: (browser selectedMessageCategoryName = 'testing').
	self assert: (browser selectedMessageName = #testBrowseTests).

	browser goTo: BrowserTest.
	browser selectMessageCategoryNamed:  'testing'.
	browser selectedMessageName: #testBrowseTests.
	browser browseTests.
	self assert: (browser selectedClass = Browser).
	self assert: (browser selectedMessageCategoryName = 'unit test support').
	self assert: (browser selectedMessageName = #browseTests).
	! !

!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 16:22'!
testClassNameFor
 	self assert: ((browser classNameFor: Browser sufix: 'Test') = #BrowserTest).
	self assert: ((browser classNameFor: Browser prefix: 'Test') = #TestBrowser).! !

!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 16:22'!
testClassNameForTestCase
 self assert: ((browser classNameForTestCase: BrowserTest) = #Browser)! !

!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 19:56'!
testCreateTestFor
	| className class testCaseName testCase |
	className _ #Azertyuiopqsdfghjklm.
 	(className sunitAsClass == nil) ifTrue: ["unable to perform test." ^self].
	Object subclass: className instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Browser'.
	class _ className sunitAsClass.
	self deny: (class == nil).
	testCaseName _ browser testCaseNameForClass: class.
	testCase _ testCaseName sunitAsClass.
	self deny: (testCase == nil).
	self assert: (testCase category = 'Tools-Browser-Tests').
	
	class removeFromSystem.
	testCase removeFromSystem.
	self assert: (className sunitAsClass == nil).
	self assert: (testCaseName sunitAsClass == nil).

! !

!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 19:28'!
testGoTo
	browser goTo: Browser.
 	self assert: (browser selectedClass = Browser)! !

!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 16:23'!
testIsTestCase
	self assert: (browser isTestCase: BrowserTest).
	self deny: (browser isTestCase: Browser).
	self deny: (browser isTestCase: TestCase).! !

!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 19:11'!
testMessageForTest
 browser goTo: Browser.
 self assert: ((browser messageForTest: #testMessageForTest) = #messageForTest:).
  self assert: ((browser messageForTest: #testMessageForTest) = #messageForTest:).! !

!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 19:20'!
testTestCase
	browser goTo: Browser.
	self assert: (browser testCase = BrowserTest).
	browser goTo: BrowserTest.
	self assert: (browser testCase = BrowserTest).! !

!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 16:22'!
testTestCaseNameForClass
	self assert:( (browser testCaseNameForClass: Browser) = #BrowserTest)! !

!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 16:30'!
testTestClassBrowsed
	browser goTo: Browser.
 	self deny: (browser testClassBrowsed).
	browser goTo: BrowserTest.
 	self assert: (browser testClassBrowsed)! !

!BrowserTest methodsFor: 'testing' stamp: 'rr 2/16/2003 16:28'!
testTestForMessage

	self assert: #testAzerty = (browser testForMessage: #azerty).
	self assert: #testAzerty = (browser testForMessage: #azerty:).
	self assert: #testAzerty = (browser testForMessage: #azerty:qwerty:).
	self assert: nil = (browser testForMessage: #+)! !

"Postscript:
Opens a browser on the Browser class, to let the user exercise the functionality"
Browser browse
!



More information about the Squeak-dev mailing list