Fix #1279: double triggering of tab change event from sliding card tray

Core/Object Arts/Dolphin/MVP/Tests/Dolphin MVP Tests.pax

@@ -740,13 +740,6 @@ UI.Tests.PresenterTest
 	imports: #()
 	classInstanceVariableNames: ''
 	classConstants: {}!
-UI.Tests.PresenterTest
-	subclass: #'UI.Tests.SlideyInneyOuteyThingTest'
-	instanceVariableNames: ''
-	classVariableNames: ''
-	imports: #()
-	classInstanceVariableNames: ''
-	classConstants: {}!
 UI.Tests.PresenterTest
 	subclass: #'UI.Tests.SpinButtonTest'
 	instanceVariableNames: ''
@@ -901,6 +894,13 @@ UI.Tests.SelectableItemsTest
 	imports: #()
 	classInstanceVariableNames: ''
 	classConstants: {}!
+UI.Tests.SelectableItemsTest
+	subclass: #'UI.Tests.SlideyInneyOuteyThingTest'
+	instanceVariableNames: 'allowCardChange'
+	classVariableNames: ''
+	imports: #()
+	classInstanceVariableNames: ''
+	classConstants: {}!
 UI.Tests.SelectableListItemsTest
 	subclass: #'UI.Tests.AbstractTabViewTest'
 	instanceVariableNames: ''

Core/Object Arts/Dolphin/MVP/Tests/UI.Tests.AbstractTabViewTest.cls

@@ -13,28 +13,45 @@ UI.Tests.AbstractTabViewTest comment: ''!
 !UI.Tests.AbstractTabViewTest methodsFor!
 
 addTestTabs
-	| objects |
-	objects := self objectsToTest.
-	presenter parentView extent: 500 @ 100.
-	presenter viewMode: #smallIcons.
 	presenter model
 		removeAll;
-		addAll: objects!
+		addAll: self objectsToTest!
 
 autoSelectsFirst
 	^true!
 
+initializePresenter
+	super initializePresenter.
+	presenter parentView extent: 500 @ 100.
+	presenter viewMode: #smallIcons.
+	"For the non-inherited tests, add some example tabs"
+	((self class lookupMethod: self selector) methodClass includesBehavior: AbstractTabViewTest)
+		ifTrue: [self addTestTabs]!
+
 removingResetsSelection
 	^false!
 
+testSelectionChangeDenied
+	| mouseClick event |
+	presenter selectionByIndex: 1.
+	self observeSelectionEvents.
+	selectionChanging := 
+			[:selectionChange |
+			self assert: selectionChange oldSelections equals: {self objectsToTest first}.
+			events add: selectionChange.
+			selectionChange value: false].
+	mouseClick := self mouseDownEventOnItem: 2 buttons: { #left }.
+	self sendClickEvent: mouseClick.
+	self assert: presenter selectionsByIndex equals: #(1).
+	event := events single.
+	self assert: event isKindOf: SelectionChangingEvent!
+
 testSelectionsPreservedOnRecreate
-	self addTestTabs.
 	presenter selectionByIndex: 2.
 	presenter recreate.
 	self assert: presenter selectionsByIndex equals: #(2)!
 
 testSetTextImageDoesNotAffectSelection
-	self addTestTabs.
 	presenter selectionByIndex: 2.
 	self
 		shouldnt: [presenter view getImageBlock: [:each | each icon imageIndex + 1]]
@@ -56,7 +73,9 @@ verifyUpgradedView: anInteger identifier: aResourceIdentifier
 !UI.Tests.AbstractTabViewTest categoriesForMethods!
 addTestTabs!helpers!private! !
 autoSelectsFirst!private!testing! !
+initializePresenter!public!Running! !
 removingResetsSelection!public!testing! !
+testSelectionChangeDenied!public!unit tests! !
 testSelectionsPreservedOnRecreate!public!unit tests! !
 testSetTextImageDoesNotAffectSelection!public!unit tests! !
 verifyUpgradedView:identifier:!helpers!private! !

Core/Object Arts/Dolphin/MVP/Tests/UI.Tests.SelectableItemsTest.cls

@@ -44,21 +44,21 @@ mouseDownEventAt: position buttons: anArray
 	mouseButton := mouseButton anyOne.
 	keys := (anArray collect: [:each | MouseEvent wParamFlags at: each]) fold: [:a :b | a bitOr: b].
 	^MouseEvent
-		window: presenter
+		window: self selectionView
 		message: (##(IdentityDictionary
 				withAll: {#left -> WM_LBUTTONDOWN. #right -> WM_RBUTTONDOWN. #middle -> WM_MBUTTONDOWN})
 					at: mouseButton)
 		wParam: keys
 		lParam: position asUInt32!
 
 mouseDownEventOn: anObject buttons: anArray
-	^self mouseDownEventOnItem: (presenter view handleFromObject: anObject) buttons: anArray!
+	^self mouseDownEventOnItem: (self selectionView handleFromObject: anObject) buttons: anArray!
 
 mouseDownEventOnItem: itemHandle buttons: anArray
 	| position |
 	position := itemHandle isNull
-				ifTrue: [presenter view clientRectangle corner - 1]
-				ifFalse: [(presenter view itemRect: itemHandle) origin + 1].
+				ifTrue: [self selectionView clientRectangle corner - 1]
+				ifFalse: [(self selectionView itemRect: itemHandle) origin + 1].
 	^self mouseDownEventAt: position buttons: anArray!
 
 mouseUpForMouseDown: aMouseEvent
@@ -98,16 +98,21 @@ onTimerTick: wParam
 			presenter postMessage: wParam + 1 wParam: 0 lParam: 0]!
 
 postMouseEvents: aSequencedReadableCollection
+	| view |
 	self assert: aSequencedReadableCollection first isButtonDown.
 	"Clear the message queue"
 	SessionManager inputState pumpMessages.
+	view := self selectionView.
 	aSequencedReadableCollection do: 
 			[:each |
-			presenter view
+			view
 				postMessage: each message
 				wParam: each wParam
 				lParam: each lParam]!
 
+selectionView
+	^presenter view!
+
 sendClickEvent: aMouseEvent
 	| pos |
 	"The mouse needs to be outside any Dolphin window in order to cause the control's WM_?BUTTONDOWN handler to block in the way described in #898"
@@ -168,6 +173,7 @@ onSelectionChanged!event handling!private! !
 onSelectionChanging:!event handling!private! !
 onTimerTick:!event handling!private! !
 postMouseEvents:!helpers!private! !
+selectionView!accessing!private! !
 sendClickEvent:!helpers!private! !
 sendMouseEvents:!helpers!private! !
 setupClickTimeout!helpers!private! !

Core/Object Arts/Dolphin/MVP/Tests/UI.Tests.SlideyInneyOuteyThingTest.cls

@@ -1,8 +1,8 @@
 "Filed out from Dolphin Smalltalk"!
 
-UI.Tests.PresenterTest
+UI.Tests.SelectableItemsTest
 	subclass: #'UI.Tests.SlideyInneyOuteyThingTest'
-	instanceVariableNames: ''
+	instanceVariableNames: 'allowCardChange'
 	classVariableNames: ''
 	imports: #()
 	classInstanceVariableNames: ''
@@ -14,6 +14,70 @@ UI.Tests.SlideyInneyOuteyThingTest comment: ''!
 classToTest
 	^SlideyInneyOuteyThing!
 
+initializePresenter
+	super initializePresenter.
+	presenter animationDuration: 0 milliseconds.
+	#(#red #green #blue) do: 
+			[:each |
+			| child |
+			child := ColorView new.
+			child model value: (Color perform: each).
+			presenter tray addSubView: child.
+			child arrangement: each capitalized].
+	allowCardChange := true!
+
+objectsToTest
+	^{5. 0. '&Hello && Welcome'. #(1 2 3). 0 @ 0}!
+
+onCardChangedFrom: oldCard to: newCard
+	events addLast: ((SelectionChangedEvent forSource: presenter tray)
+				oldSelection: oldCard;
+				newSelection: newCard;
+				yourself)!
+
+onCardChanging: aSelectionChangingEvent
+	events add: aSelectionChangingEvent.
+	aSelectionChangingEvent value: allowCardChange!
+
+selectionView
+	^presenter tabs!
+
+testCardChange
+	"Verify that preventing the card change works, and that multiple events are not sent."
+
+	| mouseClick event |
+	"Programmatic selection change will not trigger the changing event - the change cannot be prevented"
+	events := OrderedCollection new.
+	presenter tray
+		when: #currentCardChanging:
+			send: #onCardChanging:
+			to: self;
+		when: #currentCardChangedFrom:to:
+			send: #onCardChangedFrom:to:
+			to: self.
+	presenter tabs selectionByIndex: 1.
+	self assert: events size equals: 1.
+	event := events single.
+	self assert: event isKindOf: SelectionChangeEvent.
+	self assert: event oldSelection value equals: Color blue.
+	self assert: event newSelection value equals: Color red.
+	"Change selection by mouse click"
+	events := OrderedCollection new.
+	mouseClick := self mouseDownEventOnItem: 2 buttons: { #left }.
+	self sendClickEvent: mouseClick.
+	self assert: presenter tabs selectionsByIndex equals: #(2).
+	self assert: events size equals: 2.
+	event := events first.
+	self assert: event isKindOf: SelectionChangingEvent.
+	self assert: event oldSelections equals: { 'Red' }.
+	"Block selection change by mouse click"
+	events := OrderedCollection new.
+	allowCardChange := false.
+	mouseClick := self mouseDownEventOnItem: 3 buttons: { #left }.
+	self sendClickEvent: mouseClick.
+	self assert: presenter tabs selectionsByIndex equals: #(2).
+	self assert: events size equals: 1!
+
 verifyUpgradedView: anInteger identifier: aResourceIdentifier
 	| view |
 	super verifyUpgradedView: anInteger identifier: aResourceIdentifier.
@@ -27,6 +91,12 @@ verifyUpgradedView: anInteger identifier: aResourceIdentifier
 	self assert: view inheritContextMenu! !
 !UI.Tests.SlideyInneyOuteyThingTest categoriesForMethods!
 classToTest!helpers!private! !
+initializePresenter!public!Running! !
+objectsToTest!helpers!private! !
+onCardChangedFrom:to:!event handling!private! !
+onCardChanging:!event handling!private! !
+selectionView!accessing!private! !
+testCardChange!public!unit tests! !
 verifyUpgradedView:identifier:!helpers!private! !
 !
 

Core/Object Arts/Dolphin/MVP/Tests/UI.Tests.TabViewXPTest.cls

@@ -19,7 +19,6 @@ testLabelWithAmpersand
 	We have to use a bit of sleight of hand to test this, as the public effect is purely visual. Luckily the underlying API is able to modify the drawn text in place with any ellipsis that it adds. We can exploit this capability to capture the actual text it decides to draw."
 
 	| rect anon canvas actual expected extent text |
-	self addTestTabs.
 	rect := presenter itemRect: 3.
 	text := self objectsToTest at: 3.
 	"About time we did a port of MethodWrappers really"

Core/Object Arts/Dolphin/MVP/Views/Cards/UI.CardContainer.cls

@@ -237,10 +237,10 @@ onTabChanged
 	focus and a key is typed."
 	self hasFocusDeeply ifTrue: [self tabOntoCurrentCard]!
 
-onTabChanging: booleanValue
+onTabChanging: aSelectionChangingEvent
 	"Private - A tab has been selected by the user."
 
-	self trigger: #currentCardChanging: with: booleanValue!
+	self trigger: #currentCardChanging: with: aSelectionChangingEvent!
 
 onViewCreated
 	super onViewCreated.

Core/Object Arts/Dolphin/MVP/Views/Sliding Tray/Dolphin Slidey-Inney-Outey Thing.pax

@@ -38,17 +38,19 @@ UI.CapturingInteractor
 UI.ContainerView
 	subclass: #'UI.SlideyInneyOuteyThing'
 	instanceVariableNames: 'tabs tray trayExtent animationDuration tickCounter siotFlags _siotReserved1 _siotReserved2'
-	classVariableNames: 'AnimationDuration SlideInDelay'
+	classVariableNames: ''
 	imports: #(#{OS.ThemeConstants})
 	classInstanceVariableNames: ''
 	classConstants: {
 			'AnimatedCardChangeMask' -> 16r8.
 			'AnimatedUnpinMask' -> 16r2.
+			'AnimationDuration' -> 16rC8.
 			'AnimationMask' -> 16rC0010.
 			'Animations' -> (IdentityDictionary
 						withAll: { #blend -> 16r80000. #collapse -> 16r10. #roll -> 16r0. #slide -> 16r40000 }).
 			'HideOnUnpinMask' -> 16r1.
-			'ResizableMask' -> 16r4
+			'ResizableMask' -> 16r4.
+			'SlideInDelay' -> 16r1F4
 		}!
 UI.CardContainer
 	subclass: #'UI.SlidingCardTray'