Squeak-dev June 2015

squeak-dev@lists.squeakfoundation.org

35 participants
162 discussions

Squeak 4.6: TraitsTests-nice.14.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of TraitsTests to project Squeak 4.6: http://source.squeak.org/squeak46/TraitsTests-nice.14.mcz ==================== Summary ==================== Name: TraitsTests-nice.14 Author: nice Time: 27 May 2014, 2:28:14.935 am UUID: 44c0f5be-a415-4f22-a8b6-856fd0bf7e79 Ancestors: TraitsTests-fbs.13 Some Traits test do timeout. Relax the constraints. ==================== Snapshot ==================== SystemOrganization addCategory: #'TraitsTests-Kernel'! 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 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). self deny: (self c2 >> #m52) == (self t5 >> #m52). "no sharing!!" self assert: self c2 traitCompositionString = 'T5 - {#m11}'. self assert: self c2 selectors sort = #(bar foo m12 m13 m21 m22 m51 m52 m53). self assert: self c2 localSelectors sort = #(bar foo). "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!!" self assert: self c2 traitCompositionString = 'T5 - {#m11}'. self assert: self c2 selectors sort = #(bar foo m12 m13 m21 m22 m51 m52 m53). self assert: self c2 localSelectors sort = #(bar foo m51). "change superclass of C2 back to C1" self c1 subclass: self c2 name uses: self c2 traitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self c2 category. self assert: (aC2 m51 = 19). self assert: self c2 superclass == self c1. self assert: (self c2 localSelectors includes: #m51). self deny: (self c2 >> #m52) == (self t5 >> #m52). "no sharing!!" self assert: self c2 traitCompositionString = 'T5 - {#m11}'. self assert: self c2 selectors sort = #(bar foo m12 m13 m21 m22 m51 m52 m53). self assert: self c2 localSelectors sort = #(bar foo m51). ! ----- 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>>testReshapeClass (in category 'testing-applying trait composition') ----- testReshapeClass "self run: #testReshapeClass" "Ensure that reshaping a class has no impact on its traits" self assert: self c2 traitCompositionString = 'T5 - {#m11}'. self assert: self c2 selectors sort = #(bar foo m12 m13 m21 m22 m51 m52 m53). self assert: self c2 localSelectors sort = #(bar foo). self c2 addInstVarName: 'foobar'. self assert: self c2 traitCompositionString = 'T5 - {#m11}'. self assert: self c2 selectors sort = #(bar foo m12 m13 m21 m22 m51 m52 m53). self assert: self c2 localSelectors sort = #(bar foo). self c2 removeInstVarName: 'foobar'. self assert: self c2 traitCompositionString = 'T5 - {#m11}'. self assert: self c2 selectors sort = #(bar foo m12 m13 m21 m22 m51 m52 m53). self assert: self c2 localSelectors sort = #(bar foo). ! ----- 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 <timeout: 30> "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. ca := cb := ta := tb := tc := td := nil. super tearDown! ----- Method: TraitFileOutTest>>testCondenseChanges (in category 'testing') ----- testCondenseChanges "Tests moveChangesTo: in the face of aliases and other trait manipulations" | file classOrTrait originals copy | file := FileStream forceNewFileNamed: 'TraitFileOutTest.changes'. [originals := IdentityDictionary new. #(t1 t2 t3 t4 t5 t6 c1 c2) do:[:clsName| classOrTrait := self perform: clsName. classOrTrait methodsDo:[:each| originals at: each put: each getSourceFromFile. ]. file setToEnd. classOrTrait moveChangesTo: file. originals keysAndValuesDo:[:method :source| "we need the upfront assertion to avoid a current bug in #nextChunk when using out of bounds indexes" self assert: method filePosition < file size. copy := file position: method filePosition; nextChunkText. self assert: copy = source. ]. ]. ] ensure:[ TraitsResource current setDirty. file close. FileDirectory default deleteFileNamed: file name ifAbsent:[]. ].! ----- 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 globals keys includesAnyOf: #(CA CB TA TB TC TD)). self fileIn: self categoryName , '.st'.. self assert: (Smalltalk globals keys includesAllOf: #(CA CB TA TB TC TD)). ta := Smalltalk at: #TA. self assert: (ta isKindOf: Trait). self assert: 'TB + TC @ {#cc->#c} - {#c}' equals: ta traitComposition asString. self assert: (ta methodDict keys includesAllOf: #(a b cc)). cb := Smalltalk at: #CB. self assert: (cb isKindOf: Class). self assert: 'TA' equals: cb traitComposition asString. self assert: (cb methodDict keys includesAllOf: #(cb a b cc)). "test classSide traitComposition of CB" self assert: 'TA classTrait + TC' equals: cb classSide traitComposition asString. 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: 'T1 + T2 @ {#m22Alias->#m22}' equals: self t6 traitComposition asString. self assert: (self t6 methodDict keys includesAllOf: #( #localMethod: #m11 #m12 #m13 #m21 #m22 #m22Alias )). self assert: 2 equals: self t6 classSide methodDict size. self assert: (self t6 classSide methodDict keys includes: #localClassSideMethod:) description: 'Missing selector #localClassSideMethod:'. self assert: (self t6 classSide methodDict keys includes: #m2ClassSide:) description: 'Missing selector #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." <timeout: 30> "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) }. "make no undue sharing happens of exclusions and aliases after an expression copy" t6compositionCopyFirst := self t6 traitComposition copyTraitExpression. t6compositionCopyFirst at: 1 put: #m22Alias -> #m33. self assert: self t6 traitComposition second aliases first value = #m22. c2compositionCopy := self c2 traitComposition copyTraitExpression. c2compositionCopy first exclusions add: #m4. self assert: self c2 traitComposition first exclusions = #(#m11) asSet.! ----- 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 definition 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 definition 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: (UIManager default 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 globals. 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 TraitsResource resetIfDirty. self createdClassesAndTraits do: [:aClassOrTrait | | behaviorName | behaviorName := aClassOrTrait name. Smalltalk at: behaviorName ifPresent: [:classOrTrait | classOrTrait removeFromSystem]. ChangeSet current removeClassChanges: behaviorName]. createdClassesAndTraits := nil! 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 globals. 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 SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self. self createdClassesAndTraits do: [:aClassOrTrait | | behaviorName | 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)))))))))))))!

1 0

Squeak 4.6: ToolBuilder-SUnit-fbs.19.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of ToolBuilder-SUnit to project Squeak 4.6: http://source.squeak.org/squeak46/ToolBuilder-SUnit-fbs.19.mcz ==================== Summary ==================== Name: ToolBuilder-SUnit-fbs.19 Author: fbs Time: 9 January 2014, 2:54:40.438 pm UUID: 3e30756c-2af8-0741-836f-0d42a9d5af32 Ancestors: ToolBuilder-SUnit-fbs.18 Move ToolBuilder's SUnit "extensions" - the stubs we use to test ToolBuilder-built components - back to ToolBuilder-SUnit. Otherwise we break the modularity between SUnit('s GUI) and ToolBuilder. ==================== Snapshot ==================== SystemOrganization addCategory: #'ToolBuilder-SUnit'! Object subclass: #WidgetStub instanceVariableNames: 'spec state' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! WidgetStub subclass: #ButtonStub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: ButtonStub>>click (in category 'simulating') ----- click | action | action := spec action. action isSymbol ifTrue: [self model perform: action] ifFalse: [action value]! ----- Method: ButtonStub>>color (in category 'simulating') ----- color ^ state at: #color! ----- Method: ButtonStub>>isEnabled (in category 'simulating') ----- isEnabled ^ state at: #enabled! ----- Method: ButtonStub>>isPressed (in category 'simulating') ----- isPressed ^ state at: #state! ----- Method: ButtonStub>>label (in category 'simulating') ----- label ^ state at: #label! ----- Method: ButtonStub>>stateVariables (in category 'events') ----- stateVariables ^ #(label color state enabled)! WidgetStub subclass: #CompositeStub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: CompositeStub>>children (in category 'accessing') ----- children ^ state at: #children ifAbsent: [#()]! ----- Method: CompositeStub>>children: (in category 'accessing') ----- children: anObject state at: #children put: anObject! ----- Method: CompositeStub>>stateVariables (in category 'accessing') ----- stateVariables ^ #(children)! ----- Method: CompositeStub>>widgetNamed: (in category 'accessing') ----- widgetNamed: aString self name = aString ifTrue: [^ self] ifFalse: [self children do: [:ea | (ea widgetNamed: aString) ifNotNil: [:w | ^ w]]]. ^ nil! CompositeStub subclass: #PanelStub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! CompositeStub subclass: #WindowStub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: WindowStub>>close (in category 'simulating') ----- close spec model perform: spec closeAction! ----- Method: WindowStub>>stateVariables (in category 'events') ----- stateVariables ^ super stateVariables, #(label)! WidgetStub subclass: #ListStub instanceVariableNames: 'list index' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: ListStub>>click: (in category 'simulating') ----- click: aString self clickItemAt: (self list indexOf: aString)! ----- Method: ListStub>>clickItemAt: (in category 'simulating') ----- clickItemAt: anInteger | selector | selector := spec setIndex. selector ifNil: [self model perform: spec setSelected with: (self list at: anInteger)] ifNotNil: [self model perform: selector with: anInteger] ! ----- Method: ListStub>>list (in category 'simulating') ----- list ^ list ifNil: [Array new]! ----- Method: ListStub>>menu (in category 'simulating') ----- menu ^ MenuStub fromSpec: (self model perform: spec menu with: (PluggableMenuSpec withModel: self model))! ----- Method: ListStub>>refresh (in category 'events') ----- refresh self refreshList. self refreshIndex! ----- Method: ListStub>>refreshIndex (in category 'events') ----- refreshIndex | selector | selector := spec getIndex. index := selector ifNil: [self list indexOf: (self model perform: spec getSelected)] ifNotNil: [spec model perform: selector] ! ----- Method: ListStub>>refreshList (in category 'events') ----- refreshList list := self model perform: spec list! ----- Method: ListStub>>selectedIndex (in category 'simulating') ----- selectedIndex ^ index ifNil: [0]! ----- Method: ListStub>>selectedItem (in category 'simulating') ----- selectedItem | items idx | (items := self list) isEmpty ifTrue: [^ nil]. (idx := self selectedIndex) = 0 ifTrue: [^ nil]. ^ items at: idx ! ----- Method: ListStub>>update: (in category 'events') ----- update: aSelector aSelector = spec list ifTrue: [^ self refreshList]. aSelector = spec getSelected ifTrue: [^ self refreshIndex]. aSelector = spec getIndex ifTrue: [^ self refreshIndex]. ^ super update: aSelector! WidgetStub subclass: #MenuStub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: MenuStub>>click: (in category 'as yet unclassified') ----- click: aString | item | item := self items detect: [:ea | ea label = aString] ifNone: [^ self]. item action isSymbol ifTrue: [self model perform: item action] ifFalse: [item action value]! ----- Method: MenuStub>>items (in category 'as yet unclassified') ----- items ^ spec items! ----- Method: MenuStub>>labels (in category 'as yet unclassified') ----- labels ^ self items keys! WidgetStub subclass: #TextStub instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: TextStub>>accept: (in category 'simulating') ----- accept: aString state at: #getText put: aString. ^ self model perform: spec setText with: aString asText! ----- Method: TextStub>>color (in category 'simulating') ----- color ^ state at: #color! ----- Method: TextStub>>stateVariables (in category 'events') ----- stateVariables ^ #(color selection getText)! ----- Method: TextStub>>text (in category 'simulating') ----- text ^ state at: #getText! WidgetStub subclass: #TreeNodeStub instanceVariableNames: 'item' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: TreeNodeStub class>>fromSpec:item: (in category 'instance creation') ----- fromSpec: aSpec item: anObject ^ self new setSpec: aSpec item: anObject! ----- Method: TreeNodeStub>>children (in category 'simulating') ----- children ^ (self model perform: spec getChildren with: item) collect: [:ea | TreeNodeStub fromSpec: spec item: ea]! ----- Method: TreeNodeStub>>item (in category 'simulating') ----- item ^ item! ----- Method: TreeNodeStub>>label (in category 'simulating') ----- label ^ self model perform: spec label with: item! ----- Method: TreeNodeStub>>matches: (in category 'private') ----- matches: aString ^ self label = aString! ----- Method: TreeNodeStub>>openPath: (in category 'events') ----- openPath: anArray | child | anArray isEmpty ifTrue: [self select] ifFalse: [child := self children detect: [:ea | ea matches: anArray first] ifNone: [^ self select]. child openPath: anArray allButFirst] ! ----- Method: TreeNodeStub>>printOn: (in category 'printing') ----- printOn: aStream aStream print: self class; nextPut: $<; print: item; nextPut: $>! ----- Method: TreeNodeStub>>select (in category 'simulating') ----- select self model perform: spec setSelected with: item! ----- Method: TreeNodeStub>>selectPath: (in category 'private') ----- selectPath: anArray | child | anArray isEmpty ifTrue: [^ self select]. child := self children detect: [:ea | ea matches: anArray first] ifNone: [^ self select]. child selectPath: anArray allButFirst.! ----- Method: TreeNodeStub>>setSpec:item: (in category 'initialize-release') ----- setSpec: aSpec item: anObject super setSpec: aSpec. item := anObject! WidgetStub subclass: #TreeStub instanceVariableNames: 'roots' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: TreeStub>>openPath: (in category 'private') ----- openPath: anArray | first | first := roots detect: [:ea | ea matches: anArray first] ifNone: [^ self]. first openPath: anArray allButFirst! ----- Method: TreeStub>>roots: (in category 'private') ----- roots: anArray roots := anArray collect: [:ea | TreeNodeStub fromSpec: spec item: ea]. ! ----- Method: TreeStub>>select: (in category 'simulating') ----- select: anArray self openPath: anArray! ----- Method: TreeStub>>setSpec: (in category 'initialize-release') ----- setSpec: aSpec super setSpec: aSpec. self update: spec roots! ----- Method: TreeStub>>update: (in category 'events') ----- update: anObject anObject == spec roots ifTrue: [^ self updateRoots]. anObject == spec getSelectedPath ifTrue: [^ self updateSelectedPath]. (anObject isKindOf: Array) ifTrue: [^ self openPath: anObject allButFirst]. super update: anObject ! ----- Method: TreeStub>>updateRoots (in category 'events') ----- updateRoots ^ self roots: (self model perform: spec roots) ! ----- Method: TreeStub>>updateSelectedPath (in category 'events') ----- updateSelectedPath | path first | path := self model perform: spec getSelectedPath. first := roots detect: [:ea | ea item = path first] ifNone: [^ self]. first selectPath: path allButFirst.! ----- Method: WidgetStub class>>fromSpec: (in category 'instance creation') ----- fromSpec: aSpec ^ self new setSpec: aSpec! ----- Method: WidgetStub>>model (in category 'simulating') ----- model ^ spec model! ----- Method: WidgetStub>>name (in category 'accessing') ----- name ^ spec name ifNil: [' ']! ----- Method: WidgetStub>>printOn: (in category 'printing') ----- printOn: aStream aStream print: self class; nextPut: $<; nextPutAll: self name; nextPut: $>! ----- Method: WidgetStub>>refresh (in category 'events') ----- refresh self stateVariables do: [:var | self refresh: var]! ----- Method: WidgetStub>>refresh: (in category 'events') ----- refresh: var | value | value := spec perform: var. self refresh: var with: value! ----- Method: WidgetStub>>refresh:with: (in category 'events') ----- refresh: var with: value state at: var put: (value isSymbol ifTrue: [spec model perform: value] ifFalse: [value])! ----- Method: WidgetStub>>setSpec: (in category 'initialize-release') ----- setSpec: aSpec state := IdentityDictionary new. spec := aSpec. spec model addDependent: self. self refresh.! ----- Method: WidgetStub>>spec (in category 'accessing') ----- spec ^ spec! ----- Method: WidgetStub>>stateVariables (in category 'events') ----- stateVariables ^ #()! ----- Method: WidgetStub>>update: (in category 'events') ----- update: aSymbol self stateVariables do: [:var | (spec perform: var) == aSymbol ifTrue: [self refresh: var with: aSymbol. ^ self]]! ----- Method: WidgetStub>>widgetNamed: (in category 'accessing') ----- widgetNamed: aString ^ self name = aString ifTrue: [self] ifFalse: [nil]! ToolBuilder subclass: #SUnitToolBuilder instanceVariableNames: 'widgets' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! !SUnitToolBuilder commentStamp: 'cwp 6/7/2005 00:53' prior: 0! I create a set of "stub" widgets that are useful for testing. Instead of drawing themselves in some GUI, they simulate graphical widgets for testing purposes. Through my widgets, unit tests can simulate user actions and make assertions about the state of the display. See TestRunnerPlusTest for examples.! ----- Method: SUnitToolBuilder>>buildPluggableButton: (in category 'building') ----- buildPluggableButton: aSpec | w | w := ButtonStub fromSpec: aSpec. self register: w id: aSpec name. ^w! ----- Method: SUnitToolBuilder>>buildPluggableList: (in category 'building') ----- buildPluggableList: aSpec | w | w := ListStub fromSpec: aSpec. self register: w id: aSpec name. ^w! ----- Method: SUnitToolBuilder>>buildPluggableMenu: (in category 'building') ----- buildPluggableMenu: aSpec ^ MenuStub fromSpec: aSpec! ----- Method: SUnitToolBuilder>>buildPluggablePanel: (in category 'building') ----- buildPluggablePanel: aSpec | w | w := PanelStub fromSpec: aSpec. self register: w id: aSpec name. ^w! ----- Method: SUnitToolBuilder>>buildPluggableText: (in category 'building') ----- buildPluggableText: aSpec | w | w := TextStub fromSpec: aSpec. self register: w id: aSpec name. ^w! ----- Method: SUnitToolBuilder>>buildPluggableTree: (in category 'building') ----- buildPluggableTree: aSpec | w | w := TreeStub fromSpec: aSpec. self register: w id: aSpec name. ^w! ----- Method: SUnitToolBuilder>>buildPluggableWindow: (in category 'building') ----- buildPluggableWindow: aSpec | window children | window := WindowStub fromSpec: aSpec. children := aSpec children. children isSymbol ifFalse: [window children: (children collect: [:ea | ea buildWith: self])]. self register: window id: aSpec name. ^ window! ----- Method: SUnitToolBuilder>>close: (in category 'opening') ----- close: aWidget aWidget close! ----- Method: SUnitToolBuilder>>open: (in category 'opening') ----- open: anObject ^ self build: anObject! ----- Method: SUnitToolBuilder>>register:id: (in category 'private') ----- register: widget id: id id ifNil:[^self]. widgets ifNil:[widgets := Dictionary new]. widgets at: id put: widget.! ----- Method: SUnitToolBuilder>>widgetAt:ifAbsent: (in category 'private') ----- widgetAt: id ifAbsent: aBlock widgets ifNil:[^aBlock value]. ^widgets at: id ifAbsent: aBlock! ToolBuilderTests subclass: #SUnitToolBuilderTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolBuilder-SUnit'! ----- Method: SUnitToolBuilderTests>>acceptWidgetText (in category 'support') ----- acceptWidgetText widget accept: 'Some text'! ----- Method: SUnitToolBuilderTests>>buttonWidgetEnabled (in category 'support') ----- buttonWidgetEnabled ^ widget isEnabled! ----- Method: SUnitToolBuilderTests>>changeListWidget (in category 'support') ----- changeListWidget widget clickItemAt: widget selectedIndex + 1! ----- Method: SUnitToolBuilderTests>>fireButtonWidget (in category 'support') ----- fireButtonWidget widget click! ----- Method: SUnitToolBuilderTests>>fireMenuItemWidget (in category 'support') ----- fireMenuItemWidget widget click: 'Menu Item'! ----- Method: SUnitToolBuilderTests>>setUp (in category 'running') ----- setUp super setUp. builder := SUnitToolBuilder new.! ----- Method: SUnitToolBuilderTests>>testHandlingNotification (in category 'tests') ----- testHandlingNotification | receivedSignal resumed | receivedSignal := resumed := false. [ | count | "client-code puts up progress, and signals some notications" count := 0. 'doing something' displayProgressFrom: 0 to: 10 during: [ : bar | 10 timesRepeat: [ bar value: (count := count + 1). (Delay forMilliseconds: 200) wait. Notification signal: 'message'. resumed := true ] ] ] on: Notification do: [ : noti | receivedSignal := true. noti resume ]. self assert: receivedSignal ; assert: resumed! ----- Method: SUnitToolBuilderTests>>testListCached (in category 'tests') ----- testListCached self makeItemList. queries := Bag new. self changed: #getList. widget list. widget list. self assert: queries size = 1! ----- Method: SUnitToolBuilderTests>>testListSelectionCached (in category 'tests') ----- testListSelectionCached self makeItemList. queries := Bag new. self changed: #getListSelection. widget selectedIndex. widget selectedIndex. self assert: queries size = 1! ----- Method: SUnitToolBuilderTests>>testTextCached (in category 'tests') ----- testTextCached self makeText. queries := Bag new. self changed: #getText. widget text. widget text. self assert: queries size = 1! ----- Method: SUnitToolBuilderTests>>widgetColor (in category 'support') ----- widgetColor ^ widget color!

1 0

Squeak 4.6: MonticelloForTraits-fbs.1.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of MonticelloForTraits to project Squeak 4.6: http://source.squeak.org/squeak46/MonticelloForTraits-fbs.1.mcz ==================== Summary ==================== Name: MonticelloForTraits-fbs.1 Author: fbs Time: 9 August 2013, 8:46:48.716 am UUID: 160be615-5ab7-4148-a7cb-60dd629ab085 Ancestors: Initial commit. This package extends Monticello to support Traits. It exists so that one may freely unload Monticello, Traits, or both, in an image. ==================== Snapshot ==================== ----- Method: Trait>>asClassDefinition (in category '*MonticelloForTraits') ----- asClassDefinition ^Smalltalk at: #MCTraitDefinition ifPresent:[:aClass| aClass name: self name traitComposition: self traitCompositionString category: self category comment: self organization classComment asString commentStamp: self organization commentStamp].! ----- Method: Trait>>classDefinitions (in category '*MonticelloForTraits') ----- classDefinitions | definitions | definitions := OrderedCollection with: self asClassDefinition. (self hasClassTrait and: [self classTrait hasTraitComposition and: [self classTrait traitComposition isEmpty not]]) ifTrue: [definitions add: self classTrait asMCDefinition]. ^definitions asArray!

1 0

Squeak 4.6: MorphicExtrasTests-fbs.3.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of MorphicExtrasTests to project Squeak 4.6: http://source.squeak.org/squeak46/MorphicExtrasTests-fbs.3.mcz ==================== Summary ==================== Name: MorphicExtrasTests-fbs.3 Author: fbs Time: 30 November 2013, 11:03:19.679 pm UUID: 1c039763-bc92-834c-943e-d96d8820cbd7 Ancestors: MorphicExtrasTests-fbs.2 Tests for MorphicExtras's selector mangling. ==================== Snapshot ==================== SystemOrganization addCategory: #'MorphicExtrasTests-Postscript Filters'! SystemOrganization addCategory: #'MorphicExtrasTests-Flaps'! TestCase subclass: #ByteEncoderTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtrasTests-Postscript Filters'! ----- Method: ByteEncoderTest>>testIntegerByteEncoded (in category 'testing') ----- testIntegerByteEncoded self assert: (ByteEncoder stream writeNumber: 2 base: 2; yourself) contents = '10'. self assert: (ByteEncoder stream writeNumber: 21 base: 3; yourself) contents = '210'. self assert: (ByteEncoder stream writeNumber: 228 base: 4; yourself) contents = '3210'. self assert: (ByteEncoder stream writeNumber: 2930 base: 5; yourself) contents = '43210'. self assert: (ByteEncoder stream writeNumber: 44790 base: 6; yourself) contents = '543210'. self assert: (ByteEncoder stream writeNumber: 800667 base: 7; yourself) contents = '6543210'. self assert: (ByteEncoder stream writeNumber: 16434824 base: 8; yourself) contents = '76543210'. self assert: (ByteEncoder stream writeNumber: 381367044 base: 9; yourself) contents = '876543210'. self assert: (ByteEncoder stream writeNumber: 9876543210 base: 10; yourself) contents = '9876543210'. self assert: (ByteEncoder stream writeNumber: 282458553905 base: 11; yourself) contents = 'A9876543210'. self assert: (ByteEncoder stream writeNumber: 8842413667692 base: 12; yourself) contents = 'BA9876543210'. self assert: (ByteEncoder stream writeNumber: 300771807240918 base: 13; yourself) contents = 'CBA9876543210'. self assert: (ByteEncoder stream writeNumber: 11046255305880158 base: 14; yourself) contents = 'DCBA9876543210'. self assert: (ByteEncoder stream writeNumber: 435659737878916215 base: 15; yourself) contents = 'EDCBA9876543210'. self assert: (ByteEncoder stream writeNumber: 18364758544493064720 base: 16; yourself) contents = 'FEDCBA9876543210'. self assert: (ByteEncoder stream writeNumber: -2 base: 2; yourself) contents = '-10'. self assert: (ByteEncoder stream writeNumber: -21 base: 3; yourself) contents = '-210'. self assert: (ByteEncoder stream writeNumber: -228 base: 4; yourself) contents = '-3210'. self assert: (ByteEncoder stream writeNumber: -2930 base: 5; yourself) contents = '-43210'. self assert: (ByteEncoder stream writeNumber: -44790 base: 6; yourself) contents = '-543210'. self assert: (ByteEncoder stream writeNumber: -800667 base: 7; yourself) contents = '-6543210'. self assert: (ByteEncoder stream writeNumber: -16434824 base: 8; yourself) contents = '-76543210'. self assert: (ByteEncoder stream writeNumber: -381367044 base: 9; yourself) contents = '-876543210'. self assert: (ByteEncoder stream writeNumber: -9876543210 base: 10; yourself) contents = '-9876543210'. self assert: (ByteEncoder stream writeNumber: -282458553905 base: 11; yourself) contents = '-A9876543210'. self assert: (ByteEncoder stream writeNumber: -8842413667692 base: 12; yourself) contents = '-BA9876543210'. self assert: (ByteEncoder stream writeNumber: -300771807240918 base: 13; yourself) contents = '-CBA9876543210'. self assert: (ByteEncoder stream writeNumber: -11046255305880158 base: 14; yourself) contents = '-DCBA9876543210'. self assert: (ByteEncoder stream writeNumber: -435659737878916215 base: 15; yourself) contents = '-EDCBA9876543210'. self assert: (ByteEncoder stream writeNumber: -18364758544493064720 base: 16; yourself) contents = '-FEDCBA9876543210'.! TestCase subclass: #FlapTabTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtrasTests-Flaps'! !FlapTabTests commentStamp: 'wiz 6/11/2007 17:58' prior: 0! A FlapTabTests is here to test infinite recursion bug when extent: message is sent to some flap tabs see http://bugs.squeak.org/view.php?id=6486 for report. Instance Variables We inherit cases which can be filled with morphs that need to be deleted at the end of the test. ! ----- Method: FlapTabTests>>testFlapTabRecusion (in category 'tests') ----- testFlapTabRecusion | a b tab | "Create a float close to 466.700581395349" a := 1.1 at: 1 put: 1081944885; at: 2 put: 2497074009; yourself. b := 105. self deny: a + b - a = b. tab := Flaps newFlapTitled: 'Test' onEdge: #top. tab left: a. self should: [tab extent: b asPoint] notTakeMoreThanMilliseconds: 10 ! TestCase subclass: #MorphicExtrasSymbolExtensionsTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicExtrasTests-Flaps'! ----- Method: MorphicExtrasSymbolExtensionsTest>>testAsSimpleSetterReturnsSetterSelector (in category 'as yet unclassified') ----- testAsSimpleSetterReturnsSetterSelector self assert: #foo: equals: #foo asSimpleSetter. "And it really is 'simple':" self assert: #foo:: equals: #foo: asSimpleSetter.!

1 0

Squeak 4.6: SystemChangeNotification-Tests-nice.23.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of SystemChangeNotification-Tests to project Squeak 4.6: http://source.squeak.org/squeak46/SystemChangeNotification-Tests-nice.23.mcz ==================== Summary ==================== Name: SystemChangeNotification-Tests-nice.23 Author: nice Time: 18 December 2013, 2:43:23.729 pm UUID: 3eed6d26-4aef-4095-a604-d9f914240281 Ancestors: SystemChangeNotification-Tests-fbs.22 Use non logging Compiler protocol rather than providing a logged: false argument. ==================== Snapshot ==================== SystemOrganization addCategory: #'SystemChangeNotification-Tests'! TestCase subclass: #SystemChangeFileTest instanceVariableNames: 'tempChangesFile tempChangesName' classVariableNames: '' poolDictionaries: '' category: 'SystemChangeNotification-Tests'! ----- Method: SystemChangeFileTest>>change:verify: (in category 'testing') ----- change: changeBlock verify: verifyBlock self prepare: [] change: changeBlock verify: verifyBlock! ----- Method: SystemChangeFileTest>>createClass: (in category 'private') ----- createClass: name ^Object subclass: name instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self genericClassCategory! ----- Method: SystemChangeFileTest>>directory (in category 'accessing') ----- directory "Where we want to place the temporary changes file" ^FileDirectory default! ----- Method: SystemChangeFileTest>>expectedFailures (in category 'testing') ----- expectedFailures ^#( #testCategoryModified #testClassReorganized #testProtocolModified )! ----- Method: SystemChangeFileTest>>genericChangesName (in category 'private') ----- genericChangesName ^self prefixChangesName, self randomString, '.changes'! ----- Method: SystemChangeFileTest>>genericClassCategory (in category 'private') ----- genericClassCategory ^(self prefixClassCategory, self randomString capitalized) asSymbol! ----- Method: SystemChangeFileTest>>genericClassName (in category 'private') ----- genericClassName ^(self prefixClassName, self randomString capitalized) asSymbol! ----- Method: SystemChangeFileTest>>genericInstVarName (in category 'private') ----- genericInstVarName ^(self prefixInstVarName, self randomString capitalized) asSymbol! ----- Method: SystemChangeFileTest>>genericProtocol (in category 'private') ----- genericProtocol ^(self prefixProtocol, self randomString) asSymbol! ----- Method: SystemChangeFileTest>>genericSelector (in category 'private') ----- genericSelector ^(self prefixSelector, self randomString capitalized) asSymbol! ----- Method: SystemChangeFileTest>>prefixChangesName (in category 'private') ----- prefixChangesName ^self prefixGeneral! ----- Method: SystemChangeFileTest>>prefixClassCategory (in category 'private') ----- prefixClassCategory ^self prefixGeneral, 'Category-'! ----- Method: SystemChangeFileTest>>prefixClassName (in category 'private') ----- prefixClassName ^self prefixGeneral, 'Class'! ----- Method: SystemChangeFileTest>>prefixGeneral (in category 'private') ----- prefixGeneral ^self class name select: [:each | each isUppercase]! ----- Method: SystemChangeFileTest>>prefixInstVarName (in category 'private') ----- prefixInstVarName ^self prefixGeneral asLowercase, 'InstVar'! ----- Method: SystemChangeFileTest>>prefixProtocol (in category 'private') ----- prefixProtocol ^self prefixGeneral asLowercase, ' protocol '! ----- Method: SystemChangeFileTest>>prefixSelector (in category 'private') ----- prefixSelector ^self prefixGeneral asLowercase, 'Selector'! ----- Method: SystemChangeFileTest>>prepare:change:verify: (in category 'testing') ----- prepare: prepareBlock change: changeBlock verify: verifyBlock "All tests follow this pattern. Beware that prepareBlock (and verifyBlock) will be evalutated twice." "Setup the testcourt" prepareBlock value. "Embrace the changeBlock so that any change to our testcourt will be recorded in our temporary changes file" self useTemporaryChangesFile. changeBlock value. "Check if the changes we made worked as expected. We need to do this before we switch back to the standard changes file" "We raise an Error if this fails, because then the testcase is broken" [verifyBlock value] on: TestFailure do: [self error: 'The verifyBlock needs to validate the changes made in the changeBlock']. self useStandardChangesFile. "Remove the testcourt completely" self removeTestcourt. "Setup the testcourt once again" prepareBlock value. "Replay the changes from the temporary changes file" self replayChanges. "See if we got the same changes as we did before using the changeBlock" verifyBlock value. ! ----- Method: SystemChangeFileTest>>randomString (in category 'private') ----- randomString ^Character alphabet shuffled! ----- Method: SystemChangeFileTest>>removeTestcourt (in category 'private') ----- removeTestcourt SystemOrganization categories do: [:each | (each beginsWith: self prefixClassCategory) ifTrue: [ SystemOrganization removeSystemCategory: each. ]. ]. ! ----- Method: SystemChangeFileTest>>replayChanges (in category 'private') ----- replayChanges | file | file := FileStream fileNamed: (self directory fullNameFor: self tempChangesName). Transcript show: file contents; cr. file fileIn. ! ----- Method: SystemChangeFileTest>>tearDown (in category 'running') ----- tearDown self useStandardChangesFile. tempChangesFile := tempChangesFile ifNotNil: [tempChangesFile close]. (self directory fileExists: self tempChangesName) ifTrue: [self directory deleteFileNamed: self tempChangesName]. self removeTestcourt. ! ----- Method: SystemChangeFileTest>>tempChangesName (in category 'accessing') ----- tempChangesName ^tempChangesName ifNil: [tempChangesName := self genericChangesName]! ----- Method: SystemChangeFileTest>>testCategoryAdded (in category 'testing') ----- testCategoryAdded | aClassCategory | aClassCategory := self genericClassCategory. self change: [ SystemOrganization addCategory: aClassCategory. ] verify: [ self assert: (SystemOrganization categories includes: aClassCategory). ] ! ----- Method: SystemChangeFileTest>>testCategoryAddedBefore (in category 'testing') ----- testCategoryAddedBefore | aClassCategory | aClassCategory := self genericClassCategory. self change: [ SystemOrganization addCategory: aClassCategory before: nil. ] verify: [ self assert: (SystemOrganization categories includes: aClassCategory). ] ! ----- Method: SystemChangeFileTest>>testCategoryModified (in category 'as yet unclassified') ----- testCategoryModified self assert: false description: 'When does that happen?'! ----- Method: SystemChangeFileTest>>testCategoryRemoved (in category 'testing') ----- testCategoryRemoved | aClassCategory | aClassCategory := self genericClassCategory. self prepare: [ SystemOrganization addCategory: aClassCategory. ] change: [ SystemOrganization removeCategory: aClassCategory. ] verify: [ self deny: (SystemOrganization categories includes: aClassCategory). ] ! ----- Method: SystemChangeFileTest>>testCategoryRenamed (in category 'testing') ----- testCategoryRenamed | aNewClassCategory anOldClassCategory | anOldClassCategory := self genericClassCategory. aNewClassCategory := self genericClassCategory. self prepare: [ SystemOrganization addCategory: anOldClassCategory. ] change: [ SystemOrganization renameCategory: anOldClassCategory toBe: aNewClassCategory ] verify: [ self assert: (SystemOrganization categories includes: aNewClassCategory). self deny: (SystemOrganization categories includes: anOldClassCategory). ] ! ----- Method: SystemChangeFileTest>>testClassAdded (in category 'testing') ----- testClassAdded | aClassName | aClassName := self genericClassName. self change: [ self createClass: aClassName. ] verify: [ self assert: (Smalltalk globals includesKey: aClassName). ] ! ----- Method: SystemChangeFileTest>>testClassCommented (in category 'testing') ----- testClassCommented | aClass aClassName aComment | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aComment := self randomString. aClass classComment: aComment. ] verify: [ self assert: aClass organization classComment string = aComment. ].! ----- Method: SystemChangeFileTest>>testClassModified (in category 'testing') ----- testClassModified | aClass aClassName aInstVarName | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aInstVarName := self genericInstVarName. aClass addInstVarName: aInstVarName. ] verify: [ self assert: (aClass instVarNames includes: aInstVarName). ].! ----- Method: SystemChangeFileTest>>testClassRecategorized (in category 'testing') ----- testClassRecategorized | aClassName aNewClassCategory | aClassName := self genericClassName. aNewClassCategory := self genericClassCategory. self prepare: [ self createClass: aClassName. SystemOrganization addCategory: aNewClassCategory. ] change: [ SystemOrganization classify: aClassName under: aNewClassCategory. ] verify: [ self assert: (SystemOrganization categoryOfElement: aClassName) = aNewClassCategory. ] ! ----- Method: SystemChangeFileTest>>testClassRemoved (in category 'testing') ----- testClassRemoved | aClass aClassName | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aClass removeFromSystem. ] verify: [ self deny: (Smalltalk globals includesKey: aClassName). ]. ! ----- Method: SystemChangeFileTest>>testClassRenamed (in category 'testing') ----- testClassRenamed | aClass aNewClassName anOldClassName | anOldClassName := self genericClassName. aNewClassName := self genericClassName. self prepare: [ aClass := self createClass: anOldClassName. ] change: [ aClass rename: aNewClassName. ] verify: [ self assert: (Smalltalk globals includesKey: aNewClassName). self deny: (Smalltalk globals includesKey: anOldClassName). ].! ----- Method: SystemChangeFileTest>>testClassReorganized (in category 'as yet unclassified') ----- testClassReorganized self assert: false description: 'When does that happen?'! ----- Method: SystemChangeFileTest>>testExpressionDoIt (in category 'testing') ----- testExpressionDoIt | aClassName | aClassName := self genericClassName.. self prepare: [ self createClass: aClassName. ] change: [ Compiler evaluate: '(Smalltalk at: ', aClassName storeString, ') removeFromSystem'. ] verify: [ self deny: (Smalltalk globals includesKey: aClassName). ].! ----- Method: SystemChangeFileTest>>testMethodAdded (in category 'testing') ----- testMethodAdded | aClassName aClass aSelector | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aSelector := self genericSelector. aClass compile: aSelector. ] verify: [ self assert: (aClass methodDict includesKey: aSelector). ] ! ----- Method: SystemChangeFileTest>>testMethodModified (in category 'testing') ----- testMethodModified | aClassName aClass aSelector aMethodSource | aClassName := self genericClassName. aSelector := self genericSelector. self prepare: [ aClass := self createClass: aClassName. aClass compile: aSelector, ' ', self randomString storeString. ] change: [ aMethodSource := aSelector, ' ', self randomString storeString. aClass compile: aMethodSource. ] verify: [ self assert: (aClass sourceCodeAt: aSelector) string = aMethodSource. ] ! ----- Method: SystemChangeFileTest>>testMethodRecategorized (in category 'testing') ----- testMethodRecategorized | aClassName aClass aNewProtocol aSelector anOldProtocol | aClassName := self genericClassName. aSelector := self genericSelector. anOldProtocol := self genericProtocol. self prepare: [ aClass := self createClass: aClassName. aClass compile: aSelector classified: anOldProtocol. ] change: [ aNewProtocol := self genericProtocol. aClass organization classify: aSelector under: aNewProtocol. ] verify: [ self assert: (aClass organization categoryOfElement: aSelector) = aNewProtocol ] ! ----- Method: SystemChangeFileTest>>testMethodRemoved (in category 'testing') ----- testMethodRemoved | aClassName aClass aSelector | aClassName := self genericClassName. aSelector := self genericSelector. self prepare: [ aClass := self createClass: aClassName. aClass compile: aSelector. ] change: [ aClass removeSelector: aSelector. ] verify: [ self deny: (aClass methodDict includesKey: aSelector). ] ! ----- Method: SystemChangeFileTest>>testProtocolAdded (in category 'testing') ----- testProtocolAdded | aClassName aClass aProtocol | aClassName := self genericClassName. aProtocol := self genericProtocol. self prepare: [ aClass := self createClass: aClassName. ] change: [ aClass organization addCategory: aProtocol. ] verify: [ self assert: (aClass organization categories includes: aProtocol) ] ! ----- Method: SystemChangeFileTest>>testProtocolDefault (in category 'testing') ----- testProtocolDefault | aClassName aClass aSelector | aClassName := self genericClassName. self prepare: [ aClass := self createClass: aClassName. ] change: [ aSelector := self genericSelector. aClass compile: aSelector. ] verify: [ self assert: (aClass organization categoryOfElement: aSelector) = aClass organization class default. ] ! ----- Method: SystemChangeFileTest>>testProtocolModified (in category 'as yet unclassified') ----- testProtocolModified self assert: false description: 'When does that happen?'! ----- Method: SystemChangeFileTest>>testProtocolRemoved (in category 'testing') ----- testProtocolRemoved | aClassName aClass aProtocol | aClassName := self genericClassName. aProtocol := self genericProtocol. self prepare: [ aClass := self createClass: aClassName. aClass organization addCategory: aProtocol. ] change: [ aClass organization removeCategory: aProtocol. ] verify: [ self deny: (aClass organization categories includes: aProtocol) ] ! ----- Method: SystemChangeFileTest>>testProtocolRenamed (in category 'testing') ----- testProtocolRenamed | aClassName aClass anOldProtocol aNewProtocol | aClassName := self genericClassName. anOldProtocol := self genericProtocol. self prepare: [ aClass := self createClass: aClassName. aClass organization addCategory: anOldProtocol. ] change: [ aNewProtocol := self genericProtocol. aClass organization renameCategory: anOldProtocol toBe: aNewProtocol. ] verify: [ self deny: (aClass organization categories includes: anOldProtocol). self assert: (aClass organization categories includes: aNewProtocol). ] ! ----- Method: SystemChangeFileTest>>useStandardChangesFile (in category 'private') ----- useStandardChangesFile Smalltalk closeSourceFiles; openSourceFiles! ----- Method: SystemChangeFileTest>>useTemporaryChangesFile (in category 'private') ----- useTemporaryChangesFile Smalltalk closeSourceFiles. tempChangesFile := self directory forceNewFileNamed: self tempChangesName. SourceFiles at: 2 put: tempChangesFile! TestCase subclass: #SystemChangeTestRoot instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SystemChangeNotification-Tests'! !SystemChangeTestRoot commentStamp: 'rw 4/5/2006 17:28' prior: 0! The Root test class for the System Change Notification tests.! SystemChangeTestRoot subclass: #ChangeHooksTest instanceVariableNames: 'previousChangeSet testsChangeSet capturedEvents generatedTestClass generatedTestClassX createdMethodName createdMethod doItExpression' classVariableNames: '' poolDictionaries: '' category: 'SystemChangeNotification-Tests'! !ChangeHooksTest commentStamp: 'bp 12/4/2009 10:37' prior: 0! This class implements unit tests to verify that when the system changes, notification messages are sent around correctly. Therefore the test messages make a system change, after registering to receive an event after the change occured. In this event (sent immediately after the change), the actual assertions take place. Note that the system changes are *really* made to the system, but in a change set that is created in the setUp method, while the previous one is restored in the tearDown method.! ----- Method: ChangeHooksTest>>addSingleEvent: (in category 'Private') ----- addSingleEvent: anEvent capturedEvents isEmpty ifFalse: [self assert: false]. capturedEvents add: anEvent! ----- Method: ChangeHooksTest>>checkEvent:kind:item:itemKind: (in category 'Private') ----- checkEvent: anEvent kind: changeKind item: item itemKind: itemKind self assert: (anEvent perform: ('is' , changeKind) asSymbol). self assert: anEvent item = item. self assert: anEvent itemKind = itemKind! ----- Method: ChangeHooksTest>>checkForOnlySingleEvent (in category 'Private') ----- checkForOnlySingleEvent self assert: capturedEvents size = 1! ----- Method: ChangeHooksTest>>classCommentedEvent: (in category 'Events-Classes') ----- classCommentedEvent: event self addSingleEvent: event. self assert: generatedTestClass comment = self commentStringForTesting. self checkEvent: event kind: #Commented item: generatedTestClass itemKind: AbstractEvent classKind! ----- Method: ChangeHooksTest>>classCreationEvent: (in category 'Events-Classes') ----- classCreationEvent: event | classCreated | self addSingleEvent: event. classCreated := Smalltalk classNamed: self newlyCreatedClassName. self assert: classCreated notNil. self assert: ((Smalltalk organization listAtCategoryNamed: #'System-Change Notification') includes: self newlyCreatedClassName). self checkEvent: event kind: #Added item: classCreated itemKind: AbstractEvent classKind! ----- Method: ChangeHooksTest>>classRecategorizedEvent: (in category 'Events-Classes') ----- classRecategorizedEvent: event self addSingleEvent: event. self checkEvent: event kind: #Recategorized item: generatedTestClass itemKind: AbstractEvent classKind. self assert: event oldCategory = #'System-Change Notification'! ----- Method: ChangeHooksTest>>classRedefinitionEvent: (in category 'Events-Classes') ----- classRedefinitionEvent: event self addSingleEvent: event. self checkEvent: event kind: #Modified item: generatedTestClass itemKind: AbstractEvent classKind.! ----- Method: ChangeHooksTest>>classRemovalEvent: (in category 'Events-Classes') ----- classRemovalEvent: event "This event used to be sent efter the class was removed. This was changed, and therefore this test is useless currently." self addSingleEvent: event. self assert: (Smalltalk classNamed: self generatedTestClassName) isNil. self checkEvent: event kind: #Removed item: self generatedTestClassName itemKind: AbstractEvent classKind! ----- Method: ChangeHooksTest>>classRenameEvent: (in category 'Events-Classes') ----- classRenameEvent: event | renamedClass | self addSingleEvent: event. renamedClass := Smalltalk classNamed: self renamedTestClassName. self assert: renamedClass notNil. self assert: (Smalltalk classNamed: self generatedTestClassName) isNil. self checkEvent: event kind: #Renamed item: renamedClass itemKind: AbstractEvent classKind. self assert: event oldName = self generatedTestClassName! ----- Method: ChangeHooksTest>>classSuperChangedEvent: (in category 'Events-Classes') ----- classSuperChangedEvent: event self addSingleEvent: event. self checkEvent: event kind: #Modified item: generatedTestClass itemKind: AbstractEvent classKind. self assert: generatedTestClass superclass = Model! ----- Method: ChangeHooksTest>>commentStringForTesting (in category 'Private') ----- commentStringForTesting ^'Added this comment as part of the unit test in SystemChangeTest>>testClassCommentedBasicEvents. You should never see this, unless you are debugging the system somewhere in between the tests.'! ----- Method: ChangeHooksTest>>generateTestClass (in category 'Private-Generation') ----- generateTestClass generatedTestClass := Object subclass: self generatedTestClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'.! ----- Method: ChangeHooksTest>>generateTestClassX (in category 'Private-Generation') ----- generateTestClassX generatedTestClassX := Object subclass: self generatedTestClassNameX instanceVariableNames: 'x' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'.! ----- Method: ChangeHooksTest>>generatedTestClassName (in category 'Private-Generation') ----- generatedTestClassName ^#'AutoGeneratedClassForTestingSystemChanges'! ----- Method: ChangeHooksTest>>generatedTestClassNameX (in category 'Private-Generation') ----- generatedTestClassNameX ^#'AutoGeneratedClassXForTestingSystemChanges'! ----- Method: ChangeHooksTest>>instanceVariableCreationEvent: (in category 'Events-Instance Variables') ----- instanceVariableCreationEvent: event self addSingleEvent: event. self assert: event isModified. self assert: event item = generatedTestClass. self assert: event itemKind = AbstractEvent classKind. self assert: event areInstVarsModified. self deny: event isSuperclassModified. self deny: event areClassVarsModified. self deny: event areSharedPoolsModified. ! ----- Method: ChangeHooksTest>>instanceVariableRemovedEvent: (in category 'Events-Instance Variables') ----- instanceVariableRemovedEvent: event self addSingleEvent: event. self assert: event isModified. self assert: event item = generatedTestClassX. self assert: event itemKind = AbstractEvent classKind. self assert: event areInstVarsModified. self deny: event isSuperclassModified. self deny: event areClassVarsModified. self deny: event areSharedPoolsModified. ! ----- Method: ChangeHooksTest>>methodCreationEvent1: (in category 'Events-Methods') ----- methodCreationEvent1: event | methodCreated | self addSingleEvent: event. methodCreated := generatedTestClass >> createdMethodName. self checkEvent: event kind: #Added item: methodCreated itemKind: AbstractEvent methodKind! ----- Method: ChangeHooksTest>>methodCreationEvent2: (in category 'Events-Methods') ----- methodCreationEvent2: event | methodCreated | self addSingleEvent: event. methodCreated := generatedTestClass >> createdMethodName. self checkEvent: event kind: #Added item: methodCreated itemKind: AbstractEvent methodKind! ----- Method: ChangeHooksTest>>methodDoItEvent1: (in category 'Events-Expression') ----- methodDoItEvent1: event self addSingleEvent: event. self checkEvent: event kind: #DoIt item: doItExpression itemKind: AbstractEvent expressionKind. self assert: event context isNil.! ----- Method: ChangeHooksTest>>methodRecategorizationEvent: (in category 'Events-Methods') ----- methodRecategorizationEvent: event | methodCreated | self addSingleEvent: event. methodCreated := generatedTestClass >> createdMethodName. self assert: ((generatedTestClass organization categoryOfElement: createdMethodName) = #newCategory). self assert: event oldCategory = #testing. self checkEvent: event kind: #Recategorized item: methodCreated itemKind: AbstractEvent methodKind.! ----- Method: ChangeHooksTest>>methodRemovedEvent1: (in category 'Events-Methods') ----- methodRemovedEvent1: event self addSingleEvent: event. self should: [generatedTestClass >> createdMethodName] raise: Error. self checkEvent: event kind: #Removed item: createdMethod itemKind: AbstractEvent methodKind. event itemClass = generatedTestClass. event itemMethod = createdMethodName. self assert: ((generatedTestClass organization categoryOfElement: createdMethodName) isNil).! ----- Method: ChangeHooksTest>>methodRemovedEvent2: (in category 'Events-Methods') ----- methodRemovedEvent2: event self methodRemovedEvent1: event! ----- Method: ChangeHooksTest>>newlyCreatedClassName (in category 'Private-Generation') ----- newlyCreatedClassName ^#'AutoGeneratedClassWhileTestingSystemChanges'! ----- Method: ChangeHooksTest>>rememberEvent: (in category 'Events-General') ----- rememberEvent: event capturedEvents add: event! ----- Method: ChangeHooksTest>>removeGeneratedTestClasses (in category 'Private') ----- removeGeneratedTestClasses "Remove all classes that were possibly generated during testing." | possiblyToRemove | possiblyToRemove := OrderedCollection with: self generatedTestClassName with: self generatedTestClassNameX with: self renamedTestClassName with: self newlyCreatedClassName. possiblyToRemove do: [:name | (Smalltalk hasClassNamed: name) ifTrue: [(Smalltalk at: name) removeFromSystemUnlogged]]. generatedTestClass := nil. generatedTestClassX := nil! ----- Method: ChangeHooksTest>>renamedTestClassName (in category 'Private-Generation') ----- renamedTestClassName ^#'AutoRenamedClassForTestingSystemChanges'! ----- Method: ChangeHooksTest>>setUp (in category 'Running') ----- setUp previousChangeSet := ChangeSet current. testsChangeSet := ChangeSet new. ChangeSet newChanges: testsChangeSet. capturedEvents := OrderedCollection new. self generateTestClass. self generateTestClassX. super setUp! ----- Method: ChangeHooksTest>>shouldNotBeCalledEvent: (in category 'Events-General') ----- shouldNotBeCalledEvent: anEvent "This event should not be called, so fail the test." self assert: false! ----- Method: ChangeHooksTest>>tearDown (in category 'Running') ----- tearDown self removeGeneratedTestClasses. ChangeSet newChanges: previousChangeSet. ChangesOrganizer removeChangeSet: testsChangeSet. previousChangeSet := nil. testsChangeSet := nil. capturedEvents := nil. createdMethod := nil. super tearDown! ----- Method: ChangeHooksTest>>testClassCommentedEvent (in category 'Testing-Classes') ----- testClassCommentedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classCommentedEvent:. generatedTestClass comment: self commentStringForTesting. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testClassCreationEvent (in category 'Testing-Classes') ----- testClassCreationEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classCreationEvent:. Object subclass: self newlyCreatedClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testClassRecategorizedEvent1 (in category 'Testing-Classes') ----- testClassRecategorizedEvent1 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classRecategorizedEvent:. Object subclass: generatedTestClass name instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testClassRecategorizedEvent2 (in category 'Testing-Classes') ----- testClassRecategorizedEvent2 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classRecategorizedEvent:. generatedTestClass category: 'Collections-Abstract'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testClassRedefinition (in category 'Testing-Classes') ----- testClassRedefinition self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classRedefinitionEvent:. self generateTestClass! ----- Method: ChangeHooksTest>>testClassRemovalEvent (in category 'Testing-Classes') ----- testClassRemovalEvent "This event used to be sent efter the class was removed. This was changed, and therefore this test is useless currently." "Keep it, since I really want to check with the responsible for the ChangeSet, and it is very likely this will be reintroduced afterwards!!" " | createdClass | createdClass := self compileUniqueClass. self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classRemovalEvent:. createdClass removeFromSystem. self checkForOnlySingleEvent "! ----- Method: ChangeHooksTest>>testClassRenamedEvent (in category 'Testing-Classes') ----- testClassRenamedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classRenameEvent:. generatedTestClass rename: self renamedTestClassName. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testClassSuperChangedEvent (in category 'Testing-Classes') ----- testClassSuperChangedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #classSuperChangedEvent:. Model subclass: generatedTestClass name instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testDoItEvent1 (in category 'Testing-Expression') ----- testDoItEvent1 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #methodDoItEvent1:. doItExpression := '1 + 2'. Compiler evaluate: doItExpression logged: true. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testDoItEvent2 (in category 'Testing-Expression') ----- testDoItEvent2 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #shouldNotBeCalledEvent:. doItExpression := '1 + 2'. Compiler evaluate: doItExpression! ----- Method: ChangeHooksTest>>testInstanceVariableCreationEvent1 (in category 'Testing-Instance Variables') ----- testInstanceVariableCreationEvent1 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #instanceVariableCreationEvent:. Object subclass: self generatedTestClassName instanceVariableNames: 'x' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testInstanceVariableCreationEvent2 (in category 'Testing-Instance Variables') ----- testInstanceVariableCreationEvent2 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #instanceVariableCreationEvent:. generatedTestClass addInstVarName: 'x'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testInstanceVariableRemovedEvent1 (in category 'Testing-Instance Variables') ----- testInstanceVariableRemovedEvent1 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #instanceVariableRemovedEvent:. Object subclass: generatedTestClassX name instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Change Notification'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testInstanceVariableRemovedEvent2 (in category 'Testing-Instance Variables') ----- testInstanceVariableRemovedEvent2 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #instanceVariableRemovedEvent:. generatedTestClassX removeInstVarName: 'x'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testInstanceVariableRenamedSilently (in category 'Testing-Instance Variables') ----- testInstanceVariableRenamedSilently self systemChangeNotifier notify: self ofAllSystemChangesUsing: #shouldNotBeCalledEvent:. generatedTestClassX renameSilentlyInstVar: 'x' to: 'y'! ----- Method: ChangeHooksTest>>testMethodCreationEvent1 (in category 'Testing-Methods') ----- testMethodCreationEvent1 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #methodCreationEvent1:. createdMethodName := #testCreation. generatedTestClass compile: createdMethodName , ' ^1'. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testMethodCreationEvent2 (in category 'Testing-Methods') ----- testMethodCreationEvent2 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #methodCreationEvent2:. createdMethodName := #testCreation. generatedTestClass compile: createdMethodName , ' ^1' classified: #testing. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testMethodRecategorizationEvent (in category 'Testing-Methods') ----- testMethodRecategorizationEvent createdMethodName := #testCreation. generatedTestClass compile: createdMethodName , ' ^1' classified: #testing. self systemChangeNotifier notify: self ofAllSystemChangesUsing: #methodRecategorizationEvent:. generatedTestClass organization classify: createdMethodName under: #newCategory suppressIfDefault: false. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testMethodRemovedEvent1 (in category 'Testing-Methods') ----- testMethodRemovedEvent1 createdMethodName := #testCreation. generatedTestClass compile: createdMethodName , ' ^1'. createdMethod := generatedTestClass >> createdMethodName. self systemChangeNotifier notify: self ofAllSystemChangesUsing: #methodRemovedEvent1:. generatedTestClass removeSelector: createdMethodName. self checkForOnlySingleEvent! ----- Method: ChangeHooksTest>>testMethodRemovedEvent2 (in category 'Testing-Methods') ----- testMethodRemovedEvent2 createdMethodName := #testCreation. generatedTestClass compile: createdMethodName , ' ^1'. createdMethod := generatedTestClass >> createdMethodName. self systemChangeNotifier notify: self ofAllSystemChangesUsing: #methodRemovedEvent2:. Smalltalk removeSelector: (Array with: generatedTestClass name with: createdMethodName). self checkForOnlySingleEvent! SystemChangeTestRoot subclass: #SystemChangeErrorHandling instanceVariableNames: 'capturedEvents' classVariableNames: '' poolDictionaries: '' category: 'SystemChangeNotification-Tests'! !SystemChangeErrorHandling commentStamp: 'bp 12/4/2009 10:37' prior: 0! This class tests the error handing of the notification mechanism to ensure that one client that receives a system change cannot lock up the complete system.! ----- Method: SystemChangeErrorHandling>>handleEventWithError: (in category 'Event Notifications') ----- handleEventWithError: event self error: 'Example of event handling code that throws an error.'! ----- Method: SystemChangeErrorHandling>>handleEventWithHalt: (in category 'Event Notifications') ----- handleEventWithHalt: event self halt: 'Example of event handling code that contains a halt.'! ----- Method: SystemChangeErrorHandling>>setUp (in category 'Running') ----- setUp super setUp. capturedEvents := OrderedCollection new! ----- Method: SystemChangeErrorHandling>>storeEvent1: (in category 'Event Notifications') ----- storeEvent1: anEvent capturedEvents add: anEvent! ----- Method: SystemChangeErrorHandling>>storeEvent2: (in category 'Event Notifications') ----- storeEvent2: anEvent capturedEvents add: anEvent! ----- Method: SystemChangeErrorHandling>>storeEvent3: (in category 'Event Notifications') ----- storeEvent3: anEvent capturedEvents add: anEvent! ----- Method: SystemChangeErrorHandling>>tearDown (in category 'Running') ----- tearDown capturedEvents := nil. super tearDown! ----- Method: SystemChangeErrorHandling>>testErrorOperation (in category 'Testing') ----- testErrorOperation | notifier wasCaptured | notifier := self systemChangeNotifier. wasCaptured := false. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent1:. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent2:. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #handleEventWithError:. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent3:. [notifier classAdded: self class inCategory: #FooCat] on: Error do: [:exc | wasCaptured := true. self assert: (capturedEvents size = 3)]. self assert: wasCaptured.! ----- Method: SystemChangeErrorHandling>>testHaltOperation (in category 'Testing') ----- testHaltOperation | notifier wasCaptured | notifier := self systemChangeNotifier. wasCaptured := false. notifier notify: self ofAllSystemChangesUsing: #storeEvent1:. notifier notify: self ofAllSystemChangesUsing: #storeEvent2:. notifier notify: self ofAllSystemChangesUsing: #handleEventWithHalt:. notifier notify: self ofAllSystemChangesUsing: #storeEvent3:. [notifier classAdded: self class inCategory: #FooCat] on: Halt do: [:exc | wasCaptured := true. self assert: (capturedEvents size = 3)]. self assert: wasCaptured.! ----- Method: SystemChangeErrorHandling>>testUnhandledEventOperation (in category 'Testing') ----- testUnhandledEventOperation | notifier wasCaptured | notifier := self systemChangeNotifier. wasCaptured := false. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent1:. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent2:. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #zork:. notifier notify: self ofSystemChangesOfItem: #class change: #Added using: #storeEvent3:. [notifier classAdded: self class inCategory: #FooCat] on: MessageNotUnderstood do: [:exc | wasCaptured := true. self assert: (capturedEvents size = 3)]. self assert: wasCaptured.! SystemChangeTestRoot subclass: #SystemChangeErrorHandlingTest instanceVariableNames: 'capturedEvents' classVariableNames: '' poolDictionaries: '' category: 'SystemChangeNotification-Tests'! SystemChangeTestRoot subclass: #SystemChangeNotifierTest instanceVariableNames: 'capturedEvent notifier' classVariableNames: '' poolDictionaries: '' category: 'SystemChangeNotification-Tests'! !SystemChangeNotifierTest commentStamp: 'rw 4/3/2006 17:19' prior: 0! A SystemChangeNotifierTest is a test class that tests whether the triggering of changes indeed results in the intended changes to be sent to registered object. The basic mechanism for each test is fairly simple: - register the receiver as the one to get the change notifier. - manually trigger a change (so the system is not polluted just to see whether we get the needed event). - the method #event: is invoked and remembers the change event. - the change event is checked to see whether it was the intended one. Instance Variables capturedEvent: Remembers the captured event! ----- Method: SystemChangeNotifierTest>>capturedEvent: (in category 'Private') ----- capturedEvent: eventOrNil "Remember the event being sent." capturedEvent := eventOrNil! ----- Method: SystemChangeNotifierTest>>checkEventForClass:category:change: (in category 'Private') ----- checkEventForClass: aClass category: cat change: changeKind self assert: (capturedEvent perform: ('is' , changeKind) asSymbol). self assert: capturedEvent item = aClass. self assert: capturedEvent itemKind = AbstractEvent classKind. self assert: capturedEvent itemClass = aClass. self assert: capturedEvent itemCategory = cat! ----- Method: SystemChangeNotifierTest>>checkEventForMethod:protocol:change: (in category 'Private') ----- checkEventForMethod: aMethod protocol: prot change: changeKind self assert: (capturedEvent perform: ('is' , changeKind) asSymbol). self assert: capturedEvent item = aMethod. self assert: capturedEvent itemKind = AbstractEvent methodKind. self assert: capturedEvent itemClass = self class. self assert: capturedEvent itemMethod = aMethod. self assert: capturedEvent itemProtocol = prot! ----- Method: SystemChangeNotifierTest>>checkEventForMethod:protocol:change:oldMethod: (in category 'Private') ----- checkEventForMethod: aMethod protocol: prot change: changeKind oldMethod: oldMethod self checkEventForMethod: aMethod protocol: prot change: changeKind. self assert: capturedEvent oldItem == oldMethod ! ----- Method: SystemChangeNotifierTest>>event: (in category 'Event Notifications') ----- event: event "The notification message being sent to me when an event is captured. Remember it." " capturedEvent isNil ifTrue: [ self capturedEvent: event] ifFalse: [self assert: false]" self capturedEvent: event! ----- Method: SystemChangeNotifierTest>>setUp (in category 'Running') ----- setUp super setUp. notifier := SystemChangeNotifier createInstance.! ----- Method: SystemChangeNotifierTest>>systemChangeNotifier (in category 'Private') ----- systemChangeNotifier "The notifier to use. Do not use the one in the system so that the fake events triggered in the tests perturb clients of the system's change notifier (e.g. the changes file then shows fake entries)." ^notifier! ----- Method: SystemChangeNotifierTest>>tearDown (in category 'Running') ----- tearDown super tearDown. self capturedEvent: nil. notifier releaseAll. notifier := nil! ----- Method: SystemChangeNotifierTest>>testClassAddedEvent (in category 'Testing-system triggers') ----- testClassAddedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier classAdded: self class inCategory: #FooCat. self checkEventForClass: self class category: #FooCat change: #Added! ----- Method: SystemChangeNotifierTest>>testClassAddedEvent2 (in category 'Testing-system triggers') ----- testClassAddedEvent2 self systemChangeNotifier notify: self ofSystemChangesOfItem: #class change: #Added using: #event:. self systemChangeNotifier classAdded: self class inCategory: #FooCat. self checkEventForClass: self class category: #FooCat change: #Added! ----- Method: SystemChangeNotifierTest>>testClassCommentedEvent (in category 'Testing-system triggers') ----- testClassCommentedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier classCommented: self class inCategory: #FooCat. self checkEventForClass: self class category: #FooCat change: #Commented! ----- Method: SystemChangeNotifierTest>>testClassRecategorizedEvent (in category 'Testing-system triggers') ----- testClassRecategorizedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier class: self class recategorizedFrom: #FooCat to: #FooBar. self checkEventForClass: self class category: #FooBar change: #Recategorized. self assert: capturedEvent oldCategory = #FooCat! ----- Method: SystemChangeNotifierTest>>testClassRemovedEvent (in category 'Testing-system triggers') ----- testClassRemovedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier classRemoved: self class fromCategory: #FooCat. self checkEventForClass: self class category: #FooCat change: #Removed! ----- Method: SystemChangeNotifierTest>>testClassRenamedEvent (in category 'Testing-system triggers') ----- testClassRenamedEvent "self run: #testClassRenamedEvent" self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier classRenamed: self class from: #OldFooClass to: #NewFooClass inCategory: #FooCat. self checkEventForClass: self class category: #FooCat change: #Renamed. " self assert: capturedEvent oldName = #OldFooClass. self assert: capturedEvent newName = #NewFooClass"! ----- Method: SystemChangeNotifierTest>>testDoItEvent (in category 'Testing-system triggers') ----- testDoItEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier evaluated: '1 + 2' context: self. self assert: capturedEvent isDoIt. self assert: capturedEvent item = '1 + 2'. self assert: capturedEvent itemKind = AbstractEvent expressionKind. self assert: capturedEvent itemClass = nil. self assert: capturedEvent itemMethod = nil. self assert: capturedEvent itemProtocol = nil. self assert: capturedEvent itemExpression = '1 + 2'. self assert: capturedEvent context = self.! ----- Method: SystemChangeNotifierTest>>testMethodAddedEvent1 (in category 'Testing-system triggers') ----- testMethodAddedEvent1 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier methodAdded: self class >> #testMethodAddedEvent1 selector: #testMethodAddedEvent1 inProtocol: #FooCat class: self class. self checkEventForMethod: self class >> #testMethodAddedEvent1 protocol: #FooCat change: #Added! ----- Method: SystemChangeNotifierTest>>testMethodAddedEvent2 (in category 'Testing-system triggers') ----- testMethodAddedEvent2 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier methodAdded: self class >> #testMethodAddedEvent1 selector: #testMethodAddedEvent1 inClass: self class. self checkEventForMethod: self class >> #testMethodAddedEvent1 protocol: nil change: #Added! ----- Method: SystemChangeNotifierTest>>testMethodAddedEvent3 (in category 'Testing-system triggers') ----- testMethodAddedEvent3 self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier methodChangedFrom: self class >> #testMethodAddedEvent1 to: self class >> #testMethodAddedEvent2 selector: #testMethodAddedEvent2 inClass: self class. self checkEventForMethod: self class >> #testMethodAddedEvent2 protocol: nil change: #Modified oldMethod: self class >> #testMethodAddedEvent1.! ----- Method: SystemChangeNotifierTest>>testMethodRemovedEvent (in category 'Testing-system triggers') ----- testMethodRemovedEvent self systemChangeNotifier notify: self ofAllSystemChangesUsing: #event:. self systemChangeNotifier methodRemoved: self class>> #testMethodRemovedEvent selector: #testMethodRemovedEvent inProtocol: #FooCat class: self class. self checkEventForMethod: self class>> #testMethodRemovedEvent protocol: #FooCat change: #Removed.! ----- Method: SystemChangeTestRoot>>systemChangeNotifier (in category 'Private') ----- systemChangeNotifier "The notifier to use. Use the one for the system." ^SystemChangeNotifier uniqueInstance! ----- Method: SystemChangeTestRoot>>tearDown (in category 'Running') ----- tearDown self unhook. super tearDown! ----- Method: SystemChangeTestRoot>>unhook (in category 'Running') ----- unhook self systemChangeNotifier noMoreNotificationsFor: self!

1 0

Squeak 4.6: NetworkTests-fbs.37.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of NetworkTests to project Squeak 4.6: http://source.squeak.org/squeak46/NetworkTests-fbs.37.mcz ==================== Summary ==================== Name: NetworkTests-fbs.37 Author: fbs Time: 6 November 2013, 6:35:55.414 pm UUID: 97699685-5826-fe47-af98-356971abf2fb Ancestors: NetworkTests-fbs.36 More #shouldnt:raise: Error fixes. ==================== Snapshot ==================== SystemOrganization addCategory: #'NetworkTests-Kernel'! SystemOrganization addCategory: #'NetworkTests-Protocols'! SystemOrganization addCategory: #'NetworkTests-RFC822'! SystemOrganization addCategory: #'NetworkTests-URI'! SystemOrganization addCategory: #'NetworkTests-UUID'! SystemOrganization addCategory: #'NetworkTests-Url'! Stream subclass: #MockSocketStream instanceVariableNames: 'atEnd inStream outStream' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Kernel'! ----- Method: MockSocketStream class>>on: (in category 'instance creation') ----- on: socket ^self basicNew initialize! ----- Method: MockSocketStream>>atEnd (in category 'testing') ----- atEnd ^self inStream atEnd.! ----- Method: MockSocketStream>>atEnd: (in category 'accessing') ----- atEnd: aBoolean atEnd := aBoolean.! ----- Method: MockSocketStream>>inStream (in category 'accessing') ----- inStream ^inStream! ----- Method: MockSocketStream>>initialize (in category 'initialize-release') ----- initialize self resetInStream. self resetOutStream.! ----- Method: MockSocketStream>>nextLine (in category 'stream in') ----- nextLine ^self nextLineCrLf! ----- Method: MockSocketStream>>nextLineCrLf (in category 'stream in') ----- nextLineCrLf ^(self upToAll: String crlf).! ----- Method: MockSocketStream>>outStream (in category 'accessing') ----- outStream ^outStream! ----- Method: MockSocketStream>>resetInStream (in category 'stream in') ----- resetInStream inStream := WriteStream on: ''.! ----- Method: MockSocketStream>>resetOutStream (in category 'stream out') ----- resetOutStream outStream := WriteStream on: ''.! ----- Method: MockSocketStream>>sendCommand: (in category 'stream out') ----- sendCommand: aString self outStream nextPutAll: aString; nextPutAll: String crlf.! ----- Method: MockSocketStream>>upToAll: (in category 'stream in') ----- upToAll: delims ^self inStream upToAll: delims.! TestCase subclass: #MailAddressParserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-RFC822'! !MailAddressParserTest commentStamp: '<historical>' prior: 0! This is the unit test for the class MailAddressParser. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! ----- Method: MailAddressParserTest>>testAddressesIn (in category 'tests') ----- testAddressesIn | testString correctAnswer | testString := 'joe(a)lama.com, joe2(a)lama.com joe3(a)lama.com joe4 , Not an Address <joe5@address>, joe.(annoying (nested) comment)literal(a)[1.2.3.4], "an annoying" group : joe1@groupie, joe2@groupie, "Joey" joe3@groupy, "joe6"."joe8"@group.com;, Lex''s email account <lex>, foo+bar(a)baz.com'. correctAnswer := #('joe(a)lama.com' 'joe2(a)lama.com' 'joe3(a)lama.com' 'joe4' 'joe5@address' 'joe.literal(a)[1.2.3.4]' 'joe1@groupie' 'joe2@groupie' '"Joey"' 'joe3@groupy' '"joe6"."joe8"@group.com' 'lex' 'foo+bar(a)baz.com') asOrderedCollection. self assert: ((MailAddressParser addressesIn: testString) = correctAnswer).! TestCase subclass: #MailMessageTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-RFC822'! !MailMessageTest commentStamp: 'tonyg 9/12/2011 09:17' prior: 0! This is the unit test for the class MailMessage.! ----- Method: MailMessageTest>>testDateStampFractionalSecondFormatting (in category 'as yet unclassified') ----- testDateStampFractionalSecondFormatting self assert: (MailMessage dateStamp: (DateAndTime fromSeconds: 1.234)) = 'Tue, 1 Jan 1901 00:00:01' description: 'RFC822 (and RFC2822) forbids non-integer seconds in dates'! TestCase subclass: #SMTPClientTest instanceVariableNames: 'smtp socket' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Protocols'! ----- Method: SMTPClientTest>>setUp (in category 'running') ----- setUp socket := MockSocketStream on: ''. smtp := SMTPClient new. smtp stream: socket.! ----- Method: SMTPClientTest>>testMailFrom (in category 'testing') ----- testMailFrom smtp mailFrom: 'frank(a)angband.za.org'. self assert: socket outStream contents = ('MAIL FROM: <frank(a)angband.za.org>', String crlf). socket resetOutStream. smtp mailFrom: '<frank(a)angband.za.org>'. self assert: socket outStream contents = ('MAIL FROM: <frank(a)angband.za.org>', String crlf). socket resetOutStream. smtp mailFrom: 'Frank <frank(a)angband.za.org>'. self assert: socket outStream contents = ('MAIL FROM: <frank(a)angband.za.org>', String crlf).! TestCase subclass: #SocketTest instanceVariableNames: 'listenerSocket clientSocket serverSocket' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Kernel'! ----- Method: SocketTest>>listenerAddress (in category 'setup') ----- listenerAddress ^NetNameResolver localHostAddress ! ----- Method: SocketTest>>listenerPort (in category 'setup') ----- listenerPort ^42324 ! ----- Method: SocketTest>>setUp (in category 'setup') ----- setUp listenerSocket := Socket newTCP listenOn: self listenerPort backlogSize: 4 interface: self listenerAddress. ! ----- Method: SocketTest>>tearDown (in category 'setup') ----- tearDown listenerSocket ifNotNil:[listenerSocket destroy]. clientSocket ifNotNil:[clientSocket destroy]. serverSocket ifNotNil:[serverSocket destroy]. ! ----- Method: SocketTest>>testClientConnect (in category 'tests') ----- testClientConnect "Tests a client socket connection" clientSocket := Socket newTCP. clientSocket connectTo: self listenerAddress port: self listenerPort. clientSocket waitForConnectionFor: 2. self assert: clientSocket isConnected. ! ----- Method: SocketTest>>testDataReceive (in category 'tests') ----- testDataReceive "Test data transfer and related methods" self testDataSending. "It can take a tad for the status change to be visible" (Delay forMilliseconds: 200) wait. self assert: serverSocket dataAvailable. self assert: (serverSocket receiveData = 'Hello World'). self deny: (serverSocket dataAvailable). ! ----- Method: SocketTest>>testDataSending (in category 'tests') ----- testDataSending "Test data transfer and related methods" self testServerAccept. clientSocket sendData: 'Hello World'. clientSocket waitForSendDoneFor: 2. self assert: clientSocket sendDone. ! ----- Method: SocketTest>>testLocalAddress (in category 'tests') ----- testLocalAddress "Tests the various localAddress values for sockets" self testServerAccept. self assert: listenerSocket localAddress = self listenerAddress. self assert: clientSocket localAddress = self listenerAddress. self assert: serverSocket localAddress = self listenerAddress. ! ----- Method: SocketTest>>testLocalPort (in category 'tests') ----- testLocalPort "Tests the various localPort values for sockets" self testServerAccept. self assert: listenerSocket localPort = self listenerPort. self assert: clientSocket localPort > 0. self assert: serverSocket localPort > 0. ! ----- Method: SocketTest>>testPeerName (in category 'tests') ----- testPeerName "None of these should throw an exception." Socket new peerName. self testServerAccept. listenerSocket peerName. clientSocket peerName. serverSocket peerName.! ----- Method: SocketTest>>testReceiveTimeout (in category 'tests') ----- testReceiveTimeout "Test data transfer and related methods" self testServerAccept. self assert: (serverSocket receiveDataTimeout: 1) isEmpty.! ----- Method: SocketTest>>testRemoteAddress (in category 'tests') ----- testRemoteAddress "Tests the various remoteAddress values for sockets" self testServerAccept. self assert: listenerSocket remoteAddress asByteArray = #[0 0 0 0]. self assert: clientSocket remoteAddress = self listenerAddress. self assert: serverSocket remoteAddress = self listenerAddress. ! ----- Method: SocketTest>>testRemotePort (in category 'tests') ----- testRemotePort "Tests the various remoteAddress values for sockets" self testServerAccept. self assert: listenerSocket remotePort = 0. self assert: clientSocket remotePort = self listenerPort. self assert: serverSocket remotePort > 0. ! ----- Method: SocketTest>>testSendTimeout (in category 'tests') ----- testSendTimeout "Test data transfer and related methods" | buffer ex | self testServerAccept. buffer := ByteArray new: 1000. "Write to the socket until the platform reports that sending is not complete." [serverSocket sendDone] whileTrue:[ serverSocket sendSomeData: buffer. ]. "The network layer is now either blocked or in the process of sending data in its buffers. It may or may not be able buffer additional write requests, depending on the platform implemention. Keep sending data until the network reports that it is unable to process the request, at which time a exception will be raised. On Windows, the exception will be raised on the next write request, while unix platforms may provide additional buffering that permit write requests to continue being accepted." ex := nil. [[serverSocket sendSomeData: buffer startIndex: 1 count: buffer size for: 1] on: ConnectionTimedOut do: [ :e | ex := e ]. ex isNil] whileTrue: []. self assert: ex notNil. ! ----- Method: SocketTest>>testServerAccept (in category 'tests') ----- testServerAccept "Tests a server-side accept" self testClientConnect. serverSocket := listenerSocket waitForAcceptFor: 2. self assert: (serverSocket notNil). self assert: (serverSocket isConnected). ! ----- Method: SocketTest>>testSocketReuse (in category 'tests') ----- testSocketReuse "Test for SO_REUSEADDR/SO_REUSEPORT" | address port udp1 send1 udp2 recv2 sendProc recvProc received | address := #[255 255 255 255]. "broadcast" port := 31259. [ udp1 := Socket newUDP. udp1 setOption: 'SO_REUSEADDR' value: 1. udp1 setOption: 'SO_REUSEPORT' value: 1. udp1 setPort: port. udp1 setOption: 'SO_BROADCAST' value: 1. send1 := UUID new. udp2 := Socket newUDP. udp2 setOption: 'SO_REUSEADDR' value: 1. udp2 setOption: 'SO_REUSEPORT' value: 1. udp2 setPort: port. udp2 setOption: 'SO_BROADCAST' value: 1. recv2 := UUID new. received := 0. recvProc := [ [received < 16] whileTrue:[ received := received + (udp2 receiveDataInto: recv2 startingAt: received + 1). ] ] fork. sendProc := [ udp1 setPeer: address port: port. udp1 sendData: send1 count: 16. ] fork. (Delay forMilliseconds: 200) wait. self should: [recvProc isTerminated]. self should: [sendProc isTerminated]. self should: [send1 = recv2]. ] ensure:[ udp1 destroy. udp2 destroy. ]. ! ----- Method: SocketTest>>testStringFromAddress (in category 'tests') ----- testStringFromAddress "Addresses are represented by a ByteArray if NetNameResolver useOldNetwork is true, or by by SocketAddress otherwise. Ensure the #stringFromAddress: works in either case. Older versions of SocketPlugin in the VM do not provide support for SocketAddress, and ByteArray addresses are used in that case." | localAddress localAddressBytes localName1 localName2 | localAddress := NetNameResolver localHostAddress. "ByteArray or SocketAddress" localAddressBytes := localAddress asByteArray. localName1 := NetNameResolver stringFromAddress: localAddress. localName2 := NetNameResolver stringFromAddress: localAddressBytes. self assert: localName1 = localName2 ! ----- Method: SocketTest>>testUDP (in category 'tests') ----- testUDP "Test udp recv() and send() functionality" serverSocket := Socket newUDP. serverSocket setPort: 54321. clientSocket := Socket newUDP. clientSocket setPeer: NetNameResolver localHostAddress port: serverSocket port. clientSocket sendData: 'Hello World'. (Delay forMilliseconds: 200) wait. self assert: (serverSocket dataAvailable). self assert: (serverSocket receiveData = 'Hello World'). ! TestCase subclass: #TestURI instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-URI'! !TestURI commentStamp: 'mir 2/27/2002 14:42' prior: 0! Main comment stating the purpose of this class and relevant relationship to other classes. Some parsers allow the scheme name to be present in a relative URI if it is the same as the base URI scheme. This is considered to be a loophole in prior specifications of partial URI [RFC1630]. Its use should be avoided. http:g = http:g ; for validating parsers | http://a/b/c/g ; for backwards compatibility ! ----- Method: TestURI class>>generateAbnormalResolverTests (in category 'test generation') ----- generateAbnormalResolverTests "TestURI generateAbnormalResolverTests" | relURIString result method testPairs pair | testPairs := #( #('../../../g' 'http://a/../g' ) #('../../../../g' 'http://a/../../g' ) #('/./g' 'http://a/./g' ) #('/../g' 'http://a/../g' ) #('g.' 'http://a/b/c/g.' ) #('.g' 'http://a/b/c/.g' ) #('g..' 'http://a/b/c/g..' ) #('..g' 'http://a/b/c/..g' ) #('./../g' 'http://a/b/g' ) #('./g/.' 'http://a/b/c/g/' ) #('g/./h' 'http://a/b/c/g/h' ) #('g/../h' 'http://a/b/c/h' ) #('g;x=1/./y' 'http://a/b/c/g;x=1/y' ) #('g;x=1/../y' 'http://a/b/c/y' ) #('g?y/./x' 'http://a/b/c/g?y/./x' ) #('g?y/../x' 'http://a/b/c/g?y/../x' ) #('g#s/./x' 'http://a/b/c/g#s/./x' ) #('g#s/../x' 'http://a/b/c/g#s/../x' ) ). 1 to: testPairs size do: [:index | pair := testPairs at: index. relURIString := pair first. result := pair last. method := String streamContents: [:stream | stream nextPutAll: 'testResolveAbnormal' , index printString; cr. stream nextPutAll: ' | baseURI relURI resolvedURI |' ; cr; nextPutAll: ' baseURI := ''http://a/b/c/d;p?q'' asURI.' ; cr; nextPutAll: ' relURI := '; nextPut: $'; nextPutAll: relURIString; nextPutAll: '''.' ; cr; nextPutAll: ' resolvedURI := baseURI resolveRelativeURI: relURI.' ; cr; nextPutAll: ' self should: [resolvedURI asString = '''; nextPutAll: result; nextPutAll: '''].' ; cr]. self compile: method classified: 'running resolving']. ! ----- Method: TestURI class>>generateNormalResolverTests (in category 'test generation') ----- generateNormalResolverTests "TestURI generateNormalResolverTests" | relURIString result method testPairs pair | testPairs := #( #('g:h' 'g:h' ) #('g' 'http://a/b/c/g' ) #('./g' 'http://a/b/c/g' ) #('g/' 'http://a/b/c/g/' ) #('/g' 'http://a/g' ) #('//g' 'http://g' ) #('?y' 'http://a/b/c/?y' ) #('g?y' 'http://a/b/c/g?y' ) #('g#s' 'http://a/b/c/g#s' ) #('g?y#s' 'http://a/b/c/g?y#s' ) #(';x' 'http://a/b/c/;x' ) #('g;x' 'http://a/b/c/g;x' ) #('g;x?y#s' 'http://a/b/c/g;x?y#s' ) #('.' 'http://a/b/c/' ) #('./' 'http://a/b/c/' ) #('..' 'http://a/b/' ) #('../' 'http://a/b/' ) #('../g' 'http://a/b/g' ) #('../..' 'http://a/' ) #('../../' 'http://a/' ) #('../../g' 'http://a/g' ) ). 1 to: testPairs size do: [:index | pair := testPairs at: index. relURIString := pair first. result := pair last. method := String streamContents: [:stream | stream nextPutAll: 'testResolveNormal' , index printString; cr. stream nextPutAll: ' | baseURI relURI resolvedURI |' ; cr; nextPutAll: ' baseURI := ''http://a/b/c/d;p?q'' asURI.' ; cr; nextPutAll: ' relURI := '; nextPut: $'; nextPutAll: relURIString; nextPutAll: '''.' ; cr; nextPutAll: ' resolvedURI := baseURI resolveRelativeURI: relURI.' ; cr; nextPutAll: ' self should: [resolvedURI asString = '''; nextPutAll: result; nextPutAll: '''].' ; cr]. self compile: method classified: 'running resolving']. ! ----- Method: TestURI>>testDefaultDirRoundtrip (in category 'running file') ----- testDefaultDirRoundtrip | defaultDir defaultURI uriDir | defaultDir := FileDirectory default. defaultURI := defaultDir uri. uriDir := FileDirectory uri: defaultURI. self should: [defaultDir fullName = uriDir fullName]! ----- Method: TestURI>>testDirWithHash (in category 'running file') ----- testDirWithHash "Tests proper escaping of directories with hash mark" | uriDir origPath origDir dirURI | origPath := FileDirectory default pathName, '#123'. origDir := FileDirectory on: origPath. self assert: origDir pathName = origPath. dirURI := origDir uri. uriDir := FileDirectory uri: dirURI. self assert: origDir fullName = uriDir fullName.! ----- Method: TestURI>>testDirectoryRoot (in category 'running file') ----- testDirectoryRoot | rootDir uriRoot uriDir | rootDir := FileDirectory root. uriRoot := 'file:///' asURI. uriDir := FileDirectory uri: uriRoot. self should: [rootDir fullName = uriDir fullName]! ----- Method: TestURI>>testResolveAbnormal1 (in category 'running resolving') ----- testResolveAbnormal1 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../../../g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/../g']. ! ----- Method: TestURI>>testResolveAbnormal10 (in category 'running resolving') ----- testResolveAbnormal10 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := './g/.'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g/']. ! ----- Method: TestURI>>testResolveAbnormal11 (in category 'running resolving') ----- testResolveAbnormal11 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g/./h'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g/h']. ! ----- Method: TestURI>>testResolveAbnormal12 (in category 'running resolving') ----- testResolveAbnormal12 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g/../h'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/h']. ! ----- Method: TestURI>>testResolveAbnormal13 (in category 'running resolving') ----- testResolveAbnormal13 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g;x=1/./y'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g;x=1/y']. ! ----- Method: TestURI>>testResolveAbnormal14 (in category 'running resolving') ----- testResolveAbnormal14 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g;x=1/../y'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/y']. ! ----- Method: TestURI>>testResolveAbnormal15 (in category 'running resolving') ----- testResolveAbnormal15 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g?y/./x'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g?y/./x']. ! ----- Method: TestURI>>testResolveAbnormal16 (in category 'running resolving') ----- testResolveAbnormal16 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g?y/../x'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g?y/../x']. ! ----- Method: TestURI>>testResolveAbnormal17 (in category 'running resolving') ----- testResolveAbnormal17 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g#s/./x'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g#s/./x']. ! ----- Method: TestURI>>testResolveAbnormal18 (in category 'running resolving') ----- testResolveAbnormal18 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g#s/../x'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g#s/../x']. ! ----- Method: TestURI>>testResolveAbnormal2 (in category 'running resolving') ----- testResolveAbnormal2 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../../../../g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/../../g']. ! ----- Method: TestURI>>testResolveAbnormal3 (in category 'running resolving') ----- testResolveAbnormal3 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '/./g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/./g']. ! ----- Method: TestURI>>testResolveAbnormal4 (in category 'running resolving') ----- testResolveAbnormal4 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '/../g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/../g']. ! ----- Method: TestURI>>testResolveAbnormal5 (in category 'running resolving') ----- testResolveAbnormal5 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g.'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g.']. ! ----- Method: TestURI>>testResolveAbnormal6 (in category 'running resolving') ----- testResolveAbnormal6 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '.g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/.g']. ! ----- Method: TestURI>>testResolveAbnormal7 (in category 'running resolving') ----- testResolveAbnormal7 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g..'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g..']. ! ----- Method: TestURI>>testResolveAbnormal8 (in category 'running resolving') ----- testResolveAbnormal8 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '..g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/..g']. ! ----- Method: TestURI>>testResolveAbnormal9 (in category 'running resolving') ----- testResolveAbnormal9 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := './../g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/g']. ! ----- Method: TestURI>>testResolveNormal1 (in category 'running resolving') ----- testResolveNormal1 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g:h'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'g:h']. ! ----- Method: TestURI>>testResolveNormal10 (in category 'running resolving') ----- testResolveNormal10 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g?y#s'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g?y#s']. ! ----- Method: TestURI>>testResolveNormal11 (in category 'running resolving') ----- testResolveNormal11 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := ';x'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/;x']. ! ----- Method: TestURI>>testResolveNormal12 (in category 'running resolving') ----- testResolveNormal12 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g;x'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g;x']. ! ----- Method: TestURI>>testResolveNormal13 (in category 'running resolving') ----- testResolveNormal13 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g;x?y#s'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g;x?y#s']. ! ----- Method: TestURI>>testResolveNormal14 (in category 'running resolving') ----- testResolveNormal14 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '.'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/']. ! ----- Method: TestURI>>testResolveNormal15 (in category 'running resolving') ----- testResolveNormal15 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := './'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/']. ! ----- Method: TestURI>>testResolveNormal16 (in category 'running resolving') ----- testResolveNormal16 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '..'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/']. ! ----- Method: TestURI>>testResolveNormal17 (in category 'running resolving') ----- testResolveNormal17 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/']. ! ----- Method: TestURI>>testResolveNormal18 (in category 'running resolving') ----- testResolveNormal18 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/g']. ! ----- Method: TestURI>>testResolveNormal19 (in category 'running resolving') ----- testResolveNormal19 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../..'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/']. ! ----- Method: TestURI>>testResolveNormal2 (in category 'running resolving') ----- testResolveNormal2 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g']. ! ----- Method: TestURI>>testResolveNormal20 (in category 'running resolving') ----- testResolveNormal20 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../../'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/']. ! ----- Method: TestURI>>testResolveNormal21 (in category 'running resolving') ----- testResolveNormal21 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '../../g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/g']. ! ----- Method: TestURI>>testResolveNormal3 (in category 'running resolving') ----- testResolveNormal3 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := './g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g']. ! ----- Method: TestURI>>testResolveNormal4 (in category 'running resolving') ----- testResolveNormal4 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g/'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g/']. ! ----- Method: TestURI>>testResolveNormal5 (in category 'running resolving') ----- testResolveNormal5 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '/g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/g']. ! ----- Method: TestURI>>testResolveNormal6 (in category 'running resolving') ----- testResolveNormal6 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '//g'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://g']. ! ----- Method: TestURI>>testResolveNormal7 (in category 'running resolving') ----- testResolveNormal7 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := '?y'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/?y']. ! ----- Method: TestURI>>testResolveNormal8 (in category 'running resolving') ----- testResolveNormal8 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g?y'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g?y']. ! ----- Method: TestURI>>testResolveNormal9 (in category 'running resolving') ----- testResolveNormal9 | baseURI relURI resolvedURI | baseURI := 'http://a/b/c/d;p?q' asURI. relURI := 'g#s'. resolvedURI := baseURI resolveRelativeURI: relURI. self should: [resolvedURI asString = 'http://a/b/c/g#s']. ! ----- Method: TestURI>>testSchemeAbsoluteFail1 (in category 'running parsing') ----- testSchemeAbsoluteFail1 self should: [URI fromString: 'http:'] raise: IllegalURIException! ----- Method: TestURI>>testSchemeAbsolutePass1 (in category 'running parsing') ----- testSchemeAbsolutePass1 | uri | uri := URI fromString: 'http://www.squeakland.org'. self should: [uri scheme = 'http']. self should: [uri isAbsolute]. self shouldnt: [uri isOpaque]. self shouldnt: [uri isRelative]! ----- Method: TestURI>>testSchemeAbsolutePass2 (in category 'running parsing') ----- testSchemeAbsolutePass2 | uri | uri := URI fromString: 'mailto:somebody@somewhere.nowhere'. self should: [uri scheme = 'mailto']. self should: [uri isAbsolute]. self should: [uri isOpaque]. self shouldnt: [uri isRelative]! ----- Method: TestURI>>testSchemeAbsolutePass3 (in category 'running parsing') ----- testSchemeAbsolutePass3 | uri | uri := URI fromString: 'ftp://ftp@squeak.org'. self should: [uri scheme = 'ftp']. self should: [uri isAbsolute]. self shouldnt: [uri isOpaque]. self shouldnt: [uri isRelative]. self should: [uri userInfo = 'ftp']. self should: [uri host = 'squeak.org']. self should: [uri port isNil]. ! ----- Method: TestURI>>testSchemeAbsolutePass4 (in category 'running parsing') ----- testSchemeAbsolutePass4 | uri | uri := URI fromString: 'mailto:somebody@somewhere.nowhere#fragment'. self should: [uri scheme = 'mailto']. self should: [uri isAbsolute]. self should: [uri isOpaque]. self shouldnt: [uri isRelative]. self should: [uri fragment = 'fragment']. ! ----- Method: TestURI>>testSchemeAbsolutePass5 (in category 'running parsing') ----- testSchemeAbsolutePass5 | uri | uri := URI fromString: 'http://www.squeakland.org#fragment'. self should: [uri scheme = 'http']. self should: [uri isAbsolute]. self shouldnt: [uri isOpaque]. self shouldnt: [uri isRelative]. self should: [uri fragment = 'fragment']. ! TestCase subclass: #UUIDPrimitivesTest instanceVariableNames: '' classVariableNames: 'Default' poolDictionaries: '' category: 'NetworkTests-UUID'! ----- Method: UUIDPrimitivesTest>>testCreation (in category 'tests') ----- testCreation | uuid | uuid := UUID new. self should: [uuid size = 16]. self shouldnt: [uuid isNilUUID]. self should: [uuid asString size = 36]. ! ----- Method: UUIDPrimitivesTest>>testCreationEquality (in category 'tests') ----- testCreationEquality | uuid1 uuid2 | uuid1 := UUID new. uuid2 := UUID new. self should: [uuid1 = uuid1]. self should: [uuid2 = uuid2]. self shouldnt: [uuid1 = uuid2]. self shouldnt: [uuid1 hash = uuid2 hash]. ! ----- Method: UUIDPrimitivesTest>>testCreationFromString (in category 'tests') ----- testCreationFromString | uuid string | string := UUID nilUUID asString. uuid := UUID fromString: string. self should: [uuid size = 16]. self should: [uuid = UUID nilUUID]. self should: [uuid isNilUUID]. self should: [uuid asString size = 36]. self should: [uuid asArray asSet size = 1]. self should: [(uuid asArray asSet asArray at: 1) = 0]. ! ----- Method: UUIDPrimitivesTest>>testCreationFromStringNotNil (in category 'tests') ----- testCreationFromStringNotNil | uuid string | string := UUID new asString. uuid := UUID fromString: string. self should: [uuid size = 16]. self should: [uuid asString size = 36]. ! ----- Method: UUIDPrimitivesTest>>testCreationNil (in category 'tests') ----- testCreationNil | uuid | uuid := UUID nilUUID. self should: [uuid size = 16]. self should: [uuid isNilUUID]. self should: [uuid asString size = 36]. self should: [uuid asArray asSet size = 1]. self should: [(uuid asArray asSet asArray at: 1) = 0]. ! ----- Method: UUIDPrimitivesTest>>testCreationNodeBased (in category 'tests') ----- testCreationNodeBased (UUID new asString last: 12) = (UUID new asString last: 12) ifFalse: [^self]. 1000 timesRepeat: [ | uuid | uuid := UUID new. self should: [((uuid at: 7) bitAnd: 16rF0) = 16r10]. self should: [((uuid at: 9) bitAnd: 16rC0) = 16r80]] ! ----- Method: UUIDPrimitivesTest>>testDuplicationsKinda (in category 'tests') ----- testDuplicationsKinda | check size | size := 5000. check := Set new: size. size timesRepeat: [ | uuid | uuid := UUID new. self shouldnt: [check includes: uuid]. check add: uuid]. ! ----- Method: UUIDPrimitivesTest>>testOrder (in category 'tests') ----- testOrder 100 timesRepeat: [ | uuid1 uuid2 | uuid1 := UUID new. uuid2 := UUID new. (uuid1 asString last: 12) = (uuid2 asString last: 12) ifTrue: [self should: [uuid1 < uuid2]. self should: [uuid2 > uuid1]. self shouldnt: [uuid1 = uuid2]]] ! TestCase subclass: #UUIDTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-UUID'! ----- Method: UUIDTest>>testComparison (in category 'as yet unclassified') ----- testComparison "Test if the comparison operators define a total sort function." #( #[3 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0] #[2 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0] #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 1] #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 4] #[2 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0] #[3 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0] #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 4] #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 1] #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 4] #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 4] ) pairsDo: [ :x :y | | a b c d | a := UUID newFrom: x. b := UUID newFrom: y. c := x asString. d := y asString. "Check if the comparison is lexicographical, just like strings'." #(< > <= >= = ~=) do: [ :operation | self assert: (a perform: operation with: b) = (c perform: operation with: d) ]. "And a few more" self assert: (a < b) = (a >= b) not; assert: (a > b) = (a <= b) not; assert: (a = b) = (a ~= b) not; assert: (a < b) = (b > a); assert: (a > b) = (b < a); assert: (a >= b) = (b <= a); assert: (a <= b) = (b >= a); assert: (a = b) = (b = a); assert: (a ~= b) = (b ~= a); assert: (a > b) = ((a >= b) & (a ~= b)); assert: (a < b) = ((a <= b) & (a ~= b)); assert: (a >= b) = ((a = b) | (a > b)); assert: (a <= b) = ((a = b) | (a < b)); assert: (a ~= b) = ((a < b) | (a > b)); assert: (a <= b) & (b <= a) = (a = b); assert: (a >= b) & (b >= a) = (a = b); assert: (a <= b) | (b <= a); assert: (a = b) asBit + (a < b) asBit + (b < a) asBit = 1 ]! ClassTestCase subclass: #FileUrlTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! ----- Method: FileUrlTest>>testAsString (in category 'testing') ----- testAsString | target url | target := 'file://localhost/etc/rc.conf'. url := target asUrl. self assert: url asString = target. ! ClassTestCase subclass: #GenericUrlTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! ----- Method: GenericUrlTest>>testAsString (in category 'testing') ----- testAsString | url | url := GenericUrl new schemeName: 'sip' locator: 'foo@bar'. self assert: url asString = 'sip:foo@bar'.! ClassTestCase subclass: #HierarchicalUrlTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! ----- Method: HierarchicalUrlTest>>testAsString (in category 'testing') ----- testAsString | url | url := HierarchicalUrl new schemeName: 'ftp' authority: 'localhost' path: #('path' 'to' 'file') query: 'aQuery'. self assert: url asString = 'ftp://localhost/path/to/file?aQuery'.! ClassTestCase subclass: #HttpUrlTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! ----- Method: HttpUrlTest>>testHttps (in category 'as yet unclassified') ----- testHttps self assert: 'https://encrypted.google.com' asUrl class == HttpUrl! ClassTestCase subclass: #SocketStreamTest instanceVariableNames: 'clientStream serverStream' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Kernel'! ----- Method: SocketStreamTest>>setUp (in category 'setup') ----- setUp | listener clientSocket serverSocket | listener := Socket newTCP. [listener listenOn: 0 backlogSize: 4. clientSocket := Socket newTCP. clientSocket connectTo: #[127 0 0 1] port: listener localPort. clientSocket waitForConnectionFor: 1. self assert: clientSocket isConnected. serverSocket := listener waitForAcceptFor: 1. self assert: serverSocket isConnected. ] ensure:[listener destroy]. clientStream := SocketStream on: clientSocket. serverStream := SocketStream on: serverSocket. ! ----- Method: SocketStreamTest>>tearDown (in category 'setup') ----- tearDown clientStream ifNotNil:[clientStream destroy]. serverStream ifNotNil:[serverStream destroy].! ----- Method: SocketStreamTest>>testNextIntoClose (in category 'stream protocol') ----- testNextIntoClose "Ensure that #next:into: will function properly when the connection is closed" clientStream nextPutAll:'A line of text'; flush. [(Delay forMilliseconds: 100) wait. clientStream close] fork. self assert: (serverStream next: 100 into: (String new: 100) startingAt: 1) equals: 'A line of text'. ! ----- Method: SocketStreamTest>>testNextIntoCloseNonSignaling (in category 'stream protocol') ----- testNextIntoCloseNonSignaling "Ensure that #next:into: will function properly when the connection is closed" serverStream shouldSignal: false. clientStream nextPutAll:'A line of text'; flush. [(Delay forMilliseconds: 100) wait. clientStream close] fork. self assert: (serverStream next: 100 into: (String new: 100) startingAt: 1) equals: 'A line of text'. ! ----- Method: SocketStreamTest>>testUpTo (in category 'stream protocol') ----- testUpTo "Tests correct behavior of #upTo:" clientStream nextPutAll:'A line of text', String cr, 'with more text'; flush. self assert: (serverStream upTo: Character cr) = 'A line of text'. [(Delay forSeconds: 1) wait. clientStream nextPutAll: String cr; flush] fork. self assert: (serverStream upTo: Character cr) = 'with more text'. ! ----- Method: SocketStreamTest>>testUpToAfterCloseNonSignaling (in category 'stream protocol') ----- testUpToAfterCloseNonSignaling "Tests correct behavior of #upToAll" | resp | clientStream nextPutAll: 'A line of text'. clientStream close. serverStream shouldSignal: false. self shouldnt: [resp := serverStream upTo: Character cr] raise: ConnectionClosed. self assert: resp = 'A line of text'.! ----- Method: SocketStreamTest>>testUpToAfterCloseSignaling (in category 'stream protocol') ----- testUpToAfterCloseSignaling "Tests correct behavior of #upToAll" clientStream nextPutAll:'A line of text'. clientStream close. self should: [serverStream upTo: Character cr] raise: ConnectionClosed. ! ----- Method: SocketStreamTest>>testUpToAll (in category 'stream protocol') ----- testUpToAll "Tests correct behavior of #upToAll" clientStream nextPutAll:'A line of text', String crlf, 'with more text'; flush. self assert: (serverStream upToAll: String crlf) = 'A line of text'. [(Delay forSeconds: 1) wait. clientStream nextPutAll: String crlf; flush] fork. self assert: (serverStream upToAll: String crlf) = 'with more text'. ! ----- Method: SocketStreamTest>>testUpToAllAfterCloseNonSignaling (in category 'stream protocol') ----- testUpToAllAfterCloseNonSignaling "Tests correct behavior of #upToAll" | resp | clientStream nextPutAll: 'A line of text'. clientStream close. serverStream shouldSignal: false. self shouldnt: [resp := serverStream upToAll: String crlf] raise: ConnectionClosed. self assert: resp = 'A line of text'.! ----- Method: SocketStreamTest>>testUpToAllAfterCloseSignaling (in category 'stream protocol') ----- testUpToAllAfterCloseSignaling "Tests correct behavior of #upToAll" clientStream nextPutAll:'A line of text'. clientStream close. self should: [serverStream upToAll: String crlf] raise: ConnectionClosed. ! ----- Method: SocketStreamTest>>testUpToAllAsciiVsBinary (in category 'stream protocol') ----- testUpToAllAsciiVsBinary "Tests correct behavior of #upToAll" serverStream ascii. clientStream nextPutAll:'A line of text', String crlf, 'with more text'; flush. self assert: (serverStream upToAll: #[13 10]) = 'A line of text'. serverStream binary. clientStream nextPutAll: String crlf; flush. self assert: (serverStream upToAll: String crlf) asString = 'with more text'. ! ----- Method: SocketStreamTest>>testUpToAllLimit (in category 'stream protocol') ----- testUpToAllLimit "Tests correct behavior of #upToAll:limit:" clientStream nextPutAll:'A line of text'; flush. self assert: (serverStream upToAll: String crlf limit: 5) = 'A line of text'.! ----- Method: SocketStreamTest>>testUpToAllTimeout (in category 'stream protocol') ----- testUpToAllTimeout "Tests correct behavior of #upToAll" clientStream nextPutAll: 'A line of text'. serverStream timeout: 1. self should: [serverStream upToAll: String crlf] raise: ConnectionTimedOut. ! ----- Method: SocketStreamTest>>testUpToAsciiVsBinary (in category 'stream protocol') ----- testUpToAsciiVsBinary "Tests correct behavior of #upTo:" serverStream ascii. clientStream nextPutAll:'A line of text', String cr, 'with more text'; flush. self assert: (serverStream upTo: 13) = 'A line of text'. serverStream binary. clientStream nextPutAll: String cr; flush. self assert: (serverStream upTo: Character cr) asString = 'with more text'. ! ----- Method: SocketStreamTest>>testUpToEndClose (in category 'stream protocol') ----- testUpToEndClose "Ensure that #upToEnd will function properly when the connection is closed" clientStream nextPutAll:'A line of text'; flush. [(Delay forMilliseconds: 100) wait. clientStream close] fork. self assert: (serverStream upToEnd) equals: 'A line of text'. ! ----- Method: SocketStreamTest>>testUpToEndCloseNonSignaling (in category 'stream protocol') ----- testUpToEndCloseNonSignaling "Ensure that #upToEnd will function properly when the connection is closed" serverStream shouldSignal: false. clientStream nextPutAll:'A line of text'; flush. [(Delay forMilliseconds: 100) wait. clientStream close] fork. self assert: (serverStream upToEnd) equals: 'A line of text'. ! ----- Method: SocketStreamTest>>testUpToMax (in category 'stream protocol') ----- testUpToMax "Tests correct behavior of #upToAll:max:" clientStream nextPutAll:'A line of text'; flush. self assert: (serverStream upTo: Character cr limit: 5) = 'A line of text'.! ----- Method: SocketStreamTest>>testUpToTimeout (in category 'stream protocol') ----- testUpToTimeout "Tests correct behavior of #upToAll" clientStream nextPutAll: 'A line of text'. serverStream timeout: 1. self should: [serverStream upTo: Character cr] raise: ConnectionTimedOut. ! ClassTestCase subclass: #UrlTest instanceVariableNames: 'url baseUrl expected string' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! !UrlTest commentStamp: '<historical>' prior: 0! This is the unit test for the class Url. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! ----- Method: UrlTest>>testAbsoluteBrowser (in category 'tests') ----- testAbsoluteBrowser url := Url absoluteFromText: 'browser:bookmarks#mainPart'. self assert: url schemeName = 'browser'. self assert: url locator = 'bookmarks'. self assert:url fragment = 'mainPart'. self assert: url class = BrowserUrl. ! ----- Method: UrlTest>>testAbsoluteFILE (in category 'tests') ----- testAbsoluteFILE url := Url absoluteFromText: 'file:/etc/passwd#foo'. self assert: url schemeName = 'file'. self assert: url path first = 'etc'. self assert: url path size = 2. self assert: url fragment = 'foo'.! ----- Method: UrlTest>>testAbsoluteFILE2 (in category 'tests') ----- testAbsoluteFILE2 url := 'fILE:/foo/bar//zookie/?fakequery/#fragger' asUrl. self assert: url schemeName = 'file'. self assert: url class = FileUrl. self assert: url path first ='foo'. self assert: url path size = 5. self assert: url fragment = 'fragger'.! ----- Method: UrlTest>>testAbsoluteFILE3 (in category 'tests') ----- testAbsoluteFILE3 "Just a few selected tests for FileUrl, not complete by any means." {'file:'. 'file:/'. 'file://'} do: [:s | url := FileUrl absoluteFromText: s. self assert: (url asString = 'file:///'). self assert: (url host = ''). self assert: url isAbsolute]. url := FileUrl absoluteFromText: 'file://localhost/dir/file.txt'. self assert: (url asString = 'file://localhost/dir/file.txt'). self assert: (url host = 'localhost'). url := FileUrl absoluteFromText: 'file://localhost/dir/file.txt'. self assert: (url asString = 'file://localhost/dir/file.txt'). self assert: (url host = 'localhost'). self assert: url isAbsolute. url := FileUrl absoluteFromText: 'file:///dir/file.txt'. self assert: (url asString = 'file:///dir/file.txt'). self assert: (url host = ''). self assert: url isAbsolute. url := FileUrl absoluteFromText: '/dir/file.txt'. self assert: (url asString = 'file:///dir/file.txt'). self assert: url isAbsolute. url := FileUrl absoluteFromText: 'dir/file.txt'. self assert: (url asString = 'file:///dir/file.txt'). self deny: url isAbsolute. url := FileUrl absoluteFromText: 'c:/dir/file.txt'. self assert: (url asString = 'file:///c%3A/dir/file.txt'). self assert: url isAbsolute. "Only a drive letter doesn't refer to a directory." url := FileUrl absoluteFromText: 'c:'. self assert: (url asString = 'file:///c%3A/'). self assert: url isAbsolute. url := FileUrl absoluteFromText: 'c:/'. self assert: (url asString = 'file:///c%3A/'). self assert: url isAbsolute! ----- Method: UrlTest>>testAbsoluteFTP (in category 'tests') ----- testAbsoluteFTP url := 'ftP://some.server/some/directory/' asUrl. self assert: url schemeName = 'ftp'. self assert: url class = FtpUrl. self assert: url authority = 'some.server'. self assert: url path first = 'some'. self assert: url path size = 3. ! ----- Method: UrlTest>>testAbsoluteHTTP (in category 'tests') ----- testAbsoluteHTTP url := 'hTTp://chaos.resnet.gatech.edu:8000/docs/java/index.html?A%20query%20#part' asUrl. self assert: url schemeName = 'http'. self assert: url authority = 'chaos.resnet.gatech.edu'. self assert: url path first = 'docs'. self assert: url path size = 3. self assert: url query = 'A%20query%20'. self assert: url fragment = 'part'.! ----- Method: UrlTest>>testAbsolutePortErrorFix (in category 'tests') ----- testAbsolutePortErrorFix "This should not throw an exception." Url absoluteFromText: 'http://swikis.ddo.jp:8823/'. self should: [Url absoluteFromText: 'http://swikis.ddo.jp:-1/'] raise: Error. self should: [Url absoluteFromText: 'http://swikis.ddo.jp:65536/'] raise: Error. self should: [Url absoluteFromText: 'http://swikis.ddo.jp:auau/'] raise: Error.! ----- Method: UrlTest>>testAbsoluteTELNET (in category 'tests') ----- testAbsoluteTELNET url := 'telNet:chaos.resnet.gatech.edu#goo' asUrl. self assert: url schemeName = 'telnet'. self assert: url locator = 'chaos.resnet.gatech.edu'. self assert: url fragment = 'goo'. ! ----- Method: UrlTest>>testCombineWithRelative (in category 'tests') ----- testCombineWithRelative #(#('http://www.rfc1149.net/' 'foo.html' 'http://www.rfc1149.net/foo.html') #('http://www.rfc1149.net/index.html' 'foo.html' 'http://www.rfc1149.net/foo.html') #('http://www.rfc1149.net/devel/' '../sam/' 'http://www.rfc1149.net/sam/') #('http://www.rfc1149.net/devel/index.html' '../sam/' 'http://www.rfc1149.net/sam/')) do: [:a | self assert: (Url combine: a first withRelative: a second) = a third]! ----- Method: UrlTest>>testFromFileNameOrUrlString (in category 'testing') ----- testFromFileNameOrUrlString url := Url absoluteFromFileNameOrUrlString: 'asdf'. self assert: url schemeName = 'file'. self assert: url fragment isNil. self assert: url class = FileUrl. url := Url absoluteFromFileNameOrUrlString: 'http://209.143.91.36/super/SuperSwikiProj/AAEmptyTest.001.pr'. self assert: url schemeName = 'http'. self assert: url fragment isNil. self assert: url class = HttpUrl.! ----- Method: UrlTest>>testRelativeFILE (in category 'tests') ----- testRelativeFILE | url2 | baseUrl := 'file:/some/dir#fragment1' asUrl. url := baseUrl newFromRelativeText: 'file:../another/dir/#fragment2'. self assert: url asText = 'file:///another/dir/#fragment2'. url := FileUrl absoluteFromText: 'file://localhost/dir/dir2/file.txt'. url2 := FileUrl absoluteFromText: 'file://hostname/flip/file.txt'. url2 privateInitializeFromText: '../file2.txt' relativeTo: url. self assert: (url2 asString = 'file://localhost/dir/file2.txt'). self assert: (url2 host = 'localhost'). self assert: url2 isAbsolute. url := FileUrl absoluteFromText: 'file://localhost/dir/dir2/file.txt'. url2 := FileUrl absoluteFromText: 'flip/file.txt'. self deny: url2 isAbsolute. url2 privateInitializeFromText: '.././flip/file.txt' relativeTo: url. self assert: (url2 asString = 'file://localhost/dir/flip/file.txt'). self assert: (url2 host = 'localhost'). self assert: url2 isAbsolute. ! ----- Method: UrlTest>>testRelativeFTP (in category 'tests') ----- testRelativeFTP baseUrl := 'ftp://somewhere/some/dir/?query#fragment' asUrl. url := baseUrl newFromRelativeText: 'ftp://a.b'. self assert: url asString = 'ftp://a.b/'.! ----- Method: UrlTest>>testRelativeFTP2 (in category 'tests') ----- testRelativeFTP2 baseUrl := 'ftp://somewhere/some/dir/?query#fragment' asUrl. url := baseUrl newFromRelativeText: 'ftp:xyz'. self assert: url asString = 'ftp://somewhere/some/dir/xyz'.! ----- Method: UrlTest>>testRelativeFTP3 (in category 'tests') ----- testRelativeFTP3 baseUrl := 'ftp://somewhere/some/dir/?query#fragment' asUrl. url := baseUrl newFromRelativeText: 'http:xyz'. self assert: url asString = 'http://xyz/'.! ----- Method: UrlTest>>testRelativeHTTP (in category 'tests') ----- testRelativeHTTP baseUrl := 'http://some.where/some/dir?query1#fragment1' asUrl. url := baseUrl newFromRelativeText: '../another/dir/?query2#fragment2'. self assert: url asString = 'http://some.where/another/dir/?query2#fragment2'.! ----- Method: UrlTest>>testRoundTripFILE (in category 'tests') ----- testRoundTripFILE "File URLs should round-trip OK. This test should ultimately be tested on all platforms." | fileName | fileName := FileDirectory default fullNameFor: 'xxx.st'. url := FileDirectory urlForFileNamed: fileName. self assert: (url pathForFile = fileName) description: 'fileName didn''t round-trip'.! ----- Method: UrlTest>>testUrlEncoded (in category 'tests') ----- testUrlEncoded "Test the behavior of #urlEncoded" self assert: 'http://squeak.org/name with space?and=value' urlEncoded equals: 'http://squeak.org/name%20with%20space?and=value'. self assert: 'http://squeak.org/name%20with%20space?and=value' urlEncoded equals: 'http://squeak.org/name%20with%20space?and=value'. self assert: 'http://squeak.org/name%with%space?and=value' urlEncoded equals: 'http://squeak.org/name%25with%25space?and=value'. ! ----- Method: UrlTest>>testUsernamePassword (in category 'tests') ----- testUsernamePassword "basic case with a username+password specified" url := 'http://user:pword@someserver.blah:8000/root/index.html' asUrl. self should: [ url schemeName = 'http' ]. self should: [ url authority = 'someserver.blah' ]. self should: [ url port = 8000 ]. self should: [ url path first = 'root' ]. self should: [ url username = 'user' ]. self should: [ url password = 'pword' ]. "basic case for a relative url" baseUrl := 'http://anotherserver.blah:9999/somedir/someotherdir/stuff/' asUrl. url := 'http://user:pword@someserver.blah:8000/root/index.html' asUrlRelativeTo: baseUrl. self should: [ url schemeName = 'http' ]. self should: [ url authority = 'someserver.blah' ]. self should: [ url port = 8000 ]. self should: [ url path first = 'root' ]. self should: [ url username = 'user' ]. self should: [ url password = 'pword' ]. "a true relative test that should keep the username and password from the base URL" baseUrl := 'http://user:pword@someserver.blah:8000/root/index.html' asUrl. url := '/anotherdir/stuff/' asUrlRelativeTo: baseUrl. self should: [ url schemeName = 'http' ]. self should: [ url authority = 'someserver.blah' ]. self should: [ url port = 8000 ]. self should: [ url path first = 'anotherdir' ]. self should: [ url username = 'user' ]. self should: [ url password = 'pword' ]. "just a username specified" url := 'http://user@someserver.blah:8000/root/index.html' asUrl. self should: [ url schemeName = 'http' ]. self should: [ url authority = 'someserver.blah' ]. self should: [ url port = 8000 ]. self should: [ url path first = 'root' ]. self should: [ url username = 'user' ]. self should: [ url password = nil ]. "the port is not specified" url := 'http://user:pword@someserver.blah/root/index.html' asUrl. self should: [ url schemeName = 'http' ]. self should: [ url authority = 'someserver.blah' ]. self should: [ url port = nil ]. self should: [ url path first = 'root' ]. self should: [ url username = 'user' ]. self should: [ url password = 'pword' ]. "neither a path nor a port is specified" url := 'http://user:pword@someserver.blah' asUrl. self should: [ url schemeName = 'http' ]. self should: [ url authority = 'someserver.blah' ]. self should: [ url port = nil ]. self should: [ url username = 'user' ]. self should: [ url password = 'pword' ]. "relative URL where the username+password should be forgotten" baseUrl := 'http://user:pword@someserver.blah' asUrl. url := 'http://anotherserver.blah' asUrlRelativeTo: baseUrl. self should: [ url username = nil ]. self should: [ url password = nil ]. ! ----- Method: UrlTest>>testUsernamePasswordEncoded (in category 'tests') ----- testUsernamePasswordEncoded "Sometimes, weird usernames or passwords are necessary in applications, and, thus, we might receive them in a Url. The @ and the : ar the kind of critical ones. " #( "('user' 'pword' 'host' port 'path')" ('Fürst Pückler' 'leckerEis' 'cottbus.brandenburg' 80 'mein/Zuhause') ('Jeannde.d''Arc' 'jaiunesécret' 'orleans' 8080 'une/deux/trois') ('HaXor@roxor:fnac' 'my~Pa$§wert' 'cbase' 42 'do/not_try') ) do: [:urlParts | |theUrl| theUrl := ('http://{1}:{2}@{3}:{4}/{5}' format: { (urlParts at: 1) encodeForHTTP. (urlParts at: 2) encodeForHTTP. urlParts at: 3. urlParts at: 4. urlParts at: 5. }) asUrl. self should: [theUrl schemeName = 'http']; should: [theUrl username = (urlParts at: 1)]; should: [theUrl password = (urlParts at: 2)]; should: [theUrl authority = (urlParts at: 3)]; should: [theUrl port = (urlParts at: 4)]; should: [theUrl path first = ((urlParts at: 5) copyUpTo: $/)]]. ! ----- Method: UrlTest>>testUsernamePasswordPrinting (in category 'tests') ----- testUsernamePasswordPrinting #( 'http://user:pword@someserver.blah:8000/root/index.html' 'http://user@someserver.blah:8000/root/index.html' 'http://user:pword@someserver.blah/root/index.html' ) do: [ :urlText | self should: [ urlText = urlText asUrl asString ] ]. ! ----- Method: UrlTest>>testUsernamePasswordPrintingEncoded (in category 'tests') ----- testUsernamePasswordPrintingEncoded #( 'http://F%C3%BCrst%20P%C3%BCckler:leckerEis@cottbus.brandenburg:80/mein/Zuha…' 'http://Jeannde.d%27Arc:jaiunes%C3%A9cret@orleans:8080/une/deux/trois' 'http://HaXor%40roxor%3Afnac:my%7EPa%24%C2%A7wert@cbase:42/do/not_try' ) do: [ :urlText | self should: [ urlText = urlText asUrl asString ] ]. !

1 0

Squeak 4.6: 46Deprecated-dtl.4.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of 46Deprecated to project Squeak 4.6: http://source.squeak.org/squeak46/46Deprecated-dtl.4.mcz ==================== Summary ==================== Name: 46Deprecated-dtl.4 Author: dtl Time: 30 May 2015, 6:14:05.154 pm UUID: 69e9c6e3-c82e-445b-b82d-adc42cacb06b Ancestors: 46Deprecated-mt.3 Provide an implementation of MCMcmUpdater class>>useLatestPackagesFrom: because an older image may be referencing it while trying to update itself from a block in the earler class side implementation, in which case we should delegate to the current default instance of MCMcmUpdater. ==================== Snapshot ==================== SystemOrganization addCategory: #'46Deprecated-Morphic'! PluggableListMorph subclass: #PluggableMessageCategoryListMorph instanceVariableNames: 'getRawListSelector priorRawList' classVariableNames: '' poolDictionaries: '' category: '46Deprecated-Morphic'! !PluggableMessageCategoryListMorph commentStamp: '<historical>' prior: 0! A variant of PluggableListMorph designed specially for efficient handling of the --all-- feature in message-list panes. In order to be able *quickly* to check whether there has been an external change to the list, we cache the raw list for identity comparison (the actual list is a combination of the --all-- element and the the actual list).! ----- Method: PluggableMessageCategoryListMorph class>>on:list:selected:changeSelected:menu:keystroke:getRawListSelector: (in category 'as yet unclassified') ----- on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel! ----- Method: PluggableMessageCategoryListMorph>>getList (in category 'model access') ----- getList "Differs from the generic in that here we obtain and cache the raw list, then cons it together with the special '-- all --' item to produce the list to be used in the browser. This special handling is done in order to avoid excessive and unnecessary reformulation of the list in the step method" getRawListSelector == nil ifTrue: ["should not happen!!" priorRawList := nil. ^ #()]. model classListIndex = 0 ifTrue: [^ priorRawList := list := Array new]. priorRawList := model perform: getRawListSelector. list := (Array with: ClassOrganizer allCategory), priorRawList. ^list! ----- Method: PluggableMessageCategoryListMorph>>on:list:selected:changeSelected:menu:keystroke:getRawListSelector: (in category 'as yet unclassified') ----- on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel self model: anObject. getListSelector := getListSel. getIndexSelector := getSelectionSel. setIndexSelector := setSelectionSel. getMenuSelector := getMenuSel. keystrokeActionSelector := keyActionSel. autoDeselect := true. self borderWidth: 1. getRawListSelector := getRawSel. self updateList. self selectionIndex: self getCurrentSelectionIndex. self initForKeystrokes! ----- Method: PluggableMessageCategoryListMorph>>verifyContents (in category 'updating') ----- verifyContents | newList existingSelection anIndex newRawList | (model editSelection == #editComment) ifTrue: [^ self]. model classListIndex = 0 ifTrue: [^ self]. newRawList := model perform: getRawListSelector. newRawList == priorRawList ifTrue: [^ self]. "The usual case; very fast" priorRawList := newRawList. newList := (Array with: ClassOrganizer allCategory), priorRawList. list = newList ifTrue: [^ self]. existingSelection := self selection. self updateList. (anIndex := newList indexOf: existingSelection ifAbsent: [nil]) ifNotNil: [model noteSelectionIndex: anIndex for: getListSelector. self selectionIndex: anIndex] ifNil: [self changeModelSelection: 0]! ----- Method: MorphicProject>>exportSegmentWithCatagories:classes:fileName:directory: (in category '*46Deprecated') ----- exportSegmentWithCatagories: catList classes: classList fileName: aFileName directory: aDirectory "Store my project out on the disk as an *exported* ImageSegment. All outPointers will be in a form that can be resolved in the target image. Name it <project name>.extSeg. What do we do about subProjects, especially if they are out as local image segments? Force them to come in? Player classes are included automatically." | is str ans revertSeg roots holder | self flag: #toRemove. self halt. "unused" "world == World ifTrue: [^ false]." "self inform: 'Can''t send the current world out'." world ifNil: [^ false]. world presenter ifNil: [^ false]. ScrapBook default emptyScrapBook. world currentHand pasteBuffer: nil. "don't write the paste buffer." world currentHand mouseOverHandler initialize. "forget about any references here" "Display checkCurrentHandForObjectToPaste." Command initialize. world clearCommandHistory. world fullReleaseCachedState; releaseViewers. world cleanseStepList. world localFlapTabs size = world flapTabs size ifFalse: [ self error: 'Still holding onto Global flaps']. world releaseSqueakPages. holder := Project allProjects. "force them in to outPointers, where DiskProxys are made" "Just export me, not my previous version" revertSeg := self parameterAt: #revertToMe. self projectParameters removeKey: #revertToMe ifAbsent: []. roots := OrderedCollection new. roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail. roots add: world activeHand; addAll: classList; addAll: (classList collect: [:cls | cls class]). roots := roots reject: [ :x | x isNil]. "early saves may not have active hand or thumbnail" catList do: [:sysCat | (SystemOrganization listAtCategoryNamed: sysCat asSymbol) do: [:symb | roots add: (Smalltalk at: symb); add: (Smalltalk at: symb) class]]. is := ImageSegment new copySmartRootsExport: roots asArray. "old way was (is := ImageSegment new copyFromRootsForExport: roots asArray)" is state = #tooBig ifTrue: [^ false]. str := ''. "considered legal to save a project that has never been entered" (is outPointers includes: world) ifTrue: [ str := str, '\Project''s own world is not in the segment.' withCRs]. str isEmpty ifFalse: [ ans := (UIManager default chooseFrom: #('Do not write file' 'Write file anyway' 'Debug') title: str). ans = 1 ifTrue: [ revertSeg ifNotNil: [self projectParameterAt: #revertToMe put: revertSeg]. ^ false]. ans = 3 ifTrue: [self halt: 'Segment not written']]. is writeForExportWithSources: aFileName inDirectory: aDirectory. revertSeg ifNotNil: [self projectParameterAt: #revertToMe put: revertSeg]. holder. world flapTabs do: [:ft | (ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]]. is arrayOfRoots do: [:obj | obj isScriptEditorMorph ifTrue: [obj unhibernate]]. ^ true ! ----- Method: HierarchyBrowser>>potentialClassNames (in category '*46Deprecated') ----- potentialClassNames "Answer the names of all the classes that could be viewed in this browser" ^ self classList collect: [:aName | aName copyWithout: $ ]! ----- Method: MCMcmUpdater class>>useLatestPackagesFrom: (in category '*46Deprecated') ----- useLatestPackagesFrom: repo "For overriding on a per repository basis. Implementation is now on the instance side, but is also maintained here because an older image may be trying to update to current and may still be evaluating a block in its class:>>updateFromRepositoriesMCMcmUpdater that expects thiis method to be present. Delegate to the current default instance." ^ self default useLatestPackagesFrom: repo ! ----- Method: ScrollPane>>alwaysShowHScrollBar: (in category '*46Deprecated') ----- alwaysShowHScrollBar: bool self flag: #deprecated. self setProperty: #hScrollBarAlways toValue: bool. bool ifTrue: [self hScrollBarPolicy: #always] ifFalse: [self hScrollBarPolicy: #whenNeeded]. self hHideOrShowScrollBar. ! ----- Method: ScrollPane>>alwaysShowScrollBars: (in category '*46Deprecated') ----- alwaysShowScrollBars: bool "Get rid of scroll bar for short panes that don't want it shown." self flag: #deprecated. self alwaysShowHScrollBar: bool; alwaysShowVScrollBar: bool. ! ----- Method: ScrollPane>>alwaysShowVScrollBar: (in category '*46Deprecated') ----- alwaysShowVScrollBar: bool self flag: #deprecated. self setProperty: #vScrollBarAlways toValue: bool. bool ifTrue: [self vScrollBarPolicy: #always] ifFalse: [self vScrollBarPolicy: #whenNeeded]. self vHideOrShowScrollBar. ! ----- Method: ScrollPane>>hInitScrollBarTEMPORARY (in category '*46Deprecated') ----- hInitScrollBarTEMPORARY "This is called lazily before the hScrollBar is accessed in a couple of places. It is provided to transition old ScrollPanes lying around that do not have an hScrollBar. Once it has been in the image for awhile, and all ScrollPanes have an hScrollBar, this method and it's references can be removed. " "Temporary method for filein of changeset" hScrollBar ifNil: [hScrollBar := ScrollBar new model: self slotName: 'hScrollBar'. hScrollBar borderWidth: 1; borderColor: Color black. self resizeScrollBars; setScrollDeltas; hideOrShowScrollBars]. ! ----- Method: ScrollPane>>hideHScrollBarIndefinitely: (in category '*46Deprecated') ----- hideHScrollBarIndefinitely: bool "Get rid of scroll bar for short panes that don't want it shown." self flag: #deprecated. self setProperty: #noHScrollBarPlease toValue: bool. bool ifTrue: [self hScrollBarPolicy: #never] ifFalse: [self hScrollBarPolicy: #whenNeeded]. self hHideOrShowScrollBar. ! ----- Method: ScrollPane>>hideScrollBarsIndefinitely: (in category '*46Deprecated') ----- hideScrollBarsIndefinitely: bool "Get rid of scroll bar for short panes that don't want it shown." self flag: #deprecated. self hideVScrollBarIndefinitely: bool. self hideHScrollBarIndefinitely: bool. ! ----- Method: ScrollPane>>hideVScrollBarIndefinitely: (in category '*46Deprecated') ----- hideVScrollBarIndefinitely: bool "Get rid of scroll bar for short panes that don't want it shown." self flag: #deprecated. self setProperty: #noVScrollBarPlease toValue: bool. bool ifTrue: [self vScrollBarPolicy: #never] ifFalse: [self vScrollBarPolicy: #whenNeeded]. self vHideOrShowScrollBar. ! ----- Method: ScrollPane>>isAScrollbarShowing (in category '*46Deprecated') ----- isAScrollbarShowing "Return true if a either retractable scroll bar is currently showing" self flag: #deprectaed. "mt: Use #isAnyScrollbarShowing" retractableScrollBar ifFalse:[^true]. ^self hIsScrollbarShowing or: [self vIsScrollbarShowing] ! ----- Method: ScrollPane>>showHScrollBarOnlyWhenNeeded: (in category '*46Deprecated') ----- showHScrollBarOnlyWhenNeeded: bool "Get rid of scroll bar for short panes that don't want it shown." self flag: #deprecated. self setProperty: #noHScrollBarPlease toValue: bool not. self setProperty: #hScrollBarAlways toValue: bool not. bool ifTrue: [self hScrollBarPolicy: #whenNeeded] ifFalse: [self hScrollBarPolicy: #never]. self hHideOrShowScrollBar. ! ----- Method: ScrollPane>>showScrollBarsOnlyWhenNeeded: (in category '*46Deprecated') ----- showScrollBarsOnlyWhenNeeded: bool self flag: #deprecated. self showHScrollBarOnlyWhenNeeded: bool. self showVScrollBarOnlyWhenNeeded: bool. ! ----- Method: ScrollPane>>showVScrollBarOnlyWhenNeeded: (in category '*46Deprecated') ----- showVScrollBarOnlyWhenNeeded: bool "Get rid of scroll bar for short panes that don't want it shown." self flag: #deprecated. self setProperty: #noVScrollBarPlease toValue: bool not. self setProperty: #vScrollBarAlways toValue: bool not. bool ifTrue: [self vScrollBarPolicy: #whenNeeded] ifFalse: [self vScrollBarPolicy: #never]. self vHideOrShowScrollBar. ! TextMorph subclass: #SearchBarMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: '46Deprecated-Morphic'! ----- Method: SearchBarMorph>>activate: (in category 'search') ----- activate: event event hand newKeyboardFocus: self. self selectAll! ----- Method: SearchBarMorph>>fillStyle (in category 'initialize') ----- fillStyle ^backgroundColor! ----- Method: SearchBarMorph>>initialize (in category 'initialize') ----- initialize super initialize. text := Text new. backgroundColor := TranslucentColor gray alpha: 0.3. self width: 200. self crAction: (MessageSend receiver: self selector: #smartSearch:). self setBalloonText: 'Searches for globals and methods'.! ----- Method: SearchBarMorph>>smartSearch: (in category 'search') ----- smartSearch: evt "Take the user input and perform an appropriate search" | input newContents | input := self contents asString ifEmpty:[^self]. (Smalltalk bindingOf: input) ifNotNil:[:assoc| | global | "It's a global or a class" global := assoc value. ^ToolSet browse: (global isBehavior ifTrue:[global] ifFalse:[global class]) selector: nil. ]. (SystemNavigation new allImplementorsOf: input asSymbol) ifNotEmpty:[:list| ^SystemNavigation new browseMessageList: list name: 'Implementors of ' , input ]. input first isUppercase ifTrue:[ (UIManager default classFromPattern: input withCaption: '') ifNotNil:[:aClass| ^ToolSet browse: aClass selector: nil. ]. ] ifFalse:[ ^ToolSet default browseMessageNames: input ]. newContents := input, ' -- not found.'. self newContents: newContents; selectFrom: input size+1 to: newContents size. evt hand newKeyboardFocus: self! ----- Method: CodeHolder>>abbreviatedWordingFor: (in category '*46Deprecated') ----- abbreviatedWordingFor: aButtonSelector "Answer the abbreviated form of wording, from a static table. Answer nil if there is no entry -- in which case the long form will be used on the corresponding browser button." #( (browseMethodFull 'browse') (browseSendersOfMessages 'senders') (browseMessages 'impl') (browseVersions 'vers') (methodHierarchy 'inher') (classHierarchy 'hier') (browseVariableReferences 'refs') (offerMenu 'menu')) do: [:pair | pair first == aButtonSelector ifTrue: [^ pair second]]. ^ nil! ----- Method: CodeHolder>>showingDiffsString (in category '*46Deprecated') ----- showingDiffsString "Answer a string representing whether I'm showing diffs. Not sent any more but retained so that prexisting buttons that sent this will not raise errors." ^ (self showingRegularDiffs ifTrue: ['<yes>'] ifFalse: ['<no>']), 'showDiffs'! ----- Method: CodeHolder>>toggleDiff (in category '*46Deprecated') ----- toggleDiff "Retained for backward compatibility with existing buttons in existing images" self toggleDiffing! ----- Method: Browser>>classComment:notifying: (in category '*46Deprecated') ----- classComment: aText notifying: aPluggableTextMorph "The user has just entered aText. It may be all red (a side-effect of replacing the default comment), so remove the color if it is." | theClass cleanedText redRange | theClass := self selectedClassOrMetaClass. theClass ifNotNil: [cleanedText := aText asText. redRange := cleanedText rangeOf: TextColor red startingAt: 1. redRange size = cleanedText size ifTrue: [cleanedText removeAttribute: TextColor red from: 1 to: redRange last ]. theClass comment: aText stamp: Utilities changeStamp]. self changed: #classCommentText. ^ true! ----- Method: Browser>>defineMessage:notifying: (in category '*46Deprecated') ----- defineMessage: aString notifying: aController self deprecated: 'Use Browser >> #defineMessageFrom:notifying:. This returns a Symbol or nil, not a Boolean.'. ^ (self defineMessageFrom: aString notifying: aController) notNil.! ----- Method: Browser>>messageListSingleton (in category '*46Deprecated') ----- messageListSingleton | name | name := self selectedMessageName. ^ name ifNil: [Array new] ifNotNil: [Array with: name]! ----- Method: Browser>>optionalAnnotationHeight (in category '*46Deprecated') ----- optionalAnnotationHeight ^ 10! ----- Method: Browser>>optionalButtonHeight (in category '*46Deprecated') ----- optionalButtonHeight ^ 10! ----- Method: Browser>>potentialClassNames (in category '*46Deprecated') ----- potentialClassNames "Answer the names of all the classes that could be viewed in this browser. This hook is provided so that HierarchyBrowsers can indicate their restricted subset. For generic Browsers, the entire list of classes known to Smalltalk is provided, though of course that really only is accurate in the case of full system browsers." ^ Smalltalk classNames!

1 0

Squeak 4.6: PreferenceBrowser-mt.53.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of PreferenceBrowser to project Squeak 4.6: http://source.squeak.org/squeak46/PreferenceBrowser-mt.53.mcz ==================== Summary ==================== Name: PreferenceBrowser-mt.53 Author: mt Time: 25 April 2015, 10:13:23.176 am UUID: 91503306-d9bf-2a45-a7b5-faec6044b5ee Ancestors: PreferenceBrowser-mt.52 Fixed height in search field. (Note: We have to refactor that code to tool builder...) ==================== Snapshot ==================== SystemOrganization addCategory: #PreferenceBrowser! (PackageInfo named: 'PreferenceBrowser') postscript: 'Preferences removePreference: #syntaxHighlightingAsYouType. Preferences removePreference: #syntaxHighlightingAsYouTypeLeftArrowAssignment. Preferences removePreference: #syntaxHighlightingAsYouTypeAnsiAssignment.'! SystemWindow subclass: #PreferenceBrowserMorph instanceVariableNames: 'mainPanel defaultButton saveButton loadButton saveToDiskButton loadFromDiskButton themeButton helpButton preferenceList lastKeystrokeTime lastKeystrokes highlightedPreferenceButton' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! ----- Method: PreferenceBrowserMorph class>>withModel: (in category 'instance creation') ----- withModel: aPreferenceBrowser ^self new initializeWithModel: aPreferenceBrowser; yourself.! ----- Method: PreferenceBrowserMorph>>adjustPreferenceListItemsWidth (in category 'updating') ----- adjustPreferenceListItemsWidth | panel | self preferenceList scroller submorphs ifEmpty: [^self]. panel := self preferenceListInnerPanel. panel width: self preferenceList width - (self preferenceList scrollBarThickness*2). panel submorphsDo: [:ea | ea hResizing: #rigid; width: panel width]. self preferenceList setScrollDeltas.! ----- Method: PreferenceBrowserMorph>>basicButton (in category 'submorphs - buttons') ----- basicButton | button | button := SimpleButtonMorph new. button borderWidth: 2; borderColor: #raised; on: #mouseEnter send: #value to: [button borderColor: self paneColor]; on: #mouseLeave send: #value to: [button borderColor: #raised]; vResizing: #spaceFill; useRoundedCorners; clipSubmorphs: true; color: self paneColor muchLighter; target: self model. ^button! ----- Method: PreferenceBrowserMorph>>basicKeyPressed: (in category 'event handling') ----- basicKeyPressed: anEvent | aChar oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionPref | aChar := anEvent keyCharacter. nextSelection := oldSelection := self selectedPreferenceIndex. max := self selectedCategoryPreferences size. milliSeconds := Time millisecondClockValue. milliSeconds - lastKeystrokeTime > 300 ifTrue: ["just use the one current character for selecting" lastKeystrokes := '']. lastKeystrokes := lastKeystrokes , aChar asLowercase asString. lastKeystrokeTime := milliSeconds. nextSelectionList := OrderedCollection newFrom: (self selectedCategoryPreferences copyFrom: oldSelection + 1 to: max). nextSelectionList addAll: (self selectedCategoryPreferences copyFrom: 1 to: oldSelection). "Get rid of blanks and style used in some lists" nextSelectionPref := nextSelectionList detect: [:a | a name withBlanksTrimmed asLowercase beginsWith: lastKeystrokes] ifNone: [^ self preferenceList flash"match not found"]. nextSelection := self selectedCategoryPreferences findFirst: [:a | a = nextSelectionPref]. "No change if model is locked" oldSelection == nextSelection ifTrue: [^ self preferenceList flash]. ^ self selectedPreferenceIndex: nextSelection! ----- Method: PreferenceBrowserMorph>>buttonRowLayoutFrame (in category 'submorphs - buttons') ----- buttonRowLayoutFrame ^LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@ (TextStyle defaultFont height * 2.5))! ----- Method: PreferenceBrowserMorph>>defaultButton (in category 'submorphs - buttons') ----- defaultButton ^defaultButton ifNil: [defaultButton := self basicButton label: 'default' translated; actionSelector: #defaultSelected; setBalloonText: 'Click here to reset all the preferences to their standard ', 'default values.' translated]! ----- Method: PreferenceBrowserMorph>>downKeyPressed: (in category 'event handling') ----- downKeyPressed: anEvent self selectedPreferenceIndex: (self selectedPreferenceIndex + 1 min: self selectedCategoryPreferences size)! ----- Method: PreferenceBrowserMorph>>endKeyPressed: (in category 'event handling') ----- endKeyPressed: anEvent self selectedPreferenceIndex: self selectedCategoryPreferences size. ! ----- Method: PreferenceBrowserMorph>>extent: (in category 'geometry') ----- extent: aPoint super extent: aPoint. self fullBounds. self adjustPreferenceListItemsWidth.! ----- Method: PreferenceBrowserMorph>>helpButton (in category 'submorphs - buttons') ----- helpButton ^helpButton ifNil: [helpButton := self basicButton label: 'help' translated; setBalloonText: 'Click here to get some hints on use of this Preferences ', 'Panel' translated; actionSelector: #helpSelected]! ----- Method: PreferenceBrowserMorph>>homeKeyPressed: (in category 'event handling') ----- homeKeyPressed: anEvent self selectedPreferenceIndex: 1. ! ----- Method: PreferenceBrowserMorph>>initializeWithModel: (in category 'initialization') ----- initializeWithModel: aPreferenceBrowser lastKeystrokeTime := 0. lastKeystrokes := ''. self model: aPreferenceBrowser; setLabel: self model windowTitle; name: 'PreferenceBrowser'; addMorph: self rootPanel fullFrame: self rootPanelLayoutFrame; addMorph: self newButtonRow fullFrame: self buttonRowLayoutFrame.! ----- Method: PreferenceBrowserMorph>>keyPressed: (in category 'event handling') ----- keyPressed: anEvent self selectedCategory ifNil: [^self]. anEvent keyValue = 30 ifTrue: [^self upKeyPressed: anEvent]. anEvent keyValue = 31 ifTrue: [^self downKeyPressed: anEvent]. anEvent keyValue = 1 ifTrue: [^self homeKeyPressed: anEvent]. anEvent keyValue = 4 ifTrue: [^self endKeyPressed: anEvent]. anEvent keyValue = 11 ifTrue: [^self pageUpKeyPressed: anEvent]. anEvent keyValue = 12 ifTrue: [^self pageDownKeyPressed: anEvent]. self basicKeyPressed: anEvent.! ----- Method: PreferenceBrowserMorph>>loadButton (in category 'submorphs - buttons') ----- loadButton ^loadButton ifNil: [loadButton := self basicButton label: 'load' translated; actionSelector: #loadSelected; setBalloonText: 'Click here to reset all the preferences to their values ', 'in your Personal Preferences.' translated]! ----- Method: PreferenceBrowserMorph>>loadFromDiskButton (in category 'submorphs - buttons') ----- loadFromDiskButton ^loadFromDiskButton ifNil: [loadFromDiskButton := self basicButton label: 'load from disk' translated; actionSelector: #loadFromDiskSelected; setBalloonText: 'Click here to load all the preferences from ', 'their saved values on disk.' translated]! ----- Method: PreferenceBrowserMorph>>mainPanel (in category 'submorphs - main panel') ----- mainPanel ^mainPanel ifNil: [mainPanel := BorderedMorph new color: Color transparent; borderWidth: 0; hResizing: #spaceFill; vResizing: #spaceFill; cellInset: 5; changeProportionalLayout; on: #mouseEnter send: #paneTransition: to: self; addMorphBack: self newCategoryList; addMorphBack: self preferenceList; layoutFrame: (LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@ 30 corner: 0@0)); addPaneSplitters; yourself].! ----- Method: PreferenceBrowserMorph>>mouseDownOn:event: (in category 'event handling') ----- mouseDownOn: aPreferenceView event: anEvent anEvent hand newKeyboardFocus: self preferenceList scroller. anEvent yellowButtonPressed ifTrue: [aPreferenceView offerPreferenceNameMenu: self model]! ----- Method: PreferenceBrowserMorph>>newButtonRow (in category 'submorphs - buttons') ----- newButtonRow ^BorderedMorph new color: Color transparent; borderWidth: 0; cellInset: 2; layoutInset: 2; layoutPolicy: TableLayout new; listDirection: #leftToRight; listCentering: #topLeft; cellPositioning: #topLeft; on: #mouseEnter send: #paneTransition: to: self; on: #mouseLeave send: #paneTransition: to: self; addMorphBack: self defaultButton; addMorphBack: self newSeparator; addMorphBack: self saveButton; addMorphBack: self loadButton; addMorphBack: self newSeparator; addMorphBack: self saveToDiskButton; addMorphBack: self loadFromDiskButton; addMorphBack: self newSeparator; addMorphBack: self themeButton; addMorphBack: self newTransparentFiller; addMorphBack: self helpButton; yourself.! ----- Method: PreferenceBrowserMorph>>newCategoryList (in category 'submorphs - category list') ----- newCategoryList ^(PluggableListMorph on: self model list: #categoryList selected: #selectedCategoryIndex changeSelected: #selectedCategoryIndex:) color: Color white; borderInset; hResizing: #spaceFill; vResizing: #spaceFill; layoutFrame: (LayoutFrame fractions: (0@0 corner: 0.25@1)); yourself.! ----- Method: PreferenceBrowserMorph>>newCategoryListPanel (in category 'submorphs - category list') ----- newCategoryListPanel ^Morph new hResizing: #shrinkWrap; vResizing: #spaceFill; color: Color transparent; layoutPolicy: TableLayout new; cellInset: 3; listCentering: #topLeft; listDirection: #topToBottom; cellPositioning: #topLeft; clipSubmorphs: true; addMorphBack: self newCategoryListPanelLabel; addMorphBack: self newCategoryList! ----- Method: PreferenceBrowserMorph>>newCategoryListPanelLabel (in category 'submorphs - category list') ----- newCategoryListPanelLabel ^StringMorph contents: 'Categories' translated.! ----- Method: PreferenceBrowserMorph>>newPreferenceButtonFor: (in category 'submorphs - preference list') ----- newPreferenceButtonFor: aPreference | button | button := PBPreferenceButtonMorph preference: aPreference model: self model. button on: #mouseDown send: #value: to: [:anEvent | self selectedPreference: aPreference; mouseDownOn: button preferenceView event: anEvent]. ^button! ----- Method: PreferenceBrowserMorph>>newPreferenceListInnerPanel (in category 'submorphs - preference list') ----- newPreferenceListInnerPanel | panel maxWidth totalHeight | panel := (Morph new) color: Color transparent; layoutPolicy: TableLayout new; listDirection: #topToBottom; cellPositioning: #topLeft; yourself. self selectedCategoryPreferences do: [:aPref | panel addMorphBack: (self newPreferenceButtonFor: aPref)]. panel submorphs size = 0 ifTrue: [^panel]. maxWidth := (panel submorphs detectMax: [:m | m width]) width. panel width: maxWidth. totalHeight := (panel submorphs collect: [:ea | ea height]) inject: 0 into: [:h :tot | h + tot]. panel height: totalHeight. panel fullBounds. ^panel! ----- Method: PreferenceBrowserMorph>>newPreferenceListPanel (in category 'submorphs - preference list') ----- newPreferenceListPanel | panel | panel := Morph new hResizing: #spaceFill; vResizing: #spaceFill; color: Color transparent; layoutPolicy: TableLayout new; cellInset: 3; listCentering: #topLeft; listDirection: #topToBottom; cellPositioning: #topLeft; clipSubmorphs: true; addMorphBack: self newPreferenceListPanelLabel; addMorphBack: self preferenceList. ^panel.! ----- Method: PreferenceBrowserMorph>>newPreferenceListPanelLabel (in category 'submorphs - preference list') ----- newPreferenceListPanelLabel ^StringMorph contents: 'Preferences' translated.! ----- Method: PreferenceBrowserMorph>>newSearchButton (in category 'submorphs - search panel') ----- newSearchButton ^self basicButton label: 'search' translated; actionSelector: #searchSelected; setBalloonText: 'Type what you want to search for here, then hit ', 'the "Search" button, or else hit RETURN or ENTER' translated.! ----- Method: PreferenceBrowserMorph>>newSearchPanel (in category 'submorphs - search panel') ----- newSearchPanel | bottom | bottom := Morph new color: Color transparent; cellInset: 5; layoutPolicy: TableLayout new; listDirection: #leftToRight; listCentering: #topLeft; cellPositioning: #topLeft; hResizing: #spaceFill; vResizing: #shrinkWrap; addMorphBack: self newSearchTextField yourself. ^Morph new color: Color transparent; layoutPolicy: TableLayout new; listDirection: #topToBottom; listCentering: #topLeft; cellPositioning: #topLeft; hResizing: #spaceFill; vResizing: #shrinkWrap; cellInset: 3; addMorphBack: (StringMorph contents: 'Search preferences for: '); addMorphBack: bottom; yourself.! ----- Method: PreferenceBrowserMorph>>newSearchTextField (in category 'submorphs - search panel') ----- newSearchTextField | ptm | ptm := PluggableTextMorphPlus on: self model text: #searchPatternNeverTriggered accept: #searchPattern:. ptm minimumHeight: 0; balloonText: 'Search preferences ...'; hideScrollBarsIndefinitely; layoutFrame: (LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@ (TextStyle default lineGrid * 2))); borderInset; color: Color white; vResizing: #spaceFill; hResizing: #spaceFill; acceptOnCR: true; onKeyStrokeSend: #value to: [ ptm hasUnacceptedEdits ifTrue: [ ptm accept ] ]. ^ptm.! ----- Method: PreferenceBrowserMorph>>newSeparator (in category 'submorphs - buttons') ----- newSeparator ^BorderedMorph new borderWidth: 2; borderColor: Color transparent; color: self paneColor; hResizing: #rigid; width: 5; vResizing: #spaceFill; yourself! ----- Method: PreferenceBrowserMorph>>newTransparentFiller (in category 'submorphs - buttons') ----- newTransparentFiller ^Morph new color: Color transparent; vResizing: #spaceFill; hResizing: #spaceFill; yourself.! ----- Method: PreferenceBrowserMorph>>pageDownKeyPressed: (in category 'event handling') ----- pageDownKeyPressed: anEvent self selectedPreferenceIndex: (self selectedPreferenceIndex + self preferencesShowing size min: self selectedCategoryPreferences size). ! ----- Method: PreferenceBrowserMorph>>pageUpKeyPressed: (in category 'event handling') ----- pageUpKeyPressed: anEvent self selectedPreferenceIndex: (self selectedPreferenceIndex - self preferencesShowing size max: 1). ! ----- Method: PreferenceBrowserMorph>>preferenceList (in category 'submorphs - preference list') ----- preferenceList ^preferenceList ifNil: [preferenceList := ScrollPane new color: Color white; borderInset; vResizing: #spaceFill; hResizing: #spaceFill; layoutFrame: (LayoutFrame fractions: (0.25@0 corner: 1@1)). preferenceList scroller on: #mouseEnter send: #value: to: [:event | event hand newKeyboardFocus: preferenceList scroller]; on: #keyStroke send: #keyPressed: to: self. preferenceList.]! ----- Method: PreferenceBrowserMorph>>preferenceListInnerPanel (in category 'submorphs - preference list') ----- preferenceListInnerPanel ^self preferenceList scroller submorphs first! ----- Method: PreferenceBrowserMorph>>preferencesShowing (in category 'submorphs - preference list') ----- preferencesShowing | prefs | prefs := self preferenceListInnerPanel submorphs copyFrom: (self selectedPreferenceIndex max: 1) to: self selectedCategoryPreferences size. ^prefs reject: [:ea | (ea top - prefs first top) > self preferenceList scroller height].! ----- Method: PreferenceBrowserMorph>>rootPanel (in category 'submorphs - root panel') ----- rootPanel ^BorderedMorph new color: Color transparent; borderWidth: 0; changeProportionalLayout; addMorphBack: self newSearchTextField; addMorphBack: self mainPanel; yourself.! ----- Method: PreferenceBrowserMorph>>rootPanelLayoutFrame (in category 'submorphs - root panel') ----- rootPanelLayoutFrame | frame | frame := self buttonRowLayoutFrame. ^LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@(frame bottomOffset) corner: 0@0)! ----- Method: PreferenceBrowserMorph>>saveButton (in category 'submorphs - buttons') ----- saveButton ^saveButton ifNil: [saveButton := self basicButton label: 'save' translated; actionSelector: #saveSelected; setBalloonText: 'Click here to save the current constellation of Preferences ', 'settings as your personal defaults; you can get them all ', 'reinstalled with a single gesture by clicking the "Restore ', 'my Personal Preferences".' translated]! ----- Method: PreferenceBrowserMorph>>saveToDiskButton (in category 'submorphs - buttons') ----- saveToDiskButton ^saveToDiskButton ifNil: [saveToDiskButton := self basicButton label: 'save to disk' translated; actionSelector: #saveToDiskSelected; setBalloonText: 'Click here to save the current constellation of Preferences ', 'settings to a file; you can get them all reinstalled with a ', 'single gesture by clicking "Restore Settings From Disk".' translated]! ----- Method: PreferenceBrowserMorph>>selectedCategory (in category 'model access') ----- selectedCategory ^self model selectedCategory! ----- Method: PreferenceBrowserMorph>>selectedCategoryIndex (in category 'model access') ----- selectedCategoryIndex ^self model selectedCategoryIndex! ----- Method: PreferenceBrowserMorph>>selectedCategoryIndex: (in category 'model access') ----- selectedCategoryIndex: anIndex ^self model selectedCategoryIndex: anIndex! ----- Method: PreferenceBrowserMorph>>selectedCategoryPreferences (in category 'model access') ----- selectedCategoryPreferences ^self model selectedCategoryPreferences! ----- Method: PreferenceBrowserMorph>>selectedPreference (in category 'model access') ----- selectedPreference ^self model selectedPreference! ----- Method: PreferenceBrowserMorph>>selectedPreference: (in category 'model access') ----- selectedPreference: aPreference ^self model selectedPreference: aPreference! ----- Method: PreferenceBrowserMorph>>selectedPreferenceButton (in category 'submorphs - preference list') ----- selectedPreferenceButton ^(self preferenceListInnerPanel submorphs at: self selectedPreferenceIndex)! ----- Method: PreferenceBrowserMorph>>selectedPreferenceIndex (in category 'model access') ----- selectedPreferenceIndex ^self model selectedPreferenceIndex! ----- Method: PreferenceBrowserMorph>>selectedPreferenceIndex: (in category 'model access') ----- selectedPreferenceIndex: anIndex ^self model selectedPreferenceIndex: anIndex! ----- Method: PreferenceBrowserMorph>>themeButton (in category 'submorphs - buttons') ----- themeButton ^themeButton ifNil: [themeButton := self basicButton label: 'theme...' translated; actionSelector: #themeSelected; setBalloonText: 'Numerous "Preferences" govern many things about the ', 'way Squeak looks and behaves. Set individual preferences ', 'using a "Preferences" panel. Set an entire "theme" of many ', 'Preferences all at the same time by pressing this "change ', 'theme" button and choosing a theme to install. Look in ', 'category "themes" in Preferences class to see what each ', 'theme does; add your own methods to the "themes" ', 'category and they will show up in the list of theme ', 'choices.' translated].! ----- Method: PreferenceBrowserMorph>>turnOffSelectedPreference (in category 'submorphs - preference list') ----- turnOffSelectedPreference highlightedPreferenceButton ifNil: [^self]. highlightedPreferenceButton highlightOff. highlightedPreferenceButton := nil.! ----- Method: PreferenceBrowserMorph>>turnOnSelectedPreference (in category 'submorphs - preference list') ----- turnOnSelectedPreference highlightedPreferenceButton ifNotNil: [:m | m highlightOff]. highlightedPreferenceButton := self selectedPreferenceButton highlightOn; yourself. self preferenceList scrollToShow: highlightedPreferenceButton bounds.! ----- Method: PreferenceBrowserMorph>>upKeyPressed: (in category 'event handling') ----- upKeyPressed: anEvent self selectedPreferenceIndex: (self selectedPreferenceIndex - 1 max: 1). ! ----- Method: PreferenceBrowserMorph>>update: (in category 'updating') ----- update: aSymbol super update: aSymbol. aSymbol == #selectedPreference ifTrue: [self updateSelectedPreference]. aSymbol == #selectedCategoryIndex ifTrue: [self updateSelectedCategoryPreferences].! ----- Method: PreferenceBrowserMorph>>updateSelectedCategoryPreferences (in category 'updating') ----- updateSelectedCategoryPreferences Cursor wait showWhile: [self preferenceList hScrollBarValue: 0; vScrollBarValue: 0. self preferenceList scroller removeAllMorphs. self preferenceList scroller addMorphBack: self newPreferenceListInnerPanel. self adjustPreferenceListItemsWidth]! ----- Method: PreferenceBrowserMorph>>updateSelectedPreference (in category 'updating') ----- updateSelectedPreference | index | self selectedCategory ifNotNil: [self turnOffSelectedPreference]. index := self selectedPreferenceIndex. index = 0 ifTrue: [^self]. self turnOnSelectedPreference.! ----- Method: Preferences class>>addPreference:categories:default:balloonHelp:projectLocal:changeInformee:changeSelector:viewRegistry: (in category '*PreferenceBrowser') ----- addPreference: aName categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector viewRegistry: aViewRegistry "For compatibility with the old set of protocols" ^self addPreference: aName categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector type: (PreferenceViewRegistry typeOfRegistry: aViewRegistry).! Morph subclass: #PBPreferenceButtonMorph instanceVariableNames: 'moreButton model preference preferenceMorphicView preferenceView' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! ----- Method: PBPreferenceButtonMorph class>>preference: (in category 'instance creation') ----- preference: aPreference ^self preference: aPreference model: nil! ----- Method: PBPreferenceButtonMorph class>>preference:model: (in category 'instance creation') ----- preference: aPreference model: aModel ^self new initializeWithPreference: aPreference model: aModel; yourself.! ----- Method: PBPreferenceButtonMorph>>actionButtons (in category 'extra controls') ----- actionButtons ^self preferenceView actions collect: [:aTuple | self basicButton label: aTuple first; target: aTuple second; actionSelector: aTuple third; arguments: aTuple fourth; setBalloonText: aTuple fifth ]! ----- Method: PBPreferenceButtonMorph>>addExtraControls (in category 'extra controls') ----- addExtraControls | m | m := self horizontalPanel cellInset: 3; addAllMorphs: self actionButtons; addMorphBack: self horizontalFiller; addMorphBack: self moreButton; yourself. self addMorphBack: (self blankSpaceOf: 2@2); addMorphBack: self preferenceHelpTextMorph; fullBounds; "to force a layout compute needed by the textMorphs's autoFit" addMorphBack: m ! ----- Method: PBPreferenceButtonMorph>>advancedOptionsSelected (in category 'extra controls') ----- advancedOptionsSelected self preferenceView offerPreferenceNameMenu: self model! ----- Method: PBPreferenceButtonMorph>>basicButton (in category 'utility methods') ----- basicButton | button | button := SimpleButtonMorph new. button borderWidth: 1; borderColor: self paneColor; on: #mouseEnter send: #value to: [button borderWidth: 2]; on: #mouseLeave send: #value to: [button borderWidth: 1]; vResizing: #rigid; height: (TextStyle defaultFont height + 4); useSquareCorners; clipSubmorphs: true; color: self paneColor muchLighter; target: self. ^button! ----- Method: PBPreferenceButtonMorph>>basicPanel (in category 'utility methods') ----- basicPanel ^BorderedMorph new beTransparent; extent: 0@0; borderWidth: 0; layoutInset: 0; cellInset: 0; layoutPolicy: TableLayout new; listCentering: #topLeft; cellPositioning: #center; hResizing: #spaceFill; vResizing: #shrinkWrap; yourself! ----- Method: PBPreferenceButtonMorph>>blankSpaceOf: (in category 'utility methods') ----- blankSpaceOf: aPoint ^Morph new beTransparent; extent: aPoint; yourself! ----- Method: PBPreferenceButtonMorph>>caseInsensitiveBeginsWith:in: (in category 'utility methods') ----- caseInsensitiveBeginsWith: prefix in: string ^(string findString: prefix startingAt: 1 caseSensitive: false) = 1! ----- Method: PBPreferenceButtonMorph>>highlightOff (in category 'highlighting') ----- highlightOff self beTransparent. self label color: Color black. self removeExtraControls.! ----- Method: PBPreferenceButtonMorph>>highlightOn (in category 'highlighting') ----- highlightOn self color: (Color gray alpha: 0.1). self addExtraControls.! ----- Method: PBPreferenceButtonMorph>>horizontalFiller (in category 'utility methods') ----- horizontalFiller ^self horizontalPanel hResizing: #spaceFill; yourself.! ----- Method: PBPreferenceButtonMorph>>horizontalPanel (in category 'utility methods') ----- horizontalPanel ^self basicPanel cellPositioning: #center; listDirection: #leftToRight; yourself.! ----- Method: PBPreferenceButtonMorph>>initializeLayout (in category 'initialization') ----- initializeLayout self layoutPolicy: TableLayout new; beTransparent; layoutInset: 0; cellInset: 0; listCentering: #topLeft; cellPositioning: #topLeft; listDirection: #topToBottom; hResizing: #spaceFill; vResizing: #shrinkWrap. ! ----- Method: PBPreferenceButtonMorph>>initializeWithPreference:model: (in category 'initialization') ----- initializeWithPreference: aPreference model: aModel preference := aPreference. model := aModel. self initializeLayout. self addMorphBack: self preferenceMorphicView. self highlightOff.! ----- Method: PBPreferenceButtonMorph>>label (in category 'preference accessing') ----- label ^self preferenceMorphicView firstSubmorph! ----- Method: PBPreferenceButtonMorph>>model (in category 'accessing') ----- model ^model! ----- Method: PBPreferenceButtonMorph>>moreButton (in category 'extra controls') ----- moreButton ^moreButton ifNil: [moreButton := self basicButton label: 'more' translated; setBalloonText: 'Click here for advanced options'translated; actionSelector: #advancedOptionsSelected]! ----- Method: PBPreferenceButtonMorph>>paneColor (in category 'utility methods') ----- paneColor | browser | browser := (self ownerChain detect: [:ea | ea isKindOf: PreferenceBrowserMorph] ifNone: [^Color black]) . ^browser paneColor! ----- Method: PBPreferenceButtonMorph>>preference (in category 'preference accessing') ----- preference ^preference! ----- Method: PBPreferenceButtonMorph>>preferenceHelp (in category 'preference accessing') ----- preferenceHelp | help name | help := self preference helpString withBlanksTrimmed. name := self preference name. (self caseInsensitiveBeginsWith: name in: help) ifTrue: [help := help allButFirst: name size]. (help notEmpty and: [help first = $:]) ifTrue: [help := help allButFirst]. ^help withBlanksTrimmed. ! ----- Method: PBPreferenceButtonMorph>>preferenceHelpText (in category 'preference accessing') ----- preferenceHelpText ^self preferenceHelp asText addAttribute: TextEmphasis italic; yourself.! ----- Method: PBPreferenceButtonMorph>>preferenceHelpTextMorph (in category 'extra controls') ----- preferenceHelpTextMorph | text tm | text := self preferenceHelpText. tm := TextMorph new contents: text; wrapOnOff; hResizing: #spaceFill; vResizing: #shrinkWrap; lock: true; visible: text notEmpty; yourself. "we don't want an empty textmorph showing" tm isAutoFit ifFalse: [tm autoFitOnOff]. ^tm.! ----- Method: PBPreferenceButtonMorph>>preferenceMorphicView (in category 'preference accessing') ----- preferenceMorphicView ^preferenceMorphicView ifNil: [preferenceMorphicView := self preferenceView representativeButtonWithColor: Color transparent inPanel: self model. preferenceMorphicView hResizing: #spaceFill. ^preferenceMorphicView]! ----- Method: PBPreferenceButtonMorph>>preferenceView (in category 'preference accessing') ----- preferenceView ^preferenceView ifNil: [preferenceView := self preference viewForPanel: self model.]! ----- Method: PBPreferenceButtonMorph>>removeExtraControls (in category 'extra controls') ----- removeExtraControls self submorphs copyWithoutFirst do: [:ea | ea delete]! ----- Method: PBPreferenceButtonMorph>>verticalPanel (in category 'utility methods') ----- verticalPanel ^self basicPanel cellPositioning: #topLeft; listDirection: #topToBottom; yourself.! Model subclass: #PreferenceBrowser instanceVariableNames: 'selectedCategoryIndex selectedPreference searchPattern searchResults lastExecutedSearch preferences title' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! ----- Method: PreferenceBrowser class>>initialize (in category 'class initialization') ----- initialize self registerWindowColor; registerInOpenMenu; registerInFlaps! ----- Method: PreferenceBrowser class>>open (in category 'instance creation') ----- open | browser | browser := self new. (PreferenceBrowserMorph withModel: browser) openInWorld. ^browser. ! ----- Method: PreferenceBrowser class>>prototypicalToolWindow (in category 'instance creation') ----- prototypicalToolWindow | window | window := PreferenceBrowserMorph withModel: self new. window applyModelExtent. ^window! ----- Method: PreferenceBrowser class>>registerInFlaps (in category 'class initialization') ----- registerInFlaps Flaps registerQuad: { #PreferenceBrowser. #prototypicalToolWindow. 'Preference Browser' translated. 'A tool for expressing personal preferences for numerous options' translated } forFlapNamed: 'Tools' translated. Flaps replaceToolsFlap! ----- Method: PreferenceBrowser class>>registerInOpenMenu (in category 'class initialization') ----- registerInOpenMenu (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [ TheWorldMenu unregisterOpenCommand: 'Preference Browser'. TheWorldMenu registerOpenCommand: {'Preference Browser'. {self. #open}}]. ! ----- Method: PreferenceBrowser class>>registerWindowColor (in category 'class initialization') ----- registerWindowColor (Preferences windowColorFor: self name) = Color white ifTrue: [ Preferences setWindowColorFor: self name to: (Color colorFrom: self windowColorSpecification brightColor) ].! ----- Method: PreferenceBrowser class>>unload (in category 'class initialization') ----- unload self unregisterFromOpenMenu; unregisterFromFlaps.! ----- Method: PreferenceBrowser class>>unregisterFromFlaps (in category 'class initialization') ----- unregisterFromFlaps Flaps unregisterQuadsWithReceiver: self; replaceToolsFlap! ----- Method: PreferenceBrowser class>>unregisterFromOpenMenu (in category 'class initialization') ----- unregisterFromOpenMenu (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [TheWorldMenu unregisterOpenCommand: 'Preference Browser']. ! ----- Method: PreferenceBrowser class>>windowColorSpecification (in category 'window color') ----- windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Preference Browser' brightColor: #(0.645 1.0 1.0) pastelColor: #(0.886 1.0 1.0) helpMessage: 'A tool for expressing personal preferences for numerous options.'! ----- Method: PreferenceBrowser>>allCategoryLabel (in category 'user interface') ----- allCategoryLabel ^'-- all --' translated! ----- Method: PreferenceBrowser>>allCategorySelected (in category 'accessing') ----- allCategorySelected ^self selectedCategory = self allCategoryLabel! ----- Method: PreferenceBrowser>>allPreferences (in category 'accessing') ----- allPreferences ^ preferences allPreferenceObjects asSortedCollection: [:pref1 :pref2 | pref1 viewRegistry viewOrder <pref2 viewRegistry viewOrder or: [pref1 viewRegistry viewOrder =pref2 viewRegistry viewOrder &(pref1 name <pref2 name)]]! ----- Method: PreferenceBrowser>>categoryList (in category 'accessing') ----- categoryList ^OrderedCollection new add: self allCategoryLabel; addAll: preferences categoryNames asSortedCollection; add: self searchResultsCategoryLabel; yourself. ! ----- Method: PreferenceBrowser>>defaultSelected (in category 'preferences search') ----- defaultSelected Preferences chooseInitialSettings! ----- Method: PreferenceBrowser>>findCategoryFromPreference: (in category 'find') ----- findCategoryFromPreference: prefSymbol "Find all categories in which the preference occurs" | aMenu| aMenu := MenuMorph new defaultTarget: self. (preferences categoriesContainingPreference: prefSymbol) do: [:aCategory | aMenu add: aCategory target: self selector: #selectedCategory: argument: aCategory]. aMenu popUpInWorld! ----- Method: PreferenceBrowser>>helpSelected (in category 'preferences search') ----- helpSelected "Open up a workspace with explanatory info in it about the Preference Browser" Workspace new contents: self helpText; openLabel: self windowTitle.! ----- Method: PreferenceBrowser>>helpText (in category 'preferences search') ----- helpText ^(String streamContents: [:str | str nextPutAll: 'Many aspects of the system are goberned by the settings of various ''Preferences''. Click on any of the categories shown at the left list to see all the preferences in that category. Or type into the search box at the bottom of the window, then hit Search, and all Preferences matching whatever you typed in will appear in the ''search results'' category. A preference is considered to match your search if either its name matches the text *or* if anything in the preference''s help text does. To find out more about any particular Preference just select it and its help text will appear. Some preferences can be ''local'' instead of global. When a preference is set as global its value will apply to whatever project you are in. A local preference will only be valid in the project that you set it in. The ''Save'' button allow you to quickly save your current settings so it can later be restored with the ''Load'' button. To carry your settings to another Squeak you might want to use the ''Save to disk'' and ''Load from disk'' buttons. The save to disk option will store all your settings in a ''my.prefs'' file in your Squeak''s current directory. Lastly, you can use the "theme..." button to set multiple preferences all at once; click on the "theme..." button and try the themes already provided with your Squeak image.']) translated! ----- Method: PreferenceBrowser>>initialExtent (in category 'user interface') ----- initialExtent ^ 660@440! ----- Method: PreferenceBrowser>>initialize (in category 'initialize-release') ----- initialize preferences := Preferences. title := 'Preference Browser'.! ----- Method: PreferenceBrowser>>lastExecutedSearch (in category 'accessing') ----- lastExecutedSearch ^lastExecutedSearch! ----- Method: PreferenceBrowser>>lastExecutedSearch: (in category 'accessing') ----- lastExecutedSearch: aTextOrString ^lastExecutedSearch:= aTextOrString! ----- Method: PreferenceBrowser>>loadFromDiskSelected (in category 'preferences search') ----- loadFromDiskSelected preferences restorePreferencesFromDisk! ----- Method: PreferenceBrowser>>loadSelected (in category 'preferences search') ----- loadSelected preferences restorePersonalPreferences ! ----- Method: PreferenceBrowser>>nonSpecialCategorySelected (in category 'accessing') ----- nonSpecialCategorySelected ^self allCategorySelected not & self searchResultsCategorySelected not! ----- Method: PreferenceBrowser>>preferences (in category 'accessing') ----- preferences ^ preferences! ----- Method: PreferenceBrowser>>preferencesInCategory: (in category 'accessing') ----- preferencesInCategory: aCategory ^(preferences preferenceObjectsInCategory: aCategory) asSortedCollection: [:pref1 :pref2 | pref1 viewRegistry viewOrder <pref2 viewRegistry viewOrder or: [pref1 viewRegistry viewOrder =pref2 viewRegistry viewOrder &(pref1 name <pref2 name)]]! ----- Method: PreferenceBrowser>>representsSameBrowseeAs: (in category 'user interface') ----- representsSameBrowseeAs: anotherModel "If an existing Preference browser is on-screen, use it." ^ self class = anotherModel class! ----- Method: PreferenceBrowser>>saveSelected (in category 'preferences search') ----- saveSelected preferences savePersonalPreferences ! ----- Method: PreferenceBrowser>>saveToDiskSelected (in category 'preferences search') ----- saveToDiskSelected preferences storePreferencesToDisk! ----- Method: PreferenceBrowser>>searchFieldLegend (in category 'accessing') ----- searchFieldLegend ^''.! ----- Method: PreferenceBrowser>>searchPattern (in category 'accessing') ----- searchPattern ^searchPattern ifNil: [searchPattern := self searchFieldLegend]! ----- Method: PreferenceBrowser>>searchPattern: (in category 'accessing') ----- searchPattern: aStringOrText aStringOrText ifEmpty: [searchPattern := self searchFieldLegend] ifNotEmpty: [searchPattern := aStringOrText asString]. self changed: #searchPattern. ^true! ----- Method: PreferenceBrowser>>searchPatternNeverTriggered (in category 'accessing') ----- searchPatternNeverTriggered ^self searchPattern! ----- Method: PreferenceBrowser>>searchPreferencesFor: (in category 'preferences search') ----- searchPreferencesFor: pattern | result | result := pattern asString asLowercase withBlanksTrimmed. result ifEmpty: [^self]. searchResults := self allPreferences select: [:aPreference | (aPreference name includesSubstring: result caseSensitive: false) or: [aPreference helpString includesSubstring: result caseSensitive: false]]. self selectSearchResultsCategory. self lastExecutedSearch: pattern. ! ----- Method: PreferenceBrowser>>searchResults (in category 'accessing') ----- searchResults ^searchResults ifNil: [searchResults := #()]! ----- Method: PreferenceBrowser>>searchResultsCategoryLabel (in category 'user interface') ----- searchResultsCategoryLabel ^'-- search results --' translated! ----- Method: PreferenceBrowser>>searchResultsCategorySelected (in category 'accessing') ----- searchResultsCategorySelected ^self selectedCategory = self searchResultsCategoryLabel! ----- Method: PreferenceBrowser>>searchSelected (in category 'buttons callbacks') ----- searchSelected self searchPreferencesFor: self searchPattern.! ----- Method: PreferenceBrowser>>selectFirstPreferenceOrNil (in category 'accessing') ----- selectFirstPreferenceOrNil | prefs | self selectedCategory ifNil: [^self selectedPreference: nil]. prefs := self preferencesInCategory: self selectedCategory. prefs isEmpty ifTrue: [^self selectedPreference: nil]. self selectedPreference: prefs first.! ----- Method: PreferenceBrowser>>selectSearchResultsCategory (in category 'accessing') ----- selectSearchResultsCategory self selectedCategoryIndex: (self categoryList indexOf: self searchResultsCategoryLabel)! ----- Method: PreferenceBrowser>>selectedCategory (in category 'accessing') ----- selectedCategory ^self categoryList at: selectedCategoryIndex ifAbsent: []! ----- Method: PreferenceBrowser>>selectedCategory: (in category 'accessing') ----- selectedCategory: aCategorySymbol self selectedCategoryIndex: (self categoryList indexOf: aCategorySymbol ifAbsent: [0]).! ----- Method: PreferenceBrowser>>selectedCategoryIndex (in category 'accessing') ----- selectedCategoryIndex ^selectedCategoryIndex ifNil: [selectedCategoryIndex := 0].! ----- Method: PreferenceBrowser>>selectedCategoryIndex: (in category 'accessing') ----- selectedCategoryIndex: anIndex anIndex = 0 ifTrue: [^self]. self selectedPreference: nil. selectedCategoryIndex := anIndex. self changed: #selectedCategoryIndex.! ----- Method: PreferenceBrowser>>selectedCategoryPreferences (in category 'accessing') ----- selectedCategoryPreferences self allCategorySelected ifTrue: [^self allPreferences]. self searchResultsCategorySelected ifTrue: [^self searchResults]. ^self preferencesInCategory: self selectedCategory. ! ----- Method: PreferenceBrowser>>selectedPreference (in category 'accessing') ----- selectedPreference ^selectedPreference! ----- Method: PreferenceBrowser>>selectedPreference: (in category 'accessing') ----- selectedPreference: aPreference selectedPreference := aPreference. self changed: #selectedPreference. self changed: #selectedPreferenceIndex. self changed: #selectedPreferenceHelpText.! ----- Method: PreferenceBrowser>>selectedPreferenceHelpText (in category 'accessing') ----- selectedPreferenceHelpText self selectedPreference ifNil: [^'']. ^self selectedPreference helpString withBlanksTrimmed.! ----- Method: PreferenceBrowser>>selectedPreferenceIndex (in category 'accessing') ----- selectedPreferenceIndex ^self selectedCategoryPreferences indexOf: self selectedPreference ifAbsent: [0]! ----- Method: PreferenceBrowser>>selectedPreferenceIndex: (in category 'accessing') ----- selectedPreferenceIndex: anIndex anIndex = 0 ifTrue: [^self]. self selectedPreference: (self selectedCategoryPreferences at: anIndex).! ----- Method: PreferenceBrowser>>stepAt:in: (in category 'stepping') ----- stepAt: millisecondClockValue in: aWindow super stepAt: millisecondClockValue in: aWindow. self searchPattern ~= self lastExecutedSearch ifTrue: [self searchPreferencesFor: self searchPattern].! ----- Method: PreferenceBrowser>>themeSelected (in category 'preferences search') ----- themeSelected preferences offerThemesMenu! ----- Method: PreferenceBrowser>>wantsStepsIn: (in category 'stepping') ----- wantsStepsIn: aWindow ^true.! ----- Method: PreferenceBrowser>>windowTitle (in category 'user interface') ----- windowTitle ^ title translated! ----- Method: Preference>>representativeButtonWithColor:inPanel: (in category '*PreferenceBrowser') ----- representativeButtonWithColor: aColor inPanel: aPanel | view | view := self viewForPanel: aPanel. ^view ifNotNil: [view representativeButtonWithColor: aColor inPanel: aPanel]! ----- Method: Preference>>selectors (in category '*PreferenceBrowser') ----- selectors "for browsing senders" ^{name}! ----- Method: Preference>>viewClassForPanel: (in category '*PreferenceBrowser') ----- viewClassForPanel: aPreferencePanel ^self viewRegistry viewClassFor: aPreferencePanel! ----- Method: Preference>>viewForPanel: (in category '*PreferenceBrowser') ----- viewForPanel: aPreferencePanel | viewClass | viewClass := self viewClassForPanel: aPreferencePanel. ^viewClass ifNotNil: [viewClass preference: self]! ----- Method: Preference>>viewRegistry (in category '*PreferenceBrowser') ----- viewRegistry ^PreferenceViewRegistry forType: self type! Object subclass: #PreferenceView instanceVariableNames: 'preference' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! PreferenceView class instanceVariableNames: 'registeredClasses'! !PreferenceView commentStamp: '<historical>' prior: 0! My subclasses instances are responsible for building the visual representation of each kind of preference.! PreferenceView class instanceVariableNames: 'registeredClasses'! PreferenceView subclass: #PBPreferenceView instanceVariableNames: 'actions' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! !PBPreferenceView commentStamp: '<historical>' prior: 0! I am just a refactor of all the common method of the PreferenceBrowser preference views! PBPreferenceView subclass: #PBBooleanPreferenceView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! !PBBooleanPreferenceView commentStamp: '<historical>' prior: 0! I am responsible for building the visual representation of a preference that accepts true and false values. This view is aimed to be used inside a PreferenceBrowser panel.! ----- Method: PBBooleanPreferenceView class>>initialize (in category 'class initialization') ----- initialize PreferenceViewRegistry ofBooleanPreferences register: self. ! ----- Method: PBBooleanPreferenceView class>>unload (in category 'class initialization') ----- unload "Unload order is not guaranteed so guard against failure" [PreferenceViewRegistry ofBooleanPreferences unregister: self] on: Error do:[].! ----- Method: PBBooleanPreferenceView>>enabledButton (in category 'user interface') ----- enabledButton | aButton aLabel | aButton := UpdatingThreePhaseButtonMorph checkBox target: self preference; actionSelector: #togglePreferenceValue; getSelector: #preferenceValue; yourself. aLabel := (StringMorph contents: 'enabled' translated font: (StrikeFont familyName: TextStyle defaultFont familyName size: TextStyle defaultFont pointSize - 1)). ^self horizontalPanel addMorphBack: aButton; addMorphBack: aLabel; yourself.! ----- Method: PBBooleanPreferenceView>>localToProjectButton (in category 'user interface') ----- localToProjectButton | aButton aLabel | aButton := UpdatingThreePhaseButtonMorph checkBox target: self preference; actionSelector: #toggleProjectLocalness; getSelector: #localToProject; yourself. aLabel := (StringMorph contents: 'local' translated font: (StrikeFont familyName: TextStyle defaultFont familyName size: TextStyle defaultFont pointSize - 1)). ^self horizontalPanel addMorphBack: aButton; addMorphBack: aLabel; yourself.! ----- Method: PBBooleanPreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') ----- representativeButtonWithColor: aColor inPanel: aPreferencesPanel ^self horizontalPanel layoutInset: 2; cellInset: 7; color: aColor; addMorphBack: (StringMorph contents: self preference name); addMorphBack: self horizontalFiller; addMorphBack: self enabledButton; addMorphBack: self localToProjectButton; yourself.! PBPreferenceView subclass: #PBHaloThemePreferenceView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! !PBHaloThemePreferenceView commentStamp: '<historical>' prior: 0! I am responsible for building the button for the Halo Theme preference! ----- Method: PBHaloThemePreferenceView class>>initialize (in category 'class initialization') ----- initialize PreferenceViewRegistry ofHaloThemePreferences register: self.! ----- Method: PBHaloThemePreferenceView class>>unload (in category 'class initialization') ----- unload "Unload order is not guaranteed so guard against failure" [PreferenceViewRegistry ofHaloThemePreferences unregister: self] on: Error do:[]! ----- Method: PBHaloThemePreferenceView>>haloThemeRadioButtons (in category 'user interface') ----- haloThemeRadioButtons "Answer a column of butons representing the choices of halo theme" | buttonColumn | buttonColumn := self verticalPanel. #( (iconicHaloSpecifications iconic iconicHalosInForce 'circular halos with icons inside') (classicHaloSpecs classic classicHalosInForce 'plain circular halos') (simpleFullHaloSpecifications simple simpleHalosInForce 'fewer, larger halos') (customHaloSpecs custom customHalosInForce 'customizable halos')) do: [:quad | | aRow aRadioButton aLabel | aRadioButton := UpdatingThreePhaseButtonMorph radioButton target: Preferences; setBalloonText: quad fourth; actionSelector: #installHaloTheme:; getSelector: quad third; arguments: (Array with: quad first); yourself. aLabel := (StringMorph contents: quad second asString) setBalloonText: quad fourth; yourself. aRow := self horizontalPanel cellInset: 4; addMorphBack: aRadioButton; addMorphBack: aLabel. buttonColumn addMorphBack: aRow]. ^ buttonColumn "(Preferences preferenceAt: #haloTheme) view tearOffButton"! ----- Method: PBHaloThemePreferenceView>>initialize (in category 'initialization') ----- initialize self addActionTitled: 'edit custom halos' target: Preferences selector: #editCustomHalos arguments: {} balloonText: 'Click here to edit the method that defines the custom halos' translated.! ----- Method: PBHaloThemePreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') ----- representativeButtonWithColor: aColor inPanel: aPreferencesPanel | innerPanel | innerPanel := self horizontalPanel addMorphBack: (self blankSpaceOf: 10@0); addMorphBack: self haloThemeRadioButtons; yourself. ^self verticalPanel color: aColor; layoutInset: 2; addMorphBack: (StringMorph contents: self preference name); addMorphBack: innerPanel.! PBPreferenceView subclass: #PBNumericPreferenceView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! ----- Method: PBNumericPreferenceView class>>initialize (in category 'class initialization') ----- initialize PreferenceViewRegistry ofNumericPreferences register: self.! ----- Method: PBNumericPreferenceView class>>unload (in category 'class initialization') ----- unload "Unload order is not guaranteed so guard against failure" [PreferenceViewRegistry ofNumericPreferences unregister: self] on: Error do:[].! ----- Method: PBNumericPreferenceView>>preferenceValue (in category 'user interface') ----- preferenceValue ^self preference preferenceValue asString! ----- Method: PBNumericPreferenceView>>preferenceValue: (in category 'user interface') ----- preferenceValue: aTextOrString (aTextOrString notEmpty and: [aTextOrString asString isAllDigits]) ifFalse: [^false]. self preference preferenceValue: aTextOrString asNumber. ^true.! ----- Method: PBNumericPreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') ----- representativeButtonWithColor: aColor inPanel: aPreferenceBrowser ^self horizontalPanel layoutInset: 2; color: aColor; cellInset: 20; cellPositioning: #center; addMorphBack: (StringMorph contents: self preference name); addMorphBack: self textField; yourself.! ----- Method: PBNumericPreferenceView>>textField (in category 'user interface') ----- textField ^(PluggableTextMorph on: self text: #preferenceValue accept: #preferenceValue:) hideScrollBarsIndefinitely; borderColor: #inset; acceptOnCR: true; color: Color gray veryMuchLighter; vResizing: #rigid; hResizing: #spaceFill; height: TextStyle defaultFont height + 6; yourself.! ----- Method: PBPreferenceView class>>handlesPanel: (in category 'view registry') ----- handlesPanel: aPreferencePanel ^aPreferencePanel isKindOf: PreferenceBrowser! ----- Method: PBPreferenceView>>actions (in category 'actions') ----- actions ^actions ifNil: [actions := OrderedCollection new.]! ----- Method: PBPreferenceView>>addActionTitled:target:selector:arguments:balloonText: (in category 'actions') ----- addActionTitled: aTitle target: aTarget selector: aSelector arguments: aCollection balloonText: aText self actions add: { aTitle. aTarget. aSelector. aCollection. aText }! ----- Method: PBPreferenceView>>basicPanel (in category 'user interface') ----- basicPanel ^BorderedMorph new beTransparent; extent: 0@0; borderWidth: 0; layoutInset: 0; cellInset: 2; layoutPolicy: TableLayout new; listCentering: #topLeft; cellPositioning: #center; hResizing: #shrinkWrap; vResizing: #shrinkWrap; yourself! ----- Method: PBPreferenceView>>blankSpaceOf: (in category 'user interface') ----- blankSpaceOf: aPoint ^Morph new beTransparent; extent: aPoint; yourself! ----- Method: PBPreferenceView>>horizontalFiller (in category 'user interface') ----- horizontalFiller ^self horizontalPanel hResizing: #spaceFill; yourself.! ----- Method: PBPreferenceView>>horizontalPanel (in category 'user interface') ----- horizontalPanel ^self basicPanel cellPositioning: #center; listDirection: #leftToRight; yourself.! ----- Method: PBPreferenceView>>offerPreferenceNameMenu: (in category 'user interface') ----- offerPreferenceNameMenu: aPreferenceBrowser "the user clicked on a preference name -- put up a menu" | aMenu | aMenu := MenuMorph new defaultTarget: self preference; addTitle: self preference name. (Preferences okayToChangeProjectLocalnessOf: self preference name) ifTrue: [aMenu addUpdating: #isProjectLocalString target: self preference action: #toggleProjectLocalness. aMenu balloonTextForLastItem: 'Some preferences are best applied uniformly to all projects, and others are best set by each individual project. If this item is checked, then this preference will be printed in bold and will have a separate value for each project']. aMenu add: 'browse senders' translated target: self systemNavigation selector: #browseAllSelect:name:autoSelect: argumentList: {[:m | self preference selectors anySatisfy: [:sel | m hasLiteralThorough: sel]]. 'Preference senders: {1}' translated format: {self preference name}. self preference selectors first}. aMenu balloonTextForLastItem: 'This will open a method-list browser on all methods that the send the preference "', self preference name, '".'. aMenu add: 'show category...' target: aPreferenceBrowser selector: #findCategoryFromPreference: argument: self preference name. aMenu balloonTextForLastItem: 'Allows you to find out which category, or categories, this preference belongs to.'. Smalltalk isMorphic ifTrue: [aMenu add: 'hand me a button for this preference' target: self selector: #tearOffButton. aMenu balloonTextForLastItem: 'Will give you a button that governs this preference, which you may deposit wherever you wish']. aMenu add: 'copy this name to clipboard' target: self preference selector: #copyName. aMenu balloonTextForLastItem: 'Copy the name of the preference to the text clipboard, so that you can paste into code somewhere'. aMenu popUpInWorld! ----- Method: PBPreferenceView>>verticalPanel (in category 'user interface') ----- verticalPanel ^self basicPanel cellPositioning: #topLeft; listDirection: #topToBottom; yourself.! PBPreferenceView subclass: #PBTextPreferenceView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! ----- Method: PBTextPreferenceView class>>initialize (in category 'class initialization') ----- initialize PreferenceViewRegistry ofTextPreferences register: self.! ----- Method: PBTextPreferenceView class>>unload (in category 'class initialization') ----- unload "Unload order is not guaranteed so guard against failure" [PreferenceViewRegistry ofTextPreferences unregister: self] on: Error do:[]! ----- Method: PBTextPreferenceView>>preferenceValue (in category 'user interface') ----- preferenceValue ^self preference preferenceValue ifNil: ['']! ----- Method: PBTextPreferenceView>>preferenceValue: (in category 'user interface') ----- preferenceValue: aTextOrString self preference preferenceValue: aTextOrString asString. ^true.! ----- Method: PBTextPreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') ----- representativeButtonWithColor: aColor inPanel: aPreferenceBrowser ^self horizontalPanel layoutInset: 2; color: aColor; cellInset: 20; cellPositioning: #center; addMorphBack: (StringMorph contents: self preference name); addMorphBack: self textField; yourself.! ----- Method: PBTextPreferenceView>>textField (in category 'user interface') ----- textField ^(PluggableTextMorph on: self text: #preferenceValue accept: #preferenceValue:) hideScrollBarsIndefinitely; borderColor: #inset; acceptOnCR: true; color: Color gray veryMuchLighter; vResizing: #rigid; hResizing: #spaceFill; height: TextStyle defaultFont height + 6; yourself.! ----- Method: PreferenceView class>>handlesPanel: (in category 'view registry') ----- handlesPanel: aPreferencePanel self subclassResponsibility ! ----- Method: PreferenceView class>>preference: (in category 'instance creation') ----- preference: aPreference ^self new initializeWithPreference: aPreference; yourself! ----- Method: PreferenceView>>initializeWithPreference: (in category 'initialization') ----- initializeWithPreference: aPreference preference := aPreference! ----- Method: PreferenceView>>preference (in category 'accessing') ----- preference ^preference! ----- Method: PreferenceView>>representativeButtonWithColor:inPanel: (in category 'user interface') ----- representativeButtonWithColor: aColor inPanel: aPreferencesPanel self subclassResponsibility ! ----- Method: PreferenceView>>tearOffButton (in category 'user interface') ----- tearOffButton "Hand the user a button the can control this" | aButton | aButton := self representativeButtonWithColor: self preference defaultBackgroundColor inPanel: nil. aButton borderWidth: 1; borderColor: Color black; useRoundedCorners. aButton openInHand! Object subclass: #PreferenceViewRegistry instanceVariableNames: 'registeredClasses viewOrder' classVariableNames: '' poolDictionaries: '' category: 'PreferenceBrowser'! PreferenceViewRegistry class instanceVariableNames: 'registries'! !PreferenceViewRegistry commentStamp: '<historical>' prior: 0! PreferenceViewRegistry is much like the AppRegistry classes. Its purpose is to allow PreferenceBrowser implementers to register its own views for each kind of preference.! PreferenceViewRegistry class instanceVariableNames: 'registries'! ----- Method: PreferenceViewRegistry class>>forType: (in category 'accessing') ----- forType: typeName "Answer the preference registry for the given type name" ^typeName caseOf:{ [#Boolean] -> [self ofBooleanPreferences]. [#Color] -> [self ofColorPreferences]. [#Font] -> [self ofFontPreferences]. [#Number] -> [self ofNumericPreferences]. [#String] -> [self ofTextPreferences]. [#Halo] -> [self ofHaloThemePreferences]. [#WindowColor] -> [self registryOf: #windowColorPreferences] } otherwise:[self registryOf: typeName].! ----- Method: PreferenceViewRegistry class>>initialize (in category 'class initialization') ----- initialize "Ensure we aren't carrying obsolete references" self removeObsolete.! ----- Method: PreferenceViewRegistry class>>ofBooleanPreferences (in category 'instance creation') ----- ofBooleanPreferences ^(self registryOf: #booleanPreferences) viewOrder: 1; yourself.! ----- Method: PreferenceViewRegistry class>>ofColorPreferences (in category 'instance creation') ----- ofColorPreferences ^(self registryOf: #colorPreferences) viewOrder: 5; yourself.! ----- Method: PreferenceViewRegistry class>>ofFontPreferences (in category 'instance creation') ----- ofFontPreferences ^(self registryOf: #fontPreferences) viewOrder: 4; yourself.! ----- Method: PreferenceViewRegistry class>>ofHaloThemePreferences (in category 'instance creation') ----- ofHaloThemePreferences ^(self registryOf: #haloThemePreferences) viewOrder: 2; yourself.! ----- Method: PreferenceViewRegistry class>>ofNumericPreferences (in category 'instance creation') ----- ofNumericPreferences ^(self registryOf: #numericPreferences) viewOrder: 3; yourself.! ----- Method: PreferenceViewRegistry class>>ofTextPreferences (in category 'instance creation') ----- ofTextPreferences ^(self registryOf: #textPreferences) viewOrder: 3; yourself.! ----- Method: PreferenceViewRegistry class>>registries (in category 'instance creation') ----- registries ^registries ifNil: [registries := Dictionary new]! ----- Method: PreferenceViewRegistry class>>registryOf: (in category 'instance creation') ----- registryOf: aSymbol ^self registries at: aSymbol ifAbsentPut: [self new]! ----- Method: PreferenceViewRegistry class>>removeObsolete (in category 'class initialization') ----- removeObsolete "PreferenceViewRegistry removeObsolete" "Remove obsolete entries from the registries" self registries do:[:viewRegistry| viewRegistry registeredClasses copy do:[:rClass| rClass isObsolete ifTrue:[viewRegistry unregister: rClass]]].! ----- Method: PreferenceViewRegistry class>>typeOfRegistry: (in category 'accessing') ----- typeOfRegistry: aRegistry "Answer the type name for a particular view registry" ^aRegistry caseOf:{ [self ofBooleanPreferences] -> [#Boolean]. [self ofColorPreferences] -> [#Color]. [self ofFontPreferences] -> [#Font]. [self ofNumericPreferences] -> [#Number]. [self ofTextPreferences] -> [#String]. [self ofHaloThemePreferences] -> [#Halo]. [self registryOf: #windowColorPreferences] -> [#WindowColor]. } otherwise:[self registries keyAtIdentityValue: aRegistry ifAbsent:[nil]].! ----- Method: PreferenceViewRegistry>>initialize (in category 'initialize-release') ----- initialize viewOrder := 1.! ----- Method: PreferenceViewRegistry>>register: (in category 'view registry') ----- register: aProviderClass (self registeredClasses includes: aProviderClass) ifFalse: [self registeredClasses add: aProviderClass].! ----- Method: PreferenceViewRegistry>>registeredClasses (in category 'view registry') ----- registeredClasses ^registeredClasses ifNil: [registeredClasses := OrderedCollection new]! ----- Method: PreferenceViewRegistry>>unregister: (in category 'view registry') ----- unregister: aProviderClass self registeredClasses remove: aProviderClass ifAbsent: []! ----- Method: PreferenceViewRegistry>>viewClassFor: (in category 'view registry') ----- viewClassFor: aPreferencePanel ^self registeredClasses detect: [:aViewClass| aViewClass handlesPanel: aPreferencePanel] ifNone: [].! ----- Method: PreferenceViewRegistry>>viewOrder (in category 'view order') ----- viewOrder "answer the order in which the registered views should appear relative to the other views" ^viewOrder! ----- Method: PreferenceViewRegistry>>viewOrder: (in category 'view order') ----- viewOrder: aNumber viewOrder := aNumber! ----- Method: PragmaPreference>>selectors (in category '*PreferenceBrowser') ----- selectors "for browsing senders" ^ {getter. setter}!

1 0

build.squeak.org down
by Chris Muller 05 Jun '15

05 Jun '15

Service Temporarily Unavailable

1 0

Squeak 4.6: 39Deprecated-ar.19.mcz
by commits＠source.squeak.org 05 Jun '15

05 Jun '15

Chris Muller uploaded a new version of 39Deprecated to project Squeak 4.6: http://source.squeak.org/squeak46/39Deprecated-ar.19.mcz ==================== Summary ==================== Name: 39Deprecated-ar.19 Author: ar Time: 5 March 2010, 9:44:11.754 pm UUID: 8da20c38-7d28-3241-9f29-da261d6f9bfe Ancestors: 39Deprecated-dtl.18 Clean up after Smalltalk/SystemDictionary refactoring. ==================== Snapshot ==================== ----- Method: ContextPart>>methodSelector (in category '*39Deprecated') ----- methodSelector "Answer the selector of the method that created the receiver." self deprecated: 'use #selector'. ^self selector. ! ----- Method: SharedQueue2>>flush (in category '*39Deprecated') ----- flush self deprecated: 'use removeAll'. ^self removeAll! ----- Method: SharedQueue2>>flushAllSuchThat: (in category '*39Deprecated') ----- flushAllSuchThat: aBlock self deprecated: 'use removeAllSuchThat:'. ^self removeAllSuchThat: aBlock!

1 0

Jump to page: