1 unit CocoaWSCommon;
2
3 {$mode objfpc}{$H+}
4 {$modeswitch objectivec1}
5 {$include cocoadefines.inc}
6 {.$DEFINE COCOA_DEBUG_SETBOUNDS}
7
8 interface
9
10 uses
11 Types,
12 CGGeometry, CocoaAll, cocoa_extra,
13 Classes, Controls, SysUtils,
14 //
15 WSControls, LCLType, LMessages, LCLProc, Graphics, Forms,
16 CocoaPrivate, CocoaGDIObjects, CocoaCaret, CocoaUtils, LCLMessageGlue,
17 CocoaScrollers;
18
19 type
20 { TLCLCommonCallback }
21
22 TLCLCommonCallback = class(TObject, ICommonCallBack)
23 private
24 class var
25 // Store state of key modifiers so that we can emulate keyup/keydown
26 // of keys like control, option, command, caps lock, shift
27 PrevKeyModifiers: NSUInteger;
28 var
29 FPropStorage: TStringList;
30 FContext: TCocoaContext;
31 FHasCaret: Boolean;
32 FBoundsReportedToChildren: boolean;
33 FIsOpaque:boolean;
34 FIsEventRouting:boolean;
35 protected
GetHasCaretnull36 function GetHasCaret: Boolean;
37 procedure SetHasCaret(AValue: Boolean);
GetIsOpaquenull38 function GetIsOpaque: Boolean;
39 procedure SetIsOpaque(AValue: Boolean);
GetShouldBeEnablednull40 function GetShouldBeEnabled: Boolean;
41 protected
42 FTarget: TWinControl;
43 _KeyMsg : TLMKey;
44 _CharMsg : TLMKey;
45 _SendChar : Boolean;
46 _IsSysKey : Boolean;
47 _IsKeyDown : Boolean;
48 _KeyHandled: Boolean;
49 _UTF8Character : array [0..7] of TUTF8Char;
50 _UTF8Charcount : Integer;
51 procedure OffsetMousePos(LocInWin: NSPoint; out PtInBounds, PtInClient, PtForChildCtrls: TPoint );
52 procedure ScreenMousePos(var Point: NSPoint);
53 procedure KeyEvBeforeDown;
54 procedure KeyEvBeforeUp;
55 procedure KeyEvAfterUp;
56 procedure KeyEvFlagsChanged(Event: NSEvent);
57 procedure KeyEvPrepare(Event: NSEvent);
58 public
59 Owner: NSObject;
60 HandleFrame: NSView; // HWND and "frame" (rectangle) of the a control
61 BlockCocoaUpDown: Boolean;
62 BlockCocoaKeyBeep: Boolean;
63 BlockCocoaMouseMove: Boolean;
64 SuppressTabDown: Boolean; // all tabs should be suppressed, so Cocoa would not switch focus
65 ForceReturnKeyDown: Boolean; // send keyDown/LM_KEYDOWN for Return even if handled by IntfUTF8KeyPress/CN_CHAR
66
67 lastMouseDownUp: NSTimeInterval; // the last processed mouse Event
68 lastMouseWithForce: Boolean;
69
70 class constructor Create;
71 constructor Create(AOwner: NSObject; ATarget: TWinControl; AHandleFrame: NSView = nil); virtual;
72 destructor Destroy; override;
GetPropStoragenull73 function GetPropStorage: TStringList;
GetContextnull74 function GetContext: TCocoaContext;
GetTargetnull75 function GetTarget: TObject;
GetCallbackObjectnull76 function GetCallbackObject: TObject;
GetCaptureControlCallbacknull77 function GetCaptureControlCallback: ICommonCallBack;
78 procedure SendContextMenu(Event: NSEvent; out ContextMenuHandled: Boolean);
MouseUpDownEventnull79 function MouseUpDownEvent(Event: NSEvent; AForceAsMouseUp: Boolean = False; AOverrideBlock: Boolean = False): Boolean; virtual;
80
81 procedure KeyEvAfterDown(out AllowCocoaHandle: boolean);
82 procedure KeyEvBefore(Event: NSEvent; out AllowCocoaHandle: boolean);
83 procedure KeyEvAfter;
84 procedure KeyEvHandled;
85 procedure SetTabSuppress(ASuppress: Boolean);
CanFocusnull86 function CanFocus: Boolean; virtual;
87
88 procedure MouseClick; virtual;
MouseMovenull89 function MouseMove(Event: NSEvent): Boolean; virtual;
scrollWheelnull90 function scrollWheel(Event: NSEvent): Boolean; virtual;
91 procedure frameDidChange(sender: id); virtual;
92 procedure boundsDidChange(sender: id); virtual;
93 procedure BecomeFirstResponder; virtual;
94 procedure ResignFirstResponder; virtual;
95 procedure DidBecomeKeyNotification; virtual;
96 procedure DidResignKeyNotification; virtual;
97 procedure SendOnChange; virtual;
98 procedure SendOnTextChanged; virtual; // text controls (like spin) respond to OnChange for this event, but not for SendOnChange
99 procedure scroll(isVert: Boolean; Pos: Integer; AScrollPart: NSScrollerPart); virtual;
DeliverMessagenull100 function DeliverMessage(var Msg): LRESULT; virtual; overload;
DeliverMessagenull101 function DeliverMessage(Msg: Cardinal; WParam: WParam; LParam: LParam): LResult; virtual; overload;
102 procedure Draw(ControlContext: NSGraphicsContext; const bounds, dirty: NSRect); virtual;
103 procedure DrawBackground(ctx: NSGraphicsContext; const bounds, dirtyRect: NSRect); virtual;
104 procedure DrawOverlay(ControlContext: NSGraphicsContext; const bounds, dirty: NSRect); virtual;
ResetCursorRectsnull105 function ResetCursorRects: Boolean; virtual;
106 procedure RemoveTarget; virtual;
107
108 procedure InputClientInsertText(const utf8: string);
109
110 property HasCaret: Boolean read GetHasCaret write SetHasCaret;
111 property Target: TWinControl read FTarget;
112 property IsOpaque: Boolean read GetIsOpaque write SetIsOpaque;
113 end;
114
115 TLCLCommonCallBackClass = class of TLCLCommonCallBack;
116
117 { TCocoaWSWinControl }
118
119 { TCocoaWSControl }
120
121 TCocoaWSControl = class(TWSControl)
122 published
GetCanvasScaleFactornull123 class function GetCanvasScaleFactor(const AControl: TControl): Double; override;
124 end;
125
126 { TCocoaWSWinControl }
127
128 TCocoaWSWinControl = class(TWSWinControl)
129 published
CreateHandlenull130 class function CreateHandle(const AWinControl: TWinControl;
131 const AParams: TCreateParams): TLCLIntfHandle; override;
132 class procedure DestroyHandle(const AWinControl: TWinControl); override;
GetCanvasScaleFactornull133 class function GetCanvasScaleFactor(const AControl: TControl): Double; override;
134 class procedure SetText(const AWinControl: TWinControl; const AText: String); override;
GetTextnull135 class function GetText(const AWinControl: TWinControl; var AText: String): Boolean; override;
GetTextLennull136 class function GetTextLen(const AWinControl: TWinControl; var ALength: Integer): Boolean; override;
137
GetClientBoundsnull138 class function GetClientBounds(const AWincontrol: TWinControl; var ARect: TRect): Boolean; override;
GetClientRectnull139 class function GetClientRect(const AWincontrol: TWinControl; var ARect: TRect): Boolean; override;
140 class procedure GetPreferredSize(const AWinControl: TWinControl; var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean); override;
141 class procedure SetBounds(const AWinControl: TWinControl; const ALeft, ATop, AWidth, AHeight: Integer); override;
142 class procedure SetCursor(const AWinControl: TWinControl; const ACursor: HCursor); override;
143 class procedure SetFont(const AWinControl: TWinControl; const AFont: TFont); override;
144 class procedure SetColor(const AWinControl: TWinControl); override;
145 class procedure SetChildZPosition(const AWinControl, AChild: TWinControl; const AOldPos, ANewPos: Integer; const AChildren: TFPList); override;
146 class procedure ShowHide(const AWinControl: TWinControl); override;
147 class procedure Invalidate(const AWinControl: TWinControl); override;
148 class procedure PaintTo(const AWinControl: TWinControl; ADC: HDC; X, Y: Integer); override;
149 end;
150
151 { TCocoaWSCustomControl }
152
153 TCocoaWSCustomControl = class(TWSCustomControl)
154 published
CreateHandlenull155 class function CreateHandle(const AWinControl: TWinControl;
156 const AParams: TCreateParams): TLCLIntfHandle; override;
157 class procedure SetBorderStyle(const AWinControl: TWinControl;
158 const ABorderStyle: TBorderStyle); override;
159 end;
160
161 // Utility WS functions. todo: it makes sense to put them into CocoaScollers
162
EmbedInScrollViewnull163 function EmbedInScrollView(AView: NSView; AReleaseView: Boolean = true): TCocoaScrollView;
EmbedInManualScrollViewnull164 function EmbedInManualScrollView(AView: NSView): TCocoaManualScrollView;
EmbedInManualScrollHostnull165 function EmbedInManualScrollHost(AView: TCocoaManualScrollView): TCocoaManualScrollHost;
166
HWNDToTargetObjectnull167 function HWNDToTargetObject(AFormHandle: HWND): TObject;
168
169 procedure ScrollViewSetBorderStyle(sv: NSScrollView; astyle: TBorderStyle);
170 procedure UpdateFocusRing(v: NSView; astyle: TBorderStyle);
171
ButtonStateToShiftStatenull172 function ButtonStateToShiftState(BtnState: PtrUInt): TShiftState;
CocoaModifiersToKeyStatenull173 function CocoaModifiersToKeyState(AModifiers: NSUInteger): PtrInt;
CocoaPressedMouseButtonsToKeyStatenull174 function CocoaPressedMouseButtonsToKeyState(AMouseButtons: NSUInteger): PtrInt;
CocoaModifiersToShiftStatenull175 function CocoaModifiersToShiftState(AModifiers: NSUInteger; AMouseButtons: NSUInteger): TShiftState;
176
NSObjectDebugStrnull177 function NSObjectDebugStr(obj: NSObject): string;
CallbackDebugStrnull178 function CallbackDebugStr(cb: ICommonCallback): string;
179 procedure DebugDumpParents(fromView: NSView);
180
181 implementation
182
183 uses
184 Math, CocoaInt;
185
186 var
187 LastMouse: TLastMouseInfo;
188
ButtonStateToShiftStatenull189 function ButtonStateToShiftState(BtnState: PtrUInt): TShiftState;
190 begin
191 Result := [];
192 if BtnState and MK_SHIFT > 0 then Include(Result, ssShift);
193 if BtnState and MK_CONTROL > 0 then Include(Result, ssCtrl);
194 if BtnState and MK_ALT > 0 then Include(Result, ssAlt);
195 if BtnState and MK_LBUTTON > 0 then Include(Result, ssLeft);
196 if BtnState and MK_RBUTTON > 0 then Include(Result, ssRight);
197 if BtnState and MK_MBUTTON > 0 then Include(Result, ssMiddle);
198 if BtnState and MK_XBUTTON1 > 0 then Include(Result, ssExtra1);
199 if BtnState and MK_XBUTTON2 > 0 then Include(Result, ssExtra2);
200 // what MK_xxx used for Meta?
201 end;
202
CocoaModifiersToShiftStatenull203 function CocoaModifiersToShiftState(AModifiers: NSUInteger; AMouseButtons: NSUInteger): TShiftState;
204 begin
205 Result := [];
206 if AModifiers and NSShiftKeyMask <> 0 then Include(Result, ssShift);
207 if AModifiers and NSControlKeyMask <> 0 then Include(Result, ssCtrl);
208 if AModifiers and NSAlternateKeyMask <> 0 then Include(Result, ssAlt);
209 if AModifiers and NSCommandKeyMask <> 0 then Include(Result, ssMeta);
210
211 if AMouseButtons and (1 shl 0) <> 0 then Include(Result, ssLeft);
212 if AMouseButtons and (1 shl 1) <> 0 then Include(Result, ssRight);
213 if AMouseButtons and (1 shl 2) <> 0 then Include(Result, ssMiddle);
214 if AMouseButtons and (1 shl 3) <> 0 then Include(Result, ssExtra1);
215 if AMouseButtons and (1 shl 4) <> 0 then Include(Result, ssExtra2);
216 end;
217
218 procedure ScrollViewSetBorderStyle(sv: NSScrollView; astyle: TBorderStyle);
219 const
220 NSBorderStyle : array [TBorderStyle] of NSBorderType = (
221 NSNoBorder, // bsNone
222 NSBezelBorder // bsSingle (NSLineBorder is too thick)
223 );
224 begin
225 if not Assigned(sv) then Exit;
226 sv.setBorderType( NSBorderStyle[astyle] );
227 end;
228
229 procedure UpdateFocusRing(v: NSView; astyle: TBorderStyle);
230 const
231 NSFocusRing : array [TBorderStyle] of NSBorderType = (
232 NSFocusRingTypeNone, // bsNone
233 NSFocusRingTypeDefault // bsSingle s
234 );
235 begin
236 if Assigned(v) and CocoaHideFocusNoBorder then
237 v.setFocusRingType( NSFocusRing[astyle] );
238 end;
239
EmbedInScrollViewnull240 function EmbedInScrollView(AView: NSView; AReleaseView: Boolean): TCocoaScrollView;
241 var
242 r: TRect;
243 p: NSView;
244 begin
245 if not Assigned(AView) then
246 Exit(nil);
247 r := AView.lclFrame;
248 p := AView.superview;
249 Result := TCocoaScrollView.alloc.initWithFrame(NSNullRect);
250 if Assigned(p) then p.addSubView(Result);
251 Result.lclSetFrame(r);
252 {$ifdef BOOLFIX}
253 Result.setHidden_(Ord(AView.isHidden));
254 {$else}
255 Result.setHidden(AView.isHidden);
256 {$endif}
257 Result.setDocumentView(AView);
258 Result.setDrawsBackground(false); // everything is covered anyway
259 if AReleaseView then AView.release;
260 {$ifdef BOOLFIX}
261 AView.setHidden_(Ord(false));
262 {$else}
263 AView.setHidden(false);
264 {$endif}
265 SetViewDefaults(Result);
266 end;
267
EmbedInManualScrollViewnull268 function EmbedInManualScrollView(AView: NSView): TCocoaManualScrollView;
269 var
270 r: TRect;
271 p: NSView;
272 begin
273 if not Assigned(AView) then
274 begin
275 Result:=nil;
276 Exit;
277 end;
278 r := AView.lclFrame;
279 p := AView.superview;
280 Result := TCocoaManualScrollView.alloc.initWithFrame(NSNullRect);
281 if Assigned(p) then p.addSubView(Result);
282 Result.lclSetFrame(r);
283 {$ifdef BOOLFIX}
284 Result.setHidden_(Ord(AView.isHidden));
285 {$else}
286 Result.setHidden(AView.isHidden);
287 {$endif}
288 Result.setDocumentView(AView);
289 {$ifdef BOOLFIX}
290 AView.setHidden_(Ord(false));
291 {$else}
292 AView.setHidden(false);
293 {$endif}
294 AView.release;
295 SetViewDefaults(Result);
296 if AView.isKindOfClass(TCocoaCustomControl) then
297 TCocoaCustomControl(AView).auxMouseByParent := true;
298 end;
299
EmbedInManualScrollHostnull300 function EmbedInManualScrollHost(AView: TCocoaManualScrollView
301 ): TCocoaManualScrollHost;
302 var
303 r: TRect;
304 p: NSView;
305 begin
306 if not Assigned(AView) then
307 Exit(nil);
308 r := AView.lclFrame;
309 p := AView.superview;
310 Result := TCocoaManualScrollHost.alloc.initWithFrame(NSNullRect);
311 if Assigned(p) then p.addSubView(Result);
312 Result.lclSetFrame(r);
313 {$ifdef BOOLFIX}
314 Result.setHidden_(Ord(AView.isHidden));
315 {$else}
316 Result.setHidden(AView.isHidden);
317 {$endif}
318 Result.setDocumentView(AView);
319 Result.setDrawsBackground(false); // everything is covered anyway
320 Result.contentView.setAutoresizesSubviews(true);
321 AView.setAutoresizingMask(NSViewWidthSizable or NSViewHeightSizable);
322
323 AView.release;
324 {$ifdef BOOLFIX}
325 AView.setHidden_(Ord(false));
326 {$else}
327 AView.setHidden(false);
328 {$endif}
329 SetViewDefaults(Result);
330 end;
331
332 { TLCLCommonCallback }
333
GetHasCaretnull334 function TLCLCommonCallback.GetHasCaret: Boolean;
335 begin
336 Result := FHasCaret;
337 end;
338
339 procedure TLCLCommonCallback.SetHasCaret(AValue: Boolean);
340 begin
341 FHasCaret := AValue;
342 end;
343
CocoaModifiersToKeyStatenull344 function CocoaModifiersToKeyState(AModifiers: NSUInteger): PtrInt;
345 begin
346 Result := 0;
347 if AModifiers and NSShiftKeyMask <> 0 then
348 Result := Result or MK_SHIFT;
349 if AModifiers and NSControlKeyMask <> 0 then
350 Result := Result or MK_CONTROL;
351 if AModifiers and NSAlternateKeyMask <> 0 then
352 Result := Result or MK_ALT;
353 end;
354
CocoaPressedMouseButtonsToKeyStatenull355 function CocoaPressedMouseButtonsToKeyState(AMouseButtons: NSUInteger): PtrInt;
356 begin
357 Result := 0;
358 if AMouseButtons and (1 shl 0) <> 0 then
359 Result := Result or MK_LBUTTON;
360 if AMouseButtons and (1 shl 1) <> 0 then
361 Result := Result or MK_RBUTTON;
362 if AMouseButtons and (1 shl 2) <> 0 then
363 Result := Result or MK_MBUTTON;
364 if AMouseButtons and (1 shl 3) <> 0 then
365 Result := Result or MK_XBUTTON1;
366 if AMouseButtons and (1 shl 4) <> 0 then
367 Result := Result or MK_XBUTTON2;
368 end;
369
370 procedure TLCLCommonCallback.OffsetMousePos(LocInWin: NSPoint; out PtInBounds, PtInClient, PtForChildCtrls: TPoint);
371 var
372 lView: NSView;
373 pt: NSPoint;
374 cr: TRect;
375 es: NSScrollView;
376 r: NSRect;
377 begin
378 if Owner.isKindOfClass(NSWindow) then
379 begin
380 PtInBounds.x := Round(LocInWin.x);
381 PtInBounds.y := Round(NSWindow(Owner).contentView.bounds.size.height - LocInWin.y);
382 PtInClient := PtInBounds; // todo: it's different. But Owner is never NSWindow (it's TConentWindowView instead)
383 PtForChildCtrls := PtInClient;
384 end
385 else if Owner.isKindOfClass(NSView) then
386 begin
387 pt := LocInWin;
388
389 NSView(Owner).lclOffsetMousePos(pt);
390 PtInBounds.x := Round(pt.x);
391 PtInBounds.y := Round(pt.y);
392
393 //pt := NSView(Owner).frame.origin;
394 //if NSView(Owner).frame.
395 cr := NSView(Owner).lclClientFrame;
396 PtInClient.x := Round({PtInBounds.x - }pt.x - cr.Left);
397 PtInClient.y := Round({PtInBounds.y - }pt.y - cr.Top);
398 PtForChildCtrls := PtInClient;
399
400 es := NSView(Owner).enclosingScrollView;
401 if Assigned(es) and (es.documentView = NSView(Owner)) then begin
402 r := es.documentVisibleRect;
403 if NSView(Owner).isFlipped then
404 r.origin.y := (es.documentView.frame.size.height - r.size.height - r.origin.y);
405 inc(PtForChildCtrls.y, Round(r.origin.y));
406 inc(PtForChildCtrls.x, Round(r.origin.x));
407 end;
408
409 end else
410 begin
411 PtInBounds.x := Round(LocInWin.x);
412 PtInBounds.y := Round(LocInWin.y);
413 PtInClient := PtInBounds;
414 PtForChildCtrls := PtInClient;
415 end;
416 end;
417
418 procedure TLCLCommonCallback.ScreenMousePos(var Point: NSPoint);
419 var
420 f: NSRect;
421 lWindow: NSWindow;
422 begin
423 lWindow := NSWindow(GetNSObjectWindow(Owner));
424 if lWindow <> nil then
425 begin
426 f := lWindow.frame;
427 Point.x := Point.x+f.origin.x;
428 Point.y := lWindow.screen.frame.size.height- f.origin.y - Point.y;
429 end;
430 end;
431
432 class constructor TLCLCommonCallback.Create;
433 begin
434 PrevKeyModifiers := 0;
435 end;
436
437 constructor TLCLCommonCallback.Create(AOwner: NSObject; ATarget: TWinControl; AHandleFrame: NSView);
438 begin
439 inherited Create;
440 Owner := AOwner;
441 if Assigned(AHandleFrame) then
442 HandleFrame := AHandleFrame
443 else if Owner.isKindOfClass(NSView) then
444 HandleFrame := NSView(AOwner);
445 FTarget := ATarget;
446 FContext := nil;
447 FHasCaret := False;
448 FPropStorage := TStringList.Create;
449 FPropStorage.Sorted := True;
450 FPropStorage.Duplicates := dupAccept;
451 FBoundsReportedToChildren:=false;
452 FIsOpaque:=false;
453 FIsEventRouting:=false;
454 SuppressTabDown := true; // by default all Tabs would not be allowed for Cocoa.
455 // it should be enabled, i.e. for TMemo with WantTabs=true
456 end;
457
458 destructor TLCLCommonCallback.Destroy;
459 begin
460 FContext.Free;
461 FPropStorage.Free;
462 FTarget := nil;
463 inherited Destroy;
464 end;
465
GetPropStoragenull466 function TLCLCommonCallback.GetPropStorage: TStringList;
467 begin
468 Result := FPropStorage;
469 end;
470
TLCLCommonCallback.GetContextnull471 function TLCLCommonCallback.GetContext: TCocoaContext;
472 begin
473 Result := FContext;
474 end;
475
GetTargetnull476 function TLCLCommonCallback.GetTarget: TObject;
477 begin
478 Result := Target;
479 end;
480
GetCallbackObjectnull481 function TLCLCommonCallback.GetCallbackObject: TObject;
482 begin
483 Result := Self;
484 end;
485
TLCLCommonCallback.GetCaptureControlCallbacknull486 function TLCLCommonCallback.GetCaptureControlCallback: ICommonCallBack;
487 var
488 obj: NSObject;
489 lCaptureView: NSView;
490 begin
491 Result := nil;
492 if CocoaWidgetSet.CaptureControl = 0 then Exit;
493 obj := NSObject(CocoaWidgetSet.CaptureControl);
494 lCaptureView := obj.lclContentView;
495 if (obj <> Owner) and (lCaptureView <> Owner) and not FIsEventRouting then
496 begin
497 Result := lCaptureView.lclGetCallback;
498 end;
499 end;
500
501 { If a window does not display a shortcut menu it should pass
502 this message to the DefWindowProc function. If a window is
503 a child window, DefWindowProc sends the message to the parent. }
504 procedure TLCLCommonCallback.SendContextMenu(Event: NSEvent; out
505 ContextMenuHandled: Boolean);
506 var
507 MsgContext: TLMContextMenu;
508 MousePos : NSPoint;
509 Res: PtrInt;
510 Rcp : NSObject;
511 Trg : TObject;
512 cb : ICommonCallback;
513 obj : TObject;
514 cbobj : TLCLCommonCallback;
515 ed : NSText;
516 begin
517 ContextMenuHandled := false;
518 FillChar(MsgContext, SizeOf(MsgContext), #0);
519 MsgContext.Msg := LM_CONTEXTMENU;
520 MsgContext.hWnd := HWND(HandleFrame);
521 MousePos := Event.locationInWindow;
522 ScreenMousePos(MousePos);
523 MsgContext.XPos := Round(MousePos.X);
524 MsgContext.YPos := Round(MousePos.Y);
525 Rcp := Owner;
526 Res := 1;
527 repeat
528 cb := Rcp.lclGetCallback;
529 if Assigned(cb) then
530 begin
531 Trg := cb.GetTarget;
532 Res := LCLMessageGlue.DeliverMessage(Trg, MsgContext);
533 if (Res = 0) and (Rcp.isKindOfClass(NSView)) then
534 begin
535 if Assigned(NSView(Rcp).menuForEvent(Event)) then
536 Break; // Cocoa has it's own menu for the control
537
538 if Rcp.isKindOfClass(NSControl) then
539 begin
540 ed := NSControl(Rcp).currentEditor;
541 if Assigned(ed) and Assigned(ed.menuForEvent(Event)) then
542 Break; // Cocoa has it's own menu for the editor of the control
543 end;
544 end;
545
546 // not processed, need to find parent
547 if Res = 0 then
548 begin
549 cbobj := nil;
550 if Assigned(cb) then
551 begin
552 obj := cb.GetCallbackObject;
553 if obj is TLCLCommonCallback then cbobj := TLCLCommonCallback(obj);
554 end;
555 if not Assigned(cbobj) then
556 Rcp := nil
557 else
558 Rcp := cbobj.HandleFrame.superView;
559 end;
560 end else
561 Rcp := nil;
562 until (Res <> 0) or not Assigned(Rcp);
563 ContextMenuHandled := Res <> 0;
564 end;
565
566 procedure TLCLCommonCallback.KeyEvFlagsChanged(Event: NSEvent);
567 const
568 cModifiersOfInterest: NSUInteger = (NSControlKeyMask or NSShiftKeyMask or NSAlphaShiftKeyMask or NSAlternateKeyMask or NSCommandKeyMask);
569 var
570 CurMod, Diff: NSUInteger;
571 VKKeyCode: word; // VK_ code
572 KeyData: PtrInt; // Modifiers (ctrl, alt, mouse buttons...)
573 begin
574 _SendChar := False;
575 CurMod := Event.modifierFlags;
576 //see what changed. we only care of bits 16 through 20
577 Diff := (PrevKeyModifiers xor CurMod) and cModifiersOfInterest;
578
579 case Diff of
580 0 : VKKeyCode := VK_UNKNOWN; //nothing (that we cared of) changed
581 NSControlKeyMask : VKKeyCode := VK_CONTROL; //command mapped to control
582 NSShiftKeyMask : VKKeyCode := VK_SHIFT;
583 NSAlphaShiftKeyMask: VKKeyCode := VK_CAPITAL; //caps lock
584 NSAlternateKeyMask : VKKeyCode := VK_MENU; //option is alt
585 NSCommandKeyMask : VKKeyCode := VK_LWIN; //meta... map to left Windows Key?
586 end;
587 KeyData := CocoaModifiersToKeyState(CurMod);
588
589 //diff is now equal to the mask of the bit that changed, so we can determine
590 //if this change is a keydown (PrevKeyModifiers didn't have the bit set) or
591 //a keyup (PrevKeyModifiers had the bit set)
592 _IsKeyDown := ((PrevKeyModifiers and Diff) = 0);
593
594 PrevKeyModifiers := CurMod;
595
596 FillChar(_KeyMsg, SizeOf(_KeyMsg), 0);
597 _KeyMsg.KeyData := KeyData;
598 _KeyMsg.CharCode := VKKeyCode;
599 _IsSysKey := (VKKeyCode = VK_LWIN);
600 end;
601
602 procedure TLCLCommonCallback.KeyEvPrepare(Event: NSEvent);
603 var
604 KeyCode: word;
605 UTF8Character: TUTF8Char; // char to send via IntfUtf8KeyPress
606 KeyChar : char; // Ascii char, when possible (xx_(SYS)CHAR)
607 SendChar: boolean; // Should we send char?
608 VKKeyCode: word; // VK_ code
609 IsSysKey: Boolean; // Is alt (option) key down?
610 KeyData: PtrInt; // Modifiers (ctrl, alt, mouse buttons...)
611 ignModChr: NSString;
612 i,c,j : integer;
613 begin
614 SendChar := False;
615
616 UTF8Character := '';
617 KeyChar := #0;
618
619 IsSysKey := (Event.modifierFlags and NSCommandKeyMask) <> 0;
620 KeyData := (Ord(Event.isARepeat) + 1) or Event.keyCode shl 16;
621 if (Event.modifierFlags and NSAlternateKeyMask) <> 0 then
622 KeyData := KeyData or MK_ALT; // So that MsgKeyDataToShiftState recognizes Alt key, see bug 30129
623 KeyCode := Event.keyCode;
624
625 ignModChr := Event.charactersIgnoringModifiers;
626 if Assigned(ignModChr)
627 and (ignModChr.length=1)
628 and ((Event.modifierFlags and NSNumericPadKeyMask) = 0) // num pad should be checked by KeyCode
629 then
630 begin
631 VKKeyCode := MacCharToVK(ignModChr.characterAtIndex(0));
632 if VKKeyCode = VK_UNKNOWN then
633 VKKeyCode := MacCodeToVK(KeyCode); // fallback
634 end
635 else
636 VKKeyCode := MacCodeToVK(KeyCode);
637
638 case VKKeyCode of
639 // for sure, these are "non-printable" keys (see http://wiki.lazarus.freepascal.org/LCL_Key_Handling)
640 VK_F1..VK_F24, // Function keys (F1-F12)
641 VK_PRINT, VK_SCROLL, VK_PAUSE, // Print Screen, Scroll Lock, Pause
642 VK_CAPITAL, VK_TAB, // Caps Lock, Tab
643 VK_INSERT, VK_DELETE, // Insert, Delete
644 VK_HOME, VK_END, // Home, End
645 VK_PRIOR,VK_NEXT, // Page Up,Down
646 VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN, // Arrow Keys
647 VK_NUMLOCK, // Num Lock
648 VK_SLEEP, VK_APPS // power/sleep, context menu
649 :
650 SendChar := false;
651
652 // for sure, these are "printable" keys
653 VK_ESCAPE,
654 VK_BACK,
655 VK_RETURN:
656 begin
657 SendChar := true;
658 KeyChar := char(VKKeyCode);
659 UTF8Character := KeyChar;
660 end;
661 else
662 //printable keys
663 //for these keys, send char or UTF8KeyPress
664 UTF8Character := NSStringToString(Event.characters);
665
666 if Length(UTF8Character) > 0 then
667 begin
668 SendChar := True;
669 if Length(UTF8Character)=1 then
670 // ANSI layout character
671 KeyChar := Utf8Character[1]
672 else
673 // it's non ANSI character. KeyChar must be assinged anything but #0
674 // otherise the message could be surpressed.
675 // In Windows world this would be an "Ansi" char in current locale
676 KeyChar := '?';
677 end;
678 end;
679
680 FillChar(_KeyMsg, SizeOf(_KeyMsg), 0);
681 _KeyMsg.KeyData := KeyData;
682 _KeyMsg.CharCode := VKKeyCode;
683 _SendChar := SendChar;
684 _IsSysKey := IsSysKey;
685 _IsKeyDown := (Event.type_ = NSKeyDown);
686
687 c:=0;
688 i:=1;
689 j:=0;
690 while (i<=length(UTF8Character)) and (j<length(_UTF8Character)) do
691 begin
692 c := Utf8CodePointLen(@UTF8Character[i], length(UTF8Character)-i+1, false);
693 if (j=0) and (c = length(UTF8Character)) then
694 begin
695 _UTF8Character[0] := UTF8Character;
696 j := 1;
697 break;
698 end
699 else if (c > 0) then
700 begin
701 _UTF8Character[j] := Copy(UTF8Character, i, c);
702 inc(i,c);
703 inc(j);
704 end else
705 break;
706 end;
707 if (j = 0) then _UTF8Character[0] := '';
708 _UTF8Charcount := j;
709
710 FillChar(_CharMsg, SizeOf(_CharMsg), 0);
711 _CharMsg.KeyData := _KeyMsg.KeyData;
712 _CharMsg.CharCode := ord(KeyChar);
713 end;
714
715 procedure TLCLCommonCallback.KeyEvBeforeDown;
716 var
717 i: integer;
718 lclHandled: Boolean;
719 begin
720 // create the CN_KEYDOWN message
721 if _IsSysKey then
722 _KeyMsg.Msg := CN_SYSKEYDOWN
723 else
724 _KeyMsg.Msg := CN_KEYDOWN;
725
726 // is the key combination help key (Cmd + ?)
727 if _SendChar and _IsSysKey and (_UTF8Character[0] = '?') then
728 Application.ShowHelpForObject(Target);
729
730 // widget can filter some keys from being send to cocoa control
731 //if Widget.FilterKeyPress(IsSysKey, UTF8Character) then Result := noErr;
732
733 //Send message to LCL
734 if _KeyMsg.CharCode <> VK_UNKNOWN then
735 begin
736 NotifyApplicationUserInput(Target, _KeyMsg.Msg);
737 if (DeliverMessage(_KeyMsg) <> 0) or (_KeyMsg.CharCode = VK_UNKNOWN) then
738 begin
739 // the LCL handled the key
740 KeyEvHandled;
741 Exit;
742 end;
743 end;
744
745 if (_SendChar) then begin
746 // send the UTF8 keypress
747 i := 0;
748 lclHandled := false;
749 for i := 0 to _UTF8Charcount -1 do
750 begin
751 lclHandled := false;
752 if Target.IntfUTF8KeyPress(_UTF8Character[i], 1, _IsSysKey) then
753 lclHandled := true;
754 end;
755
756 if lclHandled then
757 begin
758 // the LCL has handled the key
759 if ForceReturnKeyDown and (_KeyMsg.CharCode = VK_RETURN) then
760 _SendChar := False
761 else
762 KeyEvHandled;
763 Exit;
764 end;
765
766 //if OrigChar <> _UTF8Character then
767 //LCLCharToMacEvent(_UTF8Character);
768
769 // create the CN_CHAR / CN_SYSCHAR message
770 if _IsSysKey then
771 _CharMsg.Msg := CN_SYSCHAR
772 else
773 _CharMsg.Msg := CN_CHAR;
774
775 //Send message to LCL
776 if (DeliverMessage(_CharMsg) <> 0) or (_CharMsg.CharCode=VK_UNKNOWN) then
777 begin
778 // the LCL handled the key
779 KeyEvHandled;
780 Exit;
781 end;
782
783 //if _CharMsg.CharCode <> ord(_KeyChar) then
784 //LCLCharToMacEvent(Char(_CharMsg.CharCode));
785 end;
786
787 end;
788
789 procedure TLCLCommonCallback.KeyEvBeforeUp;
790 begin
791 if _IsSysKey then
792 _KeyMsg.Msg := CN_SYSKEYUP
793 else
794 _KeyMsg.Msg := CN_KEYUP;
795
796 //Send message to LCL
797 if _KeyMsg.CharCode <> VK_UNKNOWN then
798 begin
799 NotifyApplicationUserInput(Target, _KeyMsg.Msg);
800 if (DeliverMessage(_KeyMsg) <> 0) or (_KeyMsg.CharCode = VK_UNKNOWN) then
801 begin
802 // the LCL has handled the key
803 KeyEvHandled;
804 Exit;
805 end;
806 end;
807 end;
808
809 procedure TLCLCommonCallback.KeyEvAfterDown(out AllowCocoaHandle: boolean);
810 begin
811 AllowCocoaHandle := False;
812
813 if _KeyHandled then Exit;
814 KeyEvHandled;
815
816 // Send an LM_(SYS)KEYDOWN
817 if _KeyMsg.CharCode <> VK_UNKNOWN then
818 begin
819 if _IsSysKey then
820 _KeyMsg.Msg := LM_SYSKEYDOWN
821 else
822 _KeyMsg.Msg := LM_KEYDOWN;
823
824 if (DeliverMessage(_KeyMsg) <> 0) or (_KeyMsg.CharCode = VK_UNKNOWN) then
825 Exit;
826 end;
827
828 //Send an LM_(SYS)CHAR
829 if _SendChar then begin
830 if _IsSysKey then
831 _CharMsg.Msg := LM_SYSCHAR
832 else
833 _CharMsg.Msg := LM_CHAR;
834
835 if DeliverMessage(_CharMsg) <> 0 then
836 Exit;
837 end;
838
839 if BlockCocoaKeyBeep then
840 Exit;
841
842 AllowCocoaHandle := True;
843 end;
844
845 procedure TLCLCommonCallback.KeyEvAfterUp;
846 begin
847 if _KeyHandled then Exit;
848 KeyEvHandled;
849
850 //Send a LM_(SYS)KEYUP
851 if _IsSysKey then
852 _KeyMsg.Msg := LM_SYSKEYUP
853 else
854 _KeyMsg.Msg := LM_KEYUP;
855
856 if DeliverMessage(_KeyMsg) <> 0 then
857 begin
858 // the LCL handled the key
859 NotifyApplicationUserInput(Target, _KeyMsg.Msg);
860 Exit;
861 end;
862 end;
863
864 procedure TLCLCommonCallback.KeyEvBefore(Event: NSEvent;
865 out AllowCocoaHandle: boolean);
866 begin
867 _keyHandled := False;
868 AllowCocoaHandle := true;
869
870 if Event.type_ = NSFlagsChanged then
871 KeyEvFlagsChanged(Event)
872 else
873 KeyEvPrepare(Event);
874
875 if _IsKeyDown then begin
876 KeyEvBeforeDown;
877 if SuppressTabDown and (_KeyMsg.CharCode = VK_TAB) then
878 AllowCocoaHandle := false;
879 end else
880 KeyEvBeforeUp;
881
882 if _keyHandled then
883 AllowCocoaHandle := false;
884
885 // flagsChanged always needs to be passed on to Cocoa
886 if Event.type_ = NSFlagsChanged then
887 AllowCocoaHandle := true;
888 end;
889
890 procedure TLCLCommonCallback.KeyEvAfter;
891 var
892 AllowCocoaHandle: Boolean;
893 begin
894 if _IsKeyDown then KeyEvAfterDown(AllowCocoaHandle)
895 else KeyEvAfterUp;
896 end;
897
898 procedure TLCLCommonCallback.KeyEvHandled;
899 begin
900 _KeyHandled := True;
901 end;
902
903 procedure TLCLCommonCallback.SetTabSuppress(ASuppress: Boolean);
904 begin
905 SuppressTabDown := ASuppress;
906 end;
907
CanFocusnull908 function TLCLCommonCallback.CanFocus: Boolean;
909 begin
910 Result := not Assigned(Target) or not (csDesigning in Target.ComponentState);
911 end;
912
913 procedure TLCLCommonCallback.MouseClick;
914 begin
915 LCLSendClickedMsg(Target);
916 end;
917
isContextMenuEventnull918 function isContextMenuEvent(event: NSEvent): Boolean;
919 begin
920 Result := Assigned(event)
921 and (
922 (Event.type_ = NSRightMouseDown)
923 or(
924 (Event.type_ = NSLeftMouseDown)
925 and (event.modifierFlags_ and NSControlKeyMask <> 0)
926 and (event.clickCount = 1)
927 )
928 );
929 end;
930
TLCLCommonCallback.MouseUpDownEventnull931 function TLCLCommonCallback.MouseUpDownEvent(Event: NSEvent; AForceAsMouseUp: Boolean = False; AOverrideBlock: Boolean = False): Boolean;
932 const
933 MSGKINDUP: array[0..3] of Integer = (LM_LBUTTONUP, LM_RBUTTONUP, LM_MBUTTONUP, LM_XBUTTONUP);
934 var
935 Msg: TLMMouse;
936 MousePos: NSPoint;
937 MButton: NSInteger;
938 lCaptureControlCallback: ICommonCallback;
939 //Str: string;
940 lEventType: NSEventType;
941
942 bndPt, clPt, srchPt: TPoint; // clPt - is the one to send to LCL
943 // srchPt - is the one to use for each chidlren (clPt<>srchPt for TScrollBox)
944 menuHandled : Boolean;
945 mc: Integer; // modal counter
946 begin
947 if Assigned(Owner) and not NSObjectIsLCLEnabled(Owner) then
948 begin
949 Result := True; // Cocoa should not handle the message.
950 Exit; // LCL should not get the notification either, as the control is disabled.
951 end;
952
953 // If LCL control is provided and it's in designing state.
954 // The default resolution: Notify LCL about event, but don't let Cocoa
955 // do anything with it. (Result=true)
956 Result := Assigned(Target) and (csDesigning in Target.ComponentState);
957
958 lCaptureControlCallback := GetCaptureControlCallback();
959 //Str := (Format('MouseUpDownEvent Target=%s Self=%x CaptureControlCallback=%x', [Target.name, PtrUInt(Self), PtrUInt(lCaptureControlCallback)]));
960 if lCaptureControlCallback <> nil then
961 begin
962 FIsEventRouting:=true;
963 Result := lCaptureControlCallback.MouseUpDownEvent(Event, AForceAsMouseUp);
964 FIsEventRouting:=false;
965 exit;
966 end;
967
968 // The following check prevents the same event to be handled twice
969 // Because of the compositive nature of cocoa.
970 // For example NSTextField (TEdit) may contains NSTextView and BOTH
971 // will signal mouseDown when the field is selected by mouse the first time.
972 // In this case only 1 mouseDown should be passed to LCL
973 if (lastMouseDownUp = Event.timestamp) then begin
974 if not AForceAsMouseUp then Exit; // the same mouse event from a composite child
975 if lastMouseWithForce then Exit; // the same forced mouseUp event from a composite child
976 end;
977 lastMouseDownUp := Event.timestamp;
978 lastMouseWithForce := AForceAsMouseUp;
979
980
981 FillChar(Msg, SizeOf(Msg), #0);
982
983 MousePos := Event.locationInWindow;
984 OffsetMousePos(MousePos, bndPt, clPt, srchPt);
985
986 Msg.Keys := CocoaModifiersToKeyState(Event.modifierFlags) or CocoaPressedMouseButtonsToKeyState(NSEvent.pressedMouseButtons);
987
988 Msg.XPos := clPt.X;
989 Msg.YPos := clPt.Y;
990
991 MButton := event.buttonNumber;
992 if MButton >= 3 then
993 begin
994 // high word of XButton messages indicate the X button which is pressed
995 Msg.Keys := Msg.Keys or (MButton - 2) shl 16;
996 MButton := 3;
997 end;
998
999 lEventType := Event.type_;
1000 if AForceAsMouseUp then
1001 lEventType := NSLeftMouseUp;
1002
1003 Result := Result or (BlockCocoaUpDown and not AOverrideBlock);
1004 mc := CocoaWidgetSet.ModalCounter;
1005 case lEventType of
1006 NSLeftMouseDown,
1007 NSRightMouseDown,
1008 NSOtherMouseDown:
1009 begin
1010 Msg.Msg := CheckMouseButtonDownUp(TLCLIntfHandle(Owner),FTarget,LastMouse,
1011 FTarget.ClientToScreen(Point(Msg.XPos, Msg.YPos)),MButton+1,True);
1012
1013 case LastMouse.ClickCount of
1014 2: Msg.Keys := msg.Keys or MK_DOUBLECLICK;
1015 3: Msg.Keys := msg.Keys or MK_TRIPLECLICK;
1016 4: Msg.Keys := msg.Keys or MK_QUADCLICK;
1017 end;
1018
1019 NotifyApplicationUserInput(Target, Msg.Msg);
1020 DeliverMessage(Msg);
1021
1022 // TODO: Check if Cocoa has special context menu check event
1023 // it does (menuForEvent:), but it doesn't work all the time
1024 // http://sound-of-silence.com/?article=20150923
1025 if (GetTarget is TControl) and isContextMenuEvent(Event) then
1026 begin
1027 SendContextMenu(Event, menuHandled);
1028 if menuHandled then Result := true;
1029 end;
1030 end;
1031 NSLeftMouseUp,
1032 NSRightMouseUp,
1033 NSOtherMouseUp:
1034 begin
1035 Msg.Msg := CheckMouseButtonDownUp(TLCLIntfHandle(Owner),FTarget,LastMouse,
1036 FTarget.ClientToScreen(Point(Msg.XPos, Msg.YPos)),MButton+1,False);
1037 case LastMouse.ClickCount of
1038 2: Msg.Keys := msg.Keys or MK_DOUBLECLICK;
1039 3: Msg.Keys := msg.Keys or MK_TRIPLECLICK;
1040 4: Msg.Keys := msg.Keys or MK_QUADCLICK;
1041 end;
1042
1043 NotifyApplicationUserInput(Target, Msg.Msg);
1044 DeliverMessage(Msg);
1045 end;
1046 end;
1047
1048 if mc <> CocoaWidgetSet.ModalCounter then
1049 begin
1050 // showing of a modal window is causing "mouse" event to be lost.
1051 // so, preventing Cocoa from handling it
1052 Result := true;
1053 Exit;
1054 end;
1055
1056 //debugln('MouseUpDownEvent:'+DbgS(Msg.Msg)+' Target='+Target.name+);
1057 if not Result then
1058 //Result := Result or (BlockCocoaUpDown and not AOverrideBlock);
1059 case lEventType of
1060 NSLeftMouseDown,
1061 NSRightMouseDown,
1062 NSOtherMouseDown:
1063 TrackedControl := Owner;
1064 NSLeftMouseUp,
1065 NSRightMouseUp,
1066 NSOtherMouseUp:
1067 begin
1068 if TrackedControl = Owner then TrackedControl := nil;
1069 if lEventType = NSLeftMouseUp then
1070 BlockCocoaMouseMove := false;
1071 end;
1072 end;
1073 end;
1074
MouseMovenull1075 function TLCLCommonCallback.MouseMove(Event: NSEvent): Boolean;
1076 var
1077 Msg: TLMMouseMove;
1078 MousePos: NSPoint;
1079 i: integer;
1080 rect: TRect;
1081 //mp: TPoint;
1082 obj: NSObject;
1083 callback: ICommonCallback;
1084 targetControl: TWinControl;
1085 childControl:TWinControl;
1086 bndPt, clPt: TPoint;
1087 MouseTargetLookup: Boolean;
1088 srchPt: TPoint;
1089 begin
1090 if Assigned(Owner) and not NSObjectIsLCLEnabled(Owner) then
1091 begin
1092 Result := True; // Cocoa should not handle the message.
1093 Exit; // LCL should get the notification either.
1094 end;
1095
1096 // If LCL control is provided and it's in designing state.
1097 // The default resolution: Notify LCL about event, but don't let Cocoa
1098 // do anything with it. (Result=true)
1099 Result := Assigned(Target) and (csDesigning in Target.ComponentState);
1100
1101 MousePos := Event.locationInWindow;
1102 OffsetMousePos(MousePos, bndPt, clPt, srchPt);
1103
1104 // For "dragged" events, the same "Target" should be used
1105 MouseTargetLookup := Event.type_ = NSMouseMoved;
1106
1107 if MouseTargetLookup then
1108 begin
1109 rect:=Owner.lclClientFrame;
1110 targetControl:=nil;
1111
1112 callback := GetCaptureControlCallback();
1113 if callback <> nil then
1114 begin
1115 FIsEventRouting:=true;
1116 Result := callback.MouseMove(Event);
1117 FIsEventRouting:=false;
1118 exit;
1119 end
1120 else
1121 begin
1122 rect:=Target.BoundsRect;
1123 OffsetRect(rect, -rect.Left, -rect.Top);
1124 if (event.type_ = NSMouseMoved) and (not Types.PtInRect(rect, bndPt)) then
1125 begin
1126 // do not send negative coordinates (unless dragging mouse)
1127 Exit;
1128 end;
1129
1130 if assigned(Target.Parent) and not Types.PtInRect(rect, bndPt) then
1131 targetControl:=Target.Parent // outside myself then route to parent
1132 else
1133 for i:=Target.ControlCount-1 downto 0 do // otherwise check, if over child and route to child
1134 if Target.Controls[i] is TWinControl then
1135 begin
1136 childControl:=TWinControl(Target.Controls[i]);
1137 rect:=childControl.BoundsRect;
1138 if Types.PtInRect(rect, srchPt) and childControl.Visible and childControl.Enabled then
1139 begin
1140 targetControl:=childControl;
1141 break;
1142 end;
1143 end;
1144 end;
1145
1146 if assigned(targetControl) and not FIsEventRouting then
1147 begin
1148 if not targetControl.HandleAllocated then Exit; // Fixes crash due to events being sent after ReleaseHandle
1149 FIsEventRouting:=true;
1150 //debugln(Target.name+' -> '+targetControl.Name+'- is parent:'+dbgs(targetControl=Target.Parent)+' Point: '+dbgs(br)+' Rect'+dbgs(rect));
1151 obj := NSObject(targetControl.Handle).lclContentView;
1152 if obj = nil then Exit;
1153 callback := obj.lclGetCallback;
1154 if callback = nil then Exit; // Avoids crashes
1155 result := callback.MouseMove(Event);
1156 FIsEventRouting := false;
1157 exit;
1158 end;
1159
1160 if (Event.type_ = NSMouseMoved) and Owner.lclIsMouseInAuxArea(Event) then
1161 begin
1162 // mouse is over auxillary area that's "blind" to mouse moves
1163 // even though the mouse cursos is within the control bounds.
1164 // (i.e. scrollbars)
1165 Result := false;
1166 Exit;
1167 end;
1168 end;
1169
1170 // debugln('Send to: '+Target.name+' Point: '+dbgs(mp));
1171
1172 FillChar(Msg, SizeOf(Msg), #0);
1173 Msg.Msg := LM_MOUSEMOVE;
1174 Msg.Keys := CocoaModifiersToKeyState(Event.modifierFlags) or CocoaPressedMouseButtonsToKeyState(NSEvent.pressedMouseButtons);
1175 Msg.XPos := clPt.X;
1176 Msg.YPos := clPt.Y;
1177
1178 //debugln('MouseMove x='+dbgs(MousePos.X)+' y='+dbgs(MousePos.Y)+' Target='+Target.Name);
1179
1180 NotifyApplicationUserInput(Target, Msg.Msg);
1181 Result := DeliverMessage(Msg) <> 0;
1182 if BlockCocoaMouseMove then Result := true;
1183 end;
1184
scrollWheelnull1185 function TLCLCommonCallback.scrollWheel(Event: NSEvent): Boolean;
1186 var
1187 Msg: TLMMouseEvent;
1188 MousePos: NSPoint;
1189 MButton: NSInteger;
1190 bndPt, clPt, srchPt: TPoint;
1191 dx,dy: double;
1192 isPrecise: Boolean;
1193 const
1194 WheelDeltaToLCLY = 1200; // the basic (one wheel-click) is 0.1 on cocoa
1195 WheelDeltaToLCLX = 1200; // the basic (one wheel-click) is 0.1 on cocoa
1196 LCLStep = 120;
1197 begin
1198 Result := False; // allow cocoa to handle message
1199
1200 if Assigned(Target)
1201 and not (csDesigning in Target.ComponentState)
1202 and not NSObjectIsLCLEnabled(Owner) then
1203 Exit;
1204
1205 MousePos := Event.locationInWindow;
1206 OffsetMousePos(MousePos, bndPt, clPt, srchPt);
1207
1208 MButton := event.buttonNumber;
1209 if MButton >= 3 then
1210 MButton := 3;
1211
1212 FillChar(Msg, SizeOf(Msg), #0);
1213
1214 Msg.Button := MButton;
1215 Msg.X := round(clPt.X);
1216 Msg.Y := round(clPt.Y);
1217 Msg.State := CocoaModifiersToShiftState(Event.modifierFlags, NSEvent.pressedMouseButtons);
1218
1219 if NSAppKitVersionNumber >= NSAppKitVersionNumber10_7 then
1220 begin
1221 isPrecise := event.hasPreciseScrollingDeltas;
1222 dx := event.scrollingDeltaX;
1223 dy := event.scrollingDeltaY;
1224 end else
1225 begin
1226 isPrecise := false;
1227 dx := event.deltaX;
1228 dy := event.deltaY;
1229 end;
1230
1231 // Some info on event.deltaY can be found here:
1232 // https://developer.apple.com/library/mac/releasenotes/AppKit/RN-AppKitOlderNotes/
1233 // It says that deltaY=1 means 1 line, and in the LCL 1 line is 120
1234 if dy <> 0 then
1235 begin
1236 Msg.Msg := LM_MOUSEWHEEL;
1237 if isPrecise then
1238 Msg.WheelDelta := Round(dy * LCLStep)
1239 else
1240 Msg.WheelDelta := sign(dy) * LCLStep;
1241 end
1242 else
1243 if dx <> 0 then
1244 begin
1245 Msg.Msg := LM_MOUSEHWHEEL;
1246 // see "deltaX" documentation.
1247 // on macOS: -1 = right, +1 = left
1248 // on LCL: -1 = left, +1 = right
1249 if isPrecise then
1250 Msg.WheelDelta := Round(-dx * LCLStep)
1251 else
1252 Msg.WheelDelta := sign(-dx) * LCLStep;
1253 end
1254 else
1255 // Filter out empty events - See bug 28491
1256 Exit;
1257
1258 NotifyApplicationUserInput(Target, Msg.Msg);
1259 Result := DeliverMessage(Msg) <> 0;
1260 end;
1261
1262 procedure TLCLCommonCallback.frameDidChange(sender: id);
1263 begin
1264 boundsDidChange(sender);
1265 end;
1266
1267 procedure TLCLCommonCallback.boundsDidChange(sender: id);
1268 var
1269 NewBounds, OldBounds: TRect;
1270 PosMsg: TLMWindowPosChanged;
1271 Resized, Moved, ClientResized: Boolean;
1272 SizeType: Integer;
1273 begin
1274 NewBounds := HandleFrame.lclFrame;
1275
1276 //debugln('Newbounds='+ dbgs(newbounds));
1277 // send window pos changed
1278 PosMsg.Msg := LM_WINDOWPOSCHANGED;
1279 PosMsg.Result := 0;
1280 New(PosMsg.WindowPos);
1281 try
1282 with PosMsg.WindowPos^ do
1283 begin
1284 hWndInsertAfter := 0;
1285 x := NewBounds.Left;
1286 y := NewBounds.Right;
1287 cx := NewBounds.Right - NewBounds.Left;
1288 cy := NewBounds.Bottom - NewBounds.Top;
1289 flags := 0;
1290 end;
1291 LCLMessageGlue.DeliverMessage(Target, PosMsg);
1292 finally
1293 Dispose(PosMsg.WindowPos);
1294 end;
1295
1296 OldBounds := Target.BoundsRect;
1297 //debugln('OldBounds Target='+Target.Name+':'+ dbgs(OldBounds));
1298
1299 Resized :=
1300 (OldBounds.Right - OldBounds.Left <> NewBounds.Right - NewBounds.Left) or
1301 (OldBounds.Bottom - OldBounds.Top <> NewBounds.Bottom - NewBounds.Top);
1302
1303 Moved :=
1304 (OldBounds.Left <> NewBounds.Left) or
1305 (OldBounds.Top <> NewBounds.Top);
1306
1307 ClientResized := (sender <> HandleFrame)
1308 and not EqualRect(Target.ClientRect, HandleFrame.lclClientFrame);
1309
1310 // update client rect
1311 if ClientResized or Resized or Target.ClientRectNeedsInterfaceUpdate then
1312 begin
1313 Target.InvalidateClientRectCache(false);
1314 ClientResized := True;
1315 end;
1316
1317 // then send a LM_SIZE message
1318 if Resized or ClientResized then
1319 begin
1320 LCLSendSizeMsg(Target, Max(NewBounds.Right - NewBounds.Left,0),
1321 Max(NewBounds.Bottom - NewBounds.Top,0), Owner.lclWindowState, True);
1322 end;
1323
1324 // then send a LM_MOVE message
1325 if Moved then
1326 begin
1327 LCLSendMoveMsg(Target, NewBounds.Left,
1328 NewBounds.Top, Move_SourceIsInterface);
1329 end;
1330
1331 if not FBoundsReportedToChildren then // first time we need this to update non cocoa based client rects
1332 begin
1333 Target.InvalidateClientRectCache(true);
1334 FBoundsReportedToChildren:=true;
1335 end;
1336
1337 end;
1338
1339 procedure TLCLCommonCallback.BecomeFirstResponder;
1340 begin
1341 if not Assigned(Target) then Exit;
1342 // LCL is unable to determine the "already focused" message
1343 // thus Cocoa related code is doing that.
1344 //if not Target.Focused then
1345 LCLSendSetFocusMsg(Target);
1346 end;
1347
1348 procedure TLCLCommonCallback.ResignFirstResponder;
1349 begin
1350 if not Assigned(Target) then Exit;
1351 LCLSendKillFocusMsg(Target);
1352 end;
1353
1354 procedure TLCLCommonCallback.DidBecomeKeyNotification;
1355 begin
1356 if not Assigned(Target) then Exit;
1357 LCLSendActivateMsg(Target, WA_ACTIVE, false);
1358 LCLSendSetFocusMsg(Target);
1359 end;
1360
1361 procedure TLCLCommonCallback.DidResignKeyNotification;
1362 begin
1363 if not Assigned(Target) then Exit;
1364 LCLSendActivateMsg(Target, WA_INACTIVE, false);
1365 LCLSendKillFocusMsg(Target);
1366 end;
1367
1368 procedure TLCLCommonCallback.SendOnChange;
1369 begin
1370 if not Assigned(Target) then Exit;
1371 SendSimpleMessage(Target, LM_CHANGED);
1372 end;
1373
1374 procedure TLCLCommonCallback.SendOnTextChanged;
1375 begin
1376 if not Assigned(Target) then Exit;
1377 SendSimpleMessage(Target, CM_TEXTCHANGED);
1378 end;
1379
1380 procedure TLCLCommonCallback.scroll(isVert: Boolean; Pos: Integer;
1381 AScrollPart: NSScrollerPart);
1382 var
1383 LMScroll: TLMScroll;
1384 b: Boolean;
1385 lclCode: Integer;
1386 begin
1387 FillChar(LMScroll{%H-}, SizeOf(LMScroll), #0);
1388 //todo: this should be a part of a parameter
1389 //LMScroll.ScrollBar := Target.Handle;
1390
1391 if IsVert then
1392 LMScroll.Msg := LM_VSCROLL
1393 else
1394 LMScroll.Msg := LM_HSCROLL;
1395
1396 LMScroll.Pos := Pos;
1397 case AScrollPart of
1398 NSScrollerDecrementPage: lclCode := SB_PAGELEFT;
1399 NSScrollerIncrementPage: lclCode := SB_PAGERIGHT;
1400 NSScrollerDecrementLine: lclCode := SB_LINELEFT;
1401 NSScrollerIncrementLine: lclCode := SB_LINERIGHT;
1402 else
1403 lclCode := SB_THUMBPOSITION;
1404 end;
1405 LMScroll.ScrollCode := lclCode; //SIF_POS;
1406
1407 LCLMessageGlue.DeliverMessage(Target, LMScroll);
1408 end;
1409
TLCLCommonCallback.DeliverMessagenull1410 function TLCLCommonCallback.DeliverMessage(var Msg): LRESULT;
1411 begin
1412 if Assigned(Target) then
1413 Result := LCLMessageGlue.DeliverMessage(Target, Msg)
1414 else
1415 Result := 0;
1416 end;
1417
TLCLCommonCallback.DeliverMessagenull1418 function TLCLCommonCallback.DeliverMessage(Msg: Cardinal; WParam: WParam; LParam: LParam): LResult;
1419 var
1420 Message: TLMessage;
1421 begin
1422 Message.Msg := Msg;
1423 Message.WParam := WParam;
1424 Message.LParam := LParam;
1425 Message.Result := 0;
1426 Result := DeliverMessage(Message);
1427 end;
1428
1429 procedure TLCLCommonCallback.Draw(ControlContext: NSGraphicsContext;
1430 const bounds, dirty: NSRect);
1431 var
1432 PS: TPaintStruct;
1433 nsr:NSRect;
1434 begin
1435 // todo: think more about draw call while previous draw still active
1436 if Assigned(FContext) then
1437 Exit;
1438 FContext := TCocoaContext.Create(ControlContext);
1439 FContext.isControlDC := True;
1440 try
1441 // debugln('Draw '+Target.name+' bounds='+Dbgs(NSRectToRect(bounds))+' dirty='+Dbgs(NSRectToRect(dirty)));
1442 if FContext.InitDraw(Round(bounds.size.width), Round(bounds.size.height)) then
1443 begin
1444 nsr:=dirty;
1445 nsr.origin.y:=bounds.size.height-dirty.origin.y-dirty.size.height;
1446
1447 if FIsOpaque and (Target.Color<>clDefault) then
1448 begin
1449 FContext.BkMode:=OPAQUE;
1450 FContext.BkColor:=Target.Color;
1451 FContext.BackgroundFill(nsr);
1452 //debugln('Background '+Target.name+Dbgs(NSRectToRect(dirty)));
1453 end;
1454
1455 FillChar(PS, SizeOf(TPaintStruct), 0);
1456 PS.hdc := HDC(FContext);
1457 PS.rcPaint := NSRectToRect(nsr);
1458 LCLSendPaintMsg(Target, HDC(FContext), @PS);
1459 if FHasCaret then
1460 DrawCaret;
1461 end;
1462 finally
1463 FreeAndNil(FContext);
1464 end;
1465 end;
1466
1467 procedure TLCLCommonCallback.DrawBackground(ctx: NSGraphicsContext; const bounds, dirtyRect: NSRect);
1468 var
1469 lTarget: TWinControl;
1470 begin
1471 // Implement Color property
1472 lTarget := TWinControl(GetTarget());
1473 if (lTarget.Color <> clDefault) and (lTarget.Color <> clBtnFace) then
1474 begin
1475 ColorToNSColor(ColorToRGB(lTarget.Color)).set_();
1476 NSRectFill(dirtyRect);
1477 end;
1478 end;
1479
1480 procedure TLCLCommonCallback.DrawOverlay(ControlContext: NSGraphicsContext;
1481 const bounds, dirty: NSRect);
1482 var
1483 PS : TPaintStruct;
1484 nsr : NSRect;
1485 begin
1486 // todo: think more about draw call while previous draw still active
1487 if Assigned(FContext) then
1488 Exit;
1489 FContext := TCocoaContext.Create(ControlContext);
1490 FContext.isControlDC := True;
1491 FContext.isDesignDC := True;
1492 try
1493 // debugln('Draw '+Target.name+' bounds='+Dbgs(NSRectToRect(bounds))+' dirty='+Dbgs(NSRectToRect(dirty)));
1494 if FContext.InitDraw(Round(bounds.size.width), Round(bounds.size.height)) then
1495 begin
1496 nsr:=dirty;
1497 nsr.origin.y:=bounds.size.height-dirty.origin.y-dirty.size.height;
1498
1499 FillChar(PS, SizeOf(TPaintStruct), 0);
1500 PS.hdc := HDC(FContext);
1501 PS.rcPaint := NSRectToRect(nsr);
1502 LCLSendPaintMsg(Target, HDC(FContext), @PS);
1503 end;
1504 finally
1505 FreeAndNil(FContext);
1506 end;
1507 end;
1508
ResetCursorRectsnull1509 function TLCLCommonCallback.ResetCursorRects: Boolean;
1510 var
1511 ACursor: TCursor;
1512 View: NSView;
1513 cr:TCocoaCursor;
1514 begin
1515 Result := False;
1516 View := HandleFrame.lclContentView;
1517 if View = nil then Exit;
1518 if not Assigned(Target) then Exit;
1519 if not (csDesigning in Target.ComponentState) then
1520 begin
1521 ACursor := Screen.RealCursor;
1522 if ACursor = crDefault then
1523 begin
1524 // traverse visible child controls
1525 ACursor := Target.Cursor;
1526 end;
1527 Result := ACursor <> crDefault;
1528 if Result then
1529 begin
1530 cr:=TCocoaCursor(Screen.Cursors[ACursor]);
1531 if assigned(cr) then
1532 View.addCursorRect_cursor(View.visibleRect, cr.Cursor);
1533 end;
1534 end;
1535 end;
1536
1537 procedure TLCLCommonCallback.RemoveTarget;
1538 begin
1539 FTarget := nil;
1540 end;
1541
1542 procedure TLCLCommonCallback.InputClientInsertText(const utf8: string);
1543 var
1544 i : integer;
1545 c : integer;
1546 ch : TUTF8Char;
1547 begin
1548 if (utf8 = '') then Exit;
1549 i:=1;
1550 while (i<=length(utf8)) do
1551 begin
1552 c := Utf8CodePointLen(@utf8[i], length(utf8)-i+1, false);
1553 ch := Copy(utf8, 1, c);
1554 FTarget.IntfUTF8KeyPress(ch, 1, false);
1555 inc(i, c);
1556 end;
1557
1558 end;
1559
TLCLCommonCallback.GetIsOpaquenull1560 function TLCLCommonCallback.GetIsOpaque: Boolean;
1561 begin
1562 Result:= FIsOpaque;
1563 end;
1564
1565 procedure TLCLCommonCallback.SetIsOpaque(AValue: Boolean);
1566 begin
1567 FIsOpaque:=AValue;
1568 end;
1569
TLCLCommonCallback.GetShouldBeEnablednull1570 function TLCLCommonCallback.GetShouldBeEnabled: Boolean;
1571 begin
1572 Result := Assigned(FTarget) and FTarget.Enabled;
1573 end;
1574
1575 { TCocoaWSControl }
1576
TCocoaWSControl.GetCanvasScaleFactornull1577 class function TCocoaWSControl.GetCanvasScaleFactor(const AControl: TControl
1578 ): Double;
1579 begin
1580 if Assigned(AControl.Parent) then
1581 Result := AControl.Parent.GetCanvasScaleFactor
1582 else
1583 Result := 1;
1584 end;
1585
1586 { TCocoaWSWinControl }
1587
TCocoaWSWinControl.CreateHandlenull1588 class function TCocoaWSWinControl.CreateHandle(const AWinControl: TWinControl;
1589 const AParams: TCreateParams): TLCLIntfHandle;
1590 begin
1591 Result := TCocoaWSCustomControl.CreateHandle(AWinControl, AParams);
1592 end;
1593
1594 class procedure TCocoaWSWinControl.DestroyHandle(const AWinControl: TWinControl);
1595 var
1596 obj: NSObject;
1597 Callback: ICommonCallback;
1598 CallbackObject: TObject;
1599 begin
1600 if not AWinControl.HandleAllocated then
1601 Exit;
1602
1603 if Assigned(CocoaWidgetSet) and (AWinControl.Handle = CocoaWidgetSet.GetCapture) then
1604 CocoaWidgetSet.ReleaseCapture;
1605
1606 obj := NSObject(AWinControl.Handle);
1607 if obj.isKindOfClass_(NSView) then
1608 begin
1609 // no need to "retain" prior to "removeFromSuperview"
1610 // the original referecnce count with "alloc" is not being released
1611 // after "addToSuperview"
1612 NSView(obj).removeFromSuperview;
1613 end
1614 else
1615 if obj.isKindOfClass_(NSWindow) then
1616 NSWindow(obj).close;
1617
1618 // destroy the callback
1619 Callback := obj.lclGetCallback;
1620 if Assigned(Callback) then
1621 begin
1622 if Callback.HasCaret then DestroyCaret(nil);
1623 CallbackObject := Callback.GetCallbackObject;
1624 Callback.RemoveTarget;
1625 Callback := nil;
1626 obj.lclClearCallback;
1627 // Do not free the callback object here. It might be processing an event
1628 // and is performing a self destruction. Thus there might be a code performing
1629 // even after DestroyHandle() was called. The destruction needs to be delayed
1630 // until after the event processing is done
1631 CocoaWidgetSet.AddToCollect(CallbackObject);
1632 end;
1633 obj.release;
1634 end;
1635
TCocoaWSWinControl.GetCanvasScaleFactornull1636 class function TCocoaWSWinControl.GetCanvasScaleFactor(const AControl: TControl
1637 ): Double;
1638 var
1639 obj: NSObject;
1640 win: NSWindow;
1641 begin
1642 win := nil;
1643 Result := 1;
1644
1645 if TWinControl(AControl).HandleAllocated then
1646 begin
1647 obj := NSObject(TWinControl(AControl).Handle);
1648 if obj.isKindOfClass_(NSView) then
1649 win := NSView(obj).window
1650 else if obj.isKindOfClass_(NSWindow) then
1651 win := NSWindow(obj);
1652 end;
1653
1654 if Assigned(win) then
1655 begin
1656 if win.respondsToSelector( ObjCSelector('backingScaleFactor')) then
1657 Result := win.backingScaleFactor
1658 else if win.respondsToSelector( ObjCSelector('userSpaceScaleFactor')) then // for older OSX
1659 Result := win.userSpaceScaleFactor;
1660 end;
1661 end;
1662
1663 class procedure TCocoaWSWinControl.SetText(const AWinControl: TWinControl; const AText: String);
1664 var
1665 obj: NSObject;
1666 begin
1667 if not AWinControl.HandleAllocated then
1668 Exit;
1669 obj := NSObject(AWinControl.Handle);
1670 if obj.isKindOfClass_(NSControl) then
1671 SetNSControlValue(NSControl(obj), AText);
1672 end;
1673
TCocoaWSWinControl.GetTextnull1674 class function TCocoaWSWinControl.GetText(const AWinControl: TWinControl; var AText: String): Boolean;
1675 var
1676 obj: NSObject;
1677 begin
1678 Result := AWinControl.HandleAllocated;
1679 if not Result then
1680 Exit;
1681 obj := NSObject(AWinControl.Handle);
1682 Result := obj.isKindOfClass_(NSControl);
1683 if Result then
1684 AText := GetNSControlValue(NSControl(obj));
1685 end;
1686
TCocoaWSWinControl.GetTextLennull1687 class function TCocoaWSWinControl.GetTextLen(const AWinControl: TWinControl; var ALength: Integer): Boolean;
1688 var
1689 obj: NSObject;
1690 s: NSString;
1691 begin
1692 Result := AWinControl.HandleAllocated;
1693 if not Result then
1694 Exit;
1695
1696 obj := NSObject(AWinControl.Handle);
1697 Result := obj.isKindOfClass_(NSControl);
1698 if not Result then Exit;
1699
1700 s := NSControl(obj).stringValue;
1701 if Assigned(s) then
1702 ALength := s.length
1703 else
1704 ALength := 0
1705 end;
1706
TCocoaWSWinControl.GetClientBoundsnull1707 class function TCocoaWSWinControl.GetClientBounds(const AWincontrol: TWinControl; var ARect: TRect): Boolean;
1708 begin
1709 Result := AWinControl.HandleAllocated;
1710 if Result then
1711 ARect := NSObject(AWinControl.Handle).lclClientFrame;
1712 end;
1713
TCocoaWSWinControl.GetClientRectnull1714 class function TCocoaWSWinControl.GetClientRect(const AWincontrol: TWinControl; var ARect: TRect): Boolean;
1715 begin
1716 Result:=(AWinControl.Handle<>0);
1717 if not Result then Exit;
1718 ARect:=NSObject(AWinControl.Handle).lclClientFrame;
1719 if (ARect.Left<>0) or (ARect.Top<>0) then
1720 OffsetRect(ARect, -ARect.Left, -ARect.Top);
1721 end;
1722
1723 class procedure TCocoaWSWinControl.GetPreferredSize(
1724 const AWinControl: TWinControl; var PreferredWidth, PreferredHeight: integer;
1725 WithThemeSpace: Boolean);
1726 var
1727 lView: NSView;
1728 Size: NSSize;
1729 r: TRect;
1730 begin
1731 if not AWinControl.HandleAllocated then Exit;
1732
1733 lView := NSObject(AWinControl.Handle).lclContentView;
1734 if lView = nil then Exit;
1735
1736 //todo: using fittingSize is wrong - it's based on constraints of the control solely.
1737 //CocoaWidgetset is not using these constrains. As a result, CocoaComboBox
1738 //produces wrong size: width 3 and height 26 (or OSX 10.9)
1739 //as well as SpinEdit itself. The better approach is to use intrinsicContentSize method.
1740 // Felipe: intrinsicContentSize doesn't give any better results in my tests, it results in even smaller controls
1741 if lView.respondsToSelector(objcselector('fittingSize')) then // fittingSize is 10.7+
1742 begin
1743 Size := lView.fittingSize();
1744 r := lview.lclGetFrameToLayoutDelta;
1745 PreferredWidth := Round(Size.width) - r.Left + r.Right;
1746 PreferredHeight := Round(Size.height) - r.Top + r.Bottom;
1747 end;
1748 end;
1749
1750 class procedure TCocoaWSWinControl.SetBounds(const AWinControl: TWinControl;
1751 const ALeft, ATop, AWidth, AHeight: Integer);
1752 var
1753 cb : ICommonCallBack;
1754 r : TRect;
1755 begin
1756 if AWinControl.HandleAllocated then
1757 begin
1758 {$IFDEF COCOA_DEBUG_SETBOUNDS}
1759 writeln(Format('TCocoaWSWinControl.SetBounds: %s Bounds=%s',
1760 [AWinControl.Name, dbgs(Bounds(ALeft, ATop, AWidth, AHeight))]));
1761 {$ENDIF}
1762 NSObject(AWinControl.Handle).lclSetFrame(Bounds(ALeft, ATop, AWidth, AHeight));
1763 end;
1764 end;
1765
1766 class procedure TCocoaWSWinControl.SetCursor(const AWinControl: TWinControl;
1767 const ACursor: HCursor);
1768 begin
1769 //debugln('SetCursor '+AWinControl.name+' '+dbgs(ACursor));
1770 if CocoaWidgetSet.CurrentCursor<>ACursor then
1771 begin
1772 CocoaWidgetSet.CurrentCursor:= ACursor;
1773
1774 if ACursor<>0 then
1775 TCocoaCursor(ACursor).SetCursor
1776 else
1777 TCocoaCursor.SetDefaultCursor;
1778 end;
1779 end;
1780
1781 type
1782 NSFontSetter = objccategory external(NSObject)
1783 procedure setFont(afont: NSFont); message 'setFont:';
1784 procedure setTextColor(clr: NSColor); message 'setTextColor:';
1785 end;
1786
1787 class procedure TCocoaWSWinControl.SetFont(const AWinControl: TWinControl; const AFont: TFont);
1788 var
1789 Obj: NSObject;
1790 Cell: NSCell;
1791 Str: NSAttributedString;
1792 NewStr: NSMutableAttributedString;
1793 Range: NSRange;
1794 begin
1795 if not (AWinControl.HandleAllocated) then Exit;
1796
1797 Obj := NSObject(AWinControl.Handle).lclContentView;
1798
1799 if Obj.respondsToSelector(ObjCSelector('setFont:')) then
1800 Obj.setFont(TCocoaFont(AFont.Reference.Handle).Font);
1801
1802 if Obj.respondsToSelector(ObjCSelector('setTextColor:')) then
1803 begin
1804 if AFont.Color = clDefault then
1805 Obj.setTextColor(NSColor.controlTextColor)
1806 else
1807 Obj.setTextColor(ColorToNSColor(ColorToRGB(AFont.Color)));
1808 end;
1809 end;
1810
1811 class procedure TCocoaWSWinControl.SetColor(const AWinControl: TWinControl);
1812 begin
1813 invalidate(AWinControl);
1814 end;
1815
indexInListnull1816 function indexInList(ctrl: id; l: TFPList): integer;
1817 var
1818 i : integer;
1819 begin
1820 for i:=0 to l.Count-1 do
1821 if PtrUInt(TWinControl(l[i]).Handle)=PtrUInt(ctrl) then
1822 begin
1823 Result:=i;
1824 exit;
1825 end;
1826 Result:=-1;
1827 end;
1828
SortHandlesnull1829 function SortHandles(param1: id; param2: id; param3: Pointer): NSComparisonResult; cdecl;
1830 var
1831 i1,i2: integer;
1832 begin
1833 i1:=indexInList(param1, TFPList(param3));
1834 i2:=indexInList(param2, TFPList(param3));
1835 if i1<i2 then Result:=NSOrderedDescending
1836 else if i1>i2 then Result:=NSOrderedAscending
1837 else Result:=NSOrderedSame;
1838 end;
1839
1840 class procedure TCocoaWSWinControl.SetChildZPosition(const AWinControl,
1841 AChild: TWinControl; const AOldPos, ANewPos: Integer; const AChildren: TFPList
1842 );
1843 var
1844 pr : NSView;
1845 ch : NSView;
1846 ab : NSView;
1847 c : TObject;
1848 i : integer;
1849 begin
1850 if (not AWinControl.HandleAllocated) or (not AChild.HandleAllocated) then Exit;
1851
1852 pr := NSView(AWinControl.Handle).lclContentView;
1853
1854 //todo: sorting might be a better option than removing / adding a view
1855 // (whenever a focused (firstrepsonder view) is moved to front, focus is lost.
1856 // if that's not the case for sorting, then sorting *must* be used
1857 // current problem, is that during sorting a new order needs to be determined
1858 // (the desired order is given in AChildren list).
1859 // however, on every comparison, an index must be searched withing a list.
1860 // and that might be very slow! (if a lot of sibling controls is present)
1861 // instead of a search, it's beter to store the desired sorting order with a view
1862 // itself. However, that requires adding additional methods lclSetNewOrder and lclGetNewOrder
1863 //
1864 //pr.sortSubviewsUsingFunction_context(@SortHandles, AChildren);
1865 //
1866 // if sorting is used, all code below is not needed
1867
1868 ch:=NSView(AChild.Handle);
1869
1870 // The way of changing the order in an array of views
1871 // is to remove a view and then reinstert it at the new spot
1872 ch.retain();
1873 try
1874 ch.removeFromSuperview();
1875 if ANewPos=0 then
1876 begin
1877 pr.addSubview_positioned_relativeTo(ch, NSWindowBelow, nil)
1878 end
1879 else
1880 begin
1881 i:=AChildren.Count-ANewPos;
1882 c:=TObject(AChildren[i]);
1883 if c is TWinControl then
1884 begin
1885 c:=TObject(AChildren[i]);
1886 ab:=NSView(TWinControl(c).Handle);
1887 end
1888 else
1889 ab:=nil;
1890 pr.addSubview_positioned_relativeTo(ch, NSWindowAbove, ab);
1891 end;
1892 finally
1893 ch.release();
1894 end;
1895
1896 //NSView(AChild.Handle).moveDown
1897 //inherited SetChildZPosition(AWinControl, AChild, AOldPos, ANewPos, AChildren);
1898 end;
1899
1900 class procedure TCocoaWSWinControl.ShowHide(const AWinControl: TWinControl);
1901 var
1902 lShow: Boolean;
1903 begin
1904 //WriteLn(Format('[TCocoaWSWinControl.ShowHide] AWinControl=%s %s', [AWinControl.Name, AWinControl.ClassName]));
1905 if AWinControl.HandleAllocated then
1906 begin
1907 lShow := AWinControl.HandleObjectShouldBeVisible;
1908
1909 NSObject(AWinControl.Handle).lclSetVisible(lShow);
1910 end;
1911 end;
1912
1913 class procedure TCocoaWSWinControl.Invalidate(const AWinControl: TWinControl);
1914 begin
1915 if AWinControl.HandleAllocated then
1916 NSObject(AWinControl.Handle).lclInvalidate;
1917 end;
1918
1919 class procedure TCocoaWSWinControl.PaintTo(const AWinControl: TWinControl;
1920 ADC: HDC; X, Y: Integer);
1921 var
1922 bc : TCocoaBitmapContext;
1923 v : NSView;
1924 b : NSBitmapImageRep;
1925 obj : NSObject;
1926 f : NSRect;
1927 begin
1928 if not (TObject(ADC) is TCocoaBitmapContext) then Exit;
1929 if not NSObject(AWinControl.Handle).isKindOfClass(NSView) then Exit;
1930 bc := TCocoaBitmapContext(ADC);
1931 v := NSView(AWinControl.Handle);
1932 f := v.frame;
1933 f.origin.x := 0;
1934 f.origin.y := 0;
1935
1936 b := v.bitmapImageRepForCachingDisplayInRect(f);
1937
1938 v.cacheDisplayInRect_toBitmapImageRep(f, b);
1939 bc.DrawImageRep(
1940 NSMakeRect(0,0, f.size.width, f.size.height),
1941 f, b);
1942 end;
1943
1944 { TCocoaWSCustomControl }
1945
TCocoaWSCustomControl.CreateHandlenull1946 class function TCocoaWSCustomControl.CreateHandle(const AWinControl: TWinControl;
1947 const AParams: TCreateParams): TLCLIntfHandle;
1948 var
1949 ctrl : TCocoaCustomControl;
1950 sl : TCocoaManualScrollView;
1951 hs : TCocoaManualScrollHost;
1952 lcl : TLCLCommonCallback;
1953
1954 begin
1955 ctrl := TCocoaCustomControl(TCocoaCustomControl.alloc.lclInitWithCreateParams(AParams));
1956 lcl := TLCLCommonCallback.Create(ctrl, AWinControl);
1957 lcl.BlockCocoaUpDown := true;
1958 lcl.BlockCocoaKeyBeep := true; // prevent "dings" on keyDown for custom controls (i.e. SynEdit)
1959 ctrl.callback := lcl;
1960
1961 sl := EmbedInManualScrollView(ctrl);
1962 sl.callback := ctrl.callback;
1963
1964 hs := EmbedInManualScrollHost(sl);
1965 hs.callback := ctrl.callback;
1966 lcl.HandleFrame:=hs;
1967
1968 ScrollViewSetBorderStyle(hs, TCustomControl(AWinControl).BorderStyle );
1969
1970 Result := TLCLIntfHandle(hs);
1971 end;
1972
1973 class procedure TCocoaWSCustomControl.SetBorderStyle(
1974 const AWinControl: TWinControl; const ABorderStyle: TBorderStyle);
1975 begin
1976 if not Assigned(AWinControl) or not (AWinControl.HandleAllocated) then Exit;
1977 ScrollViewSetBorderStyle( TCocoaManualScrollHost(AWinControl.Handle), ABorderStyle );
1978 end;
1979
HWNDToTargetObjectnull1980 function HWNDToTargetObject(AFormHandle: HWND): TObject;
1981 var
1982 cb : ICommonCallback;
1983 begin
1984 Result := nil;
1985 if AFormHandle = 0 then Exit;
1986 cb := NSObject(AFormHandle).lclGetCallback;
1987 if not Assigned(cb) then Exit;
1988 Result := cb.GetTarget;
1989 end;
1990
NSObjectDebugStrnull1991 function NSObjectDebugStr(obj: NSObject): string;
1992 begin
1993 Result := IntToStr(PtrUInt(obj));
1994 if Assigned(obj) then
1995 Result := Result +' '+obj.lclClassName+' lcl: '+CallbackDebugStr(obj.lclGetCallback);
1996 end;
1997
CallbackDebugStrnull1998 function CallbackDebugStr(cb: ICommonCallback): string;
1999 var
2000 trg : TObject;
2001 begin
2002 Result := IntToStr(PtrUInt(cb));
2003 if Assigned(cb) then
2004 begin
2005 trg := cb.GetTarget;
2006 Result := Result + ' trg: '+IntToStr(PtrUInt(trg));
2007 if Assigned(trg) then
2008 begin
2009 Result := Result + ' '+trg.ClassName;
2010 if trg is TWinControl then
2011 Result := Result +' '+TWinControl(trg).Name;
2012 end;
2013 end;
2014 end;
2015
2016 procedure DebugDumpParents(fromView: NSView);
2017 begin
2018 while Assigned(fromView) do begin
2019 writeln(fromView.lclClassName);
2020 fromView := fromView.superView;
2021 end;
2022 end;
2023
2024 end.
2025
2026