From VisualWorks®, 7.6 of February 1, 2008 on February 1, 2008 at 12:52:30 pm (Dialog confirm: 'You are filing-in a Parcel source file!\\While this is possible it will not have\the same effect as loading the parcel.\None of the Parcel''s prerequisites will\be loaded and none of its load actions\will be performed.\\Are you sure you want to file-in?' withCRs) ifFalse: [self error: 'Parcel file-in abandoned. Choose terminate or close.'] <class> <name>SUnitStatusBar</name> <environment>Refactory.Browser</environment> <super>UI.Panel</super> <private>false</private> none testCount defects codeModel <imports> private XProgramming.SUnit.* </imports> <category>Browser-Code Tools</category> <attributes> <package>RBSUnitExtensions</package> </attributes> </class> <comment> Refactory.Browser.SUnitStatusBar
An addition to the Browser's set of CodeTools. The tool allows Run, Debug, or Profile of concrete subclasses of TestCase, by single or multi-select of individual test selectors, classes, protocols, packages, parcels or categories. The tool obeys the #isAbstract and #shouldInheritSelectors directives on individual classes, allowing a concrete class to inherit either all or none of the test selectors in its superclass hierarchy (up to, but not including TestCase). Note that the test selector inheritance feature of the TestCase class is, contrary to standard Smalltalk expectations, NOT automatic. A class must explicitly specify that it is to be considered an abstract test case (#isAbstract) or that, as a concrete class, it wishes to inherit tests from its superclasses (#shouldInheritSelectors). The directive #shouldInheritSelectors is meaningless (and ignored) for abstract test cases, since their test selectors cannot be run directly from the abstract class. Instance Variables: codeTool <CodeTool> the tool selectionPolicy <CodeToolSelectionPolicy> the corresponding selectionPolicy
</comment> <methods> Refactory.Browser.SUnitStatusBar <category>updating</category>
debugButton ^self partAt: 5
listDefectsButton ^self partAt: 3
profileButton ^self partAt: 4
runButton ^self partAt: 6
runDefectsButton ^self partAt: 2
setTestLabel: aString | widget | widget := self labelWidget. widget widget labelString: aString. widget repairDamage
touch self updateTestLabel; updateButtons; updateIsActive
update: aspectSymbol with: parameter from: sender (testCount notNil and: [testCount > 0]) ifTrue: [testCount := testCount - 1. self setTestLabel: ((#TestsRemaining1p << #browser >> 'Tests Remaining : <1p>') expandMacrosWith: testCount)].
updateButtons self updateRunButtons; updateDefectButtons
updateDefectButtons | enable | enable := self defectsExist. self runDefectsButton isEnabled: enable. self listDefectsButton isEnabled: enable
updateIsActive | isCurrentlyActive | isCurrentlyActive := self canRunTests. isCurrentlyActive = (self propertyAt: #isActive) ifTrue: [^self]. self propertyAt: #isActive put: isCurrentlyActive. self changedPreferredBounds: nil
updateRunButtons | canRun | canRun := self canRunTests. self profileButton isEnabled: (canRun and: [self isProfilerLoaded]). self debugButton isEnabled: canRun. self runButton isEnabled: canRun
updateTestLabel | label | self isAbstractClassSelected ifTrue: [ self updateForAbstract. label := (#NotRunAbstractTest << #browser >> 'Abstract test class, cannot run') ] ifFalse: [ self updateForNotRun. label := (#NotRunC1pTests << #browser >> 'Not run: <1p> tests') expandMacrosWith: self testCases size ]. self setTestLabel: label
</methods> <methods> Refactory.Browser.SUnitStatusBar <category>private</category>
classTestCases "Answer all runnable test cases for the selected class or classes." ^self testCasesFor: codeModel selectedClasses.
parcelTestCases "Answer all runnable test cases for all classes in the selected parcel or parcels." ^codeModel parcels inject: Set new into: [:sum :eachPundle | sum addAll: (self testCasesFor: eachPundle definedClasses); yourself]
parcelTestCasesExist "Answer if runnable test cases exist in any classes in the selected parcel or parcels." ^codeModel parcels anySatisfy: [:any | self testCasesExistInAny: any definedClasses]
protocolTestCases "Answer all runnable test cases for the selected protocol or protocols." codeModel selectedClass ifNil: [^OrderedCollection new]. ^codeModel protocols inject: Set new into: [:sum :each | sum addAll: (self testCasesForSelectors: (self testSelectorsForClass: codeModel selectedClass protocol: each)); yourself]
pundleTestCases "Answer all runnable test cases for all classes in the selected pundle or pundles." ^codeModel pundles inject: Set new into: [:sum :eachPundle | sum addAll: (self testCasesFor: eachPundle definedClasses); yourself]
pundleTestCasesExist "Answer if runnable test cases exist in classes in the selected pundle or pundles." ^codeModel pundles anySatisfy: [:any | self testCasesExistInAny: any definedClasses]
selectorTestCases "Answer all runnable test cases for the selected selectors." ^self testCasesForSelectors: codeModel selectors
setFailedLabel self setTestLabel: (#Failed << #browser >> 'Failed'). self updateForFailed
setLabelColor: aColorValue | label | label := self labelWidget. label lookPreferences: (label lookPreferences backgroundColor: aColorValue)
setPassedLabel self setTestLabel: (#Passed << #browser >> 'Passed'). self updateForPassed
testCases codeModel selector notNil ifTrue: [^self selectorTestCases]. codeModel protocol notNil ifTrue: [^self protocolTestCases]. codeModel selectedClass notNil ifTrue: [^self classTestCases]. codeModel parcel notNil ifTrue: [^self parcelTestCases]. codeModel pundle notNil ifTrue: [^self pundleTestCases]. ^#()
testCasesExistInAny: classesCollection "Answer if there are any test cases in the classes listed in the argument." ^classesCollection anySatisfy: [:any | (self testSelectorsForClass: any) notEmpty]
testCasesFor: classesCollection "Answer all runnable test cases for the collection of classes." ^classesCollection inject: Set new into: [:sum :each | sum addAll: ((self testSelectorsForClass: each) collect: [:sel | each selector: sel]); yourself]
testCasesForSelectors: selectors | testSelectors | testSelectors := self testSelectorsForClass: codeModel selectedClass. ^(selectors select: [:each | testSelectors includes: each]) collect: [:each | codeModel selectedClass selector: each]
testSelectorsForClass: aClass "Answer an OrderedCollection of runnable test selectors for aClass, obeying the #isAbstract and #shouldInheritSelectors designation, provided it is a subclass of TestCase." ^ ((aClass inheritsFrom: TestCase) not or: [ aClass isAbstract ]) ifTrue: [ OrderedCollection new ] ifFalse: [ aClass shouldInheritSelectors ifTrue: [aClass allTestSelectors] ifFalse: [aClass testSelectors] ].
testSelectorsForClass: aClass protocol: aProtocol "Answer an OrderedCollection of runnable test selectors in aProtocol for aClass, obeying the #isAbstract and #shouldInheritSelectors designation, provided it is a subclass of TestCase." ^((aClass inheritsFrom: TestCase) not or: [aClass isAbstract]) ifTrue: [OrderedCollection new] ifFalse: [aClass shouldInheritSelectors ifTrue: [(aClass withAllSuperclasses) removeAll: TestCase withAllSuperclasses; inject: Set new into: [:sum :each | sum addAll: (codeModel environment selectorsFor: aProtocol in: each); yourself]] ifFalse: [codeModel environment selectorsFor: aProtocol in: aClass]]
updateForAbstract self setLabelColor: nil
updateForFailed self setLabelColor: ColorValue red
updateForNotRun self setLabelColor: nil
updateForPassed self setLabelColor: ColorValue green. defects := nil
</methods> <methods> Refactory.Browser.SUnitStatusBar <category>initialize-release</category>
actionDriver: anActionSelector ^(PluggableAdaptor on: false asValue) getBlock: [:m | m value] putBlock: [:m :v | self perform: anActionSelector] updateBlock: [:m :a :p | true]
addButtons | button | #(#runDefects #listDefects #profileTests #debugTests #runTests) with: #('Run Defects' 'List Defects' 'Profile' 'Debug' 'Run') do: [:action :label | button := self lookPolicy actionButtonClass model: (self actionDriver: action). button labelString: action >> label << #browser. self add: button]. self subparts last beDefault
addLabel | label | label := self lookPolicy passiveLabelClass new. label widgetState isOpaque: true. self add: ((WidgetWrapper on: label) widget: label)
buttonCount ^self subparts size - 1 max: 0
codeModel: aCodeModel codeModel := aCodeModel
initialize super initialize. self setLayout. self addLabel. self addButtons. self setDesiredHeight. self propertyAt: #row put: -1
setDesiredHeight | maxHeight | maxHeight := (self subparts collect: [:each | each preferredBounds height]) fold: [:a :b | a max: b]. self propertyAt: #desiredHeight put: maxHeight
</methods> <methods> Refactory.Browser.SUnitStatusBar <category>actions</category>
debugTests | failed | self shouldNotRunTests ifTrue: [^self]. self updateForNotRun. self setTestLabel: (#Debugging << #browser >> 'Debugging'). failed := false. testCount := self testCases size. [[self testCases do: [:each | each debug. (testCount notNil and: [testCount > 0]) ifTrue: [testCount := testCount - 1. self setTestLabel: ((#TestsRemaining1p << #browser>> 'Tests Remaining : <1p>') expandMacrosWith: testCount)]]] on: TestResult failure , TestResult error do: [:ex | failed := true. ex pass]] ifCurtailed: [self setFailedLabel]. failed ifTrue: [self setFailedLabel] ifFalse: [self setPassedLabel]
listDefects | testToDebug | (defects isNil or: [defects isEmpty]) ifTrue: [^self]. testToDebug := Dialog choose: (#ChooseATestToDebug << #browser >> 'Choose A Test To Debug') fromList: (defects collect: [:each | each printString]) values: defects lines: 8 cancel: [] for: Dialog defaultParentWindow. testToDebug ifNotNil: [:value | value debug]
profileTests | profiler | profiler := #{TimeProfiler} valueOrDo: [nil]. profiler isNil ifTrue: [^self warn: (#ProfilerNotLoadedLoad << #browser >> 'Profiler not loaded. Load the "AT Profiling" parcel.')]. profiler profile: [self runTests]
runDefects | suite result | (defects isNil or: [defects isEmpty]) ifTrue: [^self]. suite := TestSuite new. defects do: [:each | suite addTest: each]. testCount := defects size. suite addDependent: self. result := [suite run] ifCurtailed: [self setTestLabel: (#Failed << #browser >> 'Failed')]. self setTestLabel: (#x1QPassedORFailed2pRun3pFailed4pErrors << #browser >> '<1?Passed:Failed>: <2p> run, <3p> failed, <4p> errors' expandMacrosWith: result hasPassed with: result runCount with: result failureCount with: result errorCount). codeModel navigate. result hasPassed ifTrue: [self updateForPassed] ifFalse: [defects := result defects. self updateForFailed]. self updateDefectButtons
runTests | suite result | self shouldNotRunTests ifTrue: [^self]. self updateForNotRun. self setTestLabel: (#Running << #browser >> 'Running'). suite := TestSuite new. self testCases do: [:each | suite addTest: each]. testCount := self testCases size. suite addDependent: self. result := [suite run] ifCurtailed: [self setTestLabel: (#Failed << #browser >> 'Failed')]. self setTestLabel: (#x1QPassedORFailed2pRun3pFailed4pErrors << #browser >> '<1?Passed:Failed>: <2p> run, <3p> failed, <4p> errors' expandMacrosWith: result hasPassed with: result runCount with: result failureCount with: result errorCount). codeModel navigate. result hasPassed ifTrue: [self updateForPassed] ifFalse: [defects := result defects. self updateForFailed]. self updateDefectButtons
</methods> <methods> Refactory.Browser.SUnitStatusBar <category>testing</category>
canRunTests ^self isAbstractClassSelected not and: [self testCasesExist]
codeComponentIncludesTest: aCodeComponent ^aCodeComponent definedClasses anySatisfy: [:each | each inheritsFrom: TestCase]
defectsExist ^defects notNil and: [defects notEmpty]
hasTestsSelected (codeModel selectedClasses anySatisfy: [:each | each inheritsFrom: TestCase]) ifTrue: [^true]. codeModel objectNames notEmpty ifTrue: [^false]. (codeModel parcels anySatisfy: [:each | self codeComponentIncludesTest: each]) ifTrue: [^true]. ^codeModel pundles anySatisfy: [:each | self codeComponentIncludesTest: each]
isAbstractClassSelected ^codeModel selectedClass notNil and: [(codeModel selectedClass respondsTo: #isAbstract) and: [codeModel selectedClass isAbstract]]
isProfilerLoaded #{TimeProfiler} valueOrDo: [^false]. ^true
shouldNotRunTests ^self canRunTests not
testCasesExist codeModel selector notNil ifTrue: [^self selectorTestCases notEmpty]. codeModel protocol notNil ifTrue: [^self protocolTestCases notEmpty]. codeModel selectedClass notNil ifTrue: [^self classTestCases notEmpty]. codeModel parcel notNil ifTrue: [^self parcelTestCasesExist]. codeModel pundle notNil ifTrue: [^self pundleTestCasesExist]. ^false
</methods> <methods> Refactory.Browser.SUnitStatusBar <category>accessing</category>
labelWidget ^components first
lookPolicy ^self widgetPolicy lookPolicyClass new
</methods> <methods> Refactory.Browser.SUnitStatusBar <category>displaying</category>
displayOn: aGC self canRunTests ifTrue: [super displayOn: aGC]
</methods> <methods> Refactory.Browser.SUnitStatusBar <category>private-layout</category>
boxForButtonAt: index in: rectangle | width | width := self buttonWidthIn: rectangle. ^(rectangle right - ((self subparts size - index + 1) * width)) @ rectangle top extent: width @ rectangle height
boxForLabelIn: rectangle ^rectangle origin corner: (rectangle right - (self buttonCount * (self buttonWidthIn: rectangle))) @ rectangle bottom
buttonWidthIn: aRectangle | width | aRectangle width isZero ifTrue: [^0]. width := self defaultButtonWidth. width * self subparts size > aRectangle width ifTrue: [^aRectangle width / self subparts size]. ^width
defaultButtonWidth ^(self subparts allButFirst: 1) inject: 0 into: [:accum :each | accum max: each preferredBounds width]
setLayout self partFramingBlock: [:rectangle :part :index | index = 1 ifTrue: [self boxForLabelIn: rectangle] ifFalse: [self boxForButtonAt: index in: rectangle]]
</methods> <methods> Refactory.Browser.CodeModel class <category>status parts</category>
sunitStatusBarClass <status> ^SUnitStatusBar
</methods> "Imported Classes:" self error: 'Attempting to file-in parcel imports. Choose terminate or close' <class> <name>Panel</name> <environment>UI</environment> <super>Graphics.CompositePart</super> <private>false</private> none layoutAlgorithm <imports></imports> <category>My Classes</category> <attributes> <package>Browser-BaseUI</package> </attributes> </class>