[squeak-dev] The Trunk: TraitsTests-ar.1.mczcommits at source.squeak.org commits at source.squeak.orgThu Dec 31 14:57:41 UTC 2009
Andreas Raab uploaded a new version of TraitsTests to project The Trunk: http://source.squeak.org/trunk/TraitsTests-ar.1.mcz ==================== Summary ==================== Name: TraitsTests-ar.1 Author: ar Time: 31 December 2009, 3:57:32 am UUID: e4d14d09-2f43-1e44-b244-ed76a3641e1e Ancestors: Put traits tests back as separate package. ==================== Snapshot ==================== SystemOrganization addCategory: #'TraitsTests-Kernel'! TestResource subclass: #TraitsResource instanceVariableNames: 'createdClassesAndTraits t1 t2 t3 t4 t5 t6 c1 c2 c3 c4 c5 c6 c7 c8 dirty' classVariableNames: 'SetUpCount' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitsResource class>>resetIfDirty (in category 'as yet unclassified') ----- resetIfDirty self current isDirty ifTrue: [self reset]! ----- Method: TraitsResource>>c1 (in category 'accessing') ----- c1 ^c1! ----- Method: TraitsResource>>c1: (in category 'accessing') ----- c1: anObject ^c1 := anObject! ----- Method: TraitsResource>>c2 (in category 'accessing') ----- c2 ^c2! ----- Method: TraitsResource>>c2: (in category 'accessing') ----- c2: anObject ^c2 := anObject! ----- Method: TraitsResource>>c3 (in category 'accessing') ----- c3 ^c3! ----- Method: TraitsResource>>c3: (in category 'accessing') ----- c3: anObject ^c3 := anObject! ----- Method: TraitsResource>>c4 (in category 'accessing') ----- c4 ^c4! ----- Method: TraitsResource>>c4: (in category 'accessing') ----- c4: anObject ^c4 := anObject! ----- Method: TraitsResource>>c5 (in category 'accessing') ----- c5 ^c5! ----- Method: TraitsResource>>c5: (in category 'accessing') ----- c5: anObject ^c5 := anObject! ----- Method: TraitsResource>>c6 (in category 'accessing') ----- c6 ^c6! ----- Method: TraitsResource>>c6: (in category 'accessing') ----- c6: anObject ^c6 := anObject! ----- Method: TraitsResource>>c7 (in category 'accessing') ----- c7 ^c7! ----- Method: TraitsResource>>c7: (in category 'accessing') ----- c7: anObject ^c7 := anObject! ----- Method: TraitsResource>>c8 (in category 'accessing') ----- c8 ^c8! ----- Method: TraitsResource>>c8: (in category 'accessing') ----- c8: anObject ^c8 := anObject! ----- Method: TraitsResource>>categoryName (in category 'as yet unclassified') ----- categoryName ^self class category! ----- Method: TraitsResource>>codeChangedEvent: (in category 'as yet unclassified') ----- codeChangedEvent: anEvent (anEvent isDoIt not and: [anEvent itemClass notNil] and: [self createdClassesAndTraits includes: anEvent itemClass instanceSide]) ifTrue: [self setDirty] ! ----- Method: TraitsResource>>createClassNamed:superclass:uses: (in category 'as yet unclassified') ----- createClassNamed: aSymbol superclass: aClass uses: aTraitComposition | class | class := aClass subclass: aSymbol uses: aTraitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryName. self createdClassesAndTraits add: class. ^class! ----- Method: TraitsResource>>createTraitNamed:uses: (in category 'as yet unclassified') ----- createTraitNamed: aSymbol uses: aTraitComposition | trait | trait := Trait named: aSymbol uses: aTraitComposition category: self categoryName env: Smalltalk. self createdClassesAndTraits add: trait. ^trait! ----- Method: TraitsResource>>createdClassesAndTraits (in category 'as yet unclassified') ----- createdClassesAndTraits createdClassesAndTraits ifNil: [ createdClassesAndTraits := OrderedCollection new]. ^createdClassesAndTraits! ----- Method: TraitsResource>>isDirty (in category 'accessing') ----- isDirty ^dirty! ----- Method: TraitsResource>>setDirty (in category 'accessing') ----- setDirty dirty := true! ----- Method: TraitsResource>>setUp (in category 'as yet unclassified') ----- setUp "Please note, that most tests rely on this setup of traits and classes - and that especially the order of the definitions matters." "SetUpCount := SetUpCount + 1." dirty := false. SystemChangeNotifier uniqueInstance doSilently: [self t1: (self createTraitNamed: #T1 uses: { }). self t1 comment: 'I am the trait T1'. self t2: (self createTraitNamed: #T2 uses: { }). self t2 compile: 'm21 ^21' classified: #cat1. self t2 compile: 'm22 ^22' classified: #cat2. self t2 classSide compile: 'm2ClassSide: a ^a'. self t3: (self createTraitNamed: #T3 uses: { }). self t3 compile: 'm31 ^31' classified: #cat1. self t3 compile: 'm32 ^32' classified: #cat2. self t3 compile: 'm33 ^33' classified: #cat3. self t4: (self createTraitNamed: #T4 uses: { (self t1). (self t2) }). self t4 compile: 'm11 ^41' classified: #catX. "overrides T1>>m11" self t4 compile: 'm42 ^42' classified: #cat2. self t5: (self createTraitNamed: #T5 uses: self t1 + self t2). self t5 compile: 'm51 ^super foo' classified: #cat1. self t5 compile: 'm52 ^ self class bar' classified: #cat1. self t5 compile: 'm53 ^ self class bar' classified: #cat1. self t6: (self createTraitNamed: #T6 uses: (self t1 + self t2) @ { (#m22Alias -> #m22) }). self c1: (self createClassNamed: #C1 superclass: Object uses: { }). self c1 compile: 'foo ^true' classified: #accessing. self t1 compile: 'm11 ^11' classified: #cat1. self t1 compile: 'm12 ^12' classified: #cat2. self t1 compile: 'm13 ^self m12' classified: #cat3. self c2: (self createClassNamed: #C2 superclass: self c1 uses: self t5 - { #m11 }). self c2 compile: 'foo ^false' classified: #private. self c2 compile: 'bar ^self foo' classified: #private. self setUpTrivialRequiresFixture. self setUpTwoLevelRequiresFixture. self setUpTranslatingRequiresFixture]. SystemChangeNotifier uniqueInstance notify: self ofAllSystemChangesUsing: #codeChangedEvent:! ----- Method: TraitsResource>>setUpTranslatingRequiresFixture (in category 'as yet unclassified') ----- setUpTranslatingRequiresFixture self c6: (self createClassNamed: #C6 superclass: ProtoObject uses: { }). ProtoObject removeSubclass: self c6. self c6 superclass: nil. self c7: (self createClassNamed: #C7 superclass: self c6 uses: { }). self c8: (self createClassNamed: #C8 superclass: self c7 uses: { }). self c6 compile: 'foo ^self x' classified: #accessing. self c7 compile: 'foo ^3' classified: #accessing. self c7 compile: 'bar ^super foo' classified: #accessing. self c8 compile: 'bar ^self blah' classified: #accessing! ----- Method: TraitsResource>>setUpTrivialRequiresFixture (in category 'as yet unclassified') ----- setUpTrivialRequiresFixture self c3: (self createClassNamed: #C3 superclass: ProtoObject uses: { }). ProtoObject removeSubclass: self c3. self c3 superclass: nil. self c3 compile: 'foo ^self bla' classified: #accessing! ----- Method: TraitsResource>>setUpTwoLevelRequiresFixture (in category 'as yet unclassified') ----- setUpTwoLevelRequiresFixture self c4: (self createClassNamed: #C4 superclass: ProtoObject uses: { }). ProtoObject removeSubclass: self c4. self c4 superclass: nil. self c5: (self createClassNamed: #C5 superclass: self c4 uses: { }). self c4 compile: 'foo ^self blew' classified: #accessing. self c5 compile: 'foo ^self blah' classified: #accessing! ----- Method: TraitsResource>>t1 (in category 'accessing') ----- t1 ^t1! ----- Method: TraitsResource>>t1: (in category 'accessing') ----- t1: anObject ^t1 := anObject! ----- Method: TraitsResource>>t2 (in category 'accessing') ----- t2 ^t2! ----- Method: TraitsResource>>t2: (in category 'accessing') ----- t2: anObject ^t2 := anObject! ----- Method: TraitsResource>>t3 (in category 'accessing') ----- t3 ^t3! ----- Method: TraitsResource>>t3: (in category 'accessing') ----- t3: anObject ^t3 := anObject! ----- Method: TraitsResource>>t4 (in category 'accessing') ----- t4 ^t4! ----- Method: TraitsResource>>t4: (in category 'accessing') ----- t4: anObject ^t4 := anObject! ----- Method: TraitsResource>>t5 (in category 'accessing') ----- t5 ^t5! ----- Method: TraitsResource>>t5: (in category 'accessing') ----- t5: anObject ^t5 := anObject! ----- Method: TraitsResource>>t6 (in category 'accessing') ----- t6 ^t6! ----- Method: TraitsResource>>t6: (in category 'accessing') ----- t6: anObject ^t6 := anObject! ----- Method: TraitsResource>>tearDown (in category 'as yet unclassified') ----- tearDown | behaviorName | SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self. self createdClassesAndTraits do: [:aClassOrTrait | behaviorName := aClassOrTrait name. Smalltalk at: behaviorName ifPresent: [:classOrTrait | classOrTrait removeFromSystem]. ChangeSet current removeClassChanges: behaviorName]. createdClassesAndTraits := self t1: (self t2: (self t3: (self t4: (self t5: (self t6: (self c1: (self c2: (self c3: (self c4: (self c5: (self c6: (self c7: (self c8: nil)))))))))))))! TestCase subclass: #TraitsTestCase instanceVariableNames: 'createdClassesAndTraits' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! TraitsTestCase subclass: #ClassTraitTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: ClassTraitTest>>testChanges (in category 'testing') ----- testChanges "Test the most important features to ensure that general functionality of class traits are working." "self run: #testChanges" | classTrait | classTrait := self t1 classTrait. classTrait compile: 'm1ClassSide ^17' classified: 'mycategory'. "local selectors" self assert: (classTrait includesLocalSelector: #m1ClassSide). self deny: (classTrait includesLocalSelector: #otherSelector). "propagation" self assert: (self t5 classSide methodDict includesKey: #m1ClassSide). self assert: (self c2 class methodDict includesKey: #m1ClassSide). self shouldnt: [self c2 m1ClassSide] raise: Error. self assert: self c2 m1ClassSide = 17. "category" self assert: (self c2 class organization categoryOfElement: #m1ClassSide) = 'mycategory'. "conflicts" self t2 classSide compile: 'm1ClassSide' classified: 'mycategory'. self assert: (self c2 class methodDict includesKey: #m1ClassSide). self deny: (self c2 class includesLocalSelector: #m1ClassSide). self should: [self c2 m1ClassSide] raise: Error. "conflict category" self assert: (self c2 class organization categoryOfElement: #m1ClassSide) = #mycategory! ----- Method: ClassTraitTest>>testConflictsAliasesAndExclusions (in category 'testing') ----- testConflictsAliasesAndExclusions "conflict" self t1 classTrait compile: 'm2ClassSide: x ^99' classified: 'mycategory'. self assert: (self t1 classTrait includesLocalSelector: #m2ClassSide:). self assert: (self t5 classTrait >> #m2ClassSide:) isConflict. self assert: (self c2 class >> #m2ClassSide:) isConflict. "exclusion and alias" self assert: self t5 classSide traitComposition asString = 'T1 classTrait + T2 classTrait'. self t5 classSide uses: (self t1 classTrait @ { (#m2ClassSideAlias1: -> #m2ClassSide:) } + self t2 classTrait) @ { (#m2ClassSideAlias2: -> #m2ClassSide:) } - { #m2ClassSide: }. self deny: (self t5 classTrait >> #m2ClassSide:) isConflict. self deny: (self c2 class >> #m2ClassSide:) isConflict. self assert: (self c2 m2ClassSideAlias1: 13) = 99. self assert: (self c2 m2ClassSideAlias2: 13) = 13! ----- Method: ClassTraitTest>>testInitialization (in category 'testing') ----- testInitialization "self run: #testInitialization" | classTrait | classTrait := self t1 classTrait. self assert: self t1 hasClassTrait. self assert: self t1 classTrait == classTrait. self assert: classTrait isClassTrait. self assert: classTrait classSide == classTrait. self deny: classTrait isBaseTrait. self assert: classTrait baseTrait == self t1. "assert classtrait methods are propagated to users when setting traitComposition" self assert: self t4 hasClassTrait. self assert: self t5 hasClassTrait. self assert: (self t2 classSide includesLocalSelector: #m2ClassSide:). self assert: (self t4 classSide methodDict includesKey: #m2ClassSide:). self assert: (self t5 classSide methodDict includesKey: #m2ClassSide:). self assert: (self c2 m2ClassSide: 17) = 17! ----- Method: ClassTraitTest>>testUsers (in category 'testing') ----- testUsers self assert: self t2 classSide users size = 3. self assert: (self t2 classSide users includesAllOf: { (self t4 classTrait). (self t5 classTrait). (self t6 classTrait) }). self assert: self t5 classSide users size = 1. self assert: self t5 classSide users anyOne = self c2 class. self c2 uses: self t1 + self t5. self assert: self t5 classSide users size = 1. self assert: self t5 classSide users anyOne = self c2 class. self c2 uses: self t2 asTraitComposition. self assert: self t5 classSide users isEmpty! TraitsTestCase subclass: #PureBehaviorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: PureBehaviorTest>>testChangeSuperclass (in category 'testing-applying trait composition') ----- testChangeSuperclass "self run: #testChangeSuperclass" "Test that when the superclass of a class is changed the non-local methods of the class sending super are recompiled to correctly store the new superclass." | aC2 newSuperclass | aC2 := self c2 new. "C1 is current superclass of C2" self assert: aC2 m51. self assert: self c2 superclass == self c1. self deny: (self c2 localSelectors includes: #m51). "change superclass of C2 from C1 to X" newSuperclass := self createClassNamed: #X superclass: Object uses: {}. newSuperclass subclass: self c2 name uses: self c2 traitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self c2 category. self assert: self c2 superclass == newSuperclass. newSuperclass compile: 'foo ^17'. self assert: aC2 m51 = 17. self deny: (self c2 localSelectors includes: #m51). self c2 compile: 'm51 ^19'. self assert: aC2 m51 = 19. self deny: (self c2 >> #m52) == (self t5 >> #m52). "no sharing!!" ! ----- Method: PureBehaviorTest>>testClassesWithTraits (in category 'testing-applying trait composition') ----- testClassesWithTraits "self debug: #testClassesWithTraits" self assert: (self c1 methodDict includesKey: #foo). self assert: (self c2 methodDict includesKey: #bar). self assert: (self c2 methodDict includesKey: #m51). self assert: (self c2 methodDict includesKey: #m12). self assert: (self c2 methodDict includesKey: #m13). self assert: (self c2 methodDict includesKey: #m21). self assert: (self c2 methodDict includesKey: #m22). self deny: self c1 class hasTraitComposition. self assert: self c2 class hasTraitComposition. self assert: (self c2 class traitComposition size = 1). self assert: (self c2 class includesTrait: self t5 classTrait)! ----- Method: PureBehaviorTest>>testIsAliasSelector (in category 'testing') ----- testIsAliasSelector self deny: (self t1 isAliasSelector: #m11). self deny: (self t1 isAliasSelector: #foo). "directly" self assert: (self t6 isAliasSelector: #m22Alias). self deny: (self t6 isAliasSelector: #m22). "indirectly" self c1 uses: self t6. self assert: (self c1 isAliasSelector: #m22Alias). self deny: (self c1 isAliasSelector: #m22)! ----- Method: PureBehaviorTest>>testIsLocalAliasSelector (in category 'testing') ----- testIsLocalAliasSelector self deny: (self t1 isLocalAliasSelector: #m11). self deny: (self t1 isLocalAliasSelector: #foo). "directly" self assert: (self t6 isLocalAliasSelector: #m22Alias). self deny: (self t6 isLocalAliasSelector: #m22). "indirectly" self c1 uses: self t6 asTraitComposition. self deny: (self c1 isLocalAliasSelector: #m22Alias). self deny: (self c1 isLocalAliasSelector: #m22)! ----- Method: PureBehaviorTest>>testLocalSelectors (in category 'testing') ----- testLocalSelectors "self run: #testLocalSelectors" self assert: self t3 localSelectors size = 3. self assert: (self t3 localSelectors includesAllOf: #(#m31 #m32 #m33 )). self assert: (self t3 includesLocalSelector: #m32). self deny: (self t3 includesLocalSelector: #inexistantSelector). self assert: self t5 localSelectors size = 3. self assert: (self t5 localSelectors includes: #m51). self assert: (self t5 includesLocalSelector: #m51). self deny: (self t5 includesLocalSelector: #m11). self t5 removeSelector: #m51. self deny: (self t3 includesLocalSelector: #m51). self deny: (self t5 includesLocalSelector: #m11). self assert: self t5 localSelectors size = 2. self t5 compile: 'm52 ^self'. self assert: self t5 localSelectors size = 2. self assert: (self t5 localSelectors includes: #m52). "test that propagated methods do not get in as local methods" self t2 compile: 'local2 ^self'. self deny: (self t5 includesLocalSelector: #local2). self assert: self t5 localSelectors size = 2. self assert: (self t5 localSelectors includes: #m52). self assert: self c2 localSelectors size = 2. self assert: (self c2 localSelectors includesAllOf: #(#foo #bar ))! ----- Method: PureBehaviorTest>>testMethodCategoryReorganization (in category 'testing') ----- testMethodCategoryReorganization "self run: #testMethodCategory" self t1 compile: 'm1' classified: 'category1'. self assert: (self t5 organization categoryOfElement: #m1) = #category1. self assert: (self c2 organization categoryOfElement: #m1) = #category1. self t1 organization classify: #m1 under: #category2 suppressIfDefault: true. self assert: (self t5 organization categoryOfElement: #m1) = #category2. self assert: (self c2 organization categoryOfElement: #m1) = #category2! ----- Method: PureBehaviorTest>>testOwnMethodsTakePrecedenceOverTraitsMethods (in category 'testing-applying trait composition') ----- testOwnMethodsTakePrecedenceOverTraitsMethods "First create a trait with no subtraits and then add subtrait t1 which implements m11 as well." | trait | trait := self createTraitNamed: #TraitsTestTrait uses: { }. trait compile: 'm11 ^999'. self assert: trait methodDict size = 1. self assert: (trait methodDict at: #m11) decompileString = 'm11 ^ 999'. self createTraitNamed: #TraitsTestTrait uses: self t1. self assert: trait methodDict size = 3. self assert: (trait methodDict keys includesAllOf: #(#m11 #m12 #m13 )). self assert: (trait methodDict at: #m11) decompileString = 'm11 ^ 999'. self assert: (trait methodDict at: #m12) decompileString = 'm12 ^ 12'! ----- Method: PureBehaviorTest>>testPropagationOfChangesInTraits (in category 'testing-applying trait composition') ----- testPropagationOfChangesInTraits | aC2 | aC2 := self c2 new. self assert: self c2 methodDict size = 9. self t1 compile: 'zork ^false'. self assert: self c2 methodDict size = 10. self deny: aC2 zork. self t1 removeSelector: #m12. self assert: self c2 methodDict size = 9. self should: [aC2 m12] raise: MessageNotUnderstood. self assert: aC2 m21 = 21. self t2 compile: 'm21 ^99'. self assert: aC2 m21 = 99! ----- Method: PureBehaviorTest>>testPropagationOfChangesInTraitsToAliasMethods (in category 'testing-applying trait composition') ----- testPropagationOfChangesInTraitsToAliasMethods | anObject | anObject := (self createClassNamed: #TraitsTestAliasTestClass superclass: Object uses: self t6) new. self assert: anObject m22Alias = 22. "test update alias method" self t2 compile: 'm22 ^17'. self assert: anObject m22Alias = 17. "removing original method should also remove alias method" self t2 removeSelector: #m22. self should: [anObject m22Alias] raise: MessageNotUnderstood! ----- Method: PureBehaviorTest>>testPropagationOfChangesInTraitsToAliasMethodsWhenOriginalMethodIsExcluded (in category 'testing-applying trait composition') ----- testPropagationOfChangesInTraitsToAliasMethodsWhenOriginalMethodIsExcluded "Assert that alias method is updated although the original method is excluded from this user." | anObject | anObject := (self createClassNamed: #TraitsTestAliasTestClass superclass: Object uses: self t1 @ { (#aliasM11 -> #m11) } - { #m11 }) new. self assert: anObject aliasM11 = 11. self deny: (anObject class methodDict includesKey: #m11). self t1 compile: 'm11 ^17'. self assert: anObject aliasM11 = 17! ----- Method: PureBehaviorTest>>testPropagationWhenTraitCompositionModifications (in category 'testing-applying trait composition') ----- testPropagationWhenTraitCompositionModifications "Test that the propagation mechanism works when setting new traitCompositions." self assert: self c2 methodDict size = 9. "2 + (3+(3+2))-1" "removing methods" self createTraitNamed: #T5 uses: self t1 + self t2 - { #m21. #m22 }. self assert: self c2 methodDict size = 7. "adding methods" self createTraitNamed: #T2 uses: self t3. self assert: self c2 methodDict size = 10. self assert: (self c2 methodDict keys includesAllOf: #(#m31 #m32 #m33 ))! ----- Method: PureBehaviorTest>>testRemovingMethods (in category 'testing') ----- testRemovingMethods "When removing a local method, assure that the method from the trait is installed instead and that the users are updated." "self run: #testRemovingMethods" "Classes" self c2 compile: 'm12 ^0' classified: #xxx. self assert: (self c2 includesLocalSelector: #m12). self c2 removeSelector: #m12. self deny: (self c2 includesLocalSelector: #m12). self assert: (self c2 selectors includes: #m12). "Traits" self t5 compile: 'm12 ^0' classified: #xxx. self assert: self c2 new m12 = 0. self t5 removeSelector: #m12. self deny: (self t5 includesLocalSelector: #m12). self assert: (self t5 selectors includes: #m12). self assert: self c2 new m12 = 12! ----- Method: PureBehaviorTest>>testSuperSends (in category 'testing-applying trait composition') ----- testSuperSends | aC2 | aC2 := self c2 new. self assert: aC2 m51. self deny: aC2 foo. self deny: aC2 bar! ----- Method: PureBehaviorTest>>testTraitCompositionModifications (in category 'testing-applying trait composition') ----- testTraitCompositionModifications self assert: self t6 methodDict size = 6. self assert: (self t6 sourceCodeAt: #m22Alias) asString = 'm22Alias ^22'. self t6 uses: self t2 asTraitComposition. self assert: self t6 methodDict size = 2. self deny: (self t6 methodDict includesKey: #m22Alias). self t6 uses: self t1 @ { (#m13Alias -> #m13) } - { #m11. #m12 } + self t2. self assert: self t6 methodDict size = 4. self assert: (self t6 methodDict keys includesAllOf: #(#m13 #m13Alias #m21 #m22 )). self assert: (self t6 sourceCodeAt: #m13Alias) asString = 'm13Alias ^self m12'! ----- Method: PureBehaviorTest>>testTraitCompositionWithCycles (in category 'testing-applying trait composition') ----- testTraitCompositionWithCycles self should: [self t1 uses: self t1 asTraitComposition] raise: Error. self t2 uses: self t3 asTraitComposition. self should: [self t3 uses: self t5 asTraitComposition] raise: Error! ----- Method: PureBehaviorTest>>testUpdateWhenLocalMethodRemoved (in category 'testing-applying trait composition') ----- testUpdateWhenLocalMethodRemoved | aC2 | aC2 := self c2 new. self t5 compile: 'foo ^123'. self deny: aC2 foo. self c2 removeSelector: #foo. self assert: aC2 foo = 123! ----- Method: PureBehaviorTest>>traitOrClassOfSelector (in category 'testing') ----- traitOrClassOfSelector "self run: #traitOrClassOfSelector" "locally defined in trait or class" self assert: (self t1 >> #m12) originalTraitOrClass = self t1. self assert: (self c1 >> #foo) originalTraitOrClass = self c1. "not locally defined - simple" self assert: (self t4 >> #m21) originalTraitOrClass = self t2. self assert: (self c2 >> #m51) originalTraitOrClass = self t5. "not locally defined - into nested traits" self assert: (self c2 >> #m22) originalTraitOrClass = self t2. "not locally defined - aliases" self assert: (self t6 >> #m22Alias) originalTraitOrClass = self t2. "class side" self assert: (self t2 classSide >> #m2ClassSide:) originalTraitOrClass = self t2 classSide. self assert: (self t6 classSide >> #m2ClassSide:) originalTraitOrClass = self t2 classSide! TraitsTestCase subclass: #TraitCompositionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitCompositionTest>>testAliasCompositions (in category 'testing-basic') ----- testAliasCompositions "unary" self shouldnt: [self t2 uses: self t1 @ { (#aliasM11 -> #m11) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#alias: -> #m11) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#alias:x:y: -> #m11) }] raise: TraitCompositionException. "binary" self t1 compile: '= anObject'. self shouldnt: [self t2 uses: self t1 @ { (#equals: -> #=) }] raise: TraitCompositionException. self shouldnt: [self t2 uses: self t1 @ { (#% -> #=) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#equals -> #=) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#equals:x: -> #=) }] raise: TraitCompositionException. "keyword" self t1 compile: 'x: a y: b z: c'. self should: [self t2 uses: self t1 @ { (#'==' -> #x:y:z:) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#x -> #x:y:z:) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#x: -> #x:y:z:) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#x:y: -> #x:y:z:) }] raise: TraitCompositionException. self shouldnt: [self t2 uses: self t1 @ { (#myX:y:z: -> #x:y:z:) }] raise: TraitCompositionException. "alias same as selector" self should: [self t2 uses: self t1 @ { (#m11 -> #m11) }] raise: TraitCompositionException. "same alias name used twice" self should: [self t2 uses: self t1 @ { (#alias -> #m11). (#alias -> #m12) }] raise: TraitCompositionException. "aliasing an alias" self should: [self t2 uses: self t1 @ { (#alias -> #m11). (#alias2 -> #alias) }] raise: TraitCompositionException! ----- Method: TraitCompositionTest>>testClassMethodsTakePrecedenceOverTraitsMethods (in category 'testing-enquiries') ----- testClassMethodsTakePrecedenceOverTraitsMethods | keys | keys := Set new. self t4 methodDict bindingsDo: [:each | keys add: each key]. self assert: keys size = 6. self assert: (keys includesAllOf: #( #m12 #m13 #m13 #m21 #m22 #m11 #m42 )). self assert: (self t4 methodDict at: #m11) decompileString = 'm11 ^ 41'! ----- Method: TraitCompositionTest>>testCompositionFromArray (in category 'testing-basic') ----- testCompositionFromArray | composition | composition := TraitComposition withAll: { (self t1) }. self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: composition traits size = 1. composition := TraitComposition withAll: { (self t1). self t2 }. self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: (composition traits includes: self t2). self assert: composition traits size = 2! ----- Method: TraitCompositionTest>>testEmptyTrait (in category 'testing-basic') ----- testEmptyTrait | composition | composition := TraitComposition withAll: {}. self assert: (composition isKindOf: TraitComposition). " self assert: composition transformations isEmpty. " self assert: composition traits isEmpty! ----- Method: TraitCompositionTest>>testInvalidComposition (in category 'testing-basic') ----- testInvalidComposition self shouldnt: [self t1 @ { (#a -> #b) } @ { (#x -> #y) }] raise: TraitCompositionException. self shouldnt: [(self t1 + self t2) @ { (#a -> #b) } @ { (#x -> #y) }] raise: TraitCompositionException. self shouldnt: [self t1 - { #a } - { #b }] raise: TraitCompositionException. self shouldnt: [self t1 + self t2 - { #a } - { #b }] raise: TraitCompositionException. self should: [(self t1 - { #x }) @ { (#a -> #b) }] raise: TraitCompositionException. self should: [(self t1 + self t2 - { #x }) @ { (#a -> #b) }] raise: TraitCompositionException. self should: [self t1 + self t1] raise: TraitCompositionException. self should: [(self t1 + self t2) @ { (#a -> #b) } + self t1] raise: TraitCompositionException. self should: [self t1 @ { (#a -> #m11). (#a -> #m12) }] raise: TraitCompositionException. self should: [self t1 @ { (#a -> #m11). (#b -> #a) }] raise: TraitCompositionException! ----- Method: TraitCompositionTest>>testPrinting (in category 'testing-basic') ----- testPrinting | composition1 composition2 | composition1 := ((self t1 - { #a } + self t2) @ { (#z -> #c) } - { #b. #c } + self t3 - { #d. #e } + self t4) @ { (#x -> #a). (#y -> #b) }. composition2 := self t4 @ { (#x -> #a). (#y -> #b) } + self t1 - { #a } + self t3 - { #d. #e } + self t2 - { #b. #c }. self assertPrints: composition1 printString like: 'T1 - {#a} + T2 @ {#z->#c} - {#b. #c} + T3 - {#d. #e} + T4 @ {#x->#a. #y->#b}'. self assertPrints: composition2 printString like: 'T4 @ {#x->#a. #y->#b} + T1 - {#a} + T3 - {#d. #e} + T2 - {#b. #c}'! ----- Method: TraitCompositionTest>>testProvidedMethodBindingsWithConflicts (in category 'testing-enquiries') ----- testProvidedMethodBindingsWithConflicts | traitWithConflict methodDict | traitWithConflict := self createTraitNamed: #TraitsTestTraitWithConflict uses: self t1 + self t4. methodDict := traitWithConflict methodDict. self assert: methodDict size = 6. self assert: (methodDict keys includesAllOf: #( #m11 #m12 #m13 #m21 #m22 #m42 )). self assert: (methodDict at: #m11) decompileString = 'm11 ^ self traitConflict'! ----- Method: TraitCompositionTest>>testSum (in category 'testing-basic') ----- testSum | composition | composition := self t1 + self t2 + self t3. self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: (composition traits includes: self t2). self assert: (composition traits includes: self t3). self assert: composition traits size = 3! ----- Method: TraitCompositionTest>>testSumWithParenthesis (in category 'testing-basic') ----- testSumWithParenthesis | composition | composition := self t1 + (self t2 + self t3). self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: (composition traits includes: self t2). self assert: (composition traits includes: self t3). self assert: composition traits size = 3. self assert: composition size = 3! TraitsTestCase subclass: #TraitFileOutTest instanceVariableNames: 'ca cb ta tb tc td' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitFileOutTest>>categoryName (in category 'running') ----- categoryName ^'TraitsTests-FileOut'! ----- Method: TraitFileOutTest>>fileIn: (in category 'testing') ----- fileIn: fileName | prior file result | prior := ClassDescription traitImpl. [ ClassDescription traitImpl: Trait. file := FileStream readOnlyFileNamed: fileName. result := file fileIn ] ensure: [ file ifNotNil:[file close]. ClassDescription traitImpl: prior. ]. ^result! ----- Method: TraitFileOutTest>>setUp (in category 'running') ----- setUp super setUp. SystemOrganization addCategory: self categoryName. td := self createTraitNamed: #TD uses: {}. td compile: 'd' classified: #cat1. tc := self createTraitNamed: #TC uses: td. tc compile: 'c' classified: #cat1. tb := self createTraitNamed: #TB uses: td. tb compile: 'b' classified: #cat1. ta := self createTraitNamed: #TA uses: tb + tc @ {#cc->#c} - {#c}. ta compile: 'a' classified: #cat1. ca := self createClassNamed: #CA superclass: Object uses: {}. ca compile: 'ca' classified: #cat1. cb := self createClassNamed: #CB superclass: ca uses: ta. cb compile: 'cb' classified: #cat1. "make the class of cb also use tc:" cb class uses: ta classTrait + tc instanceVariableNames: ''.! ----- Method: TraitFileOutTest>>tearDown (in category 'running') ----- tearDown | dir | dir := FileDirectory default. self createdClassesAndTraits, self resourceClassesAndTraits do: [:each | dir deleteFileNamed: each asString , '.st' ifAbsent: []]. dir deleteFileNamed: self categoryName , '.st' ifAbsent: []. SystemOrganization removeSystemCategory: self categoryName. super tearDown! ----- Method: TraitFileOutTest>>testFileOutCategory (in category 'testing') ----- testFileOutCategory "File out whole system category, delete all classes and traits and then file them in again." "self run: #testFileOutCategory" | | SystemOrganization fileOutCategory: self categoryName. SystemOrganization removeSystemCategory: self categoryName. self deny: (Smalltalk keys includesAnyOf: #(CA CB TA TB TC TD)). self fileIn: self categoryName , '.st'.. self assert: (Smalltalk keys includesAllOf: #(CA CB TA TB TC TD)). ta := Smalltalk at: #TA. self assert: (ta isKindOf: Trait). self assert: ta traitComposition asString = 'TB + TC @ {#cc->#c} - {#c}'. self assert: (ta methodDict keys includesAllOf: #(a b cc)). cb := Smalltalk at: #CB. self assert: (cb isKindOf: Class). self assert: cb traitComposition asString = 'TA'. self assert: (cb methodDict keys includesAllOf: #(cb a b cc)). "test classSide traitComposition of CB" self assert: cb classSide traitComposition asString = 'TA classTrait + TC'. self assert: (cb classSide methodDict keys includesAllOf: #(d c)) ! ----- Method: TraitFileOutTest>>testFileOutTrait (in category 'testing') ----- testFileOutTrait "fileOut trait T6, remove it from system and then file it in again" "self run: #testFileOutTrait" | fileName | self t6 compile: 'localMethod: argument ^argument'. self t6 classSide compile: 'localClassSideMethod: argument ^argument'. self t6 fileOut. fileName := self t6 asString , '.st'. self resourceClassesAndTraits remove: self t6. self t6 removeFromSystem. self fileIn: fileName. self assert: (Smalltalk includesKey: #T6). TraitsResource current t6: (Smalltalk at: #T6). self resourceClassesAndTraits add: self t6. self assert: (self t6 isKindOf: Trait). self assert: self t6 traitComposition asString = 'T1 + T2 @ {#m22Alias->#m22}'. self assert: (self t6 methodDict keys includesAllOf: #( #localMethod: #m11 #m12 #m13 #m21 #m22 #m22Alias )). self assert: self t6 classSide methodDict size = 2. self assert: (self t6 classSide methodDict keys includesAllOf: #(#localClassSideMethod: #m2ClassSide: ))! ----- Method: TraitFileOutTest>>testRemovingMethods (in category 'testing') ----- testRemovingMethods "When removing a local method, assure that the method from the trait is installed instead and that the users are updated." "self run: #testRemovingMethods" "Classes" self c2 compile: 'm12 ^0' classified: #xxx. self assert: (self c2 includesLocalSelector: #m12). self c2 removeSelector: #m12. self deny: (self c2 includesLocalSelector: #m12). self assert: (self c2 selectors includes: #m12). "Traits" self t5 compile: 'm12 ^0' classified: #xxx. self assert: self c2 new m12 = 0. self t5 removeSelector: #m12. self deny: (self t5 includesLocalSelector: #m12). self assert: (self t5 selectors includes: #m12). self assert: self c2 new m12 = 12! TraitsTestCase subclass: #TraitMethodDescriptionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitMethodDescriptionTest>>testArgumentNames (in category 'running') ----- testArgumentNames self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. self t2 compile: 'zork1: myArgument zork2: somethingElse ^false'. self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString beginsWith: 'zork1: arg1 zork2: arg2'). self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. self t2 compile: 'zork1: somethingElse zork2: myArgument ^false'. self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString beginsWith: 'zork1: arg1 zork2: arg2')! ----- Method: TraitMethodDescriptionTest>>testCategories (in category 'running') ----- testCategories self assert: (self t4 organization categoryOfElement: #m21) = #cat1. self assert: (self t4 organization categoryOfElement: #m22) = #cat2. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t4 organization categoryOfElement: #m12) = #cat2. self assert: (self t4 organization categoryOfElement: #m13) = #cat3. self assert: (self t6 organization categoryOfElement: #m22Alias) = #cat2. self t2 organization classify: #m22 under: #catX. self assert: (self t4 organization categoryOfElement: #m22) = #catX. self assert: (self t6 organization categoryOfElement: #m22Alias) = #catX. self t6 organization classify: #m22 under: #catY. self t6 organization classify: #m22Alias under: #catY. self t2 organization classify: #m22 under: #catZ. "XXX: The following test is commented out for now. The policy is to *always* reclassify the method if the base method is reclassified. That results from the requirement that the base construction should always be repeatable (in fact, one could argue that reclassification of methods from traits is invalid without some explicit transformation)." false ifTrue:[ self assert: (self t6 organization categoryOfElement: #m22) = #catY. self assert: (self t6 organization categoryOfElement: #m22Alias) = #catY. ]. self t1 compile: 'mA' classified: #catA. self assert: (self t4 organization categoryOfElement: #mA) = #catA. self t1 organization classify: #mA under: #cat1. self assert: (self t4 organization categories includes: #catA) not! ----- Method: TraitMethodDescriptionTest>>testConflictMethodCreation (in category 'running') ----- testConflictMethodCreation "Generate conflicting methods between t1 and t2 and check the resulting method in Trait t5 (or c2). Also test selectors like foo:x (without space) or selectors with CRs." "unary" self t2 compile: 'm12 ^false'. self assert: ((self t5 sourceCodeAt: #m12) asString beginsWith: 'm12'). self should: [self c2 new m12] raise: Error. "binary" self t1 compile: '@ myArgument ^true'. self t2 compile: '@myArgument ^false'. self assert: ((self t5 sourceCodeAt: #@) asString beginsWith: '@ arg1'). self should: [self c2 new @ 17] raise: Error. "keyword" self t1 compile: 'zork: myArgument ^true'. self t2 compile: 'zork: myArgument ^false'. self assert: ((self t5 sourceCodeAt: #zork:) asString beginsWith: 'zork: arg1'). self should: [self c2 new zork: 17] raise: Error. self t1 compile: 'zork:myArgument ^true'. self t2 compile: 'zork:myArgument ^false'. self assert: ((self t5 sourceCodeAt: #zork:) asString beginsWith: 'zork: arg1'). self should: [self c2 new zork: 17] raise: Error. self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. self t2 compile: 'zork1: anObject zork2: anotherObject ^false'. self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString beginsWith: 'zork1: arg1 zork2: arg2'). self should: [self c2 new zork1: 1 zork2: 2] raise: Error! ----- Method: TraitMethodDescriptionTest>>testConflictingCategories (in category 'running') ----- testConflictingCategories | t7 t8 | self t2 compile: 'm11' classified: #catY. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t5 organization categoryOfElement: #m11) = #'conflict methods'. "was: #cat1" t7 := self createTraitNamed: #T7 uses: self t1 + self t2. self assert: (t7 organization categoryOfElement: #m11) = #'conflict methods'. "was: ClassOrganizer ambiguous" self t1 removeSelector: #m11. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t5 organization categoryOfElement: #m11) = #catY. self assert: (t7 organization categoryOfElement: #m11) = #catY. self deny: (t7 organization categories includes: #'conflict methods' "was: ClassOrganizer ambiguous"). self t1 compile: 'm11' classified: #cat1. t8 := self createTraitNamed: #T8 uses: self t1 + self t2. t8 organization classify: #m11 under: #cat1. self t1 organization classify: #m11 under: #catZ. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t5 organization categoryOfElement: #m11) = #'conflict methods'. "was: #catY" self assert: (t8 organization categoryOfElement: #m11) = #'conflict methods'. "was: #catZ"! TraitsTestCase subclass: #TraitSystemTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitSystemTest>>testAllClassesAndTraits (in category 'testing') ----- testAllClassesAndTraits "self debug: #testAllClassesAndTraits" | trait | trait := self t1. self assert: (Smalltalk allClassesAndTraits includes: trait). self deny: (Smalltalk allClasses includes: trait). ! ----- Method: TraitSystemTest>>testAllImplementedMessagesWithout (in category 'testing') ----- testAllImplementedMessagesWithout "self debug: #testAllImplementedMessagesWithout" self t6 compile: 'das2qwdqwd'. self assert: (SystemNavigation default allImplementedMessages includes: #das2qwdqwd). self deny: (SystemNavigation default allImplementedMessages includes: #qwdqwdqwdc).! ----- Method: TraitSystemTest>>testAllSentMessages (in category 'testing') ----- testAllSentMessages "self debug: #testAllSentMessages" self t1 compile: 'foo 1 dasoia'. self assert: (SystemNavigation default allSentMessages includes: 'dasoia' asSymbol). self deny: (SystemNavigation default allSentMessages includes: 'nioaosi' asSymbol).! TraitsTestCase subclass: #TraitTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitTest>>testAddAndRemoveMethodsFromSubtraits (in category 'testing') ----- testAddAndRemoveMethodsFromSubtraits | aC2 | aC2 := self c2 new. self assert: aC2 m51. self t5 removeSelector: #m51. self should: [aC2 m51] raise: MessageNotUnderstood. self t1 compile: 'foo ^true'. self deny: aC2 foo. self t1 compile: 'm51 ^self'. self shouldnt: [aC2 m51] raise: MessageNotUnderstood. self assert: aC2 m51 == aC2! ----- Method: TraitTest>>testAddAndRemoveMethodsInClassOrTrait (in category 'testing') ----- testAddAndRemoveMethodsInClassOrTrait | aC2 | aC2 := self c2 new. self assert: aC2 m51. self c2 compile: 'm51 ^123'. self assert: aC2 m51 = 123. self c2 removeSelector: #m51. self shouldnt: [aC2 m51] raise: MessageNotUnderstood. self assert: aC2 m51. self t4 removeSelector: #m11. self assert: (self t4 methodDict includesKey: #m11)! ----- Method: TraitTest>>testAllClassVarNames (in category 'testing') ----- testAllClassVarNames self assert: self t1 allClassVarNames isEmpty! ----- Method: TraitTest>>testCompositionCopy (in category 'testing') ----- testCompositionCopy | t6compositionCopyFirst c2compositionCopy | self assert: (self t1 + self t2) allTraits = (self t1 + self t2) copyTraitExpression allTraits. self assert: (self t1 classTrait + self t2 classTrait) allTraits = (self t1 classTrait + self t2 classTrait) copyTraitExpression allTraits. self assert: self t6 traitComposition allTraits = self t6 traitComposition copyTraitExpression allTraits. self assert: self t6 asTraitComposition copyTraitExpression allTraits = { (self t1). (self t2). (self t6) }. false ifTrue:[ "make no undue sharing happens of exclusions and aliases after an expression copy" t6compositionCopyFirst := self t6 traitComposition copyTraitExpression. t6compositionCopyFirst transformations at: 1 put: #m22Alias -> #m33. self assert: self t6 traitComposition transformations second aliases first value = #m22. c2compositionCopy := self c2 traitComposition copyTraitExpression. c2compositionCopy transformations first exclusions at: 1 put: #m4. self c2 traitComposition transformations first exclusions = #(#m11 ) ].! ----- Method: TraitTest>>testExplicitRequirement (in category 'testing') ----- testExplicitRequirement "self run: #testExplicitRequirement" self t1 compile: 'm self explicitRequirement'. self t2 compile: 'm ^true'. self deny: (self t4 >> #m) == (self t2 >> #m). "no sharing!!" self assert: self c2 new m. self t2 removeSelector: #m. self deny: (self t5 >> #m) == (self t1 >> #m). "no sharing!!" self should: [self c2 new m] raise: Error! ----- Method: TraitTest>>testMarkerMethods (in category 'testing') ----- testMarkerMethods "self debug: #testMarkerMethods" self t1 compile: 'm1 self foo bar'. self assert: (self t1 >> #m1) markerOrNil isNil. self t1 compile: 'm2 self requirement'. self assert: (self t1 >> #m2) markerOrNil == #requirement. self t1 compile: 'm3 ^self requirement'. self assert: (self t1 >> #m3) markerOrNil == #requirement.! ----- Method: TraitTest>>testPrinting (in category 'testing') ----- testPrinting self assertPrints: self t6 definitionST80 like: 'Trait named: #T6 uses: T1 + T2 @ {#m22Alias->#m22} category: ''TraitsTests-Kernel'''! ----- Method: TraitTest>>testPrintingClassSide (in category 'testing') ----- testPrintingClassSide "self run: #testPrintingClassSide" self assertPrints: self t6 classSide definitionST80 like: 'T6 classTrait uses: T1 classTrait + T2 classTrait'! ----- Method: TraitTest>>testRemoveFromSystem (in category 'testing') ----- testRemoveFromSystem self t4 removeFromSystem. self deny: (Smalltalk includesKey: #T4). self assert: self t4 name = 'AnObsoleteT4'. self assert: self t4 methodDict isEmpty. self deny: (self t1 users includes: self t4)! ----- Method: TraitTest>>testRequirement (in category 'testing') ----- testRequirement "self run: #testRequirement" self t1 compile: 'm self requirement'. self t2 compile: 'm ^true'. self deny: (self t4 >> #m) == (self t2 >> #m). "no sharing!!" self assert: self c2 new m. self t2 removeSelector: #m. self deny: (self t5 >> #m) == (self t1 >> #m). "no sharing!!" self should: [self c2 new m] raise: Error! ----- Method: TraitTest>>testTraitFromPattern (in category 'testing') ----- testTraitFromPattern | newTrait | newTrait := self createTraitNamed: #TTraitTestBaseTrait uses: {}. self assert: (Utilities classFromPattern: 'TTraitTestBaseT' withCaption: '') = newTrait.! ----- Method: TraitTest>>testTraitMethodClass (in category 'testing') ----- testTraitMethodClass "Tests that the #methodClass of a trait method isn't screwed up" | baseTrait classA methodA classB methodB traitMethod | baseTrait := self createTraitNamed: #TraitTestBaseTrait uses:{}. baseTrait compileSilently: 'traitMethod' classified: 'tests'. traitMethod := baseTrait compiledMethodAt: #traitMethod. self assert: traitMethod methodClass == baseTrait. classA := self createClassNamed: #TraitTestMethodClassA superclass: Object uses: baseTrait. methodA := classA compiledMethodAt: #traitMethod. self assert: traitMethod methodClass == baseTrait. self assert: methodA methodClass == classA. classB := self createClassNamed: #TraitTestMethodClassB superclass: Object uses: baseTrait. methodB := classB compiledMethodAt: #traitMethod. self assert: traitMethod methodClass == baseTrait. self assert: methodA methodClass == classA. self assert: methodB methodClass == classB.! ----- Method: TraitTest>>testTraitMethodSelector (in category 'testing') ----- testTraitMethodSelector "Tests that the #selector of a trait method isn't screwed up when aliasing traits" | baseTrait classA methodA classB methodB traitMethod | baseTrait := self createTraitNamed: #TraitTestBaseTrait uses:{}. baseTrait compileSilently: 'traitMethod' classified: 'tests'. traitMethod := baseTrait compiledMethodAt: #traitMethod. self assert: traitMethod selector == #traitMethod. classA := self createClassNamed: #TraitTestMethodClassA superclass: Object uses: {baseTrait @ {#methodA -> #traitMethod}}. methodA := classA compiledMethodAt: #methodA. self assert: traitMethod selector == #traitMethod. self assert: methodA selector == #methodA. classB := self createClassNamed: #TraitTestMethodClassB superclass: Object uses: {baseTrait @ {#methodB -> #traitMethod}}. methodB := classB compiledMethodAt: #methodB. self assert: traitMethod selector == #traitMethod. self assert: methodA selector == #methodA. self assert: methodB selector == #methodB.! ----- Method: TraitTest>>testUsers (in category 'testing') ----- testUsers self assert: self t1 users size = 3. self assert: (self t1 users includesAllOf: {self t4. self t5. self t6 }). self assert: self t3 users isEmpty. self assert: self t5 users size = 1. self assert: self t5 users anyOne = self c2. self c2 uses: self t1 + self t5. self assert: self t5 users size = 1. self assert: self t5 users anyOne = self c2. self c2 uses: self t2 asTraitComposition. self assert: self t5 users isEmpty! ----- Method: TraitsTestCase class>>resources (in category 'as yet unclassified') ----- resources ^{TraitsResource}! ----- Method: TraitsTestCase>>assertPrints:like: (in category 'utility') ----- assertPrints: aString like: anotherString self assert: (aString copyWithout: $ ) = (anotherString copyWithout: $ )! ----- Method: TraitsTestCase>>c1 (in category 'accessing') ----- c1 ^TraitsResource current c1! ----- Method: TraitsTestCase>>c2 (in category 'accessing') ----- c2 ^TraitsResource current c2! ----- Method: TraitsTestCase>>c3 (in category 'accessing') ----- c3 ^TraitsResource current c3! ----- Method: TraitsTestCase>>c4 (in category 'accessing') ----- c4 ^TraitsResource current c4! ----- Method: TraitsTestCase>>c5 (in category 'accessing') ----- c5 ^TraitsResource current c5! ----- Method: TraitsTestCase>>c6 (in category 'accessing') ----- c6 ^TraitsResource current c6! ----- Method: TraitsTestCase>>c7 (in category 'accessing') ----- c7 ^TraitsResource current c7! ----- Method: TraitsTestCase>>c8 (in category 'accessing') ----- c8 ^TraitsResource current c8! ----- Method: TraitsTestCase>>categoryName (in category 'running') ----- categoryName ^self class category! ----- Method: TraitsTestCase>>createClassNamed:superclass:uses: (in category 'utility') ----- createClassNamed: aSymbol superclass: aClass uses: aTraitComposition | class | class := aClass subclass: aSymbol uses: aTraitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryName. self createdClassesAndTraits add: class. ^class! ----- Method: TraitsTestCase>>createTraitNamed:uses: (in category 'utility') ----- createTraitNamed: aSymbol uses: aTraitComposition | trait | trait := Trait named: aSymbol uses: aTraitComposition category: self categoryName env: Smalltalk. self createdClassesAndTraits add: trait. ^trait! ----- Method: TraitsTestCase>>createdClassesAndTraits (in category 'utility') ----- createdClassesAndTraits createdClassesAndTraits ifNil: [ createdClassesAndTraits := OrderedCollection new]. ^createdClassesAndTraits! ----- Method: TraitsTestCase>>resourceClassesAndTraits (in category 'utility') ----- resourceClassesAndTraits ^TraitsResource current createdClassesAndTraits! ----- Method: TraitsTestCase>>t1 (in category 'accessing') ----- t1 ^TraitsResource current t1! ----- Method: TraitsTestCase>>t2 (in category 'accessing') ----- t2 ^TraitsResource current t2! ----- Method: TraitsTestCase>>t3 (in category 'accessing') ----- t3 ^TraitsResource current t3! ----- Method: TraitsTestCase>>t4 (in category 'accessing') ----- t4 ^TraitsResource current t4! ----- Method: TraitsTestCase>>t5 (in category 'accessing') ----- t5 ^TraitsResource current t5! ----- Method: TraitsTestCase>>t6 (in category 'accessing') ----- t6 ^TraitsResource current t6! ----- Method: TraitsTestCase>>tearDown (in category 'running') ----- tearDown | behaviorName | TraitsResource resetIfDirty. self createdClassesAndTraits do: [:aClassOrTrait | behaviorName := aClassOrTrait name. Smalltalk at: behaviorName ifPresent: [:classOrTrait | classOrTrait removeFromSystem]. ChangeSet current removeClassChanges: behaviorName]. createdClassesAndTraits := nil! ----- Method: TraitsTestCase>>testChangeSuperclass (in category 'testing-applying trait composition') ----- testChangeSuperclass "self run: #testChangeSuperclass" "Test that when the superclass of a class is changed the non-local methods of the class sending super are recompiled to correctly store the new superclass." | aC2 newSuperclass | aC2 := self c2 new. "C1 is current superclass of C2" self assert: aC2 m51. self assert: self c2 superclass == self c1. self deny: (self c2 localSelectors includes: #m51). "change superclass of C2 from C1 to X" newSuperclass := self createClassNamed: #TraitsTestX superclass: Object uses: {}. newSuperclass subclass: self c2 name uses: self c2 traitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self c2 category. self assert: self c2 superclass == newSuperclass. newSuperclass compile: 'foo ^17'. self assert: aC2 m51 = 17. self deny: (self c2 localSelectors includes: #m51). self c2 compile: 'm51 ^19'. self assert: aC2 m51 = 19. "no sharing!!" self deny: (self c2 >> #m52) == (self t5 >> #m52).!
More information about the Squeak-dev mailing list |