'From VisualWorks(R), Release 2.5 of September 26, 1995 on July 7, 1996 at 5:39:29 pm'! CompiledMethod variableSubclass: #CompiledMethodWithSource instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Test-Implementation'! !CompiledMethodWithSource methodsFor: 'source code management'! getSource ^sourceCode! methodWithSource sourceCode notNil ifTrue: [^self]. ^nil! sourceCode: aString sourceCode := aString! ! !CompiledMethodWithSource methodsFor: 'fileIn/Out'! representBinaryOn: binWriter " By default, objects do nothing special to represent themselves in binary form. " ^nil! ! Object subclass: #TestSuite instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Test-Implementation'! !TestSuite methodsFor: 'executing'! setupForTest! setupTest self class setupClassVariable! tearDownForTest! tearDownTest! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestSuite class instanceVariableNames: ''! !TestSuite class methodsFor: 'test accessing'! testNamed: aName ^nil! ! !TestSuite class methodsFor: 'accessing'! instrumentation ^CoverageEnvironment new! ! Behavior subclass: #TestBehavior instanceVariableNames: 'organization name classPool history parent instrumentation ' classVariableNames: 'TestErrorSignal ' poolDictionaries: '' category: 'Test-Implementation'! !TestBehavior methodsFor: 'initialize-release'! initializeWithName: aName ^self initializeWithSuper: self defaultSuperclass name: aName! initializeWithSuper: aClass name: aName self assignSuperclass: aClass. classPool := PoolDictionary new. history := OrderedCollection new. instrumentation := nil. self methodDictionary: MethodDictionary new. format := ((aClass isNil ifTrue: [0] ifFalse: [aClass instSize]) bitAnd: 255) + 16384. name := aName! ! !TestBehavior methodsFor: 'accessing'! allParents | current parents | parents := OrderedCollection new. current := parent. [current isNil] whileFalse: [parents add: current. current := current parent]. ^parents! allSuperclasses | current superclasses | superclasses := OrderedCollection new. current := superclass. [current == self defaultSuperclass] whileFalse: [superclasses add: current. current := current superclass]. ^superclasses! comment ^self organization classComment! comment: aComment self assignedOrganization classComment: aComment! instrumentation | current | current := self. [current isNil or: [current instrumentationOrNil notNil]] whileFalse: [current := current parent]. ^current isNil ifTrue: [superclass instrumentation] ifFalse: [current instrumentationOrNil]! instrumentation: aCoverageEnvironment instrumentation := aCoverageEnvironment! instrumentationOrNil ^instrumentation! name ^name! name: aName self subclasses do: [:each | each name: aName]. ^name := aName! topSuperclass ^superclass == self defaultSuperclass ifTrue: [self] ifFalse: [superclass topSuperclass]! ! !TestBehavior methodsFor: 'testing'! isEmpty ^self children inject: methodDict isEmpty into: [:bool :each | bool and: [each isEmpty]]! isRoot ^self parent isNil! isSuite ^false! ! !TestBehavior methodsFor: 'test history'! addHistory: aRecord history add: aRecord! clearHistory history := OrderedCollection new! history ^history! removeRecord: aRecord history remove: aRecord ifAbsent: []! ! !TestBehavior methodsFor: 'test accessing'! allChildren ^self children inject: (OrderedCollection withAll: self children) into: [:col :each | col addAll: each allChildren; yourself]! children ^#()! commonParent: aTest ^(self derivedFrom: aTest) ifTrue: [aTest] ifFalse: [self commonParent: aTest parent]! derivedFrom: aTest ^self = aTest or: [parent notNil and: [parent derivedFrom: aTest]]! parent ^parent! parent: aParent parent := aParent! removeSelf self parent isNil ifTrue: [self subclasses do: [:each | each removeSelf]. self children do: [:each | each assignSuperclass: each defaultSuperclass]] ifFalse: [superclass == self defaultSuperclass ifFalse: [self raiseError: 'Cannot remove test since it is defined in a superclass']. self parent removeTest: self. self subclasses do: [:each | each assignSuperclass: superclass. each isEmpty ifTrue: [each removeSelf]]]. self assignSuperclass: self defaultSuperclass! renameAs: aName parent isNil ifTrue: [(superclass subclasses contains: [:each | each name = aName]) ifTrue: [self raiseError: 'Class with ' , aName , ' already exists']] ifFalse: [(self subclassTestNamed: aName) isEmpty ifFalse: [self raiseError: 'Test with ' , aName , ' already exists']]. self name: aName! subclassTestNamed: aName ^#()! tabs ^#(#('code' #TestCodePresentation) #('comment' #TestCommentPresentation) #('coverage' #TestCoveragePresentation) #('history' #TestHistoryPresentation))! testClass ^parent isNil ifTrue: [self] ifFalse: [parent testClass]! ! !TestBehavior methodsFor: 'creating class hierarchy'! assignSuperclass: aClass superclass class == self class ifTrue: [self removeFromSuper]. superclass := aClass. aClass class == self class ifTrue: [self addToSuper]! ! !TestBehavior methodsFor: 'executing'! executeForAllocationProfile self executeForHistory: TestAllocationProfile! executeForCoverage self executeForHistory: TestCoverage! executeForHistory: historyClass (TestRunner on: self using: historyClass) execute! executeForProfile self executeForHistory: TestProfile! executeForResult self executeForHistory: TestResult! ! !TestBehavior methodsFor: 'printing'! displayString ^self isEmpty ifTrue: [name asText emphasizeAllWith: #italic] ifFalse: [name]! printOn: aStream "Append to the argument aStream a sequence of characters that identifies the receiver." aStream nextPutAll: self name! ! !TestBehavior methodsFor: 'class variables'! addClassVarName: aString self withAllSubclasses do: [:each | each allChildren do: [:aTest | aTest poolHas: aString asSymbol ifTrue: [:ignored | self class testErrorSignal raiseErrorString: aString , ' is already used as a variable name in ' , aTest name]]]. classPool at: aString asSymbol put: nil! addVariable: aName ^self addClassVarName: aName! nilVariables classPool associationsDo: [:each | each value: nil]. superclass == self defaultSuperclass ifFalse: [superclass nilVariables]! removeClassVarName: aString "Remove the class variable whose name is the argument, aString, from the names defined in the receiver, a class." | aSymbol association | aSymbol := aString asSymbol. (classPool includesKey: aSymbol) ifFalse: [self class testErrorSignal raiseErrorString: aString , ' is not a class variable']. association := classPool associationAt: aSymbol. self withAllSubclasses do: [:each | each allChildren do: [:test | (test whichSelectorsReferTo: association) isEmpty ifFalse: [self class testErrorSignal raiseErrorString: aString , ' is still used in ' , test name , '.']]]. classPool removeKey: aSymbol! removeVariable: aName ^self removeClassVarName: aName! variables ^classPool keys! ! !TestBehavior methodsFor: 'organization'! addCategory: aSymbol before: selectedSymbol self assignedOrganization addCategory: aSymbol before: selectedSymbol! assignedOrganization organization == nil ifTrue: [organization := TestOrganizer new]. ^organization! organization ^organization == nil ifTrue: [TestOrganizer new] ifFalse: [organization]! whichCategoryIncludesSelector: aSelector ^(self includesSelector: aSelector) ifTrue: [self organization categoryOfElement: aSelector] ifFalse: [nil]! ! !TestBehavior methodsFor: 'compiling'! bindingFor: varName ^self classPool bindingFor: varName! compile: code classified: heading notifying: requestor | selector | selector := self compile: code notifying: requestor ifFail: [^nil]. self assignedOrganization classify: selector under: heading. ^selector! compile: code notifying: requestor ifFail: failBlock | methodNode selector save method | save := code asString copy. methodNode := self compiler compile: code in: self notifying: requestor ifFail: failBlock. selector := methodNode selector. method := methodNode generate. method sourceCode: save. self addSelector: selector withMethod: method. ^selector! compiler ^(MethodWrapperCompiler new) methodClass: CompiledMethodWithSource; yourself! ! !TestBehavior methodsFor: 'private'! defaultSuperclass ^Test! raiseError: aString self class testErrorSignal raiseErrorString: aString! testNamed: aLabel ^self children detect: [:component | component name = aLabel] ifNone: [nil]! ! !TestBehavior methodsFor: 'accessing instances and variables'! classPool | pool | pool := parent notNil ifTrue: [parent classPool copy] ifFalse: [PoolDictionary new]. superclass classPool associationsDo: [:each | pool add: each]. classPool associationsDo: [:each | pool add: each]. ^pool! classVarNames "Answer a Set of the names of the class variables defined in the receiver." ^self classPool keys! ! !TestBehavior methodsFor: 'method dictionary'! removeCategory: aString (self organization listAtCategoryNamed: aString asSymbol) do: [:sel | self removeSelector: sel]. self organization removeEmptyCategories! removeSelector: aSymbol (methodDict includesKey: aSymbol) ifFalse: [^nil]. super removeSelector: aSymbol. self organization removeElement: aSymbol! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestBehavior class instanceVariableNames: ''! !TestBehavior class methodsFor: 'instance creation'! label: aLabel ^self new initializeWithName: aLabel! ! !TestBehavior class methodsFor: 'initialize'! initialize "self initialize" TestErrorSignal := (Signal genericSignal newSignal) notifierString: 'Invalid name - '; nameClass: self message: #testErrorSignal! ! !TestBehavior class methodsFor: 'accessing'! testErrorSignal ^TestErrorSignal! ! !CoverageEnvironment methodsFor: 'accessing'! setState: aState countDict := Dictionary new. classDict := Dictionary new. aState keysAndValuesDo: [:key :value | | class meta | (key size > 6 and: [(key at: key size - 5) == $ ]) ifTrue: [meta := Smalltalk at: (key copyFrom: 1 to: key size - 6) asSymbol ifAbsent: [nil]. meta isNil ifFalse: [class := meta class]] ifFalse: [class := Smalltalk at: key ifAbsent: [nil]]. class isNil ifFalse: [classDict at: class put: (value collect: [:each | each first]). countDict at: class put: (Dictionary withAll: (value collect: [:each | each first -> each last]))]]! state | counts | counts := Dictionary new. countDict keysAndValuesDo: [:key :value | counts at: key name put: (value associations collect: [:each | Array with: each key with: each value])]. ^counts! ! !RestrictedEnvironment class methodsFor: 'instance creation'! from: anEnvironment | classDict | classDict := Dictionary new. anEnvironment classesDo: [:class | classDict at: class put: (anEnvironment selectorsForClass: class)]. ^(self new) on: classDict; yourself! ! Object subclass: #TestInformation instanceVariableNames: 'owner timeStamp testClass ' classVariableNames: '' poolDictionaries: '' category: 'Test-Information'! !TestInformation methodsFor: 'initialize-release'! on: aTest testClass: aTestBehavior testBlock: aBlock owner := aTest class. testClass := aTestBehavior. timeStamp := Timestamp now. self evaluate: aBlock for: aTest! ! !TestInformation methodsFor: 'accessing'! children: aCollection! delete! owner ^owner! presentation ^(TestRecordSpec new) on: self; yourself! resultClass ^TestInformation! suiteResultClass ^TestInformation! timeStamp ^timeStamp! type ^'Unknown'! ! !TestInformation methodsFor: 'executing'! evaluate: aBlock for: aTest ^Object errorSignal handle: [:ex | ex return] do: aBlock! ! !TestInformation methodsFor: 'pass-fail'! failedTests ^OrderedCollection with: self! numPassed ^self numTotal - self failedTests size! numTotal ^1! ! !TestInformation methodsFor: 'printing'! color ^nil! displayString | string color | string := self oneLinePrintString asText. color := self color. color isNil ifTrue: [string allBold] ifFalse: [string emphasizeAllWith: (Array with: #bold with: #color -> color)]. ^string! icon ^self class icon! oneLinePrintOn: aStream aStream nextPutAll: self type; nextPutAll: ': '. owner notNil ifTrue: [aStream print: owner]. timeStamp notNil ifTrue: [aStream nextPutAll: ' run: '; print: timeStamp]! oneLinePrintString "Answer a String whose characters are a one line description of the receiver." | aStream | aStream := WriteStream on: (String new: 16). self oneLinePrintOn: aStream. ^aStream contents! printOn: aStream aStream nextPutAll: self class name; cr; nextPutAll: 'Class: '; nextPutAll: testClass name; cr; nextPutAll: owner class name; nextPutAll: ': '; nextPutAll: owner name; cr; nextPutAll: 'Date and time: '; print: timeStamp! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestInformation class instanceVariableNames: ''! !TestInformation class methodsFor: 'instance creation'! on: testBehavior testClass: aTestBehavior testBlock: aBlock ^self new on: testBehavior testClass: aTestBehavior testBlock: aBlock! ! !TestInformation class methodsFor: 'accessing'! icon ^nil! ! TestInformation subclass: #SavedTestInformation instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Test-Information'! !SavedTestInformation methodsFor: 'initialize-release'! on: aTest testClass: aTestBehavior testBlock: aBlock super on: aTest testClass: aTestBehavior testBlock: aBlock. owner addHistory: self! ! !SavedTestInformation methodsFor: 'accessing'! delete super delete. owner removeRecord: self! ! SavedTestInformation subclass: #TestProfile instanceVariableNames: 'result ' classVariableNames: '' poolDictionaries: '' category: 'Test-Information'! !TestProfile methodsFor: 'accessing'! result ^result! type ^'Profile'! ! !TestProfile methodsFor: 'executing'! evaluate: aBlock for: aTest | profiler | profiler := self profilerClass on: [super evaluate: aBlock for: aTest]. [profiler profile] valueNowOrOnUnwindDo: [| resultStream | resultStream := String new writeStream. profiler reportOn: resultStream cutoffPercent: 1. result := resultStream contents]! ! !TestProfile methodsFor: 'printing'! printOn: aStream super printOn: aStream. aStream cr; cr; nextPutAll: '-------------------'; cr; nextPutAll: result! ! !TestProfile methodsFor: 'private'! profilerClass ^TimeProfiler! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestProfile class instanceVariableNames: ''! !TestProfile class methodsFor: 'resources'! icon "UIMaskEditor new openOnClass: self andSelector: #icon" ^CachedImage on: (Image extent: 16@16 depth: 1 bitsPerPixel: 1 palette: CoveragePalette monoMaskPalette usingBits: #[0 0 0 0 31 248 0 0 48 12 0 0 97 134 0 0 65 130 0 0 65 130 0 0 65 130 0 0 65 130 0 0 65 130 0 0 64 194 0 0 64 98 0 0 64 50 0 0 96 6 0 0 48 12 0 0 31 248 0 0 0 0 0 0])! ! TestProfile subclass: #TestAllocationProfile instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Test-Information'! !TestAllocationProfile methodsFor: 'accessing'! type ^'Allocation Profile'! ! !TestAllocationProfile methodsFor: 'private'! profilerClass ^AllocationProfiler! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestAllocationProfile class instanceVariableNames: ''! !TestAllocationProfile class methodsFor: 'resources'! icon "UIMaskEditor new openOnClass: self andSelector: #icon" ^CachedImage on: (Image extent: 16@16 depth: 1 bitsPerPixel: 1 palette: CoveragePalette monoMaskPalette usingBits: #[0 0 0 0 0 0 0 0 102 102 0 0 102 102 0 0 127 254 0 0 127 254 0 0 127 254 0 0 127 252 0 0 127 252 0 0 127 254 0 0 127 254 0 0 127 254 0 0 102 102 0 0 102 102 0 0 0 0 0 0 0 0 0 0])! ! SavedTestInformation subclass: #TestCoverage instanceVariableNames: 'coverage ' classVariableNames: '' poolDictionaries: '' category: 'Test-Information'! !TestCoverage methodsFor: 'accessing'! methods ^coverage! presentation ^RefactoringBrowser onEnvironment: (CoverageEnvironment new setState: coverage)! type ^'Coverage'! ! !TestCoverage methodsFor: 'executing'! evaluate: aBlock for: aTest aTest class instrumentation installUsing: CoverageMethodWrapper. [super evaluate: aBlock for: aTest] valueNowOrOnUnwindDo: [aTest class instrumentation uninstall. coverage := aTest class instrumentation state]! ! !TestCoverage methodsFor: 'printing'! printOn: aStream super printOn: aStream.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestCoverage class instanceVariableNames: ''! !TestCoverage class methodsFor: 'resources'! icon ^OpaqueImage figure: self iconImage shape: self iconImageMask! iconImage "UIMaskEditor new openOnClass: self andSelector: #iconImage" ^CachedImage on: (Image extent: 16@16 depth: 2 bitsPerPixel: 2 palette: (MappedPalette withColors: ((Array new: 3) at: 1 put: ColorValue black; at: 2 put: ColorValue red; at: 3 put: ColorValue white; yourself)) usingBits: #[160 0 42 162 160 0 42 130 160 0 34 10 160 0 40 42 170 170 170 170 170 170 170 170 165 85 102 154 165 85 105 106 165 85 105 106 165 85 102 154 170 170 170 170 170 170 170 170 160 0 42 162 160 0 42 130 160 0 34 10 160 0 40 42])! iconImageMask "UIMaskEditor new openOnClass: self andSelector: #iconImageMask" ^CachedImage on: (Image extent: 16@16 depth: 1 bitsPerPixel: 1 palette: CoveragePalette monoMaskPalette usingBits: #[63 130 0 0 63 134 0 0 63 172 0 0 63 152 0 0 0 0 0 0 0 0 0 0 63 164 0 0 63 152 0 0 63 152 0 0 63 164 0 0 0 0 0 0 0 0 0 0 63 130 0 0 63 134 0 0 63 172 0 0 63 152 0 0])! ! ClassOrganizer subclass: #TestOrganizer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Test-Implementation'! !TestOrganizer methodsFor: 'comment'! classComment globalComment == nil ifTrue: [^'(no comment)']. ^globalComment! classComment: aString globalComment := aString! classCommentReferent self shouldNotImplement! classCommentReferent: aRemoteStringOrNil ^self shouldNotImplement! ! Object subclass: #Test instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Test-Implementation'! !Test methodsFor: 'executing'! execute self error: 'No method to execute'! setupForTest! setupTest! tearDownForTest! tearDownTest! ! !Test methodsFor: 'results'! compareResult: aResult signal: aSignal ^aSignal == nil ifTrue: [self result = aResult] ifFalse: [self signal = aSignal]! result ^Object new! signal ^nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Test class instanceVariableNames: ''! !Test class methodsFor: 'accessing'! instrumentation ^CoverageEnvironment new! ! SavedTestInformation subclass: #TestResult instanceVariableNames: 'result signal time passed ' classVariableNames: '' poolDictionaries: '' category: 'Test-Information'! !TestResult methodsFor: 'accessing'! result ^result! type ^'Test'! ! !TestResult methodsFor: 'executing'! evaluate: aBlock for: aTest Object errorSignal handle: [:ex | passed := false] do: [Object errorSignal handle: [:ex | signal := ex signal] do: [time := Time millisecondsToRun: [result := aBlock value]]. passed := aTest compareResult: result signal: signal]! ! !TestResult methodsFor: 'pass-fail'! failedTests ^passed ifTrue: [#()] ifFalse: [Array with: self]! ! !TestResult methodsFor: 'printing'! icon ^passed ifTrue: [self class passedIcon] ifFalse: [self class failedIcon]! oneLinePrintOn: aStream super oneLinePrintOn: aStream. aStream isEmpty ifFalse: [aStream nextPutAll: '--']. aStream nextPutAll: (passed ifTrue: ['Passed'] ifFalse: ['Failed'])! printOn: aStream super printOn: aStream. aStream cr. time notNil ifTrue: [aStream nextPutAll: 'Time: '; print: time; nextPutAll: ' ms'; cr]. signal isNil ifTrue: [aStream nextPutAll: 'Result: '; nextPut: $'; print: result; nextPut: $'] ifFalse: [aStream nextPutAll: 'Signal: '; print: signal]. aStream cr; nextPutAll: (passed ifTrue: ['Passed'] ifFalse: ['Failed'])! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestResult class instanceVariableNames: ''! !TestResult class methodsFor: 'resources'! failedIconImage "UIMaskEditor new openOnClass: self andSelector: #failedIconImage" ^CachedImage on: (Image extent: 16@16 depth: 1 bitsPerPixel: 1 palette: (MappedPalette withColors: ((Array new: 2) at: 1 put: ColorValue white; at: 2 put: ColorValue red; yourself)) usingBits: #[0 0 0 0 112 4 0 0 120 24 0 0 60 48 0 0 14 96 0 0 7 192 0 0 3 128 0 0 7 192 0 0 14 96 0 0 28 48 0 0 56 16 0 0 120 8 0 0 112 0 0 0 32 4 0 0 0 0 0 0 0 0 0 0])! failedIconMask "UIMaskEditor new openOnClass: self andSelector: #failedIconMask" ^CachedImage on: (Image extent: 16@16 depth: 1 bitsPerPixel: 1 palette: CoveragePalette monoMaskPalette usingBits: #[0 0 0 0 112 4 0 0 120 24 0 0 60 48 0 0 14 96 0 0 7 192 0 0 3 128 0 0 7 192 0 0 14 96 0 0 28 48 0 0 56 16 0 0 120 8 0 0 112 0 0 0 32 4 0 0 0 0 0 0 0 0 0 0])! passedIcon "UIMaskEditor new openOnClass: self andSelector: #passedIcon" ^CachedImage on: (Image extent: 19@18 depth: 1 bitsPerPixel: 1 palette: CoveragePalette monoMaskPalette usingBits: #[0 0 0 0 0 0 0 0 0 2 0 0 0 4 0 0 0 8 0 0 0 16 0 0 0 32 0 0 0 64 0 0 32 128 0 0 113 128 0 0 59 0 0 0 30 0 0 0 14 0 0 0 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0])! ! !TestResult class methodsFor: 'accessing'! failedIcon ^OpaqueImage figure: self failedIconImage shape: self failedIconMask! ! TestBehavior subclass: #TestSuiteBehavior instanceVariableNames: 'children ' classVariableNames: '' poolDictionaries: '' category: 'Test-Implementation'! !TestSuiteBehavior methodsFor: 'initialize-release'! initializeWithSuper: aClass name: aName children := OrderedCollection new. ^super initializeWithSuper: aClass name: aName! ! !TestSuiteBehavior methodsFor: 'test accessing'! addSubclassWithName: aString | test | (self subclasses contains: [:each | each name = aString]) ifTrue: [self class testErrorSignal raiseErrorString: 'Class ' , aString , ' already exists']. test := TestSuiteBehavior label: aString. test assignSuperclass: self. ^test! addSuiteWithName: aString (self testNamed: aString) notNil ifTrue: [self class testErrorSignal raiseErrorString: 'Test ' , name , ' already exists']. ^self addTest: (TestSuiteBehavior label: aString)! addTestWithName: aString (self testNamed: aString) notNil ifTrue: [self class testErrorSignal raiseErrorString: 'Test ' , aString , ' already exists']. ^self addTest: (TestBehavior label: aString)! children ^children! ! !TestSuiteBehavior methodsFor: 'testing'! isSuite ^true! ! !TestSuiteBehavior methodsFor: 'executing'! executeForResult self executeForHistory: TestSuiteResult! ! !TestSuiteBehavior methodsFor: 'printing'! displayString ^self isEmpty ifTrue: [name asText emphasizeAllWith: #(#bold #italic)] ifFalse: [name asText allBold]! ! !TestSuiteBehavior methodsFor: 'private'! addTest: aTestObject | subclassTests | subclassTests := self subclasses inject: OrderedCollection new into: [:col :each | col addAll: (each subclassTestNamed: aTestObject name); yourself]. (subclassTests inject: true into: [:bool :each | bool and: [each isSuite = aTestObject isSuite]]) ifFalse: [self raiseError: 'Naming conflict in hierarchy']. self primAddTest: aTestObject. subclassTests do: [:each | each assignSuperclass: aTestObject]. self subclasses do: [:each | (each testNamed: aTestObject name) isNil ifTrue: [each addTest: ((aTestObject class label: aTestObject name) assignSuperclass: aTestObject; yourself)]]. ^aTestObject! defaultSuperclass ^TestSuite! primAddTest: aTest aTest parent: self. children add: aTest! removeTest: aTest aTest parent: nil. ^children remove: aTest ifAbsent: [nil]! setupClassVariable parent isNil ifTrue: [(self classPool associationAt: #class ifAbsent: [[:e | ]]) value: (Smalltalk at: name asSymbol ifAbsent: [nil])]! subclassTestNamed: aName | aTest | aTest := children detect: [:each | each name = aName] ifNone: [nil]. ^aTest isNil ifTrue: [children inject: OrderedCollection new into: [:col :each | col addAll: (each subclassTestNamed: aName); yourself]] ifFalse: [Array with: aTest]! ! !TestSuiteBehavior methodsFor: 'copying'! postCopy children := children collect: [:each | each copy]! ! !TestSuiteBehavior methodsFor: 'creating class hierarchy'! assignSuperclass: aClass super assignSuperclass: aClass. superclass == self defaultSuperclass ifTrue: [^self]. superclass children do: [:each | | test | test := self testNamed: each name. test isSuite = each isSuite ifFalse: [test removeSelf. test := nil]. test isNil ifTrue: [test := each class label: each name]. test assignSuperclass: each]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestSuiteBehavior class instanceVariableNames: ''! !TestSuiteBehavior class methodsFor: 'instance creation'! createRootLabeled: aLabel ^(self label: aLabel) addVariable: #class; yourself! ! SavedTestInformation subclass: #TestSuiteResult instanceVariableNames: 'results ' classVariableNames: '' poolDictionaries: '' category: 'Test-Information'! !TestSuiteResult methodsFor: 'accessing'! children: aCollection results := aCollection asArray! delete super delete. results do: [:each | each delete]! resultClass ^TestResult! suiteResultClass ^TestSuiteResult! type ^'Test suite'! ! !TestSuiteResult methodsFor: 'pass-fail'! failedTests "Answer a collection of the path strings of Tests descended from the owner of the receiver that failed." ^results inject: OrderedCollection new into: [:col :each | col addAll: each failedTests; yourself]! numTotal "Answer the number of Tests which are descendants of the owner of the receiver." ^results inject: 0 into: [:subtotal :next | subtotal + next numTotal]! ! !TestSuiteResult methodsFor: 'printing'! icon ^self numPassed = self numTotal ifTrue: [TestResult passedIcon] ifFalse: [TestResult failedIcon]! oneLinePrintOn: aStream super oneLinePrintOn: aStream. aStream nextPutAll: '--'; print: self numPassed; nextPutAll: '/'; print: self numTotal! printOn: aStream super printOn: aStream. aStream cr; nextPutAll: 'Total tests: '; print: self numTotal; cr; nextPutAll: 'Number of tests passed: '; print: self numPassed! ! !BrowserApplicationModel methodsFor: 'private'! initializeMenu: aMenu using: aController "Hack aMenu so that it can be installed into window, and still send us the messages instead of sending them to the window's model." aMenu values: (aMenu values collect: [:each | (#(#find #replace #undo #copySelection #cut #paste #doIt #printIt #inspectIt #hardcopy) includes: each) ifTrue: [[aController perform: each]] ifFalse: [each isSymbol ifTrue: [each numArgs == 1 ifTrue: [[self perform: each with: aController]] ifFalse: [each numArgs == 2 ifTrue: [[self perform: each with: aController text with: aController]] ifFalse: [[self perform: each]]]] ifFalse: [each]]]). aMenu menuItems do: [:each | each submenu notNil ifTrue: [each submenu: (self initializeMenu: each submenu using: aController)]]. ^aMenu! ! !BrowserApplicationModel methodsFor: 'widget properties'! controllerFor: aSymbol | wrapper | builder isNil ifTrue: [^nil]. wrapper := builder componentAt: aSymbol. wrapper isNil ifTrue: [^nil]. ^wrapper widget controller! ! !EnvironmentEditor methodsFor: 'accessing'! menu ^ [| menu | menu := Menu new. (builder componentAt: #categoryList) isVisible ifTrue: [menu addItem: ((MenuItem labeled: 'Ca&tegory') submenu: [self initializeMenu: (builder menuAt: #categoryMenu)])]. (builder componentAt: #classList) isVisible ifTrue: [menu addItem: ((MenuItem labeled: '&Class') submenu: [self initializeMenu: (builder menuAt: #classMenu)])]. (builder componentAt: #protocolList) isVisible ifTrue: [menu addItem: ((MenuItem labeled: '&Protocol') submenu: [self initializeMenu: (builder menuAt: #protocolMenu)])]. (builder componentAt: #selectorList) isVisible ifTrue: [menu addItem: ((MenuItem labeled: '&Selector') submenu: [self initializeMenu: (builder menuAt: #selectorMenu)])]. menu]! ! BrowserApplicationModel subclass: #TestPresentation instanceVariableNames: 'test ' classVariableNames: '' poolDictionaries: '' category: 'Test-Presentations'! !TestPresentation methodsFor: 'initialize-release'! resetTest! test: aTest aTest == test ifFalse: [test := aTest. self resetTest]! ! !TestPresentation methodsFor: 'accessing'! menu ^nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestPresentation class instanceVariableNames: ''! !TestPresentation class methodsFor: 'interface specs'! windowSpec "UIPainter new openOnClass: self andSelector: #windowSpec" ^#(#FullSpec #window: #(#WindowSpec #label: 'Unlabeled Canvas' #bounds: #(#Rectangle 564 420 780 630 ) ) #component: #(#SpecCollection #collection: #() ) )! ! TestPresentation subclass: #TestCoveragePresentation instanceVariableNames: 'environmentEditor ' classVariableNames: '' poolDictionaries: '' category: 'Test-Presentations'! !TestCoveragePresentation methodsFor: 'initialize-release'! release self setCoverage. self environmentEditor release. super release! resetTest self environmentEditor environment: (test notNil ifTrue: [test instrumentation] ifFalse: [CoverageEnvironment new])! test: aTest aTest == test ifFalse: [self setCoverage. test := aTest. self resetTest]! ! !TestCoveragePresentation methodsFor: 'accessing'! environmentEditor "This method was generated by UIDefiner. Any edits made here may be lost whenever methods are automatically defined. The initialization provided below may have been preempted by an initialize method." ^environmentEditor isNil ifTrue: [environmentEditor := EnvironmentEditor new] ifFalse: [environmentEditor]! menu ^self environmentEditor menu! ! !TestCoveragePresentation methodsFor: 'private'! setCoverage test isNil ifTrue: [^self]. self environmentEditor environment isEmpty ifTrue: [test instrumentation: nil] ifFalse: [test instrumentation: self environmentEditor environment]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestCoveragePresentation class instanceVariableNames: ''! !TestCoveragePresentation class methodsFor: 'interface specs'! windowSpec "UIPainter new openOnClass: self andSelector: #windowSpec" ^#(#FullSpec #window: #(#WindowSpec #label: 'Unlabeled Canvas' #bounds: #(#Rectangle 113 196 612 579 ) ) #component: #(#SpecCollection #collection: #( #(#SubCanvasSpec #layout: #(#LayoutFrame 0 0 0 0 0 1 0 1 ) #name: #environmentEditor #flags: 0 #majorKey: #EnvironmentEditor #minorKey: #windowSpec #clientKey: #environmentEditor ) ) ) )! ! BrowserApplicationModel subclass: #TestRecordSpec instanceVariableNames: 'results record ' classVariableNames: '' poolDictionaries: '' category: 'Test-Presentations'! !TestRecordSpec methodsFor: 'initialize-release'! on: aRecord record := aRecord! ! !TestRecordSpec methodsFor: 'aspects'! results ^results isNil ifTrue: [results := record printString asValue] ifFalse: [results]! ! !TestRecordSpec methodsFor: 'accessing'! menu ^(Menu new) addItemLabel: 'No menu' value: #yourself; yourself! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestRecordSpec class instanceVariableNames: ''! !TestRecordSpec class methodsFor: 'interface specs'! windowSpec "UIPainter new openOnClass: self andSelector: #windowSpec" ^#(#FullSpec #window: #(#WindowSpec #label: 'Unlabeled Canvas' #bounds: #(#Rectangle 378 185 785 495 ) ) #component: #(#SpecCollection #collection: #( #(#TextEditorSpec #layout: #(#LayoutFrame 0 0 0 0 0 1 0 1 ) #flags: 5 #model: #results #tabable: true #isReadOnly: true ) ) ) )! ! TestPresentation subclass: #TestCommentPresentation instanceVariableNames: 'comment ' classVariableNames: '' poolDictionaries: '' category: 'Test-Presentations'! !TestCommentPresentation methodsFor: 'initialize-release'! initialize comment := PluggableAdaptor new. comment getBlock: [:m | m comment] putBlock: [:m :v | m comment: v] updateBlock: [:m :a :p | a == #comment]! resetTest comment model: test! ! !TestCommentPresentation methodsFor: 'aspects'! comment ^comment! ! !TestCommentPresentation methodsFor: 'accessing'! menu ^[self initializeMenu: self class commentMenu using: (self controllerFor: #comment)]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestCommentPresentation class instanceVariableNames: ''! !TestCommentPresentation class methodsFor: 'interface specs'! windowSpec "UIPainter new openOnClass: self andSelector: #windowSpec" ^#(#FullSpec #window: #(#WindowSpec #label: 'Unlabeled Canvas' #bounds: #(#Rectangle 337 225 893 636 ) ) #component: #(#SpecCollection #collection: #( #(#TextEditorSpec #layout: #(#LayoutFrame 2 0 27 0 -2 1 -2 1 ) #name: #comment #model: #comment #menu: #commentMenu ) #(#LabelSpec #layout: #(#Point 3 1 ) #label: 'Comment:' ) ) ) )! ! !TestCommentPresentation class methodsFor: 'resources'! commentMenu "UIMenuEditor new openOnClass: self andSelector: #commentMenu" ^#(#Menu #( #(#MenuItem #label: 'find...' ) #(#MenuItem #label: 'replace...' ) #(#MenuItem #label: 'undo' ) #(#MenuItem #label: 'copy' ) #(#MenuItem #label: 'cut' ) #(#MenuItem #label: 'paste' ) #(#MenuItem #label: 'cancel' ) ) #(2 1 3 1 ) #(#find #replace #undo #copySelection #cut #paste #cancel ) ) decodeAsLiteralArray! ! TestPresentation subclass: #TestHistoryPresentation instanceVariableNames: 'history subcanvas ' classVariableNames: '' poolDictionaries: '' category: 'Test-Presentations'! !TestHistoryPresentation methodsFor: 'initialize-release'! release subcanvas release. super release! resetTest self recomputeHistory! ! !TestHistoryPresentation methodsFor: 'actions'! clearResults (Dialog confirm: 'Do you want to erase all results?') ifTrue: [test clearHistory. self recomputeHistory]! removeCurrent (Dialog confirm: 'Do you want to remove this record?') ifTrue: [history value delete. self recomputeHistory]! ! !TestHistoryPresentation methodsFor: 'aspects'! history history isNil ifTrue: [history := self historyRecord asValue. history onChangeSend: #changedHistory to: self]. ^history! historyMenu ^ [| menu | menu := Menu new. test history reverseDo: [:each | | menuItem icon color | menuItem := MenuItem labeled: each displayString. icon := each icon. icon isNil ifFalse: [menuItem labelImage: icon]. color := each color. color isNil ifFalse: [menuItem color: color]. menu addItem: menuItem value: each]. test history size == 0 ifTrue: [menu addItemLabel: self noRecordsLabel value: self noRecordsLabel]. self initializeMenu: menu]! noRecordsLabel ^'no records'! selectHistoryMenu ^ [| menu | menu := Menu new. test history reverseDo: [:each | | menuItem icon color | menuItem := MenuItem labeled: each displayString. icon := each icon. icon isNil ifFalse: [menuItem labelImage: icon]. color := each color. color isNil ifFalse: [menuItem color: color]. menu addItem: menuItem value: [self history value: each]]. test history size == 0 ifTrue: [menu addItemLabel: self noRecordsLabel value: self noRecordsLabel]. self initializeMenu: menu]! ! !TestHistoryPresentation methodsFor: 'interface opening'! postBuildWith: aBuilder | widget | widget := (aBuilder componentAt: #history) widget. widget vcBlock: [:item :menu | item = self noRecordsLabel ifTrue: [Label with: item] ifFalse: [| label icon | label := LabelAndIcon with: item displayString attributes: widget textStyle. icon := item icon. icon isNil ifFalse: [label icon: icon]. label]]. "This is a hack to get the menu button to initially display the icons." widget setLabel: self historyRecord. super postBuildWith: aBuilder! preBuildWith: aBuilder | spec | super preBuildWith: aBuilder. spec := self subSpec class windowSpec. aBuilder subCanvasAt: #History at: #windowSpec put: spec! ! !TestHistoryPresentation methodsFor: 'private'! changedHistory self installSubcanvasIn: #historySpec using: self subSpec! historyRecord ^test history isEmpty ifTrue: [self noRecordsLabel] ifFalse: [test history last]! recomputeHistory self history value: self historyRecord! subSpec subcanvas notNil ifTrue: [subcanvas release]. ^subcanvas := self history value = self noRecordsLabel ifTrue: [TestPresentation new] ifFalse: [history value presentation]! ! !TestHistoryPresentation methodsFor: 'accessing'! menu ^(Menu new) addItem: ((MenuItem labeled: '&Records') submenu: self selectHistoryMenu); addItem: ((MenuItem labeled: '&Tool') submenu: [subcanvas isNil ifTrue: [(Menu new) addItemLabel: 'No menu' value: #yourself; yourself] ifFalse: [subcanvas menu value]]); yourself! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestHistoryPresentation class instanceVariableNames: ''! !TestHistoryPresentation class methodsFor: 'interface specs'! windowSpec "UIPainter new openOnClass: self andSelector: #windowSpec" ^#(#FullSpec #window: #(#WindowSpec #label: 'Unlabeled Canvas' #bounds: #(#Rectangle 251 339 764 753 ) ) #component: #(#SpecCollection #collection: #( #(#SubCanvasSpec #layout: #(#LayoutFrame 2 0 27 0 -2 1 -35 1 ) #name: #historySpec #majorKey: #History #minorKey: #windowSpec #clientKey: #subSpec ) #(#MenuButtonSpec #layout: #(#LayoutFrame 2 0 2 0 -2 1 25 0 ) #name: #history #model: #history #menu: #historyMenu ) #(#ActionButtonSpec #layout: #(#AlignmentOrigin 0 0.333333 -33 1 0.5 0 ) #model: #removeCurrent #label: 'Remove current' #defaultable: true ) #(#ActionButtonSpec #layout: #(#AlignmentOrigin 0 0.666666 -33 1 0.5 0 ) #model: #clearResults #label: 'Clear results' #defaultable: true ) ) ) )! ! !RefactoringBrowser methodsFor: 'initialize-release'! release navigator release. tools do: [:each | each release]. super release! ! !RefactoringBrowser methodsFor: 'accessing'! menu ^self initializeMenu: self menuBar! ! !RefactoringBrowser methodsFor: 'events'! noticeOfWindowClose: aWindow navigator closed. self release. ^super noticeOfWindowClose: aWindow! ! !RefactoringBrowser methodsFor: 'interface opening'! postOpenWith: aBuilder | envPrintString | envPrintString := self environment printString. aBuilder window label: 'Browser - ' , (envPrintString copyFrom: 1 to: (self maxLabelLength min: envPrintString size)). builder window application: self. builder window sendWindowEvents: #(#newGraphicsDevice #reopen). ^super postBuildWith: aBuilder! ! RefactoringBrowser removeSelector: #postBuildWith:! !RefactoringBrowser class methodsFor: 'instance creation'! onEnvironment: anEnvironment | browser | browser := self new. browser initializeOnEnvironment: anEnvironment. horizontal ifTrue: [browser beHorizontal] ifFalse: [browser beVertical]. browser policyClass: StateLockPolicy. ^browser! ! !RefactoringBrowser class methodsFor: 'interface opening'! openOnEnvironment: anEnvironment spec: aSpec | browser | anEnvironment isEmpty ifTrue: [^Dialog warn: 'Nobody']. browser := self onEnvironment: anEnvironment. aSpec == #windowSpec ifTrue: [browser beHorizontal] ifFalse: [browser beVertical]. browser openInterface: aSpec. browser currentBuffer value tool updateContents. ^browser! ! RefactoringBrowser class reorganizeFromString: '(''interface specs'' #horizontalNavigator #verticalNavigator #verticalWindowSpec #windowSpec) (''accessing'' #beHorizontal #beMultiWindow #beSingleWindow #beVertical #browserType #isMultiWindow) (''instance creation'' #onEnvironment:) (''interface opening'' #open #openHorizontal #openMultiOnEnvironment:spec: #openMultiWindowHorizontal #openMultiWindowVertical #openOnEnvironment: #openOnEnvironment:spec: #openVertical) '! BrowserApplicationModel subclass: #TestManager instanceVariableNames: 'notebook testSuites rootSuite presentation classList lastTab ' classVariableNames: '' poolDictionaries: '' category: 'Test-Presentations'! !TestManager methodsFor: 'initialize-release'! initialize rootSuite := TestSuiteBehavior createRootLabeled: 'root'. self reset. presentation := TestPresentation new. presentation test: rootSuite. self addDependent: presentation! ! !TestManager methodsFor: 'actions-class'! addClass self changeRequest ifFalse: [^self]. self handleTestError: [| name test suite | suite := classList selection. name := Dialog request: 'Enter name for class'. name = '' ifFalse: [test := suite addSubclassWithName: name. classList list add: test. classList list sortWith: self classSortBlock. classList selection: test]]! addHierarchy self changeRequest ifFalse: [^self]. self handleTestError: [| name test class | name := Dialog request: 'Enter name for class'. name = '' ifFalse: [class := Smalltalk at: name asSymbol ifAbsent: [nil]. class isBehavior ifFalse: [Dialog warn: name , ' is not a class name.'] ifTrue: [test := self addClassFor: class under: classList selection. classList list addAll: test withAllSubclasses. classList list sortWith: self classSortBlock. classList selection: test]]]! allocationProfileClass self changeRequest ifTrue: [classList selection withAllSubclasses do: [:each | each executeForAllocationProfile]]! coverageClass self changeRequest ifTrue: [classList selection withAllSubclasses do: [:each | each executeForCoverage]]! load | file | file := Dialog requestFileName: 'Enter file to load: ' default: '*.tm'. file isEmpty ifTrue: [^self]. file notNil ifTrue: [Cursor wait showWhile: [| boss | boss := BinaryObjectStorage onOld: file asFilename readStream. [rootSuite := boss next] valueNowOrOnUnwindDo: [boss close]. self reset]]! profileClass self changeRequest ifTrue: [classList selection withAllSubclasses do: [:each | each executeForProfile]]! removeClass self changeRequest ifFalse: [^self]. self handleTestError: [| test list | test := classList selection. (Dialog confirm: 'Do you want to remove ' , test name) ifTrue: [test removeSelf. list := List withAll: rootSuite withAllSubclasses. list sortWith: self classSortBlock. classList list: list. classList selection: test superclass]]! renameClass self changeRequest ifFalse: [^self]. self handleTestError: [| test name | test := classList selection. name := Dialog request: 'Enter new name' initialAnswer: test name. name = '' ifFalse: [(test isRoot or: [(test superclass testNamed: name) isNil]) ifTrue: [test name: name. testSuites list sortWith: self classSortBlock. testSuites selection: test]]]! runClass self changeRequest ifTrue: [classList selection withAllSubclasses do: [:each | each executeForResult]]! save | file | file := Dialog requestNewFileName: 'Enter filename to save: ' default: '*.tm'. file isEmpty ifTrue: [^self]. file := file asFilename. Cursor wait showWhile: [| boss | boss := BinaryObjectStorage onNew: file writeStream. [boss nextPut: rootSuite] valueNowOrOnUnwindDo: [boss close]]! ! !TestManager methodsFor: 'actions-tests'! addSuite self changeRequest ifFalse: [^self]. self handleTestError: [| name suite newSuite | suite := testSuites selection. name := Dialog request: 'Enter name for test suite'. name = '' ifFalse: [newSuite := suite addSuiteWithName: name. testSuites list add: newSuite. testSuites list sortWith: self sortBlock. testSuites selection: newSuite]]! addTest self changeRequest ifFalse: [^self]. self handleTestError: [| name test suite | suite := testSuites selection. name := Dialog request: 'Enter name for test'. name = '' ifFalse: [test := suite addTestWithName: name. testSuites list add: test. testSuites list sortWith: self sortBlock. testSuites selection: test]]! allocationProfileTest self changeRequest ifTrue: [testSuites selection executeForAllocationProfile]! coverageTest self changeRequest ifTrue: [testSuites selection executeForCoverage]! profileTest self changeRequest ifTrue: [testSuites selection executeForProfile]! removeTest self changeRequest ifFalse: [^self]. self handleTestError: [| test list children parent | test := testSuites selection. (Dialog confirm: 'Do you want to remove ' , test name) ifTrue: [children := test allChildren. parent := test parent. test removeSelf. list := testSuites list copy. list removeAllSuchThat: [:each | children includes: each]. list remove: test. list sortWith: self sortBlock. testSuites list: list. testSuites selection: parent]]! renameTest self changeRequest ifFalse: [^self]. self handleTestError: [| test name | test := testSuites selection. name := Dialog request: 'Enter new name' initialAnswer: test name. name = '' ifFalse: [(test isRoot or: [(test parent testNamed: name) isNil]) ifTrue: [test name: name. testSuites list sortWith: self sortBlock. testSuites selection: nil. testSuites selection: test]]]! runTest self changeRequest ifTrue: [testSuites selection executeForResult]! ! !TestManager methodsFor: 'aspects'! classList classList isNil ifTrue: [classList := SelectionInList new. classList selectionIndexHolder onChangeSend: #updateTestSuites to: self]. ^classList! notebook notebook isNil ifTrue: [notebook := SelectionInList new. notebook selectionIndexHolder onChangeSend: #changedTab to: self]. ^notebook! testSuites testSuites isNil ifTrue: [testSuites := SelectionInList new. testSuites selectionIndexHolder onChangeSend: #updateNotebook to: self]. ^testSuites! ! !TestManager methodsFor: 'changed'! changedTab | test class | notebook selection isNil ifFalse: [lastTab := notebook selection]. test := testSuites selection. self removeDependent: presentation. presentation release. test notNil & (notebook selectionIndex > 0) ifTrue: [class := Smalltalk at: (test tabs detect: [:each | each first = lastTab]) last ifAbsent: [TestPresentation]] ifFalse: [class := TestPresentation]. presentation := class new. presentation test: test. self addDependent: presentation. (self builder componentAt: #notebook) widget client: presentation spec: #windowSpec! ! !TestManager methodsFor: 'menu'! classMenu ^ [| menu class | menu := self class classMenu. class := classList selection. self enableMenu: menu except: (class isNil ifTrue: [#('add class...' 'add class hierarchy...' 'remove...' 'rename as...' 'run' 'coverage' 'profile' 'allocation profile')] ifFalse: [class == rootSuite ifTrue: [#('remove...')] ifFalse: [#()]]). menu]! menuBar | menu | menu := (Menu new) addItem: ((MenuItem labeled: '&Class') submenu: self classMenu); addItem: ((MenuItem labeled: '&Test') submenu: self testSuitesMenu); addItem: ((MenuItem labeled: '&Notebook') submenu: [| submenu | submenu := presentation menu value. submenu isNil ifTrue: [submenu := (Menu new) addItemLabel: 'No menu' value: #yourself; yourself]. submenu]). ^menu! testSuitesMenu ^ [| menu test suiteLabels notNilLabels rootLabels | menu := self class testSuitesMenu. test := testSuites selection. suiteLabels := #('add test suite...' 'add test...' 'expand' 'expand fully' 'contract'). notNilLabels := #('remove...' 'rename as...' 'run' 'coverage' 'profile' 'allocation profile'). rootLabels := #('remove...' 'rename as...'). self enableMenu: menu except: (test isNil ifTrue: [suiteLabels , notNilLabels] ifFalse: [(test isSuite ifTrue: [#()] ifFalse: [suiteLabels]) , (test isRoot ifTrue: [rootLabels] ifFalse: [#()])]). menu]! ! !TestManager methodsFor: 'interface opening'! postBuildWith: aBuilder | suitesBlock classBlock | super postBuildWith: aBuilder. suitesBlock := [:view :index | | each | each := view sequence at: index. Label with: each displayString attributes: view textStyle offset: each allParents size * 10 @ 0]. classBlock := [:view :index | | each | each := view sequence at: index. Label with: each displayString attributes: view textStyle offset: each allSuperclasses size * 10 @ 0]. ((builder componentAt: #testSuites) widget) visualBlock: [:view :index | BoundingWrapper on: (suitesBlock value: view value: index)]; selectedVisualBlock: [:view :index | | rw | rw := ReversingWrapper on: (suitesBlock value: view value: index). rw reverse setValue: true. BoundedWrapper on: rw]. ((aBuilder componentAt: #classList) widget) visualBlock: [:view :index | BoundingWrapper on: (classBlock value: view value: index)]; selectedVisualBlock: [:view :index | | rw | rw := ReversingWrapper on: (classBlock value: view value: index). rw reverse setValue: true. BoundedWrapper on: rw]! postOpenWith: aBuilder super postOpenWith: aBuilder. self updateNotebook! ! !TestManager methodsFor: 'private'! addClassFor: aBehavior under: aSuite | test | test := aSuite addSubclassWithName: aBehavior name. aBehavior subclasses do: [:each | self addClassFor: each under: test]. ^test! classSortBlock ^ [:v :e | | common e1 v1 | v = e or: [(v includesBehavior: e) not and: [(e includesBehavior: v) or: [common := e commonSuperclass: v. e1 := e. [e1 superclass = common] whileFalse: [e1 := e1 superclass]. v1 := v. [v1 superclass = common] whileFalse: [v1 := v1 superclass]. v1 name < e1 name]]]]! handleTestError: aBlock TestBehavior testErrorSignal handle: [:ex | Dialog warn: ex errorString. ex return] do: aBlock! reset | newClassList | newClassList := List withAll: rootSuite withAllSubclasses. newClassList sortWith: self classSortBlock. (self classList) list: newClassList; selection: rootSuite! sortBlock ^ [:v :e | | common e1 v1 | v = e or: [(v derivedFrom: e) not and: [(e derivedFrom: v) or: [common := e commonParent: v. e1 := e. [e1 parent = common] whileFalse: [e1 := e1 parent]. v1 := v. [v1 parent = common] whileFalse: [v1 := v1 parent]. v1 name < e1 name]]]]! updateListAfter: aBlock self testSuites selectionIndexHolder retractInterestsFor: self. aBlock valueNowOrOnUnwindDo: [self testSuites selectionIndexHolder onChangeSend: #updateNotebook to: self. self updateNotebook]! updateNotebook | test list | test := testSuites selection. builder notNil ifTrue: [test isNil ifTrue: [notebook list: List new] ifFalse: [list := test tabs collect: [:each | each first]. notebook list = list ifFalse: [notebook list: list]. notebook selection: (lastTab isNil ifTrue: [list first] ifFalse: [(list includes: lastTab) ifTrue: [lastTab] ifFalse: [list first]]). notebook selectionIndex = 0 ifTrue: [notebook selectionIndex: 1]]]! updateTestSuites self updateListAfter: [| class suite | class := classList selection. suite := self testSuites selection. suite isNil ifFalse: [suite := suite topSuperclass]. class notNil ifTrue: [testSuites list: ((List withAll: (Array with: class) , class allChildren) sortWith: self sortBlock; yourself). testSuites selection: (suite notNil ifTrue: [testSuites list detect: [:each | each includesBehavior: suite] ifNone: [class]] ifFalse: [class])] ifFalse: [testSuites list: List new]]! ! !TestManager methodsFor: 'events'! noticeOfWindowClose: aWindow presentation release. ^super noticeOfWindowClose: aWindow! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestManager class instanceVariableNames: ''! !TestManager class methodsFor: 'interface specs'! windowSpec "UIPainter new openOnClass: self andSelector: #windowSpec" ^#(#FullSpec #window: #(#WindowSpec #label: 'Test Manager' #min: #(#Point 640 400 ) #bounds: #(#Rectangle 271 196 911 596 ) #flags: 4 #menu: #menuBar ) #component: #(#SpecCollection #collection: #( #(#SequenceViewSpec #layout: #(#LayoutFrame 2 0 2 0 148 0 -1 0.5 ) #name: #classList #flags: 15 #model: #classList #callbacksSpec: #(#UIEventCallbackSubSpec #requestValueChangeSelector: #changeRequest ) #menu: #classMenu #multipleSelections: false ) #(#SequenceViewSpec #layout: #(#LayoutFrame 2 0 1 0.5 148 0 -2 1 ) #name: #testSuites #flags: 15 #model: #testSuites #callbacksSpec: #(#UIEventCallbackSubSpec #requestValueChangeSelector: #changeRequest ) #menu: #testSuitesMenu ) #(#NoteBookSpec #layout: #(#LayoutFrame 153 0 2 0 -2 1 -2 1 ) #name: #notebook #model: #notebook #callbacksSpec: #(#UIEventCallbackSubSpec #requestValueChangeSelector: #changeRequest ) #binderSide: #top #binderWidth: 14 #majorTabsOnRight: false #rightInset: 0 #bottomInset: 26 ) #(#DividerSpec #layout: #(#LayoutFrame 150 0 0 0 151 0 0 1 ) #orientation: #vertical ) ) ) )! ! !TestManager class methodsFor: 'resources'! classMenu "UIMenuEditor new openOnClass: self andSelector: #classMenu" ^#(#Menu #( #(#MenuItem #rawLabel: '&add class...' #value: #addClass ) #(#MenuItem #rawLabel: 'add class &hierarchy...' #value: #addHierarchy ) #(#MenuItem #rawLabel: '&remove...' #value: #removeClass ) #(#MenuItem #rawLabel: 're&name as...' #value: #renameClass ) #(#MenuItem #rawLabel: 'r&un' #value: #runClass ) #(#MenuItem #rawLabel: 'coverage' #value: #coverageClass ) #(#MenuItem #rawLabel: 'profile' #value: #profileClass ) #(#MenuItem #rawLabel: 'allocation profile' #value: #allocationProfileClass ) #(#MenuItem #rawLabel: 'open...' #value: #load ) #(#MenuItem #rawLabel: 'save...' #value: #save ) ) #(4 4 2 ) nil ) decodeAsLiteralArray! generateMainMenu "UIMenuEditor new openOnClass: self andSelector: #generateMainMenu" ^#(#Menu #( #(#MenuItem #rawLabel: '&Class' #submenu: #(#Menu #( #(#MenuItem #rawLabel: '&add class...' #value: #addClass ) #(#MenuItem #rawLabel: 'add class &hierarchy...' #value: #addHierarchy ) #(#MenuItem #rawLabel: '&remove...' #value: #removeClass ) #(#MenuItem #rawLabel: 're&name as...' #value: #renameClass ) #(#MenuItem #rawLabel: 'r&un' #value: #runClass ) #(#MenuItem #rawLabel: 'coverage' #value: #coverageClass ) #(#MenuItem #rawLabel: 'profile' #value: #profileClass ) #(#MenuItem #rawLabel: 'allocation profile' #value: #allocationProfileClass ) #(#MenuItem #rawLabel: 'open...' #value: #load ) #(#MenuItem #rawLabel: 'save...' #value: #save ) ) #(4 4 2 ) nil ) ) #(#MenuItem #rawLabel: '&Test' #submenu: #(#Menu #( #(#MenuItem #rawLabel: '&add test suite...' #value: #addSuite ) #(#MenuItem #rawLabel: 'add &test...' #value: #addTest ) #(#MenuItem #rawLabel: '&remove...' #value: #removeTest ) #(#MenuItem #rawLabel: 're&name as...' #value: #renameTest ) #(#MenuItem #rawLabel: 'r&un' #value: #runTest ) #(#MenuItem #rawLabel: 'coverage' #value: #coverageTest ) #(#MenuItem #rawLabel: 'profile' #value: #profileTest ) #(#MenuItem #rawLabel: 'allocation profile' #value: #allocationProfileTest ) ) #(4 4 ) nil ) ) ) #(2 ) nil ) decodeAsLiteralArray! testSuitesMenu "UIMenuEditor new openOnClass: self andSelector: #testSuitesMenu" ^#(#Menu #( #(#MenuItem #rawLabel: '&add test suite...' #value: #addSuite ) #(#MenuItem #rawLabel: 'add &test...' #value: #addTest ) #(#MenuItem #rawLabel: '&remove...' #value: #removeTest ) #(#MenuItem #rawLabel: 're&name as...' #value: #renameTest ) #(#MenuItem #rawLabel: 'r&un' #value: #runTest ) #(#MenuItem #rawLabel: 'coverage' #value: #coverageTest ) #(#MenuItem #rawLabel: 'profile' #value: #profileTest ) #(#MenuItem #rawLabel: 'allocation profile' #value: #allocationProfileTest ) ) #(4 4 ) nil ) decodeAsLiteralArray! ! TestPresentation subclass: #TestCodePresentation instanceVariableNames: 'variables protocol code acceptCode displayedCode selector ' classVariableNames: '' poolDictionaries: '' category: 'Test-Presentations'! !TestCodePresentation methodsFor: 'initialize-release'! initialize super initialize. self protocol selectionHolder onChangeSend: #changedProtocol to: self. self selector selectionHolder onChangeSend: #changedSelector to: self. code := String new asValue. acceptCode := false asValue. displayedCode := BufferedValueHolder subject: code triggerChannel: acceptCode! release self protocol selectionHolder retractInterestsFor: self. self selector selectionHolder retractInterestsFor: self. super release! resetTest self newProtocolList: nil. self variables list: (List withAll: test variables asSortedCollection)! ! !TestCodePresentation methodsFor: 'actions-variable'! addVariable | name | name := Dialog request: 'Enter name for variable'. name = '' ifFalse: [test addVariable: name]. variables list: (List withAll: test variables asSortedCollection)! removeVariable variables selection notNil ifTrue: [(Dialog confirm: 'Do you want to remove ' , variables selection , ' from ' , test name) ifTrue: [test removeVariable: variables selection]]. variables list: (List withAll: test variables asSortedCollection)! variableMenu ^ [| menu | menu := self initializeMenu: self class variableMenu. self variables selection isNil ifTrue: [self enableMenu: menu except: #('remove...')]. menu]! ! !TestCodePresentation methodsFor: 'actions-protocol'! addProtocol | aString newProtocol | self changeRequest ifFalse: [^self]. aString := Dialog request: 'Enter new category name'. aString isEmpty ifTrue: [^self]. newProtocol := aString asSymbol. test addCategory: newProtocol before: protocol selection. self newProtocolList: newProtocol! disabledProtocolMenuItems ^test selectors isEmpty ifTrue: [#('rename as...' 'remove...' 'find method...')] ifFalse: [#('rename as...' 'remove...')]! findMethod "Show a menu of the methods implemented by this class. Select the chosen one." | chosenSelector selectorCollection | self changeRequest ifFalse: [^self]. (selectorCollection := test organization elements asSortedCollection) size = 0 ifTrue: [^self]. chosenSelector := Dialog choose: 'Find which selector?' fromList: selectorCollection values: selectorCollection lines: 20 cancel: [nil]. chosenSelector isNil ifFalse: [self newProtocolList: (test whichCategoryIncludesSelector: chosenSelector). self newSelectorList: chosenSelector]! newProtocolList: aSelection test notNil ifTrue: [protocol list: (List withAll: test organization categories). protocol selection: aSelection]! protocolMenu ^ [| menu | menu := self initializeMenu: self class protocolMenu. self protocol selection isNil ifTrue: [self enableMenu: menu except: self disabledProtocolMenuItems]. menu]! removeProtocol | selectors | self changeRequest ifFalse: [^self]. selectors := test organization listAtCategoryNamed: protocol selection. selectors isEmpty ifFalse: [(Dialog confirm: 'Are you certain that you want to remove all methods in this category?') ifFalse: [^self]. selectors do: [:sel | test removeSelector: sel]]. test organization removeCategory: protocol selection. self newProtocolList: nil! renameProtocol | aString newProtocol | self changeRequest ifFalse: [^self]. aString := Dialog request: 'Enter new category name' initialAnswer: protocol selection. aString isEmpty ifTrue: [^self]. newProtocol := aString asSymbol. (test organization renameCategory: protocol selection to: newProtocol) ifTrue: [self newProtocolList: newProtocol]! ! !TestCodePresentation methodsFor: 'actions-selector'! disabledSelectorMenuItems ^#('senders' 'implementors' 'messages...' 'move to...' 'remove...')! implementors Dialog warn: 'Not implemented...'! messages Dialog warn: 'Not implemented...'! moveSelector | newProtocol sel | self changeRequest ifFalse: [^self]. newProtocol := Dialog request: 'Type destination protocol'. newProtocol isEmpty ifTrue: [^self]. sel := selector selection. newProtocol := newProtocol asSymbol. (test organization categories includes: newProtocol) ifFalse: [test organization addCategory: newProtocol]. self newProtocolList: newProtocol. test organization classify: sel under: newProtocol. self newSelectorList: sel! newSelectorList: initialSelection selector list: (List withAll: (test organization listAtCategoryNamed: protocol selection)). selector selection: initialSelection! removeSelector (self changeRequest and: [Dialog confirm: 'Are you certain that you want to remove this method?']) ifTrue: [test removeSelector: selector selection. self newSelectorList: nil]! selectorMenu ^ [| menu | menu := self initializeMenu: self class selectorMenu. self selector selection isNil ifTrue: [self enableMenu: menu except: self disabledSelectorMenuItems]. menu]! senders Dialog warn: 'Not implemented...'! ! !TestCodePresentation methodsFor: 'actions-code'! acceptMethod | newSelector controller text | controller := (builder componentAt: #code) widget controller. text := controller text. newSelector := test compile: text classified: protocol selection notifying: controller. newSelector == nil ifTrue: [^false]. acceptCode value: true. self newSelectorList: newSelector. ^true! cancelMethod acceptCode value: false! codeMenu ^ [| menu | menu := self initializeMenu: self class codeMenu using: (self controllerFor: #code). self protocol selection isNil ifTrue: [self disableMenu: menu]. menu]! formatMethod | newText controller text | controller := (builder componentAt: #code) widget controller. text := controller text. test isNil ifTrue: [^self]. newText := test compilerClass new format: text in: test notifying: controller. newText isNil ifFalse: [newText := newText asText makeSelectorBoldIn: test. controller selectFrom: 1 to: controller text size; deselect; replaceSelectionWith: newText asText; selectAt: 1]! ! !TestCodePresentation methodsFor: 'updating'! updateRequest ^self code isBuffering ifTrue: [self code value = code value ifTrue: [true] ifFalse: [(Dialog confirm: 'The text showing has been altered. Do you wish to discard those changes?') ifTrue: [acceptCode value: false. true] ifFalse: [false]]] ifFalse: [true]! ! !TestCodePresentation methodsFor: 'changed'! changedProtocol protocol selection isNil ifTrue: [self disableAll: #(#code #selector). selector list: List new] ifFalse: [self enableAll: #(#code #selector). selector list: (List withAll: (test organization listAtCategoryNamed: protocol selection))]! changedSelector self code value: (self selector selection isNil ifTrue: [''] ifFalse: [(test sourceCodeAt: selector selection) asText makeSelectorBoldIn: test]). acceptCode value: true! ! !TestCodePresentation methodsFor: 'aspects'! code ^displayedCode! protocol "This method was generated by UIDefiner. Any edits made here may be lost whenever methods are automatically defined. The initialization provided below may have been preempted by an initialize method." ^protocol isNil ifTrue: [protocol := SelectionInList new] ifFalse: [protocol]! selector "This method was generated by UIDefiner. Any edits made here may be lost whenever methods are automatically defined. The initialization provided below may have been preempted by an initialize method." ^selector isNil ifTrue: [selector := SelectionInList new] ifFalse: [selector]! variables "This method was generated by UIDefiner. Any edits made here may be lost whenever methods are automatically defined. The initialization provided below may have been preempted by an initialize method." ^variables isNil ifTrue: [variables := SelectionInList new] ifFalse: [variables]! ! !TestCodePresentation methodsFor: 'interface opening'! postBuildWith: aBuilder self newProtocolList: nil. ^super postBuildWith: aBuilder! ! !TestCodePresentation methodsFor: 'accessing'! menu | menu | menu := Menu new. menu addItem: ((MenuItem labeled: '&Variables') submenu: self variableMenu). menu addItem: ((MenuItem labeled: '&Protocol') submenu: self protocolMenu). menu addItem: ((MenuItem labeled: '&Selector') submenu: self selectorMenu). menu addItem: ((MenuItem labeled: '&Code') submenu: self codeMenu). ^menu! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestCodePresentation class instanceVariableNames: ''! !TestCodePresentation class methodsFor: 'interface specs'! windowSpec "UIPainter new openOnClass: self andSelector: #windowSpec" ^#(#FullSpec #window: #(#WindowSpec #label: 'Unlabeled Canvas' #bounds: #(#Rectangle 412 281 968 692 ) ) #component: #(#SpecCollection #collection: #( #(#SequenceViewSpec #layout: #(#LayoutFrame 0 0 25 0 0 0.333333 0 0.333333 ) #model: #variables #menu: #variableMenu ) #(#LabelSpec #layout: #(#Point 2 0 ) #label: 'Variables:' ) #(#LabelSpec #layout: #(#LayoutOrigin 2 0.333333 0 0 ) #label: 'Protocol:' ) #(#LabelSpec #layout: #(#LayoutOrigin 2 0.666666 0 0 ) #label: 'Selector:' ) #(#SequenceViewSpec #layout: #(#LayoutFrame 0 0.333333 25 0 0 0.666666 0 0.333333 ) #model: #protocol #menu: #protocolMenu ) #(#SequenceViewSpec #layout: #(#LayoutFrame 0 0.666666 25 0 0 1 0 0.333333 ) #name: #selector #model: #selector #menu: #selectorMenu ) #(#TextEditorSpec #layout: #(#LayoutFrame 0 0 25 0.333333 0 1 0 1 ) #name: #code #model: #code #menu: #codeMenu ) #(#LabelSpec #layout: #(#LayoutOrigin 2 0 0 0.333333 ) #label: 'Code:' ) ) ) )! ! !TestCodePresentation class methodsFor: 'resources'! codeMenu "UIMenuEditor new openOnClass: self andSelector: #codeMenu" ^#(#Menu #( #(#MenuItem #rawLabel: '&find...' #value: #find ) #(#MenuItem #rawLabel: '&replace...' #value: #replace ) #(#MenuItem #rawLabel: '&undo' #value: #undo ) #(#MenuItem #rawLabel: '©' #value: #copySelection ) #(#MenuItem #rawLabel: 'cu&t' #value: #cut ) #(#MenuItem #rawLabel: '&paste' #value: #paste ) #(#MenuItem #rawLabel: '&accept' #value: #acceptMethod ) #(#MenuItem #rawLabel: 'ca&ncel' #value: #cancelMethod ) #(#MenuItem #rawLabel: 'fo&rmat' #value: #formatMethod ) ) #(2 1 3 2 1 ) nil ) decodeAsLiteralArray! protocolMenu "UIMenuEditor new openOnClass: self andSelector: #protocolMenu" ^#(#Menu #( #(#MenuItem #label: 'add...' #accessCharacterPosition: 1 ) #(#MenuItem #label: 'rename as...' #accessCharacterPosition: 3 ) #(#MenuItem #label: 'remove...' #accessCharacterPosition: 1 ) #(#MenuItem #label: 'find method...' #accessCharacterPosition: 1 ) ) #(3 1 ) #(#addProtocol #renameProtocol #removeProtocol #findMethod ) ) decodeAsLiteralArray! selectorMenu "UIMenuEditor new openOnClass: self andSelector: #selectorMenu" ^#(#Menu #( #(#MenuItem #label: 'senders' #accessCharacterPosition: 1 ) #(#MenuItem #label: 'implementors' #accessCharacterPosition: 1 ) #(#MenuItem #label: 'messages...' #accessCharacterPosition: 1 ) #(#MenuItem #label: 'move to...' #accessCharacterPosition: 6 ) #(#MenuItem #label: 'remove...' #accessCharacterPosition: 1 ) ) #(3 2 ) #(#senders #implementors #messages #moveSelector #removeSelector ) ) decodeAsLiteralArray! variableMenu "UIMenuEditor new openOnClass: self andSelector: #variableMenu" ^#(#Menu #( #(#MenuItem #label: 'add...' ) #(#MenuItem #label: 'remove...' ) ) #(2 ) #(#addVariable #removeVariable ) ) decodeAsLiteralArray! ! Object subclass: #TestRunner instanceVariableNames: 'parent children test testBehavior result ' classVariableNames: '' poolDictionaries: '' category: 'Test-Implementation'! !TestRunner methodsFor: 'initialize-release'! children: aCollection children := aCollection. children do: [:each | each parent: self]. result children: (children collect: [:each | each result])! on: aTestBehavior using: testInfoClass testBehavior := aTestBehavior. test := testBehavior new. result := testInfoClass new! parent: aTestRunner parent := aTestRunner! ! !TestRunner methodsFor: 'executing'! execute self topParent primExecute! ! !TestRunner methodsFor: 'accessing'! result ^result! ! !TestRunner methodsFor: 'private'! children children isNil ifTrue: [self children: (testBehavior children collect: [:each | TestRunner on: each using: (each isSuite ifTrue: [result suiteResultClass] ifFalse: [result resultClass])])]. ^children! primExecute test setupTest. testBehavior isSuite ifTrue: [result on: test testClass: testBehavior testClass testBlock: [self children do: [:each | each primExecute]]] ifFalse: [self setupForTest. [result on: test testClass: testBehavior testClass testBlock: [test execute]] valueNowOrOnUnwindDo: [self tearDownForTest]]. test tearDownTest. test class nilVariables! setupForTest parent notNil ifTrue: [parent setupForTest]. test setupForTest! tearDownForTest test tearDownForTest. parent notNil ifTrue: [parent tearDownForTest]! topParent ^testBehavior parent isNil ifTrue: [self] ifFalse: [((TestRunner on: testBehavior parent using: TestInformation) children: (Array with: self); yourself) topParent]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestRunner class instanceVariableNames: ''! !TestRunner class methodsFor: 'instance creation'! on: aTestBehavior using: testInformationClass ^self new on: aTestBehavior using: testInformationClass! ! TestBehavior initialize!