1 unit MainUnit;
2
3 {$mode objfpc}{$H+}
4
5 interface
6
7 uses
8 Classes, SysUtils, TypInfo, LCLProc, Forms, Controls, Graphics, Dialogs,
9 StdCtrls, Buttons, LazUTF8, Laz_XMLStreaming, Laz2_DOM, Laz2_XMLCfg;
10
11 type
12 TMyEnum = (myEnum1, myEnum2, myEnum3);
13 TMySet = set of TMyEnum;
14
15 { TMyCollectionItem }
16
17 TMyCollectionItem = class(TCollectionItem)
18 private
19 FMyString: string;
20 published
21 property MyString: string read FMyString write FMyString;
22 end;
23
24 { TMyComponent }
25
26 TMyComponent = class(TComponent)
27 private
28 FMyBoolean: Boolean;
29 FMyCollection: TCollection;
30 FMyDouble: Double;
31 FMyEnum: TMyEnum;
32 FMyInt64: int64;
33 FMyInteger: integer;
34 FMySet: TMySet;
35 FMySingle: Single;
36 FMyString: string;
37 FMyStrings: TStrings;
38 FMyWideString: widestring;
39 public
40 constructor Create(TheOwner: TComponent); override;
41 destructor Destroy; override;
42 procedure WriteDebugReport;
43 published
44 property MyDouble: Double read FMyDouble write FMyDouble;
45 property MySingle: Single read FMySingle write FMySingle;
46 property MyWideString: widestring read FMyWideString write FMyWideString;
47 property MyInteger: integer read FMyInteger write FMyInteger;
48 property MyString: string read FMyString write FMyString;
49 property MyInt64: int64 read FMyInt64 write FMyInt64;
50 property MySet: TMySet read FMySet write FMySet;
51 property MyBoolean: Boolean read FMyBoolean write FMyBoolean;
52 property MyEnum: TMyEnum read FMyEnum write FMyEnum;
53 property MyCollection: TCollection read FMyCollection write FMyCollection;
54 property MyStrings: TStrings read FMyStrings write FMyStrings;
55 end;
56
57 { TMyGroupBox }
58
59 TMyGroupBox = class(TGroupBox)
60 published
61 procedure AnEvent(Sender: TObject);
62 end;
63
64
65 { TStreamAsXMLForm }
66
67 TStreamAsXMLForm = class(TForm)
68 Button1: TButton;
69 SourceGroupBox: TGroupBox;
70 DestinationGroupBox: TGroupBox;
71 procedure FormCreate(Sender: TObject);
72 private
73 FFilename: string;
74 procedure SetFilename(const AValue: string);
75 public
76 MyComponent: TMyComponent;
77 DemoGroupBox: TMyGroupBox;
78
79 procedure WriteComponents;
80 procedure ReadComponents;
81 procedure OnFindComponentClass({%H-}Reader: TReader; const AClassName: string;
82 var ComponentClass: TComponentClass);
83 property Filename: string read FFilename write SetFilename;
84 end;
85
86 var
87 StreamAsXMLForm: TStreamAsXMLForm;
88
CreateXMLWriternull89 function CreateXMLWriter(ADoc: TDOMDocument; const Path: string;
90 Append: Boolean; var DestroyDriver: boolean): TWriter;
CreateXMLReadernull91 function CreateXMLReader(ADoc: TDOMDocument; const Path: string;
92 var DestroyDriver: boolean): TReader;
93
94 procedure WriteComponentToXMLConfig(XMLConfig: TXMLConfig; const Path: string;
95 AComponent: TComponent);
96 procedure ReadComponentFromXMLConfig(XMLConfig: TXMLConfig; const Path: string;
97 var RootComponent: TComponent;
98 OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent);
99
100 implementation
101
102 {$R mainunit.lfm}
103
CreateXMLWriternull104 function CreateXMLWriter(ADoc: TDOMDocument; const Path: string;
105 Append: Boolean; var DestroyDriver: boolean): TWriter;
106 var
107 Driver: TAbstractObjectWriter;
108 begin
109 Driver:=TXMLObjectWriter.Create(ADoc,Path,Append);
110 DestroyDriver:=true;
111 Result:=TWriter.Create(Driver);
112 end;
113
CreateXMLReadernull114 function CreateXMLReader(ADoc: TDOMDocument; const Path: string;
115 var DestroyDriver: boolean): TReader;
116 var
117 p: Pointer;
118 Driver: TAbstractObjectReader;
119 DummyStream: TMemoryStream;
120 begin
121 DummyStream:=TMemoryStream.Create;
122 try
123 Result:=TReader.Create(DummyStream,256);
124 DestroyDriver:=false;
125 // hack to set a write protected variable.
126 // DestroyDriver:=true; TReader will free it
127 Driver:=TXMLObjectReader.Create(ADoc,Path);
128 p:=@Result.Driver;
129 Result.Driver.Free;
130 TAbstractObjectReader(p^):=Driver;
131 finally
132 DummyStream.Free;
133 end;
134 end;
135
136 procedure WriteComponentToXMLConfig(XMLConfig: TXMLConfig; const Path: string;
137 AComponent: TComponent);
138 var
139 Writer: TWriter;
140 DestroyDriver: boolean;
141 begin
142 Writer:=nil;
143 DestroyDriver:=false;
144 try
145 Writer:=CreateXMLWriter(XMLConfig.Document,Path,false,DestroyDriver);
146 XMLConfig.Modified:=true;
147 Writer.WriteRootComponent(AComponent);
148 XMLConfig.Flush;
149 finally
150 if DestroyDriver and (Writer<>nil) then
151 Writer.Driver.Free;
152 Writer.Free;
153 end;
154 end;
155
156 procedure ReadComponentFromXMLConfig(XMLConfig: TXMLConfig; const Path: string;
157 var RootComponent: TComponent;
158 OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent);
159 var
160 DestroyDriver: Boolean;
161 Reader: TReader;
162 IsInherited: Boolean;
163 AClassName: String;
164 AClass: TComponentClass;
165 begin
166 Reader:=nil;
167 DestroyDriver:=false;
168 try
169 Reader:=CreateXMLReader(XMLConfig.Document,Path,DestroyDriver);
170 Reader.OnFindComponentClass:=OnFindComponentClass;
171
172 // get root class
173 AClassName:=(Reader.Driver as TXMLObjectReader).GetRootClassName(IsInherited);
174 if IsInherited then begin
175 // inherited is not supported by this simple function
DebugLnnull176 DebugLn('ReadComponentFromXMLConfig WARNING: "inherited" is not supported by this simple function');
177 end;
178 AClass:=nil;
179 OnFindComponentClass(nil,AClassName,AClass);
180 if AClass=nil then
181 raise EClassNotFound.CreateFmt('Class "%s" not found', [AClassName]);
182
183 if RootComponent=nil then begin
184 // create root component
185 // first create the new instance and set the variable ...
186 RootComponent:=AClass.NewInstance as TComponent;
187 // then call the constructor
188 RootComponent.Create(TheOwner);
189 end else begin
190 // there is a root component, check if class is compatible
191 if not RootComponent.InheritsFrom(AClass) then begin
192 raise EComponentError.CreateFmt('Cannot assign a %s to a %s.',
193 [AClassName,RootComponent.ClassName]);
194 end;
195 end;
196
197 Reader.ReadRootComponent(RootComponent);
198 finally
199 if DestroyDriver then
200 Reader.Driver.Free;
201 Reader.Free;
202 end;
203 end;
204
205 { TStreamAsXMLForm }
206
207 procedure TStreamAsXMLForm.FormCreate(Sender: TObject);
208 var
209 MySubComponent: TMyComponent;
210 DemoGroupBox_1: TGroupBox;
211 DemoGroupBox_2: TGroupBox;
212 begin
213 Filename:='test.xml';
214
215 MyComponent:=TMyComponent.Create(Self);
216 with MyComponent do begin
217 Name:='MyComponent';
218 end;
219 MySubComponent:=TMyComponent.Create(MyComponent);
220 with MySubComponent do begin
221 Name:='MySubComponent';
222 end;
223
224 DemoGroupBox:=TMyGroupBox.Create(Self);
225 with DemoGroupBox do begin
226 Name:='DemoGroupBox';
227 SetBounds(100,2,320,180);
228 Parent:=SourceGroupBox;
229 OnClick:=@DemoGroupBox.AnEvent;
230 end;
231
232 // create nested controls
233 DemoGroupBox_1:=TGroupBox.Create(DemoGroupBox);
234 with DemoGroupBox_1 do begin
235 Name:='DemoGroupBox_1';
236 Parent:=DemoGroupBox;
237 SetBounds(5,5,150,150);
238 with TButton.Create(DemoGroupBox) do begin
239 Name:='Button1';
240 Parent:=DemoGroupBox_1;
241 SetBounds(10,20,80,30);
242 end;
243 with TButton.Create(DemoGroupBox) do begin
244 Name:='Button2';
245 Parent:=DemoGroupBox_1;
246 SetBounds(10,60,80,20);
247 end;
248 end;
249 DemoGroupBox_2:=TGroupBox.Create(DemoGroupBox);
250 with DemoGroupBox_2 do begin
251 Name:='DemoGroupBox_2';
252 Parent:=DemoGroupBox;
253 SetBounds(155,5,150,150);
254 with TButton.Create(DemoGroupBox) do begin
255 Name:='Button3';
256 Parent:=DemoGroupBox_2;
257 SetBounds(10,20,80,30);
258 end;
259 with TButton.Create(DemoGroupBox) do begin
260 Name:='Button4';
261 Parent:=DemoGroupBox_2;
262 SetBounds(10,60,80,20);
263 end;
264 end;
265
266 WriteComponents;
267 ReadComponents;
268 end;
269
270 procedure TStreamAsXMLForm.SetFilename(const AValue: string);
271 begin
272 if FFilename=AValue then exit;
273 FFilename:=AValue;
274 end;
275
276 procedure TStreamAsXMLForm.WriteComponents;
277 var
278 XMLConfig: TXMLConfig;
279 sl: TStringList;
280 begin
281 DebugLn('TStreamAsXMLForm.WriteComponents ',Filename);
282 XMLConfig:=TXMLConfig.Create(Filename);
283 try
284 //WriteComponentToXMLConfig(XMLConfig,'Component',Self);
285 WriteComponentToXMLConfig(XMLConfig,'Component',MyComponent);
286 //WriteComponentToXMLConfig(XMLConfig,'Component',DemoGroupBox);
287 XMLConfig.Flush;
288 finally
289 XMLConfig.Free;
290 end;
291
292 sl:=TStringList.Create;
293 sl.LoadFromFile(UTF8ToSys(Filename));
294 DebugLn('TStreamAsXMLForm.WriteComponents ',sl.Text);
295 sl.Free;
296 end;
297
298 procedure TStreamAsXMLForm.ReadComponents;
299 var
300 XMLConfig: TXMLConfig;
301 sl: TStringList;
302 NewComponent: TComponent;
303 begin
304 DebugLn('TStreamAsXMLForm.ReadComponents ',Filename);
305 XMLConfig:=TXMLConfig.Create(Filename);
306 try
307 NewComponent:=nil;
308 ReadComponentFromXMLConfig(XMLConfig,'Component',NewComponent,
309 @OnFindComponentClass,DestinationGroupBox);
310 if NewComponent is TMyComponent then
311 TMyComponent(NewComponent).WriteDebugReport;
312 if NewComponent is TControl then
313 TControl(NewComponent).Parent:=DestinationGroupBox;
314 XMLConfig.Flush;
315 finally
316 XMLConfig.Free;
317 end;
318
319 sl:=TStringList.Create;
320 sl.LoadFromFile(UTF8ToSys(Filename));
321 DebugLn('TStreamAsXMLForm.StreamComponents ',sl.Text);
322 sl.Free;
323 end;
324
325 procedure TStreamAsXMLForm.OnFindComponentClass(Reader: TReader;
326 const AClassName: string; var ComponentClass: TComponentClass);
327 begin
328 if CompareText(AClassName,'TGroupBox')=0 then
329 ComponentClass:=TGroupBox
330 else if CompareText(AClassName,'TButton')=0 then
331 ComponentClass:=TButton
332 else if CompareText(AClassName,'TMyComponent')=0 then
333 ComponentClass:=TMyComponent
334 else if CompareText(AClassName,'TMyGroupBox')=0 then
335 ComponentClass:=TMyGroupBox;
336 DebugLn('TStreamAsXMLForm.OnFindComponentClass ',AClassName,' ',dbgs(ComponentClass));
337 end;
338
339 { TMyComponent }
340
341 constructor TMyComponent.Create(TheOwner: TComponent);
342 begin
343 inherited Create(TheOwner);
344 MyDouble:=-1.23456789;
345 MySingle:=-1.98765432;
346 MyEnum:=myEnum2;
347 MySet:=[myEnum1,myEnum3];
348 MyString:='Some text as string';
349 MyWideString:='Some text as widestring';
350 MyInteger:=1234;
351 MyBoolean:=true;
352 MyInt64:=1234567890987654321;
353 MyCollection:=TCollection.Create(TMyCollectionItem);
354 TMyCollectionItem(MyCollection.Add).MyString:='First';
355 TMyCollectionItem(MyCollection.Add).MyString:='Second';
356 TMyCollectionItem(MyCollection.Add).MyString:='Third';
357 FMyStrings:=TStringList.Create;
358 FMyStrings.Text:='FirstLine'#10'NextLine';
359 end;
360
361 destructor TMyComponent.Destroy;
362 begin
363 FreeAndNil(FMyStrings);
364 FreeAndNil(FMyCollection);
365 inherited Destroy;
366 end;
367
368 procedure TMyComponent.WriteDebugReport;
369 var
370 i: Integer;
371 Item: TMyCollectionItem;
372 begin
373 debugln('TMyComponent.WriteDebugReport ');
374 debugln([' MyDouble=',MyDouble]);
375 debugln([' MySingle=',MySingle]);
376 debugln([' MyEnum=',GetEnumName(TypeInfo(TMyEnum),ord(MyEnum))]);
377 debugln([' MySet=',HexStr(Cardinal(MySet),8)]);
378 debugln([' MyString=',MyString]);
379 debugln([' MyWideString=',MyWideString]);
380 debugln([' MyInteger=',MyInteger]);
381 debugln([' MyInt64=',MyInt64]);
382 debugln([' MyCollection.Count=',MyCollection.Count]);
383 for i:=0 to MyCollection.Count-1 do begin
384 Item:=TMyCollectionItem(MyCollection.Items[i]);
385 debugln([' ',i,' MyString=',Item.MyString]);
386 end;
387 debugln([' MyStrings='+dbgstr(MyStrings.Text)]);
388 end;
389
390 { TMyGroupBox }
391
392 procedure TMyGroupBox.AnEvent(Sender: TObject);
393 begin
394
395 end;
396
397 end.
398
399