Various improvements and attempts at creating a WS implementation for TLazAccessibleObject

git-svn-id: trunk@34712 -

lcl/comctrls.pp

@@ -2654,14 +2654,6 @@ type
     tvimAsPrevSibling
   );
 
-  { TTreeViewAccessibleObject }
-
-  TTreeViewAccessibleObject = class(TLazAccessibleObject)
-  public
-    function GetSelectedChildAccessibleObject: TLazAccessibleObject; override;
-    function GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject; override;
-  end;
-
   TCustomTreeView = class(TCustomControl)
   private
     FBackgroundColor: TColor;
@@ -2860,7 +2852,9 @@ type
     procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS;
     procedure WMKillFocus(var Message: TLMKillFocus); message LM_KILLFOCUS;
     procedure Resize; override;
-    function CreateAccessibleObject: TLazAccessibleObject; override;
+    // Accessibility
+    function GetSelectedChildAccessibleObject: TLazAccessibleObject; override;
+    function GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject; override;
   protected
     property AutoExpand: Boolean read GetAutoExpand write SetAutoExpand default False;
     property BorderStyle default bsSingle;

lcl/controls.pp

@@ -895,17 +895,20 @@ type
   { TLazAccessibleObject }
 
   TLazAccessibleObject = class
+  private
+    FHandle: PtrInt;
+    function GetHandle: PtrInt;
   protected
     FChildren: TFPList; // of TLazAccessibleObject
+    class procedure WSRegisterClass; virtual;//override;
   public
     AccessibleDescription: TCaption;
     AccessibleName: TCaption;
     AccessibleRole: TLazAccessibilityRole;
-    ParentControl: TControl;
+    OwnerControl: TControl;
     Parent: TLazAccessibleObject;
     DataObject: TObject; // Availble to be used to connect to an object
-    Handle: PtrInt;
+    constructor Create(AOwner: TControl); virtual;
-    constructor Create; virtual;
     destructor Destroy; override;
     function AddChildAccessibleObject: TLazAccessibleObject; virtual;
     procedure ClearChildAccessibleObjects;
@@ -915,6 +918,7 @@ type
     function GetChildAccessibleObjectsCount: Integer;
     function GetSelectedChildAccessibleObject: TLazAccessibleObject; virtual;
     function GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject; virtual;
+    property Handle: PtrInt read GetHandle;
   end;
 
 {* Note on TControl.Caption
@@ -934,7 +938,6 @@ type
 
   TControl = class(TLCLComponent)
   private
-    FAccessibleObject: TLazAccessibleObject;
     FActionLink: TControlActionLink;
     FAlign: TAlign;
     FAnchors: TAnchors;
@@ -1092,6 +1095,7 @@ type
     procedure SetTop(Value: Integer);
     procedure SetWidth(Value: Integer);
   protected
+    FAccessibleObject: TLazAccessibleObject;
     FControlState: TControlState;
     FCursor: TCursor;
     class procedure WSRegisterClass; override;
@@ -1346,6 +1350,8 @@ type
     procedure SetAccesibilityFields(const ADescription, AName: string; const ARole: TLazAccessibilityRole);
     function GetAccessibleObject: TLazAccessibleObject;
     function CreateAccessibleObject: TLazAccessibleObject; virtual;
+    function GetSelectedChildAccessibleObject: TLazAccessibleObject; virtual;
+    function GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject; virtual;
   public
     // size
     procedure AdjustSize; virtual;// smart calling DoAutoSize

lcl/include/control.inc

@@ -28,15 +28,29 @@
 
 { TLazAccessibleObject }
 
-constructor TLazAccessibleObject.Create;
+function TLazAccessibleObject.GetHandle: PtrInt;
 begin
-  inherited Create;
+//  if FHandle = 0 then FHandle := TWSLazAccessibleObject(WidgetsetClass).CreateHandle(Self);
+  Result := FHandle;
+end;
+
+class procedure TLazAccessibleObject.WSRegisterClass;
+begin
+//  inherited WSRegisterClass;
+//  RegisterLazAccessibleObject;
+end;
+
+constructor TLazAccessibleObject.Create(AOwner: TControl);
+begin
+  inherited Create;//(AOwner);
+  OwnerControl := AOwner;
   FChildren := TFPList.Create;
 end;
 
 destructor TLazAccessibleObject.Destroy;
 begin
   ClearChildAccessibleObjects();
+//  if FHandle <> 0 then TWSLazAccessibleObject(WidgetsetClass).DestroyHandle(Self);
   inherited Destroy;
 end;
 
@@ -44,9 +58,8 @@ function TLazAccessibleObject.AddChildAccessibleObject: TLazAccessibleObject;
 begin
   Result := nil;
   if FChildren = nil then Exit;
-  Result := TLazAccessibleObject.Create;
+  Result := TLazAccessibleObject.Create(OwnerControl);
   Result.Parent := Self;
-  Result.ParentControl := Self.ParentControl;
   FChildren.Add(Result);
   //DebugLn('[TControl.AddChildAccessibleObject] Name=%s', [Name]);
 end;
@@ -101,11 +114,15 @@ end;
 function TLazAccessibleObject.GetSelectedChildAccessibleObject: TLazAccessibleObject;
 begin
   Result := nil;
+  if OwnerControl = nil then Exit;
+  Result := OwnerControl.GetSelectedChildAccessibleObject();
 end;
 
 function TLazAccessibleObject.GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject;
 begin
   Result := nil;
+  if OwnerControl = nil then Exit;
+  Result := OwnerControl.GetChildAccessibleObjectAtPos(APos);
 end;
 
 {------------------------------------------------------------------------------
@@ -1502,8 +1519,17 @@ end;
 
 function TControl.CreateAccessibleObject: TLazAccessibleObject;
 begin
-  Result := TLazAccessibleObject.Create;
+  Result := TLazAccessibleObject.Create(Self);
-  Result.ParentControl := Self;
+end;
+
+function TControl.GetSelectedChildAccessibleObject: TLazAccessibleObject;
+begin
+  Result := nil;
+end;
+
+function TControl.GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject;
+begin
+  Result := nil;
 end;
 
 {------------------------------------------------------------------------------

lcl/include/treeview.inc

@@ -31,32 +31,6 @@
 
 { TTreeViewAccessibleObject }
 
-function TTreeViewAccessibleObject.GetSelectedChildAccessibleObject: TLazAccessibleObject;
-var
-  lTreeView: TCustomTreeView;
-  lNode: TTreeNode;
-begin
-  Result := inherited GetSelectedChildAccessibleObject();
-  if (Result <> nil) or (ParentControl = nil) then Exit;
-  lTreeView := TCustomTreeView(ParentControl);
-  lNode := lTreeView.GetSelection();
-  if lNode = nil then Exit;
-  Result := GetChildAccessibleObjectWithDataObject(lNode);
-end;
-
-function TTreeViewAccessibleObject.GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject;
-var
-  lTreeView: TCustomTreeView;
-  lNode: TTreeNode;
-begin
-  Result := inherited GetChildAccessibleObjectAtPos(APos);
-  if (Result <> nil) or (ParentControl = nil) then Exit;
-  lTreeView := TCustomTreeView(ParentControl);
-  lNode := lTreeView.GetNodeAt(APos.X, APos.Y);
-  if lNode = nil then Exit;
-  Result := GetChildAccessibleObjectWithDataObject(lNode);
-end;
-
 const
   TTreeNodeWithPointerStreamVersion : word = 1;
   TTreeNodeStreamVersion : word = 2;
@@ -5347,10 +5321,24 @@ begin
   inherited Resize;
 end;
 
-function TCustomTreeView.CreateAccessibleObject: TLazAccessibleObject;
+function TCustomTreeView.GetSelectedChildAccessibleObject: TLazAccessibleObject;
+var
+  lNode: TTreeNode;
 begin
-  Result := TTreeViewAccessibleObject.Create;
+  Result := nil;
-  Result.ParentControl := Self;
+  lNode := GetSelection();
+  if lNode = nil then Exit;
+  Result := FAccessibleObject.GetChildAccessibleObjectWithDataObject(lNode);
+end;
+
+function TCustomTreeView.GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject;
+var
+  lNode: TTreeNode;
+begin
+  Result := nil;
+  lNode := GetNodeAt(APos.X, APos.Y);
+  if lNode = nil then Exit;
+  Result := FAccessibleObject.GetChildAccessibleObjectWithDataObject(lNode);
 end;
 
 procedure TCustomTreeView.InternalSelectionChanged;

lcl/interfaces/carbon/carbonprivatecontrol.inc

@@ -176,6 +176,7 @@ var
   lCount: Integer;
   i: Integer;
   lAccessibleObj: TLazAccessibleObject;
+  lHandle: PtrInt;
 const SName = 'CarbonControl_Accessibility';
 begin
   {$IF defined(VerboseControlEvent) or defined(VerboseAccessibilityEvent)}
@@ -207,8 +208,9 @@ begin
       if lAccessibleObj = nil then Exit;
       lAccessibleObj := lAccessibleObj.GetChildAccessibleObjectAtPos(lInputPoint);
       if (lAccessibleObj = nil) or (lAccessibleObj.Handle = 0) then Exit;
+      lHandle := lAccessibleObj.Handle;
       SetEventParameter(AEvent, kEventParamAccessibleChild, typeCFTypeRef,
-        SizeOf(AXUIElementRef), @lAccessibleObj.Handle);
+        SizeOf(AXUIElementRef), @lHandle);
     end;
     kEventAccessibleGetAllAttributeNames:
     begin
@@ -320,17 +322,9 @@ begin
         lArray := CFArrayCreateMutable(kCFAllocatorDefault, lCount, @kCFTypeArrayCallBacks);
         for i := 0 to lCount - 1 do
         begin
-          if lLazControl.GetAccessibleObject().Handle <> 0 then
+          //lElement := AXUIElementRef(lLazControl.GetAccessibleObject().Handle);
-          begin
+          lElement := MacOSAll.AXUIElementCreateSystemWide();
-            lElement := AXUIElementRef(lLazControl.GetAccessibleObject().Handle)
-          end
-          else
-          begin
-            lElement := MacOSAll.AXUIElementCreateSystemWide();
-            lLazControl.GetAccessibleObject().Handle := PtrInt(lElement);
-          end;
           CFArrayAppendValue(lArray, lElement);
-          //CFRelease(lElement);
         end;
 
         SetEventParameter(AEvent, kEventParamAccessibleAttributeValue, typeCFTypeRef,

lcl/widgetset/wscontrols.pp

@@ -67,6 +67,17 @@ type
 
   TWSDragImageListClass = class of TWSDragImageList;
 
+  { TWSLazAccessibleObject }
+
+{  TWSLazAccessibleObject = class(TWSLCLComponent)
+  published
+    class procedure SetFields(const AObject: TLazAccessibleObject; const ADescription, AName: string; const ARole: TLazAccessibilityRole); virtual;
+    class function CreateHandle(const AObject: TLazAccessibleObject): HWND; virtual;
+    class procedure DestroyHandle(const AObject: TLazAccessibleObject); virtual;
+  end;}
+  //lElement := MacOSAll.AXUIElementCreateSystemWide();
+  //CFRelease(lElement);
+
   { TWSControl }
 
   TWSControl = class(TWSLCLComponent)
@@ -76,7 +87,6 @@ type
     class function GetDefaultColor(const AControl: TControl; const ADefaultColorType: TDefaultColorType): TColor; virtual;
     class procedure ConstraintWidth(const AControl: TControl; const AConstraints: TObject; var aWidth: integer); virtual;
     class procedure ConstraintHeight(const AControl: TControl; const AConstraints: TObject; var aHeight: integer); virtual;
-    //class procedure LazAccessibility_SetFields(const AControl: TControl; const ADescription, AName: string; const ARole: TLazAccessibilityRole); virtual;
   end;
 
   TWSControlClass = class of TWSControl;
@@ -144,14 +154,35 @@ type
   published
   end;
 
-  procedure RegisterDragImageList;
+procedure RegisterDragImageList;
-  procedure RegisterControl;
+//procedure RegisterLazAccessibleObject;
-  procedure RegisterWinControl;
+procedure RegisterControl;
-  procedure RegisterGraphicControl;
+procedure RegisterWinControl;
-  procedure RegisterCustomControl;
+procedure RegisterGraphicControl;
+procedure RegisterCustomControl;
 
 implementation
 
+{ TWSLazAccessibleObject }
+
+(*class procedure TWSLazAccessibleObject.SetFields(
+  const AObject: TLazAccessibleObject; const ADescription, AName: string;
+  const ARole: TLazAccessibilityRole);
+begin
+
+end;
+
+class function TWSLazAccessibleObject.CreateHandle(
+  const AObject: TLazAccessibleObject): HWND;
+begin
+  Result := 0;
+end;
+
+class procedure TWSLazAccessibleObject.DestroyHandle(
+  const AObject: TLazAccessibleObject);
+begin
+
+end;*)
 
 { TWSControl }
 
@@ -181,12 +212,6 @@ begin
 
 end;
 
-{class procedure TWSControl.LazAccessibility_SetFields(const AControl: TControl;
-  const ADescription, AName: string; const ARole: TLazAccessibilityRole);
-begin
-
-end;}
-
 { TWSWinControl }
 
 class procedure TWSWinControl.AdaptBounds(const AWinControl: TWinControl;
@@ -384,6 +409,16 @@ begin
   Done := True;
 end;
 
+{procedure RegisterLazAccessibleObject;
+const
+  Done: Boolean = False;
+begin
+  if Done then exit;
+  if not WSRegisterControl then
+    RegisterWSComponent(TLazAccessibleObject, TWSLazAccessibleObject);
+  Done := True;
+end;}
+
 procedure RegisterControl;
 const
   Done: Boolean = False;