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