paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-07 23:20:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

Finally figured out how to properly create child non-windowed accessible objects in Carbon! Renames AccessibleName to the more useful AccessibleValue information. However it still doesnt work properly because the non-windowed accessible objects require a already created HIView so we need to figure out the proper place to do this after the HIView is created for TTreeView

Browse Source 
git-svn-id: trunk@34788 -
This commit is contained in:
sekelsenmat 2012-01-19 08:09:12 +00:00
parent 4f622019e2
commit 46e5cbf514
6 changed files with 142 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
lcl/controls.pp
View File

@ -935,17 +935,19 @@ type
public
// Primary information
AccessibleDescription: TCaption;
AccessibleName: TCaption; // currently unused
AccessibleValue: TCaption;
AccessibleRole: TLazAccessibilityRole;
// Secondary information for notifications
SelectedText: string;
//
OwnerControl: TControl;
Parent: TLazAccessibleObject;
DataObject: TObject; // Availble to be used to connect to an object
DataObject: TObject; // Available to be used to connect to an object
SecondaryHandle: PtrInt; // Available for Widgetsets to use
constructor Create(AOwner: TControl); virtual;
destructor Destroy; override;
procedure SetAccesibilityFields(const ADescription, AValue: string; const ARole: TLazAccessibilityRole);
function FindOwnerWinControl: TWinControl;
function AddChildAccessibleObject: TLazAccessibleObject; virtual;
procedure ClearChildAccessibleObjects;
procedure RemoveChildAccessibleObject(AObject: TLazAccessibleObject);
@ -1074,7 +1076,7 @@ type
function CaptureMouseButtonsIsStored: boolean;
procedure DoActionChange(Sender: TObject);
function GetAccessibleDescription: TCaption;
function GetAccessibleName: TCaption;
function GetAccessibleValue: TCaption;
function GetAccessibleRole: TLazAccessibilityRole;
function GetAutoSizingAll: Boolean;
function GetAnchorSide(Kind: TAnchorKind): TAnchorSide;
@ -1104,7 +1106,7 @@ type
Shift: TShiftState);
procedure DoMouseUp(var Message: TLMMouse; Button: TMouseButton);
procedure SetAccessibleDescription(AValue: TCaption);
procedure SetAccessibleName(AValue: TCaption);
procedure SetAccessibleValue(AValue: TCaption);
procedure SetAccessibleRole(AValue: TLazAccessibilityRole);
procedure SetAnchorSide(Kind: TAnchorKind; AValue: TAnchorSide);
procedure SetBorderSpacing(const AValue: TControlBorderSpacing);
@ -1384,7 +1386,7 @@ type
DropControl: TControl; ControlSide: TAlign): Boolean;
function Dragging: Boolean;
// accessibility
procedure SetAccesibilityFields(const ADescription, AName: string; const ARole: TLazAccessibilityRole);
procedure SetAccesibilityFields(const ADescription, AValue: string; const ARole: TLazAccessibilityRole);
function GetAccessibleObject: TLazAccessibleObject;
function CreateAccessibleObject: TLazAccessibleObject; virtual;
function GetSelectedChildAccessibleObject: TLazAccessibleObject; virtual;
@ -1514,7 +1516,7 @@ type
public
// standard properties, which should be supported by all descendants
property AccessibleDescription: TCaption read GetAccessibleDescription write SetAccessibleDescription;
property AccessibleName: TCaption read GetAccessibleName write SetAccessibleName;
property AccessibleValue: TCaption read GetAccessibleValue write SetAccessibleValue;
property AccessibleRole: TLazAccessibilityRole read GetAccessibleRole write SetAccessibleRole;
property Action: TBasicAction read GetAction write SetAction;
property Align: TAlign read FAlign write SetAlign default alNone;

39
lcl/include/control.inc
View File

@ -64,6 +64,26 @@ begin
inherited Destroy;
end;
procedure TLazAccessibleObject.SetAccesibilityFields(const ADescription,
AValue: string; const ARole: TLazAccessibilityRole);
var
WidgetsetClass: TWSLazAccessibleObjectClass;
begin
AccessibleDescription := ADescription;
AccessibleValue := AValue;
AccessibleRole := ARole;
WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
WidgetsetClass.SetFields(Self, ADescription, AValue, ARole);
end;
function TLazAccessibleObject.FindOwnerWinControl: TWinControl;
begin
Result := nil;
if (OwnerControl <> nil) and (OwnerControl is TWinControl) then Exit(OwnerControl as TWinControl);
if Self.Parent = nil then Exit;
Result := Self.Parent.FindOwnerWinControl();
end;
function TLazAccessibleObject.AddChildAccessibleObject: TLazAccessibleObject;
begin
Result := nil;
@ -1458,19 +1478,19 @@ end;
procedure TControl.SetAccessibleDescription(AValue: TCaption);
begin
if FAccessibleObject.AccessibleDescription=AValue then Exit;
SetAccesibilityFields(AValue, FAccessibleObject.AccessibleName, FAccessibleObject.AccessibleRole);
SetAccesibilityFields(AValue, FAccessibleObject.AccessibleValue, FAccessibleObject.AccessibleRole);
end;
procedure TControl.SetAccessibleName(AValue: TCaption);
procedure TControl.SetAccessibleValue(AValue: TCaption);
begin
if FAccessibleObject.AccessibleName=AValue then Exit;
if FAccessibleObject.AccessibleValue=AValue then Exit;
SetAccesibilityFields(FAccessibleObject.AccessibleDescription, AValue, FAccessibleObject.AccessibleRole);
end;
procedure TControl.SetAccessibleRole(AValue: TLazAccessibilityRole);
begin
if FAccessibleObject.AccessibleRole=AValue then Exit;
SetAccesibilityFields(FAccessibleObject.AccessibleDescription, FAccessibleObject.AccessibleName, AValue);
SetAccesibilityFields(FAccessibleObject.AccessibleDescription, FAccessibleObject.AccessibleValue, AValue);
end;
{------------------------------------------------------------------------------
@ -1523,12 +1543,9 @@ begin
end;
// accessibility
procedure TControl.SetAccesibilityFields(const ADescription, AName: string; const ARole: TLazAccessibilityRole);
procedure TControl.SetAccesibilityFields(const ADescription, AValue: string; const ARole: TLazAccessibilityRole);
begin
FAccessibleObject.AccessibleDescription := ADescription;
FAccessibleObject.AccessibleName := AName;
FAccessibleObject.AccessibleRole := ARole;
//TWSControl(WidgetSetClass).LazAccessibility_SetFields(Self, ADescription, AName, ARole);
FAccessibleObject.SetAccesibilityFields(ADescription, AValue, ARole);
end;
function TControl.GetAccessibleObject: TLazAccessibleObject;
@ -1717,9 +1734,9 @@ begin
Result := FAccessibleObject.AccessibleDescription;
end;
function TControl.GetAccessibleName: TCaption;
function TControl.GetAccessibleValue: TCaption;
begin
Result := FAccessibleObject.AccessibleName;
Result := FAccessibleObject.AccessibleValue;
end;
function TControl.GetAccessibleRole: TLazAccessibilityRole;

12
lcl/include/treeview.inc
View File

@ -1995,8 +1995,8 @@ begin
Owner.Invalidate;
end;
FSelection.Clear;
//if (FOwner <> nil) then
// FOwner.GetAccessibleObject().ClearChildAccessibleObjects();
if (FOwner <> nil) then
FOwner.GetAccessibleObject().ClearChildAccessibleObjects();
EndUpdate;
end;
@ -2225,13 +2225,13 @@ begin
if (FUpdateCount=0) and (Owner<>nil) then
Owner.Invalidate;
ok:=true;
{if ok and (Owner<>nil) then
if ok and (Owner<>nil) then
begin
lAccessibleObject := FOwner.GetAccessibleObject().AddChildAccessibleObject();
lAccessibleObject.AccessibleDescription := S;
lAccessibleObject.AccessibleRole := larTreeItem;
lAccessibleObject.DataObject := Result;
end;}
end;
finally
// this construction creates nicer exception output
if not ok then
@ -3032,7 +3032,7 @@ begin
FTreeLineColor := clWindowFrame;
FTreeLinePenStyle := psPattern;
FExpandSignColor := clWindowFrame;
SetAccesibilityFields('A tree of items', 'T Tree View', larTreeView);
SetAccesibilityFields('A tree of items', '', larTreeView);
end;
destructor TCustomTreeView.Destroy;
@ -4290,6 +4290,8 @@ begin
lSelection := Self.Selected;
if lSelection = nil then lAccessibleObject.SelectedText := ''
else lAccessibleObject.SelectedText := lSelection.Text;
lAccessibleObject.SetAccesibilityFields(lAccessibleObject.AccessibleDescription,
lSelection.Text, lAccessibleObject.AccessibleRole);
lAccessibleObject.SendNotification(lanSelectedTextChanged);
if Assigned(OnSelectionChanged) then OnSelectionChanged(Self);

20
lcl/interfaces/carbon/carbonprivatecontrol.inc
View File

@ -233,12 +233,19 @@ begin
lOutputStr := CFSTR('AXFocused');
CFArrayAppendValue(lInputMutableArray, lOutputStr);
end;
// AXChildren
lCount := lLazControl.GetAccessibleObject().GetChildAccessibleObjectsCount;
if lCount > 0 then
begin
lOutputStr := CFSTR('AXChildren');
CFArrayAppendValue(lInputMutableArray, lOutputStr);
end;
{ // AXValue
if lLazControl.GetAccessibleObject().AccessibleValue <> '' then
begin
lOutputStr := CFSTR('AXValue');
CFArrayAppendValue(lInputMutableArray, lOutputStr);
end;}
end; // kEventAccessibleGetAllAttributeNames
kEventAccessibleGetNamedAttribute:
begin
@ -262,7 +269,7 @@ begin
// kAXApplicationRole
// There is nothing in the LCL for this role, it comes automatically in the application hierarchy
// kAXBrowserRole
larTreeView: lAXRole := CFSTR('AXList');//Browser');
larTreeView: lAXRole := CFSTR('AXList');//AXBrowser');
// kAXButtonRole
larButton, larButtonDropDown: lAXRole := CFSTR('AXButton');
// kAXCheckBoxRole
@ -299,6 +306,14 @@ begin
SizeOf(CFStringRef), @lOutputStr);
FreeCFString(lOutputStr);
end
{ else if lInputPasStr = 'AXValue' then
begin
if lLazControl.AccessibleValue = '' then Exit;
CreateCFString(lLazControl.AccessibleValue, lOutputStr);
SetEventParameter(AEvent, kEventParamAccessibleAttributeValue, typeCFStringRef,
SizeOf(CFStringRef), @lOutputStr);
FreeCFString(lOutputStr);
end}
//if (CFStringCompare(lInputStr, kAXFocusedAttribute, 0) = kCFCompareEqualTo) then
else if lInputPasStr = 'AXFocused' then
begin
@ -323,7 +338,8 @@ begin
for i := 0 to lCount - 1 do
begin
lElement := AXUIElementRef(lLazControl.GetAccessibleObject().Handle);
CFArrayAppendValue(lArray, lElement);
if lElement <> nil then
CFArrayAppendValue(lArray, lElement);
end;
SetEventParameter(AEvent, kEventParamAccessibleAttributeValue, typeCFTypeRef,

85
lcl/interfaces/carbon/carbonwscontrols.pp
View File

@ -51,11 +51,13 @@ type
{ TCarbonWSLazAccessibleObject }
TCarbonWSLazAccessibleObject = class(TWSLazAccessibleObject)
private
class procedure GetCarbonAXIdentifiers(const AObject: TLazAccessibleObject; out AHIObject: HIObjectRef; out AID64: UInt64);
public
// No need to implement SetFields in Carbon since Carbon requests the info
//class procedure SetFields(const AObject: TLazAccessibleObject; const ADescription, AName: string; const ARole: TLazAccessibilityRole); virtual;
class procedure SetFields(const AObject: TLazAccessibleObject; const ADescription, AValue: string; const ARole: TLazAccessibilityRole); override;
class function CreateHandle(const AObject: TLazAccessibleObject): HWND; override;
class procedure DestroyHandle(const AObject: TLazAccessibleObject); override;
class procedure SendNotification(const AObject: TLazAccessibleObject; ANotification: TLazAccessibilityNotification); override;
end;
{ TCarbonWSControl }
@ -119,15 +121,65 @@ uses
{ 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) then
begin
lControlHandle := TCarbonControl(TWinControl(AObject.OwnerControl).Handle);
AHIObject := 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 := lControlHandle.Widget;
end;
end;
class procedure TCarbonWSLazAccessibleObject.SetFields(
const AObject: TLazAccessibleObject; const ADescription, AValue: string;
const ARole: TLazAccessibilityRole);
var
lElement: AXUIElementRef;
lHIObject: HIObjectRef;
lID64: UInt64;
lValueStr: CFStringRef;
begin
GetCarbonAXIdentifiers(AObject, lHIObject, lID64);
if lHIObject = nil then Exit;
CreateCFString(AValue, lValueStr);
HIObjectSetAuxiliaryAccessibilityAttribute(lHIObject, lID64, CFStr('AXValue'), lValueStr);
FreeCFString(lValueStr);
end;
class function TCarbonWSLazAccessibleObject.CreateHandle(
const AObject: TLazAccessibleObject): HWND;
var
lElement: AXUIElementRef;
lHIObject: HIObjectRef;
lID64: UInt64;
begin
{ lObject := HIObjectCreate();
AObject.SecondaryHandle := PtrInt(lObject); AXUIElementCreateWithHIObjectAndIdentifier}
lElement := MacOSAll.AXUIElementCreateSystemWide();
Result := HWND(lElement);
Result := 0;
GetCarbonAXIdentifiers(AObject, lHIObject, lID64);
if lHIObject = nil then Exit;
lElement := AXUIElementCreateWithHIObjectAndIdentifier(lHIObject, lID64);
end;
class procedure TCarbonWSLazAccessibleObject.DestroyHandle(
@ -140,6 +192,27 @@ begin
CFRelease(lElement);
end;
class procedure TCarbonWSLazAccessibleObject.SendNotification(
const AObject: TLazAccessibleObject;
ANotification: TLazAccessibilityNotification);
var
lNotification: CFStringRef;
lHIObject: HIObjectRef;
lID64: UInt64;
begin
GetCarbonAXIdentifiers(AObject, lHIObject, lID64);
if lHIObject = nil then Exit;
case ANotification of
lanSelectedTextChanged: lNotification := CFSTR('AXValueChanged');
lanValueChanged: lNotification := CFSTR('AXValueChanged');
else
Exit;
end;
AXNotificationHIObjectNotify(lNotification, lHIObject, lID64);
end;
{ TCarbonWSWinControl }
{------------------------------------------------------------------------------

4
lcl/widgetset/wscontrols.pp
View File

@ -71,7 +71,7 @@ type
TWSLazAccessibleObject = class(TWSObject)
public
class procedure SetFields(const AObject: TLazAccessibleObject; const ADescription, AName: string; const ARole: TLazAccessibilityRole); virtual;
class procedure SetFields(const AObject: TLazAccessibleObject; const ADescription, AValue: string; const ARole: TLazAccessibilityRole); virtual;
class function CreateHandle(const AObject: TLazAccessibleObject): HWND; virtual;
class procedure DestroyHandle(const AObject: TLazAccessibleObject); virtual;
class procedure SendNotification(const AObject: TLazAccessibleObject; ANotification: TLazAccessibilityNotification); virtual;
@ -166,7 +166,7 @@ implementation
{ TWSLazAccessibleObject }
class procedure TWSLazAccessibleObject.SetFields(
const AObject: TLazAccessibleObject; const ADescription, AName: string;
const AObject: TLazAccessibleObject; const ADescription, AValue: string;
const ARole: TLazAccessibilityRole);
begin