好记性不如烂笔头

[教程]QJSON 4.0 与 3.0 功能特性对比

Sat, 08 Mar 2025 16:47:13 +0800

QJSON 4.0 目录已经处于基本可用状态，可以供大家在新的开发项目中试用，就目前版本来说，4.0 相比 3.0 版有以下大不同：

架构变化

3.0 版 TQJson 是一个类 (class)，4.0 版是一个记录类型 (record) 并且改名为 TQJsonNode 以避免和 3.0 版本冲突
4.0 版实现了 IQSerializeReader 和 IQSerializeWriter 接口，可以统一多种格式的序列化和反序列化
4.0 版将支持 Free Pascal 3.3.1 + 版本，3.0 版本不支持

内存管理

4.0 支持字符串缓存模式，重复的字符串内容，只会保存一个版本
4.0 使用双向链表而不是数组来存储同级的兄弟结点，分配内存次数相比数组模式更少
4.0 支持按数组方式访问，但如果你不使用，它永远不会分配数据索引，从而节省开销
4.0 对序列化进行了专门的优化，从流中加载大 JSON 和将 JSON 数据保存到流都会节省很多内存
4.0 通过支持缓存模式和只进模式，可以大幅节省内存占用和分配次数
总体来说，4.0 在保证性能的前提下，对内存使用情况更克制，算法也更复杂一些。

性能变化

使用 TQSerializer 进行基于 RTTI 的序列化和反序列化（推荐，接口统一，更易拓展）
基于 TQJsonEncoder/TQJsonParser 来执行序列化或反序列化（内存占用更小
对于遍历的场景，4.0 因为使用双向链接表，ForEach 或直接通过 FirstChild->LastChild 遍历都很方便，理论性能和 3.0 一致
对于随机只读场景，4.0 因为在首次随机访问时会缓存索引，纯随机读取场景要稍差一点，但也只限于首次访问，后续访问性能没有差距。
对于追加数据场景，4.0 因为增加链表元素分配一次内存，相比数组方式可能要调整数据大小，理论上要更快一些
对于解析场景，4.0 因为新的架构和解析算法，理论性能比 3.0 有了较大的提升
对于序列化场景，4.0 实现了新的工作流程，减少了内存的重复分配和释放，在性能上也有了很大的提升。与 3.0 相比，也提供了更多的序列化方式：

学习难度

4.0 统一了 JSON/XML/MessagePack 等格式序列化接口，提供了 TQSerializer 来统一格式的序列化和反序列化，方便用户将来能够快速的支持多种格式输出。
4.0 公开接口和 3.0 基本保持一致，迁移成本不高。但因为 4.0 从类转为记录类型，所以相对来说，还是要用户不可避免的在代码层级做一些变动，但学习难度几乎没有。

其它变化

4.0 完整支持注释类型（jdtLineComment / jdtBlockComment)，而 3.0 无论解码还是编码，都会忽略注释
4.0 用户可以通过回调来控制解析流程，跳过不需要解析的结点，从而提升效率
4.0 编码设置增加了额外的选项来更灵活的控制输出 JSON 的方式，比如日期时间类型输出为 Unix 时间戳。
更多变动，请阅读源码了解。

QPlugins 插件引擎教程 – 让 QPlugins 协助你解耦程序

Thu, 21 Nov 2024 17:41:12 +0800

程序就是一堆面条，理顺了，好用又好看，如果缠在一起，那就会煮成一坨面疙瘩了。QPlugins 虽然是一个插件引擎，但是记住我们的理念，插件即服务，服务也就是插件一种插接方式。

首先，我们了解的第一个基于 QPlugins 的 Demo 位于 DockForms 里的 InProcess 目录下。它的目标是将不同单元的窗体嵌入到主窗体的 TPageControl 的不同页面中，而不需要引用主窗体的任何东西。

使用 QPlugins 插件引擎所要做的第一件事：确定服务的接口方式。

如在了解 QPlugins 的整体架构一节中所说的，我们通过 IQPluginsManager 接口来管理一切服务和通知，而每个插件或主程序本身提供一个或多个服务。而服务的调用者与服务之间要如何交互呢？这是在将 QPlugins 插件引擎引入到你程序时，需要考虑的第一个问题：

使用一个 Interface 接口定义
此方式的优点是参数形式统一明确，而且参数类型一般是系统提供的内置类型，效率较高，调用时与传统习惯比较一致。
使用 IQService 的 Execute 函数来执行
此方式的优点是不需要预先定义接口，但仍然要知道需要传递的参数的类型。此类调用通过 IQParams 接口来将参数传递给服务的提供者，而服务的提供者通过 IQParams 来得到相关的参数数据，并执行服务。在本示例中，我们使用将演示这一用法。

好了，由于本示例使用的第二种方式来调用，也就是说，我们不知道提供服务接口的GUID编码，那么我们就需要知道怎么找到这个服务。QPlugins 提供了一个 ByPath 函数来让我们通过路径来查找服务。我们来看 ByPath 的声明：

function ByPath(APath: PWideChar): IQService; stdcall;

实际上，这个函数是由 IQServices 接口规定的，APath 约定了服务提供路径，如本示例中的 “Services/Docks”。

为了更好的说明这一点，我们来看我们示例中的代码：

procedure TForm1.FormCreate(Sender: TObject);
var
  ARoot: IQServices;
  I: Integer;
  ATabSheet: TTabSheet;
  AParams: IQParams;
begin
  ARoot := PluginsManager.ByPath('Services/Docks') as IQServices;
  if Assigned(ARoot) then
  begin
    AParams := TQParams.Create;
    AParams.Add('Parent', ptUInt64);
    for I := 0 to ARoot.Count - 1 do
    begin
      ATabSheet := TTabSheet.Create(PageControl1);
      ATabSheet.PageControl := PageControl1;
      ATabSheet.Caption := ARoot[I].Name;
      AParams[0].AsInt64 := IntPtr(ATabSheet);
      ARoot[I].Execute(AParams, nil);
    end;
  end;
end;

首先，在继续之前，我们了解下这里的一个约定，所有要嵌入的子窗体必需将自己注册到 “Services/Docks” 服务列表（IQServices）结点下，做为子服务，以便主程序进行调用。

接下来，各个子窗体的实现单元，自己在 initialization 单元中，通过 RegisterService 将自己注册到 PluginsManager 的 “Service/Docks”下面，做为一个子服务。

好了，现在我们来看上面的代码做了什么：

检查 “Service/Docks” 这个根服务结点是否存在，如果不存在，说明没有任何子服务注册，就不需要继续了；
创建一个 IQParams 接口的实例 AParams，添加一个名为 Parent 的参数，考虑到64位编译的支持，这里类型定义为了ptUInt64（64位无符号整数）。这个 Parent 参数，用来传递给子窗体，告诉它要嵌入的目标控件地址（TWinControl 的子类）。
循环遍历每一个注册的子服务，调用其Execute方法，并将 AParams 做为参数传递进去，以执行服务。

好了，主窗体单元所要做的一切都已OK了，我们接下来实现子窗体的服务了。因为所有的窗体嵌入这块，实际上可以共用同样的代码，所以我们将其提炼一下，将其写到了 dockservice 单元。我们来看它的源码：

unit dockservice;

interface

uses classes, qstring, qplugins, controls;

type
  TDockService = class(TQService)
  private
    FControlClass: TControlClass;
  public
    function Execute(AParams: IQParams; AResult: IQParams): Boolean;
      override; stdcall;
    property ControlClass: TControlClass read FControlClass write FControlClass;
  end;

const
  IDockServices: TGuid = '{9DDD6DD9-3053-4EE2-90D5-759267DBB10C}';
procedure RegisterDock(AClass: TControlClass);

implementation

{ TDockService }

function TDockService.Execute(AParams, AResult: IQParams): Boolean;
var
  AParent: TWinControl;
  AControl: TControl;
begin
  AParent := Pointer(AParams[0].AsInt64);
  AControl := ControlClass.Create(AParent);
  AControl.HostDockSite := AParent;
  AControl.Visible := True;
  AControl.Align := alClient;
  Result := True;
end;

procedure RegisterDock(AClass: TControlClass);
var
  AParent: IQServices;
  AService: TDockService;
begin
  AParent := PluginsManager.ById(IDockServices) as IQServices;
  AService := TDockService.Create(NewId, AClass.ClassName);
  AService.ControlClass := AClass;
  AParent.Add(AService);
end;

procedure RegisterClass;
begin
  PluginsManager.Services.Add(TQServices.Create(IDockServices, 'Docks'));
end;

initialization

RegisterClass;

end.

很短的一段代码，TDockService 继承自 TQService，并重载了 Execute 方法，以便提供服务的实现。另外，定义了一个 ControlClass 属性，来指定要嵌入的控件类型。剩下还有两个方法：

RegisterDock 是一个简单的二次封装，让用户直接调用并传递要嵌入的控件类型就OK，不去再关心注册服务的问题。
RegisterClass 用来在 “Serivces” 下，添加一个名为 “Docks” 的子结点。好吧，回过头看前面，知道 “Services/Docks” 来自于那里了吧:)

最后，我们在 initialization 里注册调用 RegisterClass 来初始化注册 “Service/Docks” 这个服务列表。

好了，现在我们随便设计两个窗体单元，在 Unit2 和 Unit3 中，窗体上你随心放置一些组件用于演示的目的。然后我们引入 qdockservices 单元，然后添加 initialization 小节，加入 RegisterDock 的调用来注册窗体类别，示例如下：

uses dockservice;
{$R *.dfm}

initialization

RegisterDock(TForm2);

end.

好吧，我们的第一个基于 QPlugins 松散耦合，面向服务的程序就此诞生了。现在我们 F9 运行它，可以看到两个窗体被正确的嵌入到相应的位置了：

简单总结一下 QPlugins 程序编写的几个步骤：

【服务的消费者】-本示例中是主窗体单元

1、通过路径或ID来查找服务（本示例通过路径）；

2、通过接口或者服务的 Execute 方法来调用服务（本示例调用 Execute 方法）；

【服务的提供者】-本示例中为各个子窗体实现单元

1、实现 IQService 接口和自己特定的接口（本示例没有特定的接口，直接继承 TQService 并实现了Execute 方法）；

2、在单元的 initialization 小节中，注册自己到编写的服务路径下（本示例中的 “Services/Docks”）；

一个共享的计时器类封装

Tue, 20 Aug 2024 17:24:42 +0800

QDAC 4.0 中已经包含了此单元，名称改为qdac.timer.share，使用 TQShareTimer 来做相关处理。

这个是一个精度为秒的共享定时器实现，可以秒为单位创建多个共享的定时器，这些定时器的回调的维护和回调都要求在主线程中执行。

这个代码真正想给大家说的是 GetCallbackOwner 函数中，关于匿名函数关联的 Self 的地址获取方式。至于其它实现，实际上大家应该很容易就能看到。

___Parent 成员指向自己的一层匿名函数的实例地址
Self 成员指向关联的 Self 实例地址
通过递归找到 Self

unit Timer.share;

interface

uses System.Classes, System.Sysutils, System.Generics.Collections, System.Generics.Defaults, System.Rtti, Vcl.ExtCtrls,
  Winapi.Windows;

type

  PShareTimerItem = ^TShareTimerItem;

  // 共享定时器项目定义
  TShareTimerItem = record
    // 回调函数
    Callback: TMethod;
    // 末次触发时间
    LastTick: UInt64;
    // 定时器间隔，单位为毫秒（注意添加时用的单位是秒，内部换算成毫秒，以减少1次计算
    Interval: Cardinal;
    // 触发次数
    Times: Cardinal;
    // 引用计数
    RefCount: Integer;
  end;

  TTimerProc = procedure(const AItem: TShareTimerItem) of object;
  TTimerProcA = reference to procedure(const AItem: TShareTimerItem);
  TTimerProcG = procedure(const AItem: TShareTimerItem);

  TShareTimer = class sealed
  private
    class var FCurrent: TShareTimer;
    class function GetCurrent: TShareTimer; static;
  protected
    FCallbacks: TList<PShareTimerItem>;
    FTimerId: Cardinal;
    class procedure DoTimer(wnd: HWND; msg: UINT; timerId: UINT_PTR; dwTime: DWORD); static;
    procedure InternalAdd(const AMethod: TMethod; AInterval: Cardinal);
    procedure InternalRemove(const AMethod: TMethod);
    procedure DoListNotify(Sender: TObject; const Item: PShareTimerItem; Action: TCollectionNotification);
    function DoClear(Owner: TObject): Integer;
    procedure FreeTimer(ATimer: PShareTimerItem);
    // 获取定时器关联的所有者对象实例(即回调函数中 Self 对应的值，如果是全局回调，则为空)
    function GetCallbackOwner(const ATimer: TShareTimerItem): TObject;
  public
    constructor Create; overload;
    destructor Destroy; override;
    class destructor Destroy;
    /// <summary>清除所有的定时器<summary>
    class procedure Clear; overload;
    /// <summary>清除关联到指定对象的所有定时器</summary>
    /// <param name="Owner">所有者对象</param>
    /// <remark>对于对象的成员函数，Owner 为对象的地址，对于匿名函数，则指向对应的回调函数的 Self 成员</remark>
    class function Clear(Owner: TObject): Integer; overload;
    /// <summary>添加一个定时器回调</summary>
    /// <param name="ACallback">定时器回调函数</param>
    /// <param name="AInterval">定时器间隔，单位为秒</param>
    class procedure Add(ACallback: TTimerProc; AInterval: Cardinal = 1); overload;
    /// <summary>添加一个定时器回调</summary>
    /// <param name="ACallback">定时器回调函数</param>
    /// <param name="AInterval">定时器间隔，单位为秒</param>
    class procedure Add(ACallback: TTimerProcG; AInterval: Cardinal = 1); overload;
    /// <summary>添加一个定时器回调</summary>
    /// <param name="ACallback">定时器回调函数</param>
    /// <param name="AInterval">定时器间隔，单位为秒</param>
    class procedure Add(ACallback: TTimerProcA; AInterval: Cardinal = 1); overload;

    /// <summary>删除一个定时器回调</summary>
    /// <param name="ACallback">定时器回调函数</param>
    class procedure Remove(ACallback: TTimerProc); overload;
    /// <summary>删除一个定时器回调</summary>
    /// <param name="ACallback">定时器回调函数</param>
    class procedure Remove(ACallback: TTimerProcG); overload;
    /// <summary>删除一个定时器回调</summary>
    /// <param name="ACallback">定时器回调函数</param>
    /// <remarks>注意匿名函数是一个接口，每次调用会对应不同的实例，这个需要自己注意管理。
    /// 如果要清除一个对象的所有定时器，调用 Clear(对象实例)
    /// <remarks>
    class procedure Remove(ACallback: TTimerProcA); overload;
    /// 全局公共实例
    class property Current: TShareTimer read GetCurrent;
  end;

implementation

{ TShareTimer }

class procedure TShareTimer.Add(ACallback: TTimerProc; AInterval: Cardinal);
begin
  Current.InternalAdd(TMethod(ACallback), AInterval * 1000);
end;

class procedure TShareTimer.Add(ACallback: TTimerProcG; AInterval: Cardinal);
var
  AMethod: TMethod;
begin
  AMethod.Code := @ACallback;
  AMethod.Data := nil;
  Current.InternalAdd(AMethod, AInterval * 1000);
end;

class procedure TShareTimer.Add(ACallback: TTimerProcA; AInterval: Cardinal);
var
  AMethod: TMethod;
begin
  AMethod.Code := nil;
  AMethod.Data := Pointer(-1);
  TTimerProcA(AMethod.Code) := ACallback;
  Current.InternalAdd(AMethod, AInterval * 1000);
end;

class procedure TShareTimer.Clear;
begin
  Current.FCallbacks.Clear;
end;

class function TShareTimer.Clear(Owner: TObject): Integer;
begin
  Result := Current.DoClear(Owner);
end;

constructor TShareTimer.Create;
begin
  inherited Create;
  FCallbacks := TList<PShareTimerItem>.Create(TComparer<PShareTimerItem>.Construct(
    function(const L, R: PShareTimerItem): Integer
    begin
      Result := IntPtr(L.Callback.Code) - IntPtr(R.Callback.Code);
      if Result = 0 then
        Result := IntPtr(L.Callback.Data) - IntPtr(R.Callback.Data);
    end));
  FCallbacks.OnNotify := DoListNotify;
end;

destructor TShareTimer.Destroy;
begin
  FCallbacks.Clear;
  FreeAndNil(FCallbacks);
  inherited;
end;

class destructor TShareTimer.Destroy;
begin
  if Assigned(FCurrent) then
    FreeAndNil(FCurrent);
end;

function TShareTimer.DoClear(Owner: TObject): Integer;
var
  I: Integer;
begin
  I := 0;
  Result := 0;
  while I < FCallbacks.Count do
  begin
    if GetCallbackOwner(FCallbacks[I]^) = Owner then
    begin
      FCallbacks.Delete(I);
      Inc(Result);
      continue;
    end;
    Inc(I);
  end;
end;

procedure TShareTimer.DoListNotify(Sender: TObject; const Item: PShareTimerItem; Action: TCollectionNotification);
begin
  if Action in [cnExtracted, cnRemoved] then
    FreeTimer(Item);
end;

class procedure TShareTimer.DoTimer(wnd: HWND; msg: UINT; timerId: UINT_PTR; dwTime: DWORD);
var
  ATick: UInt64;
  ATimers: TArray<PShareTimerItem>;
begin
  ATick := TThread.GetTickCount64;
  with TShareTimer.FCurrent do
  begin
    ATimers := FCallbacks.ToArray;
    for var I := 0 to High(ATimers) do
      Inc(ATimers[I].RefCount);
    try
      for var I := 0 to High(ATimers) do
      begin
        try
          if ATick - ATimers[I].LastTick >= ATimers[I].Interval then
          begin
            ATimers[I].LastTick := ATick;
            Inc(ATimers[I].Times);
            case IntPtr(ATimers[I].Callback.Data) of
              0:
                TTimerProcG(ATimers[I].Callback.Code)(ATimers[I]^);
              -1:
                TTimerProcA(ATimers[I].Callback.Code)(ATimers[I]^)
            else
              TTimerProc(ATimers[I].Callback)(ATimers[I]^);
            end;
          end;
        except
          on E: Exception do

        end;
      end;
    finally
      for var I := 0 to High(ATimers) do
        FreeTimer(ATimers[I]);
    end;
  end;
end;

procedure TShareTimer.FreeTimer(ATimer: PShareTimerItem);
var
  AProc: TTimerProcA;
begin
  Dec(ATimer.RefCount);
  if ATimer.RefCount = 0 then
  begin
    if (ATimer.Callback.Data = Pointer(-1)) then
    begin
      PPointer(@AProc)^ := ATimer.Callback.Code;
      AProc := nil; // 引用计数
    end;
    Dispose(ATimer);
  end;
end;

class function TShareTimer.GetCurrent: TShareTimer;
begin
  if not Assigned(FCurrent) then
    FCurrent := TShareTimer.Create;
  Result := FCurrent;
end;

function TShareTimer.GetCallbackOwner(const ATimer: TShareTimerItem): TObject;
  function GetObject(AObj: TObject): TObject;
  var
    AType: TRttiType;
    AField: TRttiField;
  begin
    Result := nil;
    AType := TRttiContext.Create.GetType(AObj.ClassType);
    if Assigned(AType) then
    begin
      AField := AType.GetField('___Parent');
      if Assigned(AField) then
        Result := GetObject(AField.GetValue(AObj).AsObject)
      else
      begin
        AField := AType.GetField('Self');
        if Assigned(AField) then
          Result := AField.GetValue(AObj).AsObject;
      end;
    end;
  end;

var
  I: Integer;
begin
  I := 0;
  if FCallbacks[I].Callback.Data <> nil then
  begin
    if FCallbacks[I].Callback.Data = Pointer(-1) then
      Result := GetObject(IInterface(FCallbacks[I].Callback.Code) as TObject)
    else
      Result := FCallbacks[I].Callback.Data;
  end
  else
    Result := nil;
end;

procedure TShareTimer.InternalAdd(const AMethod: TMethod; AInterval: Cardinal);
var
  AItem: PShareTimerItem;
  AIndex: Integer;
begin
  New(AItem);
  AItem.Callback := AMethod;
  AItem.LastTick := TThread.GetTickCount64;
  AItem.Interval := AInterval;
  AItem.RefCount := 1;
  AItem.Times := 0;
  if not FCallbacks.BinarySearch(AItem, AIndex) then
    FCallbacks.Insert(AIndex, AItem);
  if FTimerId = 0 then
    FTimerId := SetTimer(0, 0, 1000, TFNTimerProc(@DoTimer));
end;

procedure TShareTimer.InternalRemove(const AMethod: TMethod);
var
  AIndex: Integer;
  ATemp: TShareTimerItem;
begin
  ATemp.Callback := AMethod;
  if FCallbacks.BinarySearch(@ATemp, AIndex) then
    FCallbacks.Delete(AIndex);
  if FCallbacks.Count = 0 then
  begin
    KillTimer(0, FTimerId);
    FTimerId := 0;
  end;
end;

class procedure TShareTimer.Remove(ACallback: TTimerProc);
begin
  if Assigned(FCurrent) then
    FCurrent.InternalRemove(TMethod(ACallback));
end;

class procedure TShareTimer.Remove(ACallback: TTimerProcG);
var
  AMethod: TMethod;
begin
  if Assigned(FCurrent) then
  begin
    AMethod.Code := @ACallback;
    AMethod.Data := nil;
    FCurrent.InternalRemove(AMethod);
  end;
end;

class procedure TShareTimer.Remove(ACallback: TTimerProcA);
var
  AMethod: TMethod;
begin
  if Assigned(FCurrent) then
  begin
    AMethod.Code := nil;
    AMethod.Data := Pointer(-1);
    FCurrent.InternalRemove(AMethod);
  end;
end;

end.

运行时动态修改 FMX 样式

Sun, 14 Jul 2024 10:57:11 +0800

简单说几个点：

1、FMX 框架下，样式是通过名称来标志的。

2、GetStyleObject 默认是克隆原始的样式，所以直接修改对象自身的 FResourceLink 实例，不会影响其它样式，如果要修改全部同一类型控件的样式，手动调用控件的 GetStyleObject(false) 来获取样式的原始实例即可，进行调整即可。

2、只修改当前实例的特定样式步骤：

通过 ResourceLink 保护属性获取对应的样式对象（受保护成员具体如何访问参考以前的文章）
直接修改对应的样式对象或者从 ResourceLink 中删除它，然后再创建一个新的 StyleName 同名的对象，添加到 ResourceLink 中
调用 ApplyStyle 保护方法，来应用样式

3、修改全局样式步骤：

通过 GetStyleObject 保护方法，获取原始的对象链接。
查找对应的样式对象实例
视需要直接修改对应的样式对象或者从 ResourceLink 中删除它，然后再创建一个新的 StyleName 同名的对象，添加到 ResourceLink 中
发送 TStyleChangedMessage 消息，这样所有的控件都会更新样式。如果只是当前控件，那么调用下NeedStyleLookup 即可。

参考代码：

uses syste
m.Messaging;
{$R *.fmx}
type
THackedListView=class(TListView)

end;
procedure TForm4.ComboColorBox1Change(Sender: TObject);
var
  AStyle,AStyleLink:TFMXObject;
begin
// 仅修改 ListView1 的样式
//  AStyleLink:=THackedListView(ListView1).ResourceLink;
// 修改全局的 TListView 样式
  AStyleLink:= THackedListView(ListView1).GetStyleObject(false);
  AStyle:=AStyleLink.FindStyleResource('selection');
  if Assigned(AStyle) then
  begin
    if not (AStyle is TColorObject) then
      begin
      AStyleLink.RemoveObject(AStyle);
      AStyle:=TColorObject.Create(AStyleLink);
      AStyle.StyleName:='selection';
      AStyleLink.AddObject(AStyle);
      end;
      (AStyle as TColorObject).Color:=ComboColorBox1.Color;  
//仅修改 ListView1 的样式
//  THackedListView(ListView1).ApplyStyle;
// 修改了全局样式，但当前只应用 ListView1
//  ListView1.NeedStyleLookup;
// 修改了全局样式，其它所有 ListView 都更新
      TMessageManager.DefaultManager.SendMessage(Sender,TStyleChangedMessage.Create(StyleBook));

  end;
end;

上面的代码在 Windows 下是没有问题的，在其它平台，由于在克隆样式时，FMX 采用了不同的策略，所以需要做变动，参考代码如下：

type
  THackedListView = class(TListView)

  end;

procedure ChangeListViewSelectionColor(AListView: TListView; ANewColor: TAlphaColor); overload;
var
  AStyle, AStyleLink: TFmxObject;
begin
  AStyleLink := THackedListView(AListView).ResourceLink;
  AStyle := AStyleLink.FindStyleResource('selection');
  if Assigned(AStyle) then
  begin
    if not(AStyle is TColorObject) then
    begin
      AStyleLink.RemoveObject(AStyle);
      AStyle := TColorObject.Create(AStyleLink);
      AStyle.StyleName := 'selection';
      AStyleLink.AddObject(AStyle);
    end;
    (AStyle as TColorObject).Color := ANewColor;
    THackedListView(AListView).ApplyStyle;
  end;
end;

procedure ChangeListViewSelectionColor(ANewColor: TAlphaColor); overload;
var
  I: Integer;
  procedure ApplyColor(AParent: TFmxObject);
  var
    AIndex: Integer;
  begin
    if AParent is TListView then
      ChangeListViewSelectionColor(TListView(AParent),ANewColor);
    for AIndex := 0 to AParent.ChildrenCount - 1 do
      ApplyColor(AParent.Children[AIndex]);
  end;

begin
  for I := 0 to Screen.FormCount - 1 do
    ApplyColor(Screen.Forms[I]);
end;

Delphi 函数的内部函数在匿名回调函数中无法使用的一种解决办法

Sat, 13 Jul 2024 09:38:53 +0800

这个问题很简单，将对应的函数改写赋值到一个匿名函数变量即可。

function test;
  function add(x,y:Integer):Integer;
  begin
    Result:=x+y;
  end
begin 
...
end

上面的代码改写成：

type
  TfnAdd=reference to function (x,y:Integer):Integer;
function test;
var
  add:TfnAdd;
begin 
add:=function add(x,y:Integer):Integer;
  begin
    Result:=x+y;
  end;
...
end

然后在后面的直接调用 add 即可。

高效处理在主线程中显示后台线程处理进度

Thu, 11 Jul 2024 10:38:55 +0800

先看经典的处理方法：

TThread.CreateAnonymousThread(
    procedure
    var
      AHint: TZProgressNotify;
      ACount: Integer;
      ATime: Cardinal;
    const
      PassCount=1000000;
    begin
      ACount := 0;
      ATime := TThread.GetTickCount;
      while (not Application.Terminated) and (ACount < PassCount) do
      begin
        AHint.Progress := ACount*100 div PassCount ;
        AHint.HintText := ACount.ToString;
        Inc(ACount);        TThread.Synchronize(nil,
          procedure
          begin
            FProgress.Update(AHint);
          end
        );
        FProgress.Update(AHint);
      end;
      AHint.HintText := (TThread.GetTickCount - ATime).ToString + 'ms';
      FProgress.Update(AHint);
    end).Start;

我们需要更新进度时，将其切换到主线程，并更新进度显示。我们测试显示用了32735ms，也就是说100万次进度更新，用了约33秒。

接下来我们来看下优化后的代码：

TThread.CreateAnonymousThread(
    procedure
    var
      AHint: TZProgressNotify;
      ACount: Integer;
      ATime: Cardinal;
    const
      PassCount=1000000;
    begin
      ACount := 0;
      ATime := TThread.GetTickCount;
      while (not Application.Terminated) and (ACount < PassCount) do
      begin
        AHint.Progress := ACount*100 div PassCount ;
        AHint.HintText := ACount.ToString;
        Inc(ACount);        FProgress.Update(AHint);
      end;
      AHint.HintText := (TThread.GetTickCount - ATime).ToString + 'ms';
      FProgress.Update(AHint);
    end).Start;

对的，你没看错，我们将 FProgress.Update 直接在后台线程调用了。我们对其代码进行了逻辑隔离，实测 100 万次进度更新，用时 78 毫秒。

我们来看一下具体的实现：

type
  TZProgressNotify = record
    Progress: Integer;
    HintText: String;
  end;

TZMainThreadUpdator < T: record >= record
private
const
  FLAG_READING = Integer($80000000);
var
  FBuffers: array [0 .. 1] of T;
  FActiveIndex, FUpdateRefCount: Integer;
public
  procedure Update(const AValue: T);
  function GetData: T;overload;
  procedure GetData(var AValue: T);overload;
  property Data: T read GetData;
end;

{ TZMainThreadUpdator<T> }

procedure TZMainThreadUpdator<T>.GetData(var AValue: T);
// 值复制可能会引起冲突，我们需要避免在值复制时，外部更新，所以将 FActiveIndex 加入标志位
var
  ABufferIndex: Integer;
begin
  Assert(MainThreadId = TThread.Current.ThreadID,
    'GetData must invoke in main thread');
  //设置读取中标记位，设置后，Update不会更新 FActiveIndex 的值
  repeat
    ABufferIndex := FActiveIndex;
  until AtomicCmpExchange(FActiveIndex, ABufferIndex or FLAG_READING,
    ABufferIndex) = ABufferIndex;
  AValue := FBuffers[ABufferIndex];
  //允许后续的 Update 更新 FActiveIndex 的值以体现最新的进度
  AtomicExchange(FActiveIndex, ABufferIndex);
end;

function TZMainThreadUpdator<T>.GetData: T;
begin
  GetData(Result);
end;

procedure TZMainThreadUpdator<T>.Update(const AValue: T);
var
  ABufferIndex: Integer;
begin
  ABufferIndex := AtomicIncrement(FUpdateRefCount);
  try
    // 增加计数，如果有多个同时提交更新，只有第一个会保留，剩下的会丢弃
    if ABufferIndex = 1 then
    begin
      // 多个线程同时更新，只保留第一个更新线程的结果，避免使用锁
      ABufferIndex := (FActiveIndex + 1) and $1;
      FBuffers[ABufferIndex] := AValue;
      // 如果 FActiveIndex 不处于读状态，则更新，否则忽略更新，可以增加额外的标记来记录这个情况，然后在读取的时候清楚这一标记，本版本不做处理
      AtomicCmpExchange(FActiveIndex, ABufferIndex, FActiveIndex and $1);
    end;
  finally
    AtomicDecrement(FUpdateRefCount);
  end;
end;

Ｄelphi 泛型中数据内容比较

Wed, 10 Jul 2024 11:27:41 +0800

第一：你需要引入 System.Generics.Defaults 单元，系统默认实现的比较方法，都在该单元定义。

第二：你要明确下你的需求，是只比较相等就可以，还是要比较大小。

IEqualityComparer<T> 是用来比较两个值是否相等的接口
IComparer<T> 是用来比较两个值大小的接口

第三：确定是否要自己实现比较函数还是使用默认的比较函数，如果使用默认的比较函数：

IEqualityComparer<T> 的值取 TEqualityComparer<T>.Default
IComparer<T> 的值取 TEqualityComparer<T>.Default

如果要实现自己的比较函数，则可以使用预置的封装加一个匿名函数实现：

IEqualityComparer<T> 的值取 TEqualityComparer<T>.Construct(…)
IComparer<T> 的值取 TEqualityComparer<T>.Construct(…)

执行实现比较时，使用对应的 IComparer<T>.Compare 或 IEqualityComparer<T>.Equals 来比较。