-
Notifications
You must be signed in to change notification settings - Fork 11
/
BrazilMappingForWin32.ns
4387 lines (4317 loc) · 140 KB
/
BrazilMappingForWin32.ns
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
Newspeak3
'BrazilForWindows-Mapping'
class BrazilMappingForWin32 platform: platform = (
(* This is the top-level Brazil Windows mapping module that holds together all the bits and pieces of the mapping, most importantly agent classes and the agent factory.
Copyright 2008, 2012 Cadence Design Systems, Inc.
Licensed under the Apache License, Version 2.0 (the ''License''); you may not use this file except in compliance with the License. You may obtain a copy of the License at https://www.apache.org/licenses/LICENSE-2.0
*)
| (* imports *)
private Map = platform squeak Dictionary.
private IdentityMap = platform squeak IdentityDictionary.
private List = platform squeak OrderedCollection.
private Error = platform squeak Error.
private Alien = platform squeak Alien.
private UnsafeAlien = platform squeak UnsafeAlien.
private Callback = platform squeak Callback.
private NsFFISessionManager = platform squeak NsFFISessionManager.
private Transcript = platform squeak Transcript.
private FileStream = platform squeak FileStream.
private TimeStamp = platform squeak TimeStamp.
private Time = platform time Time.
private UnhandledError = platform squeak UnhandledError.
private Process = platform squeak Process.
private Color = platform squeak Color.
private TextColor = platform squeak TextColor.
private TextEmphasis = platform squeak TextEmphasis.
(* Hack dependencies we should eventually lose *)
private WorldState = platform squeak WorldState.
(* Brazil specific imports *)
private brazil = platform brazil.
private MessageBox = brazil tools MessageBox.
private AbstractAgentFactory = brazil mapping AbstractAgentFactory.
private GenericAgent = brazil mapping BrazilMappingAgent.
private Font = brazil plumbing Font.
private ModifierKeyState = brazil plumbing ModifierKeyState.
(* module variables *)
public api = platform apiManager win32api.
public agentFactory = AgentFactory new.
public windowsSession = WindowsSession new.
public squeakWindowHandle
public useDoubleBuffering ::= false.
private activeImageAgentStates = ActiveImageAgentStateClasses new.
private hyperlinkAgentStates = HyperlinkAgentStateClasses new.
|) (
class ActiveImageAgent forVisual: image = ImageAgent forVisual: image (
(* Maps ActiveIcon visuals. *)
|
state ::= activeImageAgentStates NormalState forAgent: self.
|) (
public connectOwnArtifacts = (
super connectOwnArtifacts.
map: visual disabledImageA to: [:newImage | invalidate].
map: visual hoverImageA to: [:newImage | invalidate].
map: visual downImageA to: [:newImage | invalidate].
map: visual enabledA to: [:newEnabledState | invalidate].
(* The actOnMouseDownA attribute is checked on the fly and needs no mapping. *)
)
public enterState: stateClass = (
state:: stateClass forAgent: self.
invalidate.
)
public findConsumerForMouseEventAt: parentRelativePoint <Point> ^<Agent | nil> = (
^(visual bounds containsPoint: parentRelativePoint)
ifTrue: [self]
ifFalse: [nil]
)
public processMouseDownLeft = (
state respondToMouseDownLeft.
)
public processMouseEntry = (
state respondToMouseEntry.
)
public processMouseExit = (
state respondToMouseExit.
)
public processMouseUpLeft = (
state respondToMouseUpLeft
)
protected visualImage ^<Form | nil> = (
(* Answer the image to use as our picture at this very moment. Sent by the painting code. *)
^state image
)
) : (
)
class ActiveImageAgentStateClasses = (
(* This is a nested module defining the classes of ActiveImageAgent states, to avoid having a unique set of those in each ActiveImageAgent instance. *)
) (
class AgentState forAgent: theAgent = (
(* This is the abstract superclass of all other other active image state classes. *)
|
agent = theAgent.
|) (
public respondToMouseDownLeft = (
)
public respondToMouseEntry = (
)
public respondToMouseExit = (
agent enterState: activeImageAgentStates NormalState.
)
public respondToMouseMove = (
)
public respondToMouseUpLeft = (
)
public visual = (
^agent visual
)
) : (
)
public class HoverState forAgent: theAgent = AgentState forAgent: theAgent (
(* Represents the state when the mouse is within the bounds of the visual but no buttons are pressed. *)
) (
public image = (
^(visual enabled
ifTrue: [visual hoverImage]
ifFalse: [visual disabledImage])
ifNil: [visual image]
)
public respondToMouseDownLeft = (
visual enabled ifTrue:
[visual actOnMouseDown
ifTrue: [visual doAction]
ifFalse: [agent enterState: activeImageAgentStates PressedState]]
)
public respondToMouseExit = (
agent enterState: activeImageAgentStates NormalState
)
) : (
)
public class NormalState forAgent: theAgent = AgentState forAgent: theAgent (
(* Represents the state when the mouse is outside the bounds of the visual. *)
) (
public image = (
^visual enabled
ifTrue: [visual image]
ifFalse: [visual disabledImage ifNil: [visual image]]
)
public respondToMouseEntry = (
agent enterState: activeImageAgentStates HoverState
)
) : (
)
public class PressedState forAgent: theAgent = AgentState forAgent: theAgent (
(* Represents the state when the mouse is within the bounds of the visual and a button is pressed. *)
) (
public image = (
^(visual enabled
ifTrue: [visual downImage]
ifFalse: [visual disabledImage])
ifNil: [visual image]
)
public respondToMouseExit = (
agent enterState: activeImageAgentStates WarmState
)
public respondToMouseUpLeft = (
agent enterState: activeImageAgentStates HoverState.
(visual enabled and: [visual actOnMouseDown not])
ifTrue: [visual doAction]
)
) : (
)
public class WarmState forAgent: theAgent = NormalState forAgent: theAgent (
(* Describes the state of the button when it was initially pressed and then the cursor left its bounds. It now displays itself as normal but will switch to being pressed again if the cursor reenters. *)
) (
public respondToMouseEntry = (
agent enterState: (agent isLeftButtonDown
ifTrue: [activeImageAgentStates PressedState]
ifFalse: [activeImageAgentStates HoverState])
)
) : (
)
) : (
)
class ActiveLabelAgent forVisual: v = LabelAgent forVisual: v (
(* Represents Brazil ActiveLabels. Largely the same as LabelAgent, but expresses interest in mouse events and forwards them to the visual. *)
) (
public findConsumerForMouseEventAt: parentRelativePoint <Point> ^<Agent | nil> = (
^(visual bounds containsPoint: parentRelativePoint)
ifTrue: [self]
ifFalse: [nil]
)
public processMouseDownLeft = (
visual respondToMouseDownLeft
)
public processMouseEntry = (
visual respondToMouseEntry
)
public processMouseExit = (
visual respondToMouseExit
)
public processMouseMove = (
visual respondToMouseMove
)
public processMouseUpLeft = (
visual respondToMouseUpLeft
)
) : (
)
class Agent forVisual: visual = GenericAgent forVisual: visual (
(* This is the common superclass of all Agents used for mapping Brazil visuals to Windows artifacts. *)
|
api_
agentFactory_
protected areBoundsChanging <Boolean> ::= false.
|) (
agentFactory = (
^agentFactory_ ifNil:
[agentFactory_: outer BrazilMappingForWin32 agentFactory.
agentFactory_]
)
public api ^<Win32API> = (
#BOGUS. (* Why is there here? *)
^api_ ifNil:
[api_: outer BrazilMappingForWin32 api.
api_]
)
public areBoundsHereOrInAncestorsChanging = (
^areBoundsChanging or:
[parent
ifNil: [false]
ifNotNil: [:it | it areBoundsHereOrInAncestorsChanging]]
)
areBoundsInAncestorsChanging = (
^parent
ifNil: [false]
ifNotNil: [:it | it areBoundsHereOrInAncestorsChanging]
)
public collectControlsByHandleInto: aDictionary = (
childrenDo: [:each | each collectControlsByHandleInto: aDictionary]
)
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point> = (
(* This message is first sent by a WindowAgent during the processing of a WM_PAINT. The WindowAgent takes care of calling BeginPaint before this request to obtain the HDC. It will call EndPaint afterwards to clean up. Agents that are interested in painting things inside the window should do it here. NOTE: the HDC is untranslated, agents need to translate their visual's coordinates to be window-relative using the supplied parentOrigin. *)
| translatedUpdateRect myOrigin |
translatedUpdateRect:: parentRelativeUpdateRect
translateBy: visual origin negated.
myOrigin:: parentOrigin + visual origin.
childrenDo:
[:each |
each
contributeToWM_PAINTOn: hdc
inside: translatedUpdateRect
translatedBy: myOrigin]
)
ensureUpToDateAppearance = (
handle ifNotNil: [:it | api UpdateWindow value: it]
)
fillRectangle: rect <Rectangle> on: hdc <Integer> withGradient: gradient <Gradient> = (
| topColor bottomColor sizeofTrivertex vertices gradientRect |
topColor:: gradient startColor.
bottomColor:: gradient endColor.
sizeofTrivertex:: api TRIVERTEX dataSize.
vertices:: Alien newC: sizeofTrivertex * 2.
(api TRIVERTEX atAddress: vertices address)
x: rect left;
y: rect top;
red: (topColor red * 16rFFFF) asInteger;
green: (topColor green * 16rFFFF) asInteger;
blue: (topColor blue * 16rFFFF) asInteger.
(api TRIVERTEX atAddress: vertices address + sizeofTrivertex)
x: rect right;
y: rect bottom;
red: (bottomColor red * 16rFFFF) asInteger;
green: (bottomColor green * 16rFFFF) asInteger;
blue: (bottomColor blue * 16rFFFF) asInteger.
gradientRect:: api GRADIENT_RECT newC.
gradientRect
UpperLeft: 0;
LowerRight: 1.
api GradientFill
value: hdc
value: vertices address
value: 2
value: gradientRect address
value: 1
value: api GRADIENT_FILL_RECT_V.
gradientRect free.
vertices free.
)
fillRectangle: rect <Rectangle> on: hdc <Integer> withSolidColor: color <Color> = (
| oldBrush oldPen |
oldBrush:: api SelectObject
unsignedValue: hdc
value: (api GetStockObject unsignedValue: api DC_BRUSH).
oldPen:: api SelectObject
unsignedValue: hdc
value: (api GetStockObject unsignedValue: 8 (* api NULL_PEN *)).
api SetDCBrushColor
unsignedValue: hdc
value: color asColorref.
api Rectangle
value: hdc
value: rect left
value: rect top
value: rect right + 1
value: rect bottom + 1.
api SelectObject value: hdc value: oldBrush.
api SelectObject value: hdc value: oldPen.
)
public findConsumerForMouseEventAt: parentRelativePoint <Point> ^<Agent | nil> = (
(* If the agent is willing to handle a mouse event that has just occurred at the specified point, it should return itself. A container may return a child instead of itself. When a parent passes this request down to the child it should take care to translate the argument accordingly. *)
^nil
)
public grabMouse = (
hostWindowAgent setMouseGrabTo: self
)
public handle ^<Integer> = (
(* Answer the handle of the window the agent created to represent its visual, or the handle of the nearest parent mapped to a window if the visual has no window for itself. *)
subclassResponsibility
)
public hostWindowAgent ^<Agent | nil> = (
(* The agent that manages the native window this agent is located in. This may or may not be the direct parent of the agent. The visual overriding this method with ^self will typically need to reimplement invalidate: and invalidateRectangle: as direct native calls. *)
^parent ifNotNil: [:it | it hostWindowAgent]
)
invalidate = (
(* Invalidate the area currently occupied by the visual. *)
parent ifNotNil:
[:it |
it invalidateRectangle: visual bounds]
(* hostWindowAgent ifNotNil:
[:it |
it invalidateRectangle: (rectangleRelativeToHostWindow: visual localBounds)]. *)
)
public invalidateRectangle: rectangle <Rectangle> = (
(* Invalidate the rectangle. The rectangle is relative to the visual's top left corner. *)
parent ifNotNil:
[:it | it invalidateRectangle: (rectangle translateBy: visual origin)].
(* hostWindowAgent ifNotNil:
[:it |
it invalidateRectangle: (rectangleRelativeToHostWindow: rectangle)].
*)
)
invalidateWindow = (
windowHandle ifNotNil:
[:hwnd |
api InvalidateRect
value: hwnd
value: 0 (* null rectangle, i.e. the whole thing *)
value: 0 (* do not erase background--painted by agent *)]
)
isLeftButtonDown ^<Boolean> = (
^(api GetKeyState unsignedValue: api VK_LBUTTON) > 1
(* Checking for the state to be > 1 rather than ~= 0 so that the toggle bit (LSB) doesn't get in the way. *)
)
matchVisualsBounds = (
)
public mousePoint = (
^visual desktop
ifNil: [0 @ 0]
ifNotNil: [:it | it mousePoint translateFrom: it to: visual]
)
public noteBeginningOfBoundsChangeAndProvideEndContinuation = (
areBoundsChanging: true.
^[areBoundsChanging: false]
)
platform = (
^#win32
)
public processMouseDownLeft = (
)
public processMouseEntry = (
)
public processMouseExit = (
)
public processMouseMove = (
)
public processMouseUpLeft = (
)
public rectangleRelativeToHostWindow: rect <Rectangle> ^<Rectangle> = (
(* By request (presumably) from a child, translate the rectangle to be relative to whatever visual that provides the host reference frame for the child. This rectangle is in our coordinate system. *)
^parent
ifNil: [rect]
ifNotNil: [:it | it rectangleRelativeToHostWindow: (rect translateBy: visual origin)]
)
public releaseMouse = (
hostWindowAgent releaseMouseGrabFrom: self
)
windowHandle ^<Integer | nil> = (
(* Answer the Windows handle of the window containing this agent's visual. Answer nil if there is no window or the window is not mapped. *)
^visual window ifNotNil:
[:it | it agent ifNotNil:
[:wagent | wagent handle]]
)
windowsSession ^<WindowsSession> = (
^outer BrazilMappingForWin32 windowsSession.
)
) : (
)
class AgentFactory = AbstractAgentFactory (
(* The rest of Brazil refers to classes such as this one as mappings, however from here on we'll consider a mapping to be the entire body of code that handles the representation of Brazil visuals as a particular set of native UI primitives. What was previously known as mappings will now be called agent factories of mappings. *)
) (
public createAgentForActiveIcon: icon <ActiveIcon> = (
^ActiveImageAgent forVisual: icon
)
public createAgentForActiveLabel: label <ActiveLabel> = (
^ActiveLabelAgent forVisual: label
)
public createAgentForBlank: blank <Blank> = (
^NullAgent forVisual: blank
)
public createAgentForCompositeVisual: visual <CompositeVisual> = (
^NullColoredAgent forVisual: visual
)
public createAgentForDesktop: aDesktop <Desktop> = (
^DesktopAgent desktop: aDesktop
)
public createAgentForEllipseShape: shape <EllipseShape> = (
^EllipseShapeAgent forVisual: shape
)
public createAgentForHyperlink: link <Hyperlink> = (
^HyperlinkAgent forVisual: link
)
public createAgentForIcon: icon <Icon> = (
^ImageAgent forVisual: icon
)
public createAgentForLabel: label <Label> = (
^LabelAgent forVisual: label
)
public createAgentForLineShape: shape <LineShape> = (
^LineShapeAgent forVisual: shape
)
public createAgentForListBox: listBox <ListBox> = (
^ListBoxAgent forVisual: listBox
)
public createAgentForMenu: menu <Menu> = (
^MenuAgent menu: menu
)
public createAgentForPolygonShape: shape <PolygonShape> = (
^PolygonShapeAgent forVisual: shape
)
public createAgentForPushButton: button <PushButton> = (
^ButtonAgent forVisual: button
)
public createAgentForRectangleShape: shape <RectangleShape> = (
^RectangleShapeAgent forVisual: shape
)
public createAgentForSensitiveIcon: icon <SensitiveIcon> = (
^SensitiveImageAgent forVisual: icon
)
public createAgentForTextDisplay: visual <TextDisplay> = (
^TextDisplayAgent forVisual: visual
)
public createAgentForTextView: textView <TextView> = (
^TextViewAgent forVisual: textView
)
public createAgentForVerticalViewport: viewport <VerticalViewport> = (
^VerticalViewportAgent forVisual: viewport
)
public createAgentForVerticalVisualSequence: visual <VisualSequence> = (
^VerticalVisualSequenceAgent forVisual: visual
)
public createAgentForViewport: viewport <Viewport> = (
^ViewportAgent forVisual: viewport
)
public createAgentForVisualSequence: visual <VisualSequence> = (
^NullColoredAgent forVisual: visual
)
public createAgentForWindow: window <Window> = (
^WindowAgent forVisual: window
)
public createAgentForWrapper: wrapper <Wrapper> = (
^NullColoredAgent forVisual: wrapper
)
) : (
)
class AgentWithHandle forVisual: visual = Agent forVisual: visual (
(* This is an abstract superclass of those agents that create an actual Windows window to represent their visuals. The 'handle' slot holds the integer value of the handle, if it exists. The class also provides some facilities common to window management such as enabling and disabling the window, sending it messages, or changing its style. *)
|
public handle
|) (
public enableWindow: doEnable <Boolean> = (
| success |
ifHandleValid:
[api EnableWindow
boolValue: handle
value: (doEnable ifTrue: [1] ifFalse: [0])]
)
getDCWhile: action <Block> ifNotMapped: unmappedAction <Block> = (
| hdc |
handle isNil ifTrue: [^unmappedAction value].
hdc:: api GetDC unsignedValue: handle.
hdc = 0 ifTrue: [api reportError: 'GetDC() failed'].
^[action value: hdc] ensure:
[api ReleaseDC value: handle value: hdc]
)
getWindowExStyle = (
^getWindowLong: api GWL_EXSTYLE
)
getWindowLong: index <Integer> ^<Integer> = (
handle isNil ifTrue: [error: 'agent has no window handle'].
^api GetWindowLong
unsignedValue: handle
value: index.
)
getWindowStyle = (
^getWindowLong: api GWL_STYLE
)
getWindowText ^<String> = (
^getWindowTextIfNone: [String new]
)
getWindowTextIfNone: noneBlock ^<String> = (
| length |
handle ifNil: [^noneBlock value].
length:: sendMessage: api WM_GETTEXTLENGTH wParam: 0 lParam: 0.
^(Alien newC: length + 1) freeAfter:
[:buffer |
sendMessage: api WM_GETTEXT
wParam: length + 1
lParam: buffer address.
buffer strcpy withSqueakLineEndings]
)
ifHandleValid: block = (
^handle ifNotNil: [block value]
)
public resetForNewImageSession = (
handle:: nil
)
sendMessage: msg <Integer> wParam: wParam <Integer> lParam: lParam <Integer> ^<Integer> = (
(* Send a Windows message to the agent's Windows window. *)
^ifHandleValid:
[api SendMessage
unsignedValue: handle
value: msg
value: wParam
value: lParam]
)
setWindowExStyle: value <Integer> = (
setWindowLong: api GWL_EXSTYLE to: value
)
setWindowLong: index <Integer> to: value <Integer> = (
ifHandleValid:
[api SetWindowLong
unsignedValue: handle
value: index
value: value]
)
setWindowStyle: value <Integer> = (
setWindowLong: api GWL_STYLE to: value
)
public setWindowText: newText <String> = (
(Alien newCString: newText) freeAfter:
[:cString |
sendMessage: api WM_SETTEXT
wParam: 0
lParam: cString address]
)
showWindow: doShow <Boolean> = (
ifHandleValid:
[api ShowWindow
value: handle
value: (doShow ifTrue: [api SW_SHOW] ifFalse: [api SW_HIDE])]
)
takeKeyboardFocus = (
^ifHandleValid:
[api SetFocus unsignedValue: handle]
)
updateWindow = (
ifHandleValid:
[api UpdateWindow value: handle]
)
) : (
)
class BogusAgent forVisual: v = NullAgent forVisual: v (
(* An agent we use in cases when there is no real agent yet that we could use. *)
) (
public matchScrollbarRange = (
flag: #BOGUS. (* Provided temporarily only so that we can use this as a viewport agent. *)
)
naturalExtent = (
^100 @ 20
)
public naturalHeightForWidth: ignored = (
^20
)
scrollbarHeight = (
flag: #BOGUS. (* Provided temporarily only so that we can use this as a viewport agent. *)
^15
)
) : (
)
class BoxShapeAgent forVisual: v <Visual> = NullAgent forVisual: v (
(* This is the abstract superclass of agents for those shape visuals that are defined by their bounding box, i.e. rectangles and ellipses. *)
) (
asColor: color <Color | Gradient> = (
^color isColor
ifTrue: [color]
ifFalse: [color startColor mixed: 0.5 with: color endColor]
)
public connectOwnArtifacts = (
super connectOwnArtifacts.
map: visual colorA to: [:ignored | self invalidate].
map: visual borderColorA to: [:ignored | self invalidate].
map: visual borderWidthA to: [:ignored | self invalidate].
)
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point> = (
(needsPaintingRect: parentRelativeUpdateRect) ifTrue:
[paintShapeOn: hdc in: (visual bounds translateBy: parentOrigin)].
)
public destroyOwnArtifacts = (
super destroyOwnArtifacts.
invalidate
)
public findConsumerForMouseEventAt: parentRelativePoint <Point> ^<Agent | nil> = (
^(visual bounds containsPoint: parentRelativePoint)
ifTrue: [self]
ifFalse: [nil]
)
isColor: color = (
^color yourself asColor == color yourself
)
needsPainting ^<Boolean> = (
^visual visible and:
[visual color asColor isTransparent not or:
[visual borderWidth > 0]]
)
needsPaintingRect: parentRelativeRect <Rectangle> = (
^needsPainting
and: [visual bounds intersects: parentRelativeRect]
)
paintShapeOn: hdc <Integer> in: boundsBox <Rectangle> = (
subclassResponsibility
)
public processMouseDownLeft = (
visual respondToMouseDownLeft
)
public processMouseEntry = (
visual respondToMouseEntry
)
public processMouseExit = (
visual respondToMouseExit
)
public processMouseMove = (
visual respondToMouseMove
)
public processMouseUpLeft = (
visual respondToMouseUpLeft
)
setupContextPenIn: hdc <Integer> while: action <Block> = (
| oldPen |
oldPen:: api SelectObject
unsignedValue: hdc
value: (api GetStockObject unsignedValue: api DC_PEN).
api SetDCPenColor
unsignedValue: hdc
value: visual borderColor asColorref.
^action ensure:
[api SelectObject value: hdc value: oldPen].
)
setupFillBrushIn: hdc <Integer> while: action <Block> = (
| oldBrush |
oldBrush:: api SelectObject
unsignedValue: hdc
value: (api GetStockObject unsignedValue: api DC_BRUSH).
api SetDCBrushColor
unsignedValue: hdc
value: (asColor: visual color) asColorref.
^action ensure:
[api SelectObject value: hdc value: oldBrush].
)
setupNullBrushIn: hdc <Integer> while: action <Block> = (
| oldBrush |
oldBrush:: api SelectObject
unsignedValue: hdc
value: (api GetStockObject unsignedValue: (* NULL_BRUSH *) 5).
^action ensure:
[api SelectObject value: hdc value: oldBrush].
)
setupNullPenIn: hdc <Integer> while: action <Block> = (
| oldPen |
oldPen:: api SelectObject
unsignedValue: hdc
value: (api GetStockObject unsignedValue: 8 (* api NULL_PEN *)).
^action ensure:
[api SelectObject value: hdc value: oldPen].
)
setupOutlinePenIn: hdc <Integer> while: action <Block> = (
^(visual borderWidth > 0 and: [visual borderColor isTransparent not])
ifTrue: [setupContextPenIn: hdc while: action]
ifFalse: [setupNullPenIn: hdc while: action]
)
) : (
)
class ButtonAgent forVisual: visual = WindowControlAgent forVisual: visual (
|
protected cachedNaturalExtent
|) (
public connectOwnArtifacts = (
map: visual labelA to: self ~ #setWindowText:.
map: visual enabledA to: self ~ #enableWindow:.
super connectOwnArtifacts.
)
controlClassName = (
^'BUTTON'
)
controlWindowTitle = (
^visual label
)
protected finalExtentFrom: stringExtent <Point> ^ <Point> = (
| extra |
extra:: stringExtent y.
^stringExtent + (2 * extra @ extra)
)
protected measureNaturalExtent ^<Point> = (
(* We cannot use the BCM_GETIDEALSIZE message provided by XP and above, because it is only available if the application is built with a linker flag or a manifest indicating that it uses CommCtl 6.0+. Thus we need to estimate the size based on some arbitrary assumptions. Insert a suitably sarcastic comment on Microsoft's software design acumen. *)
^getDCWhile:
[:hdc |
selectProperFontInto: hdc.
finalExtentFrom:
(measureString: visual label asString using: hdc)]
ifNotMapped: [0@0].
)
protected measureString: aString using: hdc ^<Point> = (
| result |
^api POINT newC freeAfter:
[:sizeBuffer |
result:: api GetTextExtentPoint32
unsignedValue: hdc
value: (UnsafeAlien forPointerTo: aString)
value: aString size
value: sizeBuffer address.
result = 0 ifTrue: [api reportError: 'GetTextExtentPoint32() failed'].
sizeBuffer asPoint]
)
public naturalExtent ^<Point> = (
^cachedNaturalExtent ifNil:
[cachedNaturalExtent:: measureNaturalExtent.
cachedNaturalExtent]
)
public processCommand: code <Integer> ^<Integer> = (
code = api BN_CLICKED ifTrue:
(* [visual desktop scheduleUIAction: [visual doAction]]. *)
[visual doAction].
^0
)
protected selectProperFontInto: hdc <Integer> = (
| hfont |
hfont:: windowsSession fontMapper defaultControlFontHandle.
api SelectObject value: hdc value: hfont.
)
public setWindowText: newText <String> = (
cachedNaturalExtent: nil.
super setWindowText: newText asString
)
) : (
)
class DesktopAgent = (
(* This agent maps the desktop of the host platform. *)
|
public desktop
protected modifierKeyStateForCurrentEventX
|) (
public areBoundsHereOrInAncestorsChanging = (
^false
)
public clearDraggedImage = (
windowsSession removeDragCue
)
public connectArtifactsOfChild: ignored = (
)
public desktopBounds ^<Rectangle> = (
(* Answer the area of the main desktop available for placing windows. *)
^windowsSession systemMetrics desktopBounds
)
disableUserInputDuring: action = (
windowsSession disableAll.
[^action value] ensure: [windowsSession enableAll]
)
ensureUpToDateAppearance = (
(* We are always up-to-date on Windows. *)
)
public isMorphic ^<Boolean> = (
^false
)
isNull ^<Boolean> = (
^false
)
public isWindows ^<Boolean> = (
^true
)
public mapping = (
^outer BrazilMappingForWin32 agentFactory
)
public modifierKeyStateForCurrentEvent = (
^modifierKeyStateForCurrentEventX ifNil: [ModifierKeyState new]
)
public mousePoint ^<Point> = (
| api |
api:: outer BrazilMappingForWin32 api.
^api POINT newC freeAfter:
[:point | | result |
result:: api GetCursorPos unsignedValue: point address.
result = 0
ifTrue:
[api reportError: 'GetCursorPos() failed'.
0 @ 0]
ifFalse:
[point asPoint]]
)
public noticeChangeInChildAgentStructure = (
)
public resetForContinuingImageSession = (
desktop windows copy do: [:window |
window agent destroy.
].
windowsSession resetForContinuingImageSession.
)
public scheduleUIAction: action <[]> = (
NsFFISessionManager soleInstance scheduleDeferredAction: action
)
public scheduleUIInstallment: action <[]> = (
NsFFISessionManager soleInstance scheduleDeferredInstallment: action
)
public setDraggedImage: image <Form> = (
windowsSession placeDragCue: image at: mousePoint
)
setFingerCursor = (
(* Unimplemented. *)
#BOGUS yourself
)
setLeftRightCursor = (
(* Unimplemented. *)
#BOGUS yourself
)
public setModifierKeyState: state <ModifierKeyState> while: action <Block> = (
| oldValue |
oldValue:: modifierKeyStateForCurrentEventX.
modifierKeyStateForCurrentEventX:: state.
^action ensure: [modifierKeyStateForCurrentEventX:: oldValue]
)
setNormalCursor = (
(* Unimplemented. *)
#BOGUS yourself
)
setWaitCursor = (
(* Unimplemented. *)
#BOGUS yourself
)
systemIsIdle = (
| now |
now:: Time millisecondClockValue.
^(now - windowsSession lastActivity) > 300000
and: [(now - WorldState currentEvent timeStamp) > 300000]
)
public updateDraggedImagePosition = (
windowsSession moveDragCueTo: mousePoint
)
usableDesktopBounds ^<Rectangle> = (
(* Answer the area of the screen excluding the task bar. *)
^windowsSession systemMetrics workArea
)
public windowAtPoint: point <Point> ^<Window | nil> = (
| pointStruct hwnd |
pointStruct:: api POINT new initializeFromPoint: point.
hwnd:: api WindowFromPoint unsignedValue: pointStruct.
hwnd = 0 ifTrue: [^nil].
hwnd:: api GetAncestor unsignedValue: hwnd value: api GA_ROOT.
hwnd = 0 ifTrue: [^nil].
^desktop windows
detect: [:some | some agent handle = hwnd]
ifNone: [nil]
)
) : (
public desktop: desktop = (
^DesktopAgent new desktop: desktop
)
)
class EllipseShapeAgent forVisual: v <EllipseShape> = BoxShapeAgent forVisual: v (
(* Specializes the superclass to paint an ellipse when needed. *)
) (
paintShapeOn: hdc <Integer> in: boundingBox <Rectangle> = (
(* Cannot fill with a gradient in GDI. *)
setupFillBrushIn: hdc while:
[setupOutlinePenIn: hdc while:
[api Ellipse
value: hdc
value: boundingBox left
value: boundingBox top
value: boundingBox right
value: boundingBox bottom]]
)
) : (
)
class HyperlinkAgent forVisual: visual = ActiveLabelAgent forVisual: visual (
(* Represents Brazil Hyperlinks. For now we are handling these as soft widgets because the story of Windows command link buttons and syslink widgets is unclear. *)
|
state ::= hyperlinkAgentStates NormalState forAgent: self.
isTrackingButtonPress ::= false.
|) (
public contributeToWM_PAINTOn: hdc <Integer>
inside: parentRelativeUpdateRect <Rectangle>
translatedBy: parentOrigin <Point>
= (
(* This is the painting workhorse. The hdc is already configured with colors and other settings appropriate for the visual, and the box contains a DC-relative rectangle describing the bounds of the visual. *)
super
contributeToWM_PAINTOn: hdc
inside: parentRelativeUpdateRect
translatedBy: parentOrigin.
state shouldShowUnderline ifTrue:
[paintUnderlineOn: hdc inside:
(visual bounds translateBy: parentOrigin)].
)
enterState: stateClass = (
state:: stateClass forAgent: self.
invalidate
)
protected paintUnderlineOn: hdc <Integer> inside: box <Rectangle> = (
| right bottom pen oldPen |
bottom:: box top + naturalExtent y - 1 min: box bottom.
right:: box left + naturalExtent x min: box right.
pen:: api CreatePen
unsignedValue: 0 (* PS_SOLID *)
value: 1
value: state color asColorref.
oldPen:: api SelectObject value: hdc value: pen.
api MoveToEx
value: hdc value: box left value: bottom value: 0.
api LineTo
value: hdc value: right value: bottom.
api SelectObject value: hdc value: oldPen.
api DeleteObject value: pen.
)
public processMouseDownLeft = (
isTrackingButtonPress:: true.
enterState: hyperlinkAgentStates PressedState.
visual dragTracker ifNotNil: [:it | it respondToMouseDown].
)
public processMouseEntry = (
(* #processMouseMove will take care of changing states. *)
)
public processMouseExit = (
enterState: hyperlinkAgentStates NormalState.
)
public processMouseMove = (
isTrackingButtonPress
ifTrue:
[visual containsMouse
ifTrue: [state isPressed ifFalse: [enterState: hyperlinkAgentStates PressedState]]
ifFalse: [state isNormal ifFalse: [enterState: hyperlinkAgentStates NormalState]]]
ifFalse:
[state isHover ifFalse: [enterState: hyperlinkAgentStates HoverState]].
visual dragTracker ifNotNil: [:it | it respondToMouseMove]
)
public processMouseUpLeft = (
| wasDragInProgress |
isTrackingButtonPress:: false.
wasDragInProgress:: false.
visual dragTracker notNil ifTrue:
[(* The tracker must always be sent #respondToMouseUp
so that it gets a chance to reset itself and release the mouse focus. *)
wasDragInProgress:: visual dragTracker isDragging.
visual dragTracker respondToMouseUp].
state respondToButtonRelease.
enterState::
visual containsMouse
ifTrue: [hyperlinkAgentStates HoverState]
ifFalse: [hyperlinkAgentStates NormalState]
)
protected selectProperColorInto: hdc <Integer> = (
api SetTextColor value: hdc value: state color asColorref.
)
) : (
)
class HyperlinkAgentStateClasses = (
(* This is a nested module containing the classes used internally by HyperlinkAgent, to avoid creating unique class instances for each agent instance. *)
) (
class AgentState forAgent: theAgent = (
(* The common superclass of all hyperlink agent states. *)
|
agent = theAgent.
|) (
public isHover = (
^false
)
public isNormal = (
^false
)
public isPressed = (
^false
)
public respondToButtonRelease = (
)
) : (
)
public class HoverState forAgent: theAgent = AgentState forAgent: theAgent (
(* Captures the behavior of the agent that in has when the mouse is hovering over it. *)
) (
public color ^<Color> = (
^agent visual hoverColor
)
public isHover = (