Frank Shearar uploaded a new version of Tests to project The Trunk:
http://source.squeak.org/trunk/Tests-fbs.254.mcz==================== Summary ====================
Name: Tests-fbs.254
Author: fbs
Time: 24 September 2013, 10:20:04.736 pm
UUID: a3fc070d-993c-4b4a-ba6e-55916e3aa234
Ancestors: Tests-nice.253
Tests (gasp!) for RecentMessages. Note the hopefully novel use of an Environment as a sandbox.
=============== Diff against Tests-nice.253 ===============
Item was added:
+ Object subclass: #FakeObjectOut
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Tests-System-Support'!
+
+ !FakeObjectOut commentStamp: 'fbs 9/2/2013 11:08' prior: 0!
+ RecentMessagesTest uses me to show how it behaves when recent submissions contain references to methods in classes no longer in the image.!
Item was added:
+ ----- Method: FakeObjectOut>>doesNotUnderstand: (in category 'as yet unclassified') -----
+ doesNotUnderstand: aMessage
+ ^ aMessage sendTo: self class !
Item was added:
+ ----- Method: FakeObjectOut>>isInMemory (in category 'as yet unclassified') -----
+ isInMemory
+ ^ false.!
Item was added:
+ TestCase subclass: #RecentMessagesTest
+ instanceVariableNames: 'rm env'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Tests-System-Support'!
Item was added:
+ ----- Method: RecentMessagesTest>>createClass: (in category 'private') -----
+ createClass: aSymbol
+ | builder |
+ builder := ClassBuilder new.
+ builder
+ name: aSymbol
+ inEnvironment: env
+ subclassOf: Object
+ type: #normal
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Test'.
+ ^ env at: aSymbol.!
Item was added:
+ ----- Method: RecentMessagesTest>>setUp (in category 'running') -----
+ setUp
+ rm := RecentMessages new.
+ env := Environment withName: 'EnvironmentForRecentMessagesTest'.
+ env at: #FakeObjectOut put: FakeObjectOut new.!
Item was added:
+ ----- Method: RecentMessagesTest>>testIsEmpty (in category 'testing') -----
+ testIsEmpty
+ self assert: rm isEmpty description: 'Initially, must be empty'.
+ rm recordSelector: #foo forClass: Utilities inEnvironment: Smalltalk globals.
+ self deny: rm isEmpty description: 'After submission, must not be empty'.!
Item was added:
+ ----- Method: RecentMessagesTest>>testMaximumSubmissionCountCanReduceNumberOfReferences (in category 'testing') -----
+ testMaximumSubmissionCountCanReduceNumberOfReferences
+ rm maximumSubmissionCount: 2.
+ rm recordSelector: #foo forClass: Utilities inEnvironment: Smalltalk globals.
+ rm recordSelector: #bar forClass: Utilities inEnvironment: Smalltalk globals.
+ rm maximumSubmissionCount: 1.
+ self assert: 1 equals: rm size.!
Item was added:
+ ----- Method: RecentMessagesTest>>testMaximumSubmissionCountCapsReferenceCount (in category 'testing') -----
+ testMaximumSubmissionCountCapsReferenceCount
+ rm maximumSubmissionCount: 2.
+ rm recordSelector: #foo forClass: Utilities inEnvironment: Smalltalk globals.
+ rm recordSelector: #bar forClass: Utilities inEnvironment: Smalltalk globals.
+ rm recordSelector: #baz forClass: Utilities inEnvironment: Smalltalk globals.
+ self assert: #bar equals: rm oldest selector.!
Item was added:
+ ----- Method: RecentMessagesTest>>testMaximumSubmissionCountDefaultsToTen (in category 'testing') -----
+ testMaximumSubmissionCountDefaultsToTen
+ self assert: 10 equals: rm maximumSubmissionCount.!
Item was added:
+ ----- Method: RecentMessagesTest>>testMaximumSubmissionCountReturnsMaximumNumberOfRecordedMethodSubmissions (in category 'testing') -----
+ testMaximumSubmissionCountReturnsMaximumNumberOfRecordedMethodSubmissions
+ rm maximumSubmissionCount: 0.
+ self assert: 0 equals: rm maximumSubmissionCount.
+ rm maximumSubmissionCount: 1.
+ self assert: 1 equals: rm maximumSubmissionCount.!
Item was added:
+ ----- Method: RecentMessagesTest>>testMethodReferencesReturnsAllSubmissions (in category 'testing') -----
+ testMethodReferencesReturnsAllSubmissions
+ | expected |
+ expected := {
+ MethodReference class: Utilities selector: #foo environment: env.
+ MethodReference class: Utilities selector: #bar environment: env}.
+ rm recordSelector: #foo forClass: Utilities inEnvironment: env.
+ rm recordSelector: #bar forClass: Utilities inEnvironment: env.
+ self assert: expected equals: rm methodReferences.!
Item was added:
+ ----- Method: RecentMessagesTest>>testMethodReferencesReturnsaCopy (in category 'testing') -----
+ testMethodReferencesReturnsaCopy
+ | expected original |
+ rm recordSelector: #foo forClass: Utilities inEnvironment: env.
+ original := rm methodReferences.
+ expected := original copy.
+ rm recordSelector: #bar forClass: Utilities inEnvironment: env.
+ self assert: expected equals: original.!
Item was added:
+ ----- Method: RecentMessagesTest>>testMostRecentReturnsLastAddedReference (in category 'testing') -----
+ testMostRecentReturnsLastAddedReference
+ | victim |
+ victim := self createClass: #Victim.
+ victim compile: 'foo ^ 1'.
+ victim compile: 'bar ^ 1'.
+ rm recordSelector: #foo forClass: victim inEnvironment: env.
+ self assert: #foo equals: rm mostRecent selector.
+ rm recordSelector: #bar forClass: victim inEnvironment: env.
+ self assert: #bar equals: rm mostRecent selector.!
Item was added:
+ ----- Method: RecentMessagesTest>>testMostRecentReturnsLastExtantReference (in category 'testing') -----
+ testMostRecentReturnsLastExtantReference
+ | victim |
+ victim := self createClass: #Victim.
+ victim compile: 'foo ^ 1'.
+ victim compile: 'bar ^ 1'.
+ rm recordSelector: #foo forClass: victim inEnvironment: env.
+ rm recordSelector: #bar forClass: victim inEnvironment: env.
+ victim removeSelector: #bar.
+ self assert: #foo equals: rm mostRecent selector.!
Item was added:
+ ----- Method: RecentMessagesTest>>testOldestReturnsOldestSubmission (in category 'testing') -----
+ testOldestReturnsOldestSubmission
+ self assert: nil equals: rm oldest description: 'Return nil if no submissions yet'.
+ rm recordSelector: #foo forClass: Utilities inEnvironment: Smalltalk globals.
+ self assert: #foo equals: rm oldest selector.
+ rm recordSelector: #baz forClass: Utilities inEnvironment: Smalltalk globals.
+ self assert: #foo equals: rm oldest selector.!
Item was added:
+ ----- Method: RecentMessagesTest>>testPurgeMissingMethods (in category 'testing') -----
+ testPurgeMissingMethods
+ rm recordSelector: #utilitiesDoesNotKnowThisSelector forClass: Utilities inEnvironment: Smalltalk globals.
+ rm recordSelector: #utilitiesDoesNotKnowThisSelectorEither forClass: Utilities inEnvironment: Smalltalk globals.
+ rm purgeMissingMethods.
+ self assert: 0 equals: rm size.!
Item was added:
+ ----- Method: RecentMessagesTest>>testPurgeMissingMethodsKeepsComments (in category 'testing') -----
+ testPurgeMissingMethodsKeepsComments
+ rm recordSelector: #Comment forClass: Utilities inEnvironment: Smalltalk globals.
+ self deny: rm isEmpty.!
Item was added:
+ ----- Method: RecentMessagesTest>>testPurgeMissingMethodsRemovesSubmissionsForMissingClasses (in category 'testing') -----
+ testPurgeMissingMethodsRemovesSubmissionsForMissingClasses
+ | missingClass |
+ missingClass := FakeObjectOut new.
+ rm recordSelector: #Comment forClass: missingClass inEnvironment: env.
+ rm recordSelector: #foo forClass: missingClass inEnvironment: env.
+ rm purgeMissingMethods.
+ self assert: rm isEmpty.!
Item was added:
+ ----- Method: RecentMessagesTest>>testPurgeRemovesReferences (in category 'testing') -----
+ testPurgeRemovesReferences
+ | ref |
+ rm recordSelector: #foo forClass: Utilities inEnvironment: Smalltalk globals.
+ ref := MethodReference class: Utilities selector: #foo environment: Smalltalk globals.
+ rm purge: ref.
+ self assert: 0 equals: rm size.!
Item was added:
+ ----- Method: RecentMessagesTest>>testRecordSelectorForClassInEnvironmentAlwaysReturnsMethodReference (in category 'testing') -----
+ testRecordSelectorForClassInEnvironmentAlwaysReturnsMethodReference
+ | r |
+ WantsChangeSetLogging no.
+ r := rm recordSelector: #foo forClass: WantsChangeSetLogging inEnvironment: Smalltalk globals.
+ self assert: MethodReference equals: r class description: 'Even when not logging, always return a MethodReference'.!
Item was added:
+ ----- Method: RecentMessagesTest>>testRecordSelectorForClassInEnvironmentReturnsMethodReference (in category 'testing') -----
+ testRecordSelectorForClassInEnvironmentReturnsMethodReference
+ | r sel class env |
+ sel := #foo.
+ class := self class.
+ env := self class environment.
+ r := rm recordSelector: sel forClass: class inEnvironment: env.
+ self assert: sel equals: r selector.
+ self assert: class equals: r actualClass.
+ self assert: env equals: r environment.
+
+ self assert: r equals: (rm recordSelector: sel forClass: class inEnvironment: env).!
Item was added:
+ ----- Method: RecentMessagesTest>>testReferencesAreUnique (in category 'testing') -----
+ testReferencesAreUnique
+ rm recordSelector: #foo forClass: Utilities inEnvironment: Smalltalk globals.
+ rm recordSelector: #foo forClass: Utilities inEnvironment: Smalltalk globals.
+ self assert: 1 equals: rm size description: 'After duplicate'.!
Item was added:
+ ----- Method: RecentMessagesTest>>testRevertLastRemovesLatestVersion (in category 'testing') -----
+ testRevertLastRemovesLatestVersion
+ | victim |
+ victim := self createClass: #Victim.
+ victim compile: 'foo ^ 1'.
+ victim compile: 'foo ^ 2'.
+ rm recordSelector: #foo forClass: victim inEnvironment: env.
+ rm revertLast.
+ self assert: 1 equals: victim new foo description: 'Version not removed'.!
Item was added:
+ ----- Method: RecentMessagesTest>>testRevertLastRemovesNewMethod (in category 'testing') -----
+ testRevertLastRemovesNewMethod
+ | victim |
+ victim := self createClass: #Victim.
+ victim compile: 'foo ^ 1'.
+ rm recordSelector: #foo forClass: victim inEnvironment: env.
+ rm revertLast.
+ self deny: (victim includesSelector: #foo) description: 'Method not removed'.!
Item was added:
+ ----- Method: RecentMessagesTest>>testSizeReturnsNumberOfRecordedMethodSubmissions (in category 'testing') -----
+ testSizeReturnsNumberOfRecordedMethodSubmissions
+ self assert: 0 equals: rm size description: 'Initial state'.
+ rm recordSelector: #foo forClass: Utilities inEnvironment: Smalltalk globals.
+ self assert: 1 equals: rm size description: 'After 1 submission'.
+ rm recordSelector: #bar forClass: Utilities inEnvironment: Smalltalk globals.
+ self assert: 2 equals: rm size description: 'After 2 submissions'.!
Item was added:
+ ----- Method: RecentMessagesTest>>testSubmissionClassControlsLogging (in category 'testing') -----
+ testSubmissionClassControlsLogging
+ WantsChangeSetLogging yes.
+ rm recordSelector: #foo forClass: WantsChangeSetLogging inEnvironment: Smalltalk globals.
+ WantsChangeSetLogging no.
+ rm recordSelector: #bar forClass: WantsChangeSetLogging inEnvironment: Smalltalk globals.
+ self assert: 1 equals: rm size description: 'Class asked for logging not to happen'.!
Item was added:
+ Object subclass: #WantsChangeSetLogging
+ instanceVariableNames: ''
+ classVariableNames: 'WantsChangeSetLoggingFlag'
+ poolDictionaries: ''
+ category: 'Tests-System-Support'!
+
+ !WantsChangeSetLogging commentStamp: 'fbs 9/2/2013 11:08' prior: 0!
+ RecentMessagesTest uses me to show how it behaves when classes don't want to log to a change set.!
Item was added:
+ ----- Method: WantsChangeSetLogging class>>no (in category 'instance creation') -----
+ no
+ WantsChangeSetLoggingFlag := false.!
Item was added:
+ ----- Method: WantsChangeSetLogging class>>wantsChangeSetLogging (in category 'compiling') -----
+ wantsChangeSetLogging
+ ^ WantsChangeSetLoggingFlag.!
Item was added:
+ ----- Method: WantsChangeSetLogging class>>yes (in category 'instance creation') -----
+ yes
+ WantsChangeSetLoggingFlag := true.!
Locked
SqueakDebug.log (14K)