Login | ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/fastphp/trunk/FastPHPTreeView.pas
Revision: 44
Committed: Mon Dec 18 15:13:00 2017 UTC (2 years, 3 months ago) by daniel-marschall
Content type: text/x-pascal
File size: 6150 byte(s)

File Contents

# Content
1 unit FastPHPTreeView;
2
3 interface
4
5 uses
6 SysUtils, Classes, ComCtrls;
7
8 (*
9
10 <FastPHPData> ::= <FastPHPData100> .
11
12 Version 1.00 (signature "FAST100!"):
13
14 <FastPHPData100> ::= <Signature100> ( <Nodes> <Exit> | <Exit> ) .
15 <Signature100> ::= "F" "A" "S" "T" "1" "0" "0" "!" .
16 <Nodes> ::= <Node> | ( <Nodes> <Node> ) .
17 <Node> ::= <LeafNode> | ( <LeafNode> <IncreaseLevel> <Nodes> <DecreaseLevel> ) .
18
19 <LeafNode> ::= "N" <Icon> <LineNo> <DescLen> <Desc> .
20 <IncreaseLevel> ::= "I" .
21 <DecreaseLevel> ::= "D" .
22 <Exit> ::= "X" .
23
24 <LineNo> ::= <Int8> .
25 <DescLen> ::= <Int4> .
26 <Desc> ::= (Utf8-String) .
27 <Icon> ::= <NoIcon> | <ImageIndex> .
28
29 <NoIcon> ::= "_" "_" "_" "_" .
30 <ImageIndex> ::= <Int4> .
31
32 <Int1> ::= "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" .
33 <Int2> ::= <Int1> <Int1> .
34 <Int4> ::= <Int2> <Int2> .
35 <Int8> ::= <Int4> <Int4> .
36
37 *)
38
39 type
40 TTreeViewFastPHP = class helper for TTreeView
41 private
42 class function Read(var ptr: PChar; len: integer): string; inline;
43 procedure Rec100(tn: TTreeNode; var ptr: PChar);
44 protected
45 function DoFillWithFastPHPData(ptr: PChar): boolean;
46 public
47 function FillWithFastPHPData(data: string): boolean;
48 end;
49
50 EFastNodeException = class(Exception);
51
52 implementation
53
54 uses
55 StrUtils, Windows;
56
57 const
58 LEN_MAGIC = 8;
59 LEN_ICON = 4;
60 LEN_LINENO = 8;
61 LEN_DESCLEN = 4;
62
63 {$EXTERNALSYM LockWindowUpdate}
64 function LockWindowUpdate(hWndLock: HWND): BOOL; stdcall; external user32 name 'LockWindowUpdate';
65
66 function HexToInt(HexNum: string): LongInt;
67 begin
68 Result := StrToInt('$' + HexNum);
69 end;
70
71 function TTreeViewFastPHP.DoFillWithFastPHPData(ptr: PChar): boolean;
72
73 function _NodeID(tn: TTreeNode): string;
74 var
75 tmp: TTreeNode;
76 begin
77 // Attention: This function requires that the tree node items are unique
78 // e.g. Class1->function1() is unique
79 result := tn.Text;
80 tmp := tn.Parent;
81 while tmp <> nil do
82 begin
83 result := tmp.Text + #0 + result;
84 tmp := tmp.Parent;
85 end;
86 end;
87
88 var
89 s: String;
90 tn: TTreeNode;
91 expanded: TStringList;
92 selected, magic: string;
93 horPos, verPos: integer;
94 i: integer;
95 begin
96 // No update if the user is dragging the scrollbar
97 // (otherwise the program will somehow lock up)
98 result := GetCapture <> Handle;
99 if not result then exit;
100
101 selected := '';
102 expanded := TStringList.Create;
103 horPos := GetScrollPos(Handle, SB_HORZ);
104 verPos := GetScrollPos(Handle, SB_VERT);
105 LockWindowUpdate(Handle); // Parent is better choice for FastPHP... but for other applications it might be wrong?
106 Self.Items.BeginUpdate;
107 try
108 {$REGION 'Remember our current state (selected and expanded flags)'}
109 for i := 0 to Self.Items.Count-1 do
110 begin
111 tn := Self.Items.Item[i];
112 s := _NodeID(tn);
113 if tn.Selected then selected := s;
114 if tn.Expanded and tn.HasChildren then expanded.Add(s);
115 end;
116 {$ENDREGION}
117
118 {$REGION 'Update the treeview'}
119 Self.Items.Clear;
120 magic := Read(ptr, LEN_MAGIC);
121 if magic = 'FAST100!' then
122 Rec100(nil, ptr)
123 else
124 raise EFastNodeException.CreateFmt('FastNode version "%s" not supported.', [magic]);
125 {$ENDREGION}
126
127 {$REGION 'Recover the previous current state (selected and expanded flags)'}
128 for i := 0 to Self.Items.Count-1 do
129 begin
130 tn := Self.Items.Item[i];
131 s := _NodeID(tn);
132 if selected = s then tn.Selected := true;
133 if expanded.IndexOf(s) >= 0 then tn.Expand(false);
134 end;
135 {$ENDREGION}
136 finally
137 Self.Items.EndUpdate;
138 LockWindowUpdate(0);
139
140 SetScrollPos(Handle, SB_HORZ, horPos, false);
141 SetScrollPos(Handle, SB_VERT, verPos, false);
142
143 expanded.Free;
144 end;
145 end;
146
147 function TTreeViewFastPHP.FillWithFastPHPData(data: string): boolean;
148 var
149 tn: TTreeNode;
150 begin
151 result := false;
152 try
153 data := Trim(data);
154 if not EndsStr('X', data) then raise EFastNodeException.Create('FastNode string must end with "X"');
155
156 result := DoFillWithFastPHPData(PChar(data));
157 except
158 on E: Exception do
159 begin
160 Self.Items.Clear;
161 tn := Self.Items.Add(nil, 'ERROR: ' + E.Message);
162 tn.ImageIndex := -1;
163 tn.SelectedIndex := -1;
164 end;
165 end;
166 end;
167
168 class function TTreeViewFastPHP.Read(var ptr: PChar; len: integer): string;
169 begin
170 result := Copy(string(ptr), 1, len);
171 inc(ptr, len);
172 end;
173
174 procedure TTreeViewFastPHP.Rec100(tn: TTreeNode; var ptr: PChar);
175 var
176 typ, icon, lineno, len, caption: string;
177 lastTn: TTreeNode;
178 begin
179 try
180 lastTn := nil;
181 while true do
182 begin
183 repeat
184 typ := Read(ptr, 1);
185 until Trim(typ) <> '';
186 if typ = 'N' then // new node
187 begin
188 icon := Read(ptr, LEN_ICON);
189 lineno := Read(ptr, LEN_LINENO);
190 len := Read(ptr, LEN_DESCLEN);
191 caption := Utf8Decode(Read(ptr, StrToInt(len)));
192 if tn = nil then
193 lastTn := Self.Items.Add(nil, caption)
194 else
195 lastTn := Self.Items.AddChild(tn, caption);
196
197 {$REGION 'Determinate icon'}
198 if icon = '____' then
199 lastTn.ImageIndex := -1
200 else
201 lastTn.ImageIndex := StrToInt(icon);
202 lastTn.SelectedIndex := lastTn.ImageIndex;
203 {$ENDREGION}
204
205 lastTn.Data := Pointer(StrToInt(lineno)); // Hack...
206 end
207 else if typ = 'I' then // increase level
208 begin
209 if LastTn = nil then raise EFastNodeException.Create('Fast100: Increase command requires previous node');
210 Rec100(lastTn, ptr);
211 end
212 else if typ = 'D' then Exit // decrease level
213 else if typ = 'X' then Abort // exit
214 else raise EFastNodeException.CreateFmt('Fast100: Command "%s" unknown', [typ]);
215 end;
216 except
217 on E: EAbort do
218 if tn = nil then
219 exit
220 else
221 raise;
222 else
223 raise;
224 end;
225 end;
226
227 end.