mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-12-06 03:17:22 +01:00
513 lines
19 KiB
ObjectPascal
513 lines
19 KiB
ObjectPascal
{
|
|
*****************************************************************************
|
|
* CarbonWSControls.pp *
|
|
* --------------- *
|
|
* *
|
|
* *
|
|
*****************************************************************************
|
|
|
|
*****************************************************************************
|
|
This file is part of the Lazarus Component Library (LCL)
|
|
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
}
|
|
unit CarbonWSControls;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
// defines
|
|
{$I carbondefines.inc}
|
|
|
|
uses
|
|
// libs
|
|
MacOSAll, Classes, SysUtils,
|
|
// LCL
|
|
Forms, Controls, Graphics, LCLType, LCLProc,
|
|
// widgetset
|
|
WSControls, WSLCLClasses,
|
|
// LCL Carbon
|
|
CarbonDef, CarbonPrivate, CarbonEdits, CarbonListViews;
|
|
|
|
type
|
|
|
|
{ TCarbonWSDragImageList }
|
|
|
|
TCarbonWSDragImageList = class(TWSDragImageList)
|
|
published
|
|
end;
|
|
|
|
{ TCarbonWSLazAccessibleObject }
|
|
|
|
TCarbonWSLazAccessibleObject = class(TWSLazAccessibleObject)
|
|
private
|
|
class procedure GetCarbonAXIdentifiers(const AObject: TLazAccessibleObject; out AHIObject: HIObjectRef; out AID64: UInt64);
|
|
public
|
|
class function CreateHandle(const AObject: TLazAccessibleObject): HWND; override;
|
|
class procedure DestroyHandle(const AObject: TLazAccessibleObject); override;
|
|
class procedure SetAccessibleDescription(const {%H-}AObject: TLazAccessibleObject; const {%H-}ADescription: string); override;
|
|
class procedure SetAccessibleValue(const AObject: TLazAccessibleObject; const AValue: string); override;
|
|
class procedure SetAccessibleRole(const {%H-}AObject: TLazAccessibleObject; const {%H-}ARole: TLazAccessibilityRole); override;
|
|
end;
|
|
|
|
{ TCarbonWSControl }
|
|
|
|
TCarbonWSControl = class(TWSControl)
|
|
published
|
|
end;
|
|
|
|
{ TCarbonWSWinControl }
|
|
|
|
TCarbonWSWinControlClass = class of TCarbonWSWincontrol;
|
|
TCarbonWSWinControl = class(TWSWinControl)
|
|
published
|
|
class function CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): TLCLIntfHandle; override;
|
|
|
|
class function CanFocus(const AWincontrol: TWinControl): Boolean; override;
|
|
|
|
class procedure AddControl(const AControl: TControl); override;
|
|
class procedure DestroyHandle(const AWinControl: TWinControl); override;
|
|
class function GetClientBounds(const AWincontrol: TWinControl; var ARect: TRect): Boolean; override;
|
|
class function GetClientRect(const AWincontrol: TWinControl; var ARect: TRect): Boolean; override;
|
|
class function GetDesignInteractive(const AWinControl: TWinControl; AClientPos: TPoint): Boolean; override;
|
|
class procedure GetPreferredSize(const AWinControl: TWinControl; var PreferredWidth, PreferredHeight: integer; {%H-}WithThemeSpace: Boolean); override;
|
|
class function GetText(const AWinControl: TWinControl; var AText: String): Boolean; override;
|
|
class procedure SetBounds(const AWinControl: TWinControl; const ALeft, ATop, AWidth, AHeight: Integer); override;
|
|
class procedure SetChildZPosition(const AWinControl, AChild: TWinControl;
|
|
const AOldPos, ANewPos: Integer;
|
|
const AChildren: TFPList); override;
|
|
class procedure SetColor(const AWinControl: TWinControl); override;
|
|
class procedure SetCursor(const AWinControl: TWinControl; const ACursor: HCursor); override;
|
|
class procedure SetFont(const AWinControl: TWinControl; const AFont: TFont); override;
|
|
class procedure SetText(const AWinControl: TWinControl; const AText: String); override;
|
|
class procedure Invalidate(const AWinControl: TWinControl); override;
|
|
class procedure ShowHide(const AWinControl: TWinControl); override;
|
|
class procedure ScrollBy(const AWinControl: TWinControl; DeltaX, DeltaY: integer); override;
|
|
end;
|
|
|
|
{ TCarbonWSGraphicControl }
|
|
|
|
TCarbonWSGraphicControl = class(TWSGraphicControl)
|
|
published
|
|
end;
|
|
|
|
{ TCarbonWSCustomControl }
|
|
|
|
TCarbonWSCustomControl = class(TWSCustomControl)
|
|
published
|
|
class function CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): TLCLIntfHandle; override;
|
|
end;
|
|
|
|
{ TCarbonWSImageList }
|
|
|
|
TCarbonWSImageList = class(TWSImageList)
|
|
published
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
CarbonProc;
|
|
|
|
{ TCarbonWSLazAccessibleObject }
|
|
|
|
class procedure TCarbonWSLazAccessibleObject.GetCarbonAXIdentifiers(
|
|
const AObject: TLazAccessibleObject; out AHIObject: HIObjectRef; out
|
|
AID64: UInt64);
|
|
var
|
|
lControlHandle: TCarbonControl;
|
|
lWinControl: TWinControl;
|
|
begin
|
|
AHIObject := nil;
|
|
AID64 := 0;
|
|
lWinControl := AObject.FindOwnerWinControl();
|
|
if lWinControl = nil then Exit;
|
|
// Requesting a handle allocation here might be too soon and crash, so cancel the whole action
|
|
if not lWinControl.HandleAllocated then Exit;
|
|
|
|
if (AObject.OwnerControl <> nil) and (AObject.OwnerControl is TWinControl) and
|
|
(AObject.OwnerControl.GetAccessibleObject() = AObject) then
|
|
begin
|
|
lControlHandle := TCarbonControl(TWinControl(AObject.OwnerControl).Handle);
|
|
AHIObject := HIObjectRef(lControlHandle.Widget);
|
|
AID64 := 0;
|
|
end
|
|
else
|
|
begin
|
|
lControlHandle := TCarbonControl(lWinControl.Handle);
|
|
// If this is an internal sub-element, then simply represent it with the
|
|
// memory address of the object
|
|
AID64 := UInt64(PtrInt(AObject));
|
|
AHIObject := HIObjectRef(lControlHandle.Widget);
|
|
end;
|
|
end;
|
|
|
|
class function TCarbonWSLazAccessibleObject.CreateHandle(
|
|
const AObject: TLazAccessibleObject): HWND;
|
|
var
|
|
lElement: AXUIElementRef;
|
|
lHIObject: HIObjectRef;
|
|
lID64: UInt64;
|
|
begin
|
|
Result := 0;
|
|
GetCarbonAXIdentifiers(AObject, lHIObject, lID64);
|
|
if lHIObject = nil then Exit;
|
|
|
|
lElement := AXUIElementCreateWithHIObjectAndIdentifier(lHIObject, lID64);
|
|
Result := {%H-}HWND(lElement);
|
|
end;
|
|
|
|
class procedure TCarbonWSLazAccessibleObject.DestroyHandle(
|
|
const AObject: TLazAccessibleObject);
|
|
var
|
|
lElement: AXUIElementRef;
|
|
begin
|
|
if AObject.Handle = 0 then Exit;
|
|
lElement := {%H-}AXUIElementRef(AObject.Handle);
|
|
CFRelease(lElement);
|
|
end;
|
|
|
|
class procedure TCarbonWSLazAccessibleObject.SetAccessibleDescription(const AObject: TLazAccessibleObject; const ADescription: string);
|
|
begin
|
|
|
|
end;
|
|
|
|
class procedure TCarbonWSLazAccessibleObject.SetAccessibleValue(const AObject: TLazAccessibleObject; const AValue: string);
|
|
var
|
|
lHIObject: HIObjectRef;
|
|
lID64: UInt64;
|
|
lValueStr, lNotification: CFStringRef;
|
|
begin
|
|
GetCarbonAXIdentifiers(AObject, lHIObject, lID64);
|
|
if lHIObject = nil then Exit;
|
|
|
|
CreateCFString(AValue, lValueStr);
|
|
HIObjectSetAuxiliaryAccessibilityAttribute(lHIObject, lID64, CFStr('AXValue'), lValueStr);
|
|
FreeCFString(lValueStr);
|
|
|
|
lNotification := CFSTR('AXValueChanged');
|
|
AXNotificationHIObjectNotify(lNotification, lHIObject, lID64);
|
|
|
|
if AObject.AccessibleRole in larAXListRoles then
|
|
begin
|
|
lNotification := CFSTR('AXFocusedUIElementChanged');
|
|
AXNotificationHIObjectNotify(lNotification, lHIObject, lID64);
|
|
end;
|
|
end;
|
|
|
|
class procedure TCarbonWSLazAccessibleObject.SetAccessibleRole(const AObject: TLazAccessibleObject; const ARole: TLazAccessibilityRole);
|
|
begin
|
|
|
|
end;
|
|
|
|
{ TCarbonWSWinControl }
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.GetDesignInteractive
|
|
Params: AWinControl - LCL win control
|
|
AClientPos - Pos
|
|
Returns: If client pos should be interactive in designer
|
|
------------------------------------------------------------------------------}
|
|
class function TCarbonWSWinControl.GetDesignInteractive(
|
|
const AWinControl: TWinControl; AClientPos: TPoint): Boolean;
|
|
begin
|
|
Result := False;
|
|
if not CheckHandle(AWinControl, Self, 'GetDesignInteractive') then Exit;
|
|
Result := TCarbonWidget(AWinControl.Handle).IsDesignInteractive(AClientPos);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.GetPreferredSize
|
|
Params: AWinControl - LCL control
|
|
PreferredWidth - Preferred width, valid if > 0
|
|
PreferredHeight - Preferred height, valid if > 0
|
|
WithThemeSpace - Whether to include space for theme
|
|
|
|
Retrieves the preferred size of control in Carbon interface to support
|
|
autosizing of controls
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSWinControl.GetPreferredSize(const AWinControl: TWinControl;
|
|
var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean);
|
|
var
|
|
S: TPoint;
|
|
begin
|
|
if not CheckHandle(AWinControl, Self, 'GetPreferredSize') then Exit;
|
|
|
|
S := TCarbonWidget(AWinControl.Handle).GetPreferredSize;
|
|
PreferredWidth := S.X;
|
|
PreferredHeight := S.Y;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.GetText
|
|
Params: AWinControl - LCL control
|
|
AText - Text
|
|
Returns: If the function succeeds
|
|
|
|
Retrieves the text (caption) of control in Carbon interface
|
|
------------------------------------------------------------------------------}
|
|
class function TCarbonWSWinControl.GetText(const AWinControl: TWinControl;
|
|
var AText: String): Boolean;
|
|
begin
|
|
Result := False;
|
|
if not CheckHandle(AWinControl, Self,'GetText') then Exit;
|
|
|
|
Result := TCarbonWidget(AWinControl.Handle).GetText(AText);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.SetBounds
|
|
Params: AWinControl - LCL control
|
|
ALeft, ATop, AWidth, AHeight - Coordinates
|
|
|
|
Sets the bounds of control in Carbon interface
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSWinControl.SetBounds(const AWinControl: TWinControl;
|
|
const ALeft, ATop, AWidth, AHeight: Integer);
|
|
begin
|
|
if not CheckHandle(AWinControl, Self, 'SetBounds') then Exit;
|
|
|
|
TCarbonWidget(AWinControl.Handle).SetBounds(Bounds(ALeft, ATop, AWidth, AHeight));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.SetChildZPosition
|
|
Params: AWinControl - Parent LCL control
|
|
AChild - Child LCL control
|
|
AOldPos - Old z position
|
|
ANewPos - New z position
|
|
AChildren - List of all child controls
|
|
|
|
Sets the child z position of control in Carbon interface in the parent control
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSWinControl.SetChildZPosition(const AWinControl,
|
|
AChild: TWinControl; const AOldPos, ANewPos: Integer; const AChildren: TFPList);
|
|
begin
|
|
if not CheckHandle(AWinControl, Self, 'SetChildZPosition') then Exit;
|
|
if not CheckHandle(AChild, Self, 'SetChildZPosition AChild') then Exit;
|
|
|
|
TCarbonWidget(AWinControl.Handle).SetChildZPosition(TCarbonWidget(AChild.Handle),
|
|
AOldPos, ANewPos, AChildren);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.SetColor
|
|
Params: AWinControl - LCL control
|
|
|
|
Sets the color of control in Carbon interface according to the LCL control
|
|
NOTE: Functions only for controls with edit
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSWinControl.SetColor(const AWinControl: TWinControl);
|
|
begin
|
|
if not CheckHandle(AWinControl, Self, 'SetColor') then Exit;
|
|
|
|
TCarbonWidget(AWinControl.Handle).SetColor(AWinControl.Color);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.SetFont
|
|
Params: AWinControl - LCL control
|
|
ACursor - Cursor
|
|
|
|
Sets the cursor of control in Carbon interface
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSWinControl.SetCursor(const AWinControl: TWinControl;
|
|
const ACursor: HCursor);
|
|
begin
|
|
if not CheckHandle(AWinControl, Self, 'SetCursor') then Exit;
|
|
|
|
TCarbonWidget(AWinControl.Handle).SetCursor(ACursor);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.SetFont
|
|
Params: AWinControl - LCL control
|
|
AFont - Font
|
|
|
|
Sets the font of control in Carbon interface
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSWinControl.SetFont(const AWinControl: TWinControl;
|
|
const AFont: TFont);
|
|
begin
|
|
if not CheckHandle(AWinControl, Self, 'SetFont') then Exit;
|
|
|
|
TCarbonWidget(AWinControl.Handle).SetFont(AFont);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.SetText
|
|
Params: AWinControl - LCL control
|
|
AText - Text
|
|
|
|
Sets the text (caption) of control in Carbon interface
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSWinControl.SetText(const AWinControl: TWinControl;
|
|
const AText: String);
|
|
begin
|
|
if not CheckHandle(AWinControl, Self, 'SetText') then Exit;
|
|
|
|
//DebugLn('TCarbonWSWinControl.SetText ',dbgsName(AWinControl),' ',AText);
|
|
TCarbonWidget(AWinControl.Handle).SetText(AText);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.Invalidate
|
|
Params: AWinControl - LCL control
|
|
|
|
Invalidates control in Carbon interface
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSWinControl.Invalidate(const AWinControl: TWinControl);
|
|
begin
|
|
if not CheckHandle(AWinControl, Self, 'Invalidate') then Exit;
|
|
|
|
TCarbonWidget(AWinControl.Handle).Invalidate;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.ShowHide
|
|
Params: AWinControl - LCL control
|
|
|
|
Changes visibility of control in Carbon interface according to the LCL control
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSWinControl.ShowHide(const AWinControl: TWinControl);
|
|
begin
|
|
if not CheckHandle(AWinControl, Self, 'ShowHide') then Exit;
|
|
|
|
TCarbonWidget(AWinControl.Handle).ShowHide(AWinControl.HandleObjectShouldBeVisible);
|
|
end;
|
|
|
|
class procedure TCarbonWSWinControl.ScrollBy(const AWinControl: TWinControl;
|
|
DeltaX, DeltaY: integer);
|
|
begin
|
|
if not CheckHandle(AWinControl, Self, 'ScrollBy') then Exit;
|
|
|
|
TCarbonWidget(AWinControl.Handle).ScrollBy(DeltaX, DeltaY);
|
|
AWinControl.Invalidate;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.CreateHandle
|
|
Params: AWinControl - LCL control
|
|
AParams - Creation parameters
|
|
Returns: Handle to the control in Carbon interface
|
|
|
|
Creates new win control in Carbon interface with the specified parameters
|
|
------------------------------------------------------------------------------}
|
|
class function TCarbonWSWinControl.CreateHandle(const AWinControl: TWinControl;
|
|
const AParams: TCreateParams): TLCLIntfHandle;
|
|
begin
|
|
DebugLn('Warning: Using Carbon custom control instead of not implemented win control!');
|
|
|
|
Result := TLCLIntfHandle(TCarbonCustomControl.Create(AWinControl, AParams));
|
|
end;
|
|
|
|
class function TCarbonWSWinControl.CanFocus(const AWincontrol: TWinControl): Boolean;
|
|
var
|
|
Bit: CFIndex;
|
|
Valid: Boolean;
|
|
begin
|
|
Result := inherited;
|
|
if not AWinControl.HandleAllocated then
|
|
begin
|
|
Result:=AWinControl.CanFocus;
|
|
Exit;
|
|
end;
|
|
if not CheckHandle(AWincontrol, Self, 'CanFocus') then Exit;
|
|
|
|
Bit := CFPreferencesGetAppIntegerValue(CFSTR('AppleKeyboardUIMode'),
|
|
kCFPreferencesCurrentApplication, Valid{%H-});
|
|
|
|
if Valid then
|
|
begin
|
|
if (Bit <> 0) then
|
|
Result := True
|
|
else
|
|
Result := (TCarbonWidget(AWincontrol.Handle) is TCarbonControlWithEdit) or
|
|
(TCarbonWidget(AWincontrol.Handle) is TCarbonDataBrowser) or
|
|
(TCarbonWidget(AWincontrol.Handle) is TCarbonCustomControl);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.AddControl
|
|
Params: AControl - LCL control to add
|
|
|
|
Adds new control to parent control or window in Carbon interface
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSWinControl.AddControl(const AControl: TControl);
|
|
begin
|
|
if not CheckHandle(AControl as TWinControl, Self, 'AddControl') then Exit;
|
|
if not CheckHandle(AControl.Parent, Self, 'AddControl Parent') then Exit;
|
|
|
|
TCarbonWidget((AControl as
|
|
TWinControl).Handle).AddToWidget(TCarbonWidget(AControl.Parent.Handle));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.DestroyHandle
|
|
Params: AWinControl - LCL control
|
|
|
|
Destroys control in Carbon interface
|
|
------------------------------------------------------------------------------}
|
|
class procedure TCarbonWSWinControl.DestroyHandle(const AWinControl: TWinControl);
|
|
begin
|
|
if not CheckHandle(AWinControl, Self, 'DestroyHandle') then Exit;
|
|
|
|
TCarbonWidget(AWinControl.Handle).FreeCarbonWidget;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.GetClientBounds
|
|
Params: AWinControl - LCL control
|
|
ARect - Record for client bounding rect
|
|
|
|
Retrieves the client bounding rect of control in Carbon interface
|
|
------------------------------------------------------------------------------}
|
|
class function TCarbonWSWinControl.GetClientBounds(
|
|
const AWincontrol: TWinControl; var ARect: TRect): Boolean;
|
|
begin
|
|
Result := False;
|
|
if not CheckHandle(AWinControl, Self, 'GetClientBounds') then Exit;
|
|
|
|
Result := TCarbonWidget(AWinControl.Handle).GetClientRect(ARect);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSWinControl.GetClientRect
|
|
Params: AWinControl - LCL control
|
|
ARect - Record for client rect
|
|
|
|
Retrieves the client rect of control in Carbon interface
|
|
------------------------------------------------------------------------------}
|
|
class function TCarbonWSWinControl.GetClientRect(
|
|
const AWincontrol: TWinControl; var ARect: TRect): Boolean;
|
|
begin
|
|
Result := False;
|
|
if not CheckHandle(AWinControl, Self, 'GetClientRect') then Exit;
|
|
|
|
Result := TCarbonWidget(AWinControl.Handle).GetClientRect(ARect);
|
|
if Result then OffsetRect(ARect, -ARect.Left, -ARect.Top);
|
|
end;
|
|
|
|
{ TCarbonWSCustomControl }
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonWSCustomControl.CreateHandle
|
|
Params: AWinControl - LCL control
|
|
AParams - Creation parameters
|
|
Returns: Handle to the control in Carbon interface
|
|
|
|
Creates new custom control in Carbon interface with the specified parameters
|
|
------------------------------------------------------------------------------}
|
|
class function TCarbonWSCustomControl.CreateHandle(const AWinControl: TWinControl;
|
|
const AParams: TCreateParams): TLCLIntfHandle;
|
|
begin
|
|
Result := TLCLIntfHandle(TCarbonCustomControl.Create(AWinControl, AParams));
|
|
end;
|
|
|
|
end.
|