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

git-svn-id: trunk@34788 -

lcl/controls.pp

@@ -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;

lcl/include/control.inc

@@ -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.SetAccesibilityFields(ADescription, AValue, ARole);
-  FAccessibleObject.AccessibleName := AName;
-  FAccessibleObject.AccessibleRole := ARole;
-  //TWSControl(WidgetSetClass).LazAccessibility_SetFields(Self, ADescription, AName, 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;

lcl/include/treeview.inc

@@ -1995,8 +1995,8 @@ begin
       Owner.Invalidate;
   end;
   FSelection.Clear;
-  //if (FOwner <> nil) then
+  if (FOwner <> nil) then
-  //  FOwner.GetAccessibleObject().ClearChildAccessibleObjects();
+    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);

lcl/interfaces/carbon/carbonprivatecontrol.inc

@@ -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,

lcl/interfaces/carbon/carbonwscontrols.pp

@@ -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, AValue: string; const ARole: TLazAccessibilityRole); override;
-    //class procedure SetFields(const AObject: TLazAccessibleObject; const ADescription, AName: string; const ARole: TLazAccessibilityRole); virtual;
     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();
+  Result := 0;
-  AObject.SecondaryHandle := PtrInt(lObject); AXUIElementCreateWithHIObjectAndIdentifier}
+  GetCarbonAXIdentifiers(AObject, lHIObject, lID64);
-  lElement := MacOSAll.AXUIElementCreateSystemWide();
+  if lHIObject = nil then Exit;
-  Result := HWND(lElement);
+
+  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 }
 
 {------------------------------------------------------------------------------

lcl/widgetset/wscontrols.pp

@@ -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