Нарушение прав доступа после уничтожения TStringEditLink (TVirtualStringTree) — пример Lazarus

У меня нет Lazarus, но на XE4 он ведет себя так же.

В моей установке VST, расположенной в ./VirtualTreeviewV5.3.0/Demos/Advanced, есть файл Editors.pas, в котором я нашел деструктор ниже. Обратите внимание на комментарий casues issue #357:

destructor TPropertyEditLink.Destroy;
begin
  //FEdit.Free; casues issue #357. Fix:
  if FEdit.HandleAllocated then
    PostMessage(FEdit.Handle, CM_RELEASE, 0, 0);
  inherited;
end;

Более того, FEdit.Free выполняется в методе PrepareEdit перед его новым созданием:

function TStringEditLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean;
var
  FCellText: String;
  FCellTextBounds: TRect;
  FCellFont: TFont;
begin
  Result := True;
  FTree := Tree as TVirtualStringTree;

  FNode := Node;
  FColumn := Column;

  FEdit.Free;
  FEdit := nil;

  FCellFont:= TFont.Create;
  FTree.GetTextInfo(FNode, FColumn, FCellFont, FCellTextBounds, FCellText);

  FEdit := TComboBox.Create(nil);
  with FEdit as TComboBox do
  . . .

Это решает проблемы VK_ESC и VK_RETURN в моей установке XE4 и XE7.

Проблема #357, похоже, еще не решена: см. - Used fix proposed in issue #361 to fix issue #357 (AV in advanced demo - PropertiesDemo form in XE3+). Я не нашел никаких доказательств существования #361 fix.

procedure TForm2.VirtualTreeClick(Sender: TObject);
var
  VT: TVirtualStringTree;
  Click: THitInfo;
begin
  VT:= Sender as TVirtualStringTree;
  VT.GetHitTestInfoAt(Mouse.CursorPos.X-VT.ClientOrigin.X, Mouse.CursorPos.Y-VT.ClientOrigin.Y, True, Click);

  if Assigned(Click.HitNode) then
    VT.EditNode(Click.HitNode,Click.HitColumn);
end;

uses Unit2;

Эта трассировка псевдостека вашего кода иллюстрирует проблему:

FEdit.EditKeyDown()
  -- calls --
FTree.EndEditNode()  { or FTree.CancelEditNode }
  -- which calls --
TStringEditLink.Destroy()
  -- which calls --
FEdit.Free()

Код в обработчике событий для FEdit.EditKeyDown() освобождает FEdit до того, как завершится выполнение кода обработчика событий нажатия клавиши. Таким образом, ошибка нарушения доступа.

Мы справились с этим, настроив сигнальный механизм, чтобы TStringEditLink могла сигнализировать основной форме, когда это будет сделано, и главная форма могла запустить код для уничтожения TStringEditLink (поскольку именно она создала TStringEditLink в первую очередь). Мы добавили TTimer в основную форму и свойство для получения сигнала. TTimer наблюдает за собственностью. Компонент TStringEditLink имеет указатель на форму, поэтому он может установить свойство.

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, VirtualTrees;

type
  TEditorAction = (eaCancel, eaAccept, eaNotSet);

  TForm1 = class(TForm)
    vstTree: TVirtualStringTree;
    procedure vstTreeCreateEditor(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; out EditLink: IVTEditLink);
    procedure DoWatchTreeEditorTimer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FEndEditTimer: TTimer;
    FEditorAction: TEditorAction;
    procedure SetEditorAction(const Value: TEditorAction);
  public
    property EditorAction: TEditorAction read FEditorAction write SetEditorAction;
  end;

  TPropertyEdit = class(TInterfacedObject, IVTEditLink)
    procedure EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  private
    FEdit: TWinControl;
    FTree: TVirtualStringTree;
    FNode: PVirtualNode;
    FColumn: Integer;
  public
    FForm: TForm1;
    destructor Destroy; override;
    function BeginEdit: Boolean; stdcall;
    function CancelEdit: Boolean; stdcall;
    function EndEdit: Boolean; stdcall;
    function GetBounds: TRect; stdcall;
    function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall;
    procedure ProcessMessage(var Message: TMessage); stdcall;
    procedure SetBounds(R: TRect); stdcall;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  FEndEditTimer := TTimer.Create(nil);
  FEndEditTimer.Enabled := False;
  FEndEditTimer.Interval := 100;
  FEndEditTimer.OnTimer := DoWatchTreeEditorTimer;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeAndNil(FEndEditTimer);
end;

procedure TForm1.vstTreeCreateEditor(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; out EditLink: IVTEditLink);
begin
  EditLink := TPropertyEdit.Create;
  TPropertyEdit(EditLink).FForm := Self; { lets us signal the form when the editor needs to be destroyed }
  FEditorAction := eaNotSet;
end;

procedure TForm1.SetEditorAction(const Value: TEditorAction);
begin
  if FEditorAction <> Value then
  begin
    FEditorAction := Value;
    FEndEditTimer.Enabled := True;
  end;
end;

procedure TForm1.DoWatchTreeEditorTimer(Sender: TObject);
begin
  FEndEditTimer.Enabled := False;
  Application.ProcessMessages;
  case FEditorAction of
    eaCancel:
      begin
        vstTree.CancelEditNode;
        vstTree.SetFocus;
      end;
    eaAccept:
      begin
        vstTree.EndEditNode;
        vstTree.SetFocus;
      end;
  end;
end;

{ TPropertyEdit }

function TPropertyEdit.BeginEdit: Boolean;
begin
  Result := True;
  FEdit.Show;
end;

function TPropertyEdit.CancelEdit: Boolean;
begin
  Result := True;
  FEdit.Hide;
  FForm.FEditorAction := eaCancel;
end;

destructor TPropertyEdit.Destroy;
begin
  if FEdit <> nil then
    FreeAndNil(FEdit);
  inherited;
end;

procedure TPropertyEdit.EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  case Key of
    VK_ESCAPE:
      begin
        Key := Word(0); { some versions of Delphi throw random A/V errors if '0' is not cast as a Word() }
        FForm.EditorAction := eaCancel;
      end;
    VK_RETURN:
      begin
        Key := Word(0); { some versions of Delphi throw random A/V errors if '0' is not cast as a Word() }
        FForm.EditorAction := eaAccept
      end;
  end;
end;

function TPropertyEdit.EndEdit: Boolean;
begin
  Result := True;
  { Do something with the value provided by the user }
  FEdit.Hide;
  FForm.EditorAction := eaAccept;
end;

function TPropertyEdit.GetBounds: TRect;
begin
  Result := FEdit.BoundsRect;
end;

function TPropertyEdit.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean;
begin
  Result := True;
  FTree := Tree as TVirtualStringTree;
  FNode := Node;
  FColumn := Column;
  { Setup the editor for user }
  FEdit := TSomeWinControl.Create(nil);
  FEdit.Properties := Values;
  { Capture keystrokes }
  FEdit.OnKeyDown := EditKeyDown;
end;

procedure TPropertyEdit.ProcessMessage(var Message: TMessage);
begin
  FEdit.WindowProc(Message);
end;

procedure TPropertyEdit.SetBounds(R: TRect);
var
  Dummy: Integer;
begin
  FTree.Header.Columns.GetColumnBounds(FColumn, Dummy, R.Right);
  FEdit.BoundsRect := R;
end;

end.

Наш код делает много дополнительных вещей, поэтому приведенный выше код представляет собой копирование/вставку основных частей, чтобы продемонстрировать, как преодолеть состояние гонки. Это не проверено, но должно указать вам правильное направление.

Одним из решений также является освобождение ранее созданных элементов управления.

function TStringEditLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean;
var
  FCellText: String;
  FCellTextBounds: TRect;
  FCellFont: TFont;
  i: Integer;
  Item: TControl;
begin
  Result := True;
  FTree := Tree as TVirtualStringTree;

  FNode := Node;
  FColumn := Column;

  FCellFont:= TFont.Create;
  FTree.GetTextInfo(FNode, FColumn, FCellFont, FCellTextBounds, FCellText);

  //----->> free previuous created control <<----------
  for i := (FTree.ControlCount - 1) downto 0 do
    begin
      Item := FTree.controls[i];
      if assigned(item) then
        begin
          if item is TComboBox then FreeAndNil(item);
        end;
    end;
  //---------------------------------------------------

  FEdit := TComboBox.Create(nil);
  with FEdit as TComboBox do
    begin
      Visible := False;
      Parent := Tree;
      Items.Add('Google');
      Items.Add('Yahoo');
      Items.Add('Altavista');
      OnKeyDown := EditKeyDown;
      Text:= FCellText;
    end;
end;

Решение, которое я использовал в конце, указано ниже:

TBasePanel = class(TPanel)
  private
    procedure CMRelease(var Message: TMessage); message CM_RELEASE;
  protected
  public
    procedure Release; virtual;
  end;

TStringEditLink = class(TInterfacedObject, IVTEditLink)
  private
    FBasePanel: TBasePanel;
    ...
  protected
    procedure EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  public
    destructor Destroy; override;
    function BeginEdit: Boolean; stdcall;
    function CancelEdit: Boolean; stdcall;
    function EndEdit: Boolean; stdcall;
    function GetBounds: TRect; stdcall;
    function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall;
    procedure ProcessMessage(var Message: TMessage); stdcall;
    procedure SetBounds(R: TRect); stdcall;
  end;

implementation

procedure TBasePanel.CMRelease(var Message: TMessage);
begin
  Free;
end;

procedure TBasePanel.Release;
begin
  if HandleAllocated then
    PostMessage(Handle, CM_RELEASE, 0, 0);
end;

destructor TStringEditLink.Destroy;
begin
  if Assigned(FBasePanel) then FBasePanel.Release;
  inherited;
end;

FBasePanel следует использовать как owner и как parent, поскольку столько редакторов компонентов хотели бы отображать одновременно.

В исходном коде HeidiSql есть хороший пример, позволяющий избежать этой ошибки. Код немного изменился:

procedure TBaseEditorLink.TempWindowProc(var Message: TMessage);
begin
  case Message.Msg of
    WM_CHAR: //Catch hotkeys
      if not (TWMChar(Message).CharCode = VK_TAB) then FOldWindowProc(Message);
    WM_GETDLGCODE: //"WantTabs" mode for main control
      Message.Result := Message.Result or DLGC_WANTARROWS or DLGC_WANTALLKEYS or DLGC_WANTTAB;
    else
      begin
        try
          FOldWindowProc(Message);
        except
          on E : EAccessViolation do; //EAccessViolation occurring in some cases
          on E : Exception do raise;
        end;
      end;
  end;
end;