mirror of
https://github.com/keymanapp/keyman.git
synced 2026-08-12 20:05:34 +00:00
419 lines
11 KiB
ObjectPascal
419 lines
11 KiB
ObjectPascal
(*
|
|
Name: UfrmDebugStatus_Elements
|
|
Copyright: Copyright (C) SIL International.
|
|
Documentation:
|
|
Description:
|
|
Create Date: 14 Sep 2006
|
|
|
|
Modified Date: 30 May 2007
|
|
Authors: mcdurdin
|
|
Related Files:
|
|
Dependencies:
|
|
|
|
Bugs:
|
|
Todo:
|
|
Notes:
|
|
History: 14 Sep 2006 - mcdurdin - Initial version
|
|
30 May 2007 - mcdurdin - I800 - Fix crash when resizing store elements
|
|
*)
|
|
unit UfrmDebugStatus_Elements;
|
|
|
|
interface
|
|
|
|
uses
|
|
System.Contnrs,
|
|
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
|
Dialogs, ComCtrls, DebugListView, XString, Menus,
|
|
UfrmDebugStatus_Child, Keyman.System.Debug.DebugEvent;
|
|
|
|
type
|
|
TfrmDebugStatus_Elements = class(TfrmDebugStatus_Child)
|
|
lvElements: TDebugListView;
|
|
mnuPopupStores: TPopupMenu;
|
|
mnuPopupStoresHexadecimalView: TMenuItem;
|
|
procedure mnuPopupStoresHexadecimalViewClick(Sender: TObject);
|
|
procedure FormResize(Sender: TObject);
|
|
procedure lvElementsCustomDrawSubItem(Sender: TCustomListView;
|
|
Item: TListItem; SubItem: Integer; State: TCustomDrawState;
|
|
var DefaultDraw: Boolean);
|
|
procedure lvElementsCustomDrawItem(Sender: TCustomListView; Item: TListItem;
|
|
State: TCustomDrawState; var DefaultDraw: Boolean);
|
|
procedure lvElementsCustomDraw(Sender: TCustomListView; const ARect: TRect;
|
|
var DefaultDraw: Boolean);
|
|
procedure lvElementsEnter(Sender: TObject);
|
|
procedure lvElementsExit(Sender: TObject);
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure FormDestroy(Sender: TObject);
|
|
private
|
|
{ Element and Store functions }
|
|
elements: TXStringElementList;
|
|
FShowHexadecimal: TXStringFormatOptions;
|
|
|
|
function FormatStoreDisplay(p: WideString; start, len: Integer): WideString;
|
|
function GetStoreDisplayWidth(Element: TXStringElement): Integer;
|
|
procedure ResizeStoreGrid;
|
|
|
|
protected
|
|
function GetHelpTopic: string; override;
|
|
procedure DisplayFontChanged; override;
|
|
public
|
|
procedure UpdateStores(Event: TDebugEvent);
|
|
procedure ClearStores;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
Keyman.Developer.System.HelpTopics,
|
|
|
|
KeymanDeveloperOptions,
|
|
UfrmDebugStatus;
|
|
|
|
{$R *.dfm}
|
|
|
|
const
|
|
LVM_FIRST = $1000;
|
|
LVM_GETSUBITEMRECT = LVM_FIRST+56;
|
|
LVIR_BOUNDS = 0;
|
|
|
|
procedure TfrmDebugStatus_Elements.ClearStores;
|
|
begin
|
|
lvElements.Items.Clear;
|
|
elements.Clear;
|
|
end;
|
|
|
|
procedure TfrmDebugStatus_Elements.lvElementsCustomDraw(Sender: TCustomListView;
|
|
const ARect: TRect; var DefaultDraw: Boolean);
|
|
begin
|
|
if (lvElements.Items.Count = 0) and lvElements.Focused then
|
|
with lvElements.Canvas do
|
|
begin
|
|
// DefaultDraw := False;
|
|
DrawFocusRect(Rect(0, 0, lvElements.Columns[0].Width, TextHeight('A')+1));
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmDebugStatus_Elements.lvElementsCustomDrawItem(
|
|
Sender: TCustomListView; Item: TListItem; State: TCustomDrawState;
|
|
var DefaultDraw: Boolean);
|
|
var
|
|
p1, p2, p3, p: WideString;
|
|
sz1, sz2: TSize;
|
|
r: TRect;
|
|
Element: TXStringElement;
|
|
hOldFont: HFONT;
|
|
begin
|
|
DefaultDraw := False;
|
|
with Sender.Canvas do
|
|
begin
|
|
Element := TXStringElement(Item.Data);
|
|
Font := lvElements.Font;
|
|
//Font.Name := 'Tahoma';
|
|
|
|
r := Item.DisplayRect(drSelectBounds);
|
|
|
|
p := Element.Name;
|
|
if FKeymanDeveloperOptions.DebuggerShowStoreOffset and (Element.Tag > 0) then
|
|
p := p + ' ('+IntToStr(Element.Tag)+')';
|
|
|
|
GetTextExtentPoint32W(Handle, PWideChar(p), Length(p), sz1);
|
|
if sz1.cx+2 < lvElements.Column[0].Width
|
|
then r.Right := r.Left + sz1.cx+2
|
|
else r.Right := r.Left + lvElements.Column[0].Width;
|
|
|
|
SetBkMode(Handle, TRANSPARENT);
|
|
if cdsSelected in State then
|
|
begin
|
|
SetTextColor(Handle, GetSysColor(COLOR_HIGHLIGHTTEXT));
|
|
Windows.FillRect(Handle, r, HBRUSH(COLOR_HIGHLIGHT+1));
|
|
end
|
|
else
|
|
begin
|
|
SetTextColor(Handle, GetSysColor(COLOR_WINDOWTEXT));
|
|
Windows.FillRect(Handle, r, HBRUSH(COLOR_WINDOW+1));
|
|
end;
|
|
if cdsFocused in State then
|
|
DrawFocusRect(r);
|
|
|
|
TextOutW(Handle, r.Left + 2, r.Top + 1, PWideChar(p), Length(p));
|
|
end;
|
|
|
|
with Sender.Canvas do
|
|
begin
|
|
Element := TXStringElement(Item.Data);
|
|
Font := lvElements.Font;
|
|
hOldFont := SelectObject(Handle, Font.Handle); // Selecting font not working?
|
|
|
|
if Element.Tag = 0 then
|
|
with TXString.Create(Element.Store, debugkeyboard) do
|
|
try
|
|
p1 := FormatString(FShowHexadecimal);
|
|
p2 := '';
|
|
p3 := '';
|
|
finally
|
|
Free;
|
|
end
|
|
else
|
|
begin
|
|
p1 := FormatStoreDisplay(Element.Store, 1, Element.Tag-1);
|
|
p2 := ' '+FormatStoreDisplay(Element.Store, Element.Tag, 1)+' ';
|
|
p3 := FormatStoreDisplay(Element.Store, Element.Tag+1, $FFFF);
|
|
if p1 = '' then Delete(p2,1,1);
|
|
if p3 = '' then Delete(p2,Length(p2),1);
|
|
end;
|
|
|
|
r.Top := 1;
|
|
r.Left := LVIR_BOUNDS;
|
|
SendMessage(Sender.Handle, LVM_GETSUBITEMRECT, Item.Index, DWord(@r));
|
|
|
|
if xfoHexadecimal in FShowHexadecimal then
|
|
begin
|
|
SelectObject(Handle, hOldFont); // Selecting font not working?
|
|
Font.Name := 'Courier New';
|
|
hOldFont := SelectObject(Handle, Font.Handle); // Selecting font not working?
|
|
end;
|
|
|
|
Windows.FillRect(Handle, r, HBRUSH(COLOR_WINDOW+1));
|
|
|
|
GetTextExtentPoint32W(Handle, PWideChar(p1), Length(p1), sz1);
|
|
GetTextExtentPoint32W(Handle, PWideChar(p2), Length(p2), sz2);
|
|
SetTextColor(Handle, GetSysColor(COLOR_WINDOWTEXT));
|
|
TextOutW(Handle, r.Left + 2, r.Top + 1, {Rect.Left + 2, Rect.Top + 1,} PWideChar(p1), Length(p1));
|
|
SetTextColor(Handle, RGB(255,0,0));
|
|
TextOutW(Handle, r.Left + sz1.cx+2, r.Top + 1, {Rect.Left + sz1.cx + 2, Rect.Top + 1,} PWideChar(p2), Length(p2));
|
|
SetTextColor(Handle, GetSysColor(COLOR_WINDOWTEXT));
|
|
TextOutW(Handle, r.Left + sz1.cx+sz2.cx+2, r.Top + 1, {Rect.Left + sz1.cx + sz2.cx + 2, Rect.Top + 1,} PWideChar(p3), Length(p3));
|
|
SelectObject(Handle, hOldFont); // Selecting font not working?
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmDebugStatus_Elements.lvElementsCustomDrawSubItem(
|
|
Sender: TCustomListView; Item: TListItem; SubItem: Integer;
|
|
State: TCustomDrawState; var DefaultDraw: Boolean);
|
|
begin
|
|
DefaultDraw := False;
|
|
end;
|
|
|
|
procedure TfrmDebugStatus_Elements.lvElementsEnter(Sender: TObject);
|
|
begin
|
|
lvElements.Repaint;
|
|
end;
|
|
|
|
procedure TfrmDebugStatus_Elements.lvElementsExit(Sender: TObject);
|
|
begin
|
|
lvElements.Repaint;
|
|
end;
|
|
|
|
procedure TfrmDebugStatus_Elements.mnuPopupStoresHexadecimalViewClick(Sender: TObject);
|
|
begin
|
|
if xfoHexadecimal in FShowHexadecimal
|
|
then FShowHexadecimal := []
|
|
else FShowHexadecimal := [xfoHexadecimal];
|
|
UpdateStores(CurrentEvent);
|
|
lvElements.Repaint;
|
|
end;
|
|
|
|
procedure TfrmDebugStatus_Elements.DisplayFontChanged;
|
|
begin
|
|
inherited;
|
|
lvElements.Font := DisplayFont;
|
|
lvElements.Invalidate;
|
|
ResizeStoreGrid;
|
|
end;
|
|
|
|
procedure TfrmDebugStatus_Elements.UpdateStores(Event: Keyman.System.Debug.DebugEvent.TDebugEvent);
|
|
var
|
|
ncontext, i: Integer;
|
|
e: TXStringElement;
|
|
begin
|
|
SendMessage(lvElements.Handle, WM_SETREDRAW, 0, 0);
|
|
try
|
|
lvElements.DoubleBuffered := True;
|
|
lvElements.Items.Clear;
|
|
elements.Clear;
|
|
|
|
if not Assigned(Event) then Exit;
|
|
|
|
with TXString.Create(Event.Rule.Rule.dpContext, debugkeyboard) do
|
|
try
|
|
FormatElements(elements, FShowHexadecimal);
|
|
finally
|
|
Free;
|
|
end;
|
|
|
|
ncontext := elements.Count;
|
|
|
|
with TXString.Create(Event.Rule.Rule.dpOutput, debugkeyboard) do
|
|
try
|
|
FormatElements(elements, FShowHexadecimal);
|
|
finally
|
|
Free;
|
|
end;
|
|
|
|
{ Set store offsets for all stores }
|
|
for i := 0 to Event.Rule.nStores - 1 do
|
|
elements[i].Tag := Event.Rule.StoreOffsets[i]+1;
|
|
|
|
{ Add + > }
|
|
|
|
e := TXStringElement.Create;
|
|
e.StoreIndex := -1;
|
|
e.Pos := 0;
|
|
elements.Insert(ncontext, e);
|
|
|
|
if Event.Rule.Group.fUsingKeys then
|
|
with TXString.Create(Event.Rule.Rule.Key, debugkeyboard) do
|
|
try
|
|
e.Name := '+ '+FormatString(FShowHexadecimal)+' >';
|
|
finally
|
|
Free;
|
|
end
|
|
else
|
|
e.Name := '>';
|
|
|
|
for i := 0 to elements.Count - 1 do
|
|
with lvElements.Items.Add do
|
|
begin
|
|
Data := elements[i];
|
|
Caption := '';
|
|
SubItems.Add('');
|
|
end;
|
|
|
|
ResizeStoreGrid;
|
|
finally
|
|
SendMessage(lvElements.Handle, WM_SETREDRAW, 1, 0);
|
|
lvElements.Repaint;
|
|
end;
|
|
end;
|
|
|
|
function TfrmDebugStatus_Elements.FormatStoreDisplay(p: WideString; start, len: Integer): WideString;
|
|
var
|
|
s: WideString;
|
|
begin
|
|
with TXString.Create(p, debugkeyboard) do
|
|
try
|
|
s := SubString(start, len);
|
|
finally
|
|
Free;
|
|
end;
|
|
|
|
with TXString.Create(s, debugkeyboard) do
|
|
try
|
|
Result := FormatString(FShowHexadecimal);
|
|
finally
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmDebugStatus_Elements.FormCreate(Sender: TObject);
|
|
begin
|
|
inherited;
|
|
elements := TXStringElementList.Create;
|
|
end;
|
|
|
|
procedure TfrmDebugStatus_Elements.FormDestroy(Sender: TObject);
|
|
begin
|
|
inherited;
|
|
FreeAndNil(elements);
|
|
end;
|
|
|
|
procedure TfrmDebugStatus_Elements.FormResize(Sender: TObject);
|
|
begin
|
|
ResizeStoreGrid;
|
|
lvElements.Repaint;
|
|
end;
|
|
|
|
function TfrmDebugStatus_Elements.GetHelpTopic: string;
|
|
begin
|
|
Result := SHelpTopic_Context_DebugStatus_Elements;
|
|
end;
|
|
|
|
function TfrmDebugStatus_Elements.GetStoreDisplayWidth(Element: TXStringElement): Integer;
|
|
var
|
|
p1, p2, p3: WideString;
|
|
sz1, sz2, sz3: TSize;
|
|
hOldFont: HFONT;
|
|
begin
|
|
if Element.Tag = 0 then
|
|
with TXString.Create(Element.Store, debugkeyboard) do
|
|
try
|
|
p1 := FormatString(FShowHexadecimal);
|
|
p2 := '';
|
|
p3 := '';
|
|
finally
|
|
Free;
|
|
end
|
|
else
|
|
begin
|
|
p1 := FormatStoreDisplay(Element.Store, 1, Element.Tag-1);
|
|
p2 := ' '+FormatStoreDisplay(Element.Store, Element.Tag, 1)+' ';
|
|
p3 := FormatStoreDisplay(Element.Store, Element.Tag+1, $FFFF);
|
|
if p1 = '' then Delete(p2,1,1);
|
|
if p3 = '' then Delete(p2,Length(p2),1);
|
|
end;
|
|
|
|
with lvElements.Canvas do
|
|
begin
|
|
Font := lvElements.Font;
|
|
if xfoHexadecimal in FShowHexadecimal then Font.Name := 'Courier New';
|
|
hOldFont := SelectObject(Handle, Font.Handle);
|
|
GetTextExtentPoint32W(Handle, PWideChar(p1), Length(p1), sz1);
|
|
GetTextExtentPoint32W(Handle, PWideChar(p2), Length(p2), sz2);
|
|
GetTextExtentPoint32W(Handle, PWideChar(p3), Length(p3), sz3);
|
|
Result := sz1.cx + sz2.cx + sz3.cx;
|
|
SelectObject(Handle, hOldFont);
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmDebugStatus_Elements.ResizeStoreGrid;
|
|
var
|
|
w, maxw, i: Integer;
|
|
p: WideString;
|
|
sz: TSize;
|
|
hOldFont: HFONT;
|
|
begin
|
|
lvElements.Columns[1].Width := 1; // Don't interfere with scroll bars
|
|
|
|
maxw := 100;
|
|
with lvElements.Canvas do
|
|
begin
|
|
Font := lvElements.Font;
|
|
//Font.Name := 'Tahoma';
|
|
hOldFont := SelectObject(Handle, Font.Handle);
|
|
|
|
for i := 0 to lvElements.Items.Count-1 do
|
|
begin
|
|
with TXStringElement(lvElements.Items[i].Data) do
|
|
begin
|
|
p := Name;
|
|
if FKeymanDeveloperOptions.DebuggerShowStoreOffset and (Tag > 0) then
|
|
p := p + ' ('+IntToStr(Tag)+')';
|
|
end;
|
|
GetTextExtentPoint32W(Handle, PWideChar(p), Length(p), sz);
|
|
if sz.cx + 4 > maxw then maxw := sz.cx + 4;
|
|
end;
|
|
|
|
SelectObject(Handle, hOldFont);
|
|
|
|
lvElements.Columns[0].Width := maxw;
|
|
end;
|
|
|
|
maxw := lvElements.ClientWidth - lvElements.Columns[0].Width - 4;
|
|
for i := 0 to lvElements.Items.Count-1 do
|
|
begin
|
|
w := GetStoreDisplayWidth(TXStringElement(lvElements.Items[i].Data));
|
|
if w > maxw then maxw := w;
|
|
end;
|
|
|
|
if maxw <= 0 then maxw := 1;
|
|
lvElements.Columns[1].Width := maxw;
|
|
end;
|
|
|
|
{procedure TfrmDebugStatus_Elements.RefreshOptions;
|
|
begin
|
|
lvElements.Repaint;
|
|
end;}
|
|
|
|
end.
|
|
|
|
|