← Back to branch summary

~ubuntu-branches/ubuntu/vivid/lazarus/vivid

« back to all changes in this revision

Viewing changes to examples/xmlresource/xmlresourcefile.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Paul Gevers
  • Date: 2014-02-22 10:25:57 UTC
  • mfrom: (1.1.11)
  • Revision ID: package-import@ubuntu.com-20140222102557-ors9d31r84nz31jq
Tags: 1.2~rc2+dfsg-1
http://bugs.debian.org/724776
[ Abou Al Montacir ]
* New upstream pre-release.
  + Moved ideintf to components directory.
  + Added new package cairocanvas.
* Remove usage of depreciated parameters form of find. (Closes: Bug#724776)
* Bumped standard version to 3.9.5.
* Clean the way handling make files generation and removal.

[ Paul Gevers ]
* Remove nearly obsolete bzip compression for binary packages
  (See https://lists.debian.org/debian-devel/2014/01/msg00542.html)
* Update d/copyright for newly added dir in examples and components
* Update Vcs-* fields with new packaging location
* Update d/watch file to properly (Debian way) change upstreams versions
* Prevent 46MB of package size by sym linking duplicate files
* Patches
  - refresh to remove fuzz
  - add more Lintian found spelling errors
  - new patch to add shbang to two scripts in lazarus-src
* Drop lcl-# from Provides list of lcl-units-#
* Make lazarus-ide-qt4-# an arch all until it really contains stuff
* Make all metapackages arch all as the usecase for arch any doesn't
  seem to warrant the addition archive hit
* Fix permissions of non-scripts in lazarus-src-#

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/xmlresource/xmlresourcefile.pas
 
1
unit xmlresourcefile;
 
2
 
 
3
{$mode objfpc}{$H+}
 
4
 
 
5
interface
 
6
 
 
7
uses
 
8
  Classes, SysUtils,
 
9
  LCLMemManager, forms,
 
10
  dom, XMLRead,XMLWrite,
 
11
  ProjectIntf,
 
12
  UnitResources;
 
13
 
 
14
type
 
15
 
 
16
  { TXMLUnitResourcefileFormat }
 
17
 
 
18
  TXMLUnitResourcefileFormat = class(TUnitResourcefileFormat)
 
19
  private
 
20
    class procedure QuickReadXML(s: TStream; out AComponentName, AClassName, ALCLVersion: string);
 
21
  public
 
22
    class function FindResourceDirective(Source: TObject): boolean; override;
 
23
    class function ResourceDirectiveFilename: string; override;
 
24
    class function GetUnitResourceFilename(AUnitFilenae: string): string; override;
 
25
    class procedure TextStreamToBinStream(ATxtStream, ABinStream: TExtMemoryStream); override;
 
26
    class procedure BinStreamToTextStream(ABinStream, ATextStream: TExtMemoryStream); override;
 
27
    class function GetClassNameFromStream(s: TStream; out IsInherited: Boolean): shortstring; override;
 
28
    class function CreateReader(s: TStream; var DestroyDriver: boolean): TReader; override;
 
29
    class function CreateWriter(s: TStream; var DestroyDriver: boolean): TWriter; override;
 
30
    class function QuickCheckResourceBuffer(PascalBuffer, LFMBuffer: TObject;
 
31
      out LFMType, LFMComponentName, LFMClassName: string; out
 
32
      LCLVersion: string; out MissingClasses: TStrings): TModalResult; override;
 
33
  end;
 
34
 
 
35
  { TXMLReader }
 
36
 
 
37
  TXMLReader = class(TReader)
 
38
  protected
 
39
    function CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectReader; override;
 
40
  end;
 
41
 
 
42
  { TXMLObjectReader }
 
43
 
 
44
  TXMLObjectReader = class(TAbstractObjectReader)
 
45
  private
 
46
    FXMLDoc: TXMLDocument;
 
47
    FStream: TStream;
 
48
    FObjNode: TDOMNode;
 
49
    FCurNode: TDOMNode;
 
50
    FCurValue: string;
 
51
    FReadingChilds: Boolean;
 
52
  public
 
53
    constructor create(AStream: TStream); virtual;
 
54
    destructor Destroy; override;
 
55
    function NextValue: TValueType; override;
 
56
    function ReadValue: TValueType; override;
 
57
    procedure BeginRootComponent; override;
 
58
    procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer;
 
59
      var CompClassName, CompName: String); override;
 
60
    function BeginProperty: String; override;
 
61
 
 
62
    //Please don't use read, better use ReadBinary whenever possible
 
63
    procedure Read(var Buf; Count: LongInt); override;
 
64
    { All ReadXXX methods are called _after_ the value type has been read! }
 
65
    procedure ReadBinary(const DestData: TMemoryStream); override;
 
66
    function ReadCurrency: Currency; override;
 
67
    function ReadIdent(ValueType: TValueType): String; override;
 
68
    function ReadInt8: ShortInt; override;
 
69
    function ReadInt16: SmallInt; override;
 
70
    function ReadInt32: LongInt; override;
 
71
    function ReadInt64: Int64; override;
 
72
    function ReadSet(EnumType: Pointer): Integer; override;
 
73
    function ReadStr: String; override;
 
74
    function ReadString(StringType: TValueType): String; override;
 
75
    function ReadWideString: WideString;override;
 
76
    function ReadUnicodeString: UnicodeString;override;
 
77
    procedure SkipComponent(SkipComponentInfos: Boolean); override;
 
78
    procedure SkipValue; override;
 
79
  end;
 
80
 
 
81
  { TXMLWriter }
 
82
 
 
83
  TXMLWriter = class(TWriter)
 
84
  protected
 
85
    function CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectWriter; override;
 
86
  end;
 
87
 
 
88
  { TXMLObjectWriter }
 
89
 
 
90
  TXMLObjectWriter = class(TAbstractObjectWriter)
 
91
  private
 
92
    FXMLCreated: boolean;
 
93
    FXMLDoc: TXMLDocument;
 
94
    FListLevel: integer;
 
95
    FObjNode: TDOMNode;
 
96
    FCurNode: TDOMElement;
 
97
    FStream: TStream;
 
98
    FIsStreamingProps: boolean;
 
99
  private
 
100
    procedure CreateXML;
 
101
  public
 
102
    constructor Create(Stream: TStream; BufSize: Integer);
 
103
    destructor Destroy; override;
 
104
 
 
105
    procedure BeginCollection; override;
 
106
    procedure BeginComponent(Component: TComponent; Flags: TFilerFlags;
 
107
      ChildPos: Integer); override;
 
108
    procedure BeginList; override;
 
109
    procedure EndList; override;
 
110
    procedure BeginProperty(const PropName: String); override;
 
111
    procedure EndProperty; override;
 
112
 
 
113
    //Please don't use write, better use WriteBinary whenever possible
 
114
    procedure Write(const Buffer; Count: Longint); override;
 
115
    procedure WriteBinary(const Buffer; Count: LongInt); override;
 
116
    procedure WriteBoolean(Value: Boolean); override;
 
117
 
 
118
    procedure WriteCurrency(const Value: Currency); override;
 
119
    procedure WriteIdent(const Ident: string); override;
 
120
    procedure WriteInteger(Value: Int64); override;
 
121
    procedure WriteUInt64(Value: QWord); override;
 
122
    procedure WriteMethodName(const Name: String); override;
 
123
    procedure WriteSet(Value: LongInt; SetType: Pointer); override;
 
124
    procedure WriteString(const Value: String); override;
 
125
    procedure WriteWideString(const Value: WideString); override;
 
126
    procedure WriteUnicodeString(const Value: UnicodeString); override;
 
127
    procedure WriteVariant(const VarValue: Variant);override;
 
128
 
 
129
    procedure WriteFloat(const Value: Extended);  override;
 
130
    procedure WriteSingle(const Value: Single); override;
 
131
    procedure WriteDate(const Value: TDateTime); override;
 
132
 
 
133
 
 
134
  end;
 
135
 
 
136
  { TFileDescPascalUnitWithXMLResource }
 
137
 
 
138
  TFileDescPascalUnitWithXMLResource = class(TFileDescPascalUnitWithResource)
 
139
  public
 
140
    constructor Create; override;
 
141
    function GetLocalizedName: string; override;
 
142
    function GetLocalizedDescription: string; override;
 
143
    function GetImplementationSource(const Filename, SourceName, ResourceName: string): string; override;
 
144
  end;
 
145
 
 
146
 
 
147
procedure register;
 
148
 
 
149
implementation
 
150
 
 
151
uses
 
152
  FileUtil,
 
153
  RtlConsts,
 
154
  CodeCache;
 
155
 
 
156
procedure register;
 
157
begin
 
158
  RegisterUnitResourcefileFormat(TXMLUnitResourcefileFormat);
 
159
  RegisterProjectFileDescriptor(TFileDescPascalUnitWithXMLResource.Create,
 
160
                                FileDescGroupName);
 
161
end;
 
162
 
 
163
{ TFileDescPascalUnitWithXMLResource }
 
164
 
 
165
constructor TFileDescPascalUnitWithXMLResource.Create;
 
166
begin
 
167
  inherited Create;
 
168
  ResourceClass:=TForm;
 
169
end;
 
170
 
 
171
function TFileDescPascalUnitWithXMLResource.GetLocalizedName: string;
 
172
begin
 
173
  Result:='Form with XML resource file';
 
174
end;
 
175
 
 
176
function TFileDescPascalUnitWithXMLResource.GetLocalizedDescription: string;
 
177
begin
 
178
  Result:='Create a new unit with a LCL form with XML resource file.';
 
179
end;
 
180
 
 
181
function TFileDescPascalUnitWithXMLResource.GetImplementationSource(
 
182
  const Filename, SourceName, ResourceName: string): string;
 
183
var
 
184
  ResourceFilename: String;
 
185
  LE: String;
 
186
begin
 
187
  LE:=LineEnding;
 
188
  case GetResourceType of
 
189
    rtLRS:
 
190
      begin
 
191
        ResourceFilename:=TrimFilename(ExtractFilenameOnly(Filename)+DefaultResFileExt);
 
192
        Result:='initialization'+LE+'  {$I '+ResourceFilename+'}'+LE+LE;
 
193
      end;
 
194
    rtRes: Result := '{$R *.xml}'+LE+LE;
 
195
  end;
 
196
end;
 
197
 
 
198
{ TXMLObjectWriter }
 
199
 
 
200
procedure TXMLObjectWriter.CreateXML;
 
201
begin
 
202
  FXMLDoc := TXMLDocument.Create;
 
203
  FXMLCreated:=true;
 
204
end;
 
205
 
 
206
constructor TXMLObjectWriter.Create(Stream: TStream; BufSize: Integer);
 
207
begin
 
208
  inherited Create;
 
209
  FStream:=Stream;
 
210
end;
 
211
 
 
212
destructor TXMLObjectWriter.Destroy;
 
213
begin
 
214
  FXMLDoc.Free;
 
215
  inherited Destroy;
 
216
end;
 
217
 
 
218
procedure TXMLObjectWriter.BeginCollection;
 
219
begin
 
220
 
 
221
end;
 
222
 
 
223
procedure TXMLObjectWriter.BeginComponent(Component: TComponent;
 
224
  Flags: TFilerFlags; ChildPos: Integer);
 
225
var
 
226
  ANewNode : TDOMElement;
 
227
begin
 
228
  if not FXmlCreated then
 
229
    begin
 
230
    CreateXML;
 
231
    end;
 
232
  inc(FListLevel,2);
 
233
  ANewNode := FXMLDoc.CreateElement('object');
 
234
 
 
235
  ANewNode.AttribStrings['type'] := Component.ClassName;
 
236
  ANewNode.AttribStrings['name'] := Component.Name;
 
237
  if not assigned(FObjNode) then
 
238
    FXMLDoc.AppendChild(ANewNode)
 
239
  else
 
240
    FObjNode.AppendChild(ANewNode);
 
241
  FObjNode := ANewNode;
 
242
  FIsStreamingProps:=True;
 
243
end;
 
244
 
 
245
procedure TXMLObjectWriter.BeginList;
 
246
begin
 
247
  inc(FListLevel);
 
248
end;
 
249
 
 
250
procedure TXMLObjectWriter.EndList;
 
251
begin
 
252
  dec(FListLevel);
 
253
  if FIsStreamingProps then
 
254
    begin
 
255
    FIsStreamingProps:=false;
 
256
    end
 
257
  else
 
258
    FObjNode := FObjNode.ParentNode;
 
259
 
 
260
  if FListLevel=0 then
 
261
    WriteXMLFile(FXMLDoc,FStream);
 
262
end;
 
263
 
 
264
procedure TXMLObjectWriter.BeginProperty(const PropName: String);
 
265
begin
 
266
  FCurNode := FXMLDoc.CreateElement('property');
 
267
  FObjNode.AppendChild(FCurNode);
 
268
  FCurNode.AttribStrings['name'] := PropName;
 
269
end;
 
270
 
 
271
procedure TXMLObjectWriter.EndProperty;
 
272
begin
 
273
  // Do nothing
 
274
end;
 
275
 
 
276
procedure TXMLObjectWriter.Write(const Buffer; Count: Longint);
 
277
begin
 
278
 
 
279
end;
 
280
 
 
281
procedure TXMLObjectWriter.WriteBinary(const Buffer; Count: LongInt);
 
282
begin
 
283
 
 
284
end;
 
285
 
 
286
procedure TXMLObjectWriter.WriteBoolean(Value: Boolean);
 
287
begin
 
288
  if value then
 
289
    begin
 
290
    FCurNode.AttribStrings['type'] := 'vatrue';
 
291
    FCurNode.TextContent:='True';
 
292
    end
 
293
  else
 
294
    begin
 
295
    FCurNode.AttribStrings['type'] := 'vafalse';
 
296
    FCurNode.TextContent:='False';
 
297
    end
 
298
end;
 
299
 
 
300
procedure TXMLObjectWriter.WriteCurrency(const Value: Currency);
 
301
begin
 
302
 
 
303
end;
 
304
 
 
305
procedure TXMLObjectWriter.WriteIdent(const Ident: string);
 
306
begin
 
307
  FCurNode.AttribStrings['type'] := 'ident';
 
308
  FCurNode.TextContent:=Ident;
 
309
end;
 
310
 
 
311
procedure TXMLObjectWriter.WriteInteger(Value: Int64);
 
312
begin
 
313
  FCurNode.AttribStrings['type'] := 'int64';
 
314
  FCurNode.TextContent:=inttostr(value);
 
315
end;
 
316
 
 
317
procedure TXMLObjectWriter.WriteUInt64(Value: QWord);
 
318
begin
 
319
  FCurNode.AttribStrings['type'] := 'int64';
 
320
  FCurNode.TextContent:=inttostr(value);
 
321
end;
 
322
 
 
323
procedure TXMLObjectWriter.WriteMethodName(const Name: String);
 
324
begin
 
325
  FCurNode.AttribStrings['type'] := 'ident';
 
326
  FCurNode.TextContent:=Name;
 
327
end;
 
328
 
 
329
procedure TXMLObjectWriter.WriteSet(Value: LongInt; SetType: Pointer);
 
330
begin
 
331
 
 
332
end;
 
333
 
 
334
procedure TXMLObjectWriter.WriteString(const Value: String);
 
335
begin
 
336
  FCurNode.AttribStrings['type'] := 'string';
 
337
  FCurNode.TextContent:=value;
 
338
end;
 
339
 
 
340
procedure TXMLObjectWriter.WriteWideString(const Value: WideString);
 
341
begin
 
342
 
 
343
end;
 
344
 
 
345
procedure TXMLObjectWriter.WriteUnicodeString(const Value: UnicodeString);
 
346
begin
 
347
 
 
348
end;
 
349
 
 
350
procedure TXMLObjectWriter.WriteVariant(const VarValue: Variant);
 
351
begin
 
352
 
 
353
end;
 
354
 
 
355
procedure TXMLObjectWriter.WriteFloat(const Value: Extended);
 
356
begin
 
357
  //
 
358
end;
 
359
 
 
360
procedure TXMLObjectWriter.WriteSingle(const Value: Single);
 
361
begin
 
362
  //
 
363
end;
 
364
 
 
365
procedure TXMLObjectWriter.WriteDate(const Value: TDateTime);
 
366
begin
 
367
  //
 
368
end;
 
369
 
 
370
{ TXMLWriter }
 
371
 
 
372
function TXMLWriter.CreateDriver(Stream: TStream; BufSize: Integer
 
373
  ): TAbstractObjectWriter;
 
374
begin
 
375
  Result:=TXMLObjectWriter.Create(Stream,BufSize);
 
376
end;
 
377
 
 
378
{ TXMLObjectReader }
 
379
 
 
380
constructor TXMLObjectReader.create(AStream: TStream);
 
381
begin
 
382
  inherited create;
 
383
 
 
384
  If (AStream=Nil) then
 
385
    Raise EReadError.Create(SEmptyStreamIllegalReader);
 
386
 
 
387
  FStream := AStream;
 
388
end;
 
389
 
 
390
destructor TXMLObjectReader.Destroy;
 
391
begin
 
392
  FXMLDoc.Free;
 
393
  inherited Destroy;
 
394
end;
 
395
 
 
396
function TXMLObjectReader.NextValue: TValueType;
 
397
var
 
398
  StoreNode,
 
399
  StoreObjNode: TDOMNode;
 
400
  StoreReadingChilds: boolean;
 
401
begin
 
402
  StoreNode := FCurNode;
 
403
  StoreObjNode := FObjNode;
 
404
  StoreReadingChilds := FReadingChilds;
 
405
  result := ReadValue;
 
406
  FCurNode:=StoreNode;
 
407
  FObjNode:=StoreObjNode;
 
408
  FReadingChilds:=StoreReadingChilds;
 
409
end;
 
410
 
 
411
function TXMLObjectReader.ReadValue: TValueType;
 
412
begin
 
413
  result := vaNull;
 
414
  if not assigned(FCurNode) then
 
415
    begin
 
416
    if not FReadingChilds then
 
417
      begin
 
418
      FCurNode := FObjNode.FirstChild;
 
419
      while assigned(FCurNode) and (FCurNode.NodeName<>'object') do
 
420
        FCurNode := FCurNode.NextSibling;
 
421
      FReadingChilds:=true;
 
422
      end
 
423
    else
 
424
      begin
 
425
      if assigned(FObjNode.NextSibling) then
 
426
        FCurNode := FObjNode.NextSibling
 
427
      else if assigned(FObjNode.ParentNode) then
 
428
        FObjNode := FObjNode.ParentNode;
 
429
 
 
430
      while assigned(FCurNode) and (FCurNode.NodeName<>'object') do
 
431
        FCurNode := FCurNode.NextSibling;
 
432
      end;
 
433
    Exit;
 
434
    end;
 
435
 
 
436
  if not FReadingChilds and (FCurNode.NodeName='property') then
 
437
    begin
 
438
    FCurValue := FCurNode.TextContent;
 
439
    if FCurNode.Attributes.GetNamedItem('type').NodeValue='int16' then
 
440
      result := vaInt16
 
441
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='int64' then
 
442
      result := vaInt32
 
443
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='string' then
 
444
      result := vaString
 
445
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='vatrue' then
 
446
      result := vaTrue
 
447
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='vafalse' then
 
448
      result := vaFalse
 
449
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='ident' then
 
450
      result := vaIdent
 
451
    else
 
452
      raise EReadError.CreateFmt('Unknown property type %s',[FCurNode.Attributes.GetNamedItem('type').NodeValue]);
 
453
    end;
 
454
 
 
455
  if FReadingChilds and (FCurNode.NodeName='object') then
 
456
    result := vaIdent;
 
457
 
 
458
  FCurNode := FCurNode.NextSibling;
 
459
  while assigned(FCurNode) do
 
460
    begin
 
461
    if FReadingChilds and (FCurNode.NodeName='object') then
 
462
      break;
 
463
    if not FReadingChilds and (FCurNode.NodeName='property') then
 
464
      break;
 
465
    FCurNode := FCurNode.NextSibling;
 
466
    end;
 
467
end;
 
468
 
 
469
procedure TXMLObjectReader.BeginRootComponent;
 
470
begin
 
471
  FXMLDoc.Free;
 
472
 
 
473
  ReadXMLFile(FXMLDoc, FStream);
 
474
  FCurNode := FXMLDoc.FindNode('object');
 
475
  if not assigned(FCurNode) then
 
476
    raise EReadError.Create('Invalid XML-stream format: No object node found');
 
477
end;
 
478
 
 
479
procedure TXMLObjectReader.BeginComponent(var Flags: TFilerFlags;
 
480
  var AChildPos: Integer; var CompClassName, CompName: String);
 
481
begin
 
482
  flags := [];
 
483
  FReadingChilds:=false;
 
484
 
 
485
  assert(FObjNode.NodeName='object');
 
486
  FObjNode:=FCurNode;
 
487
  CompName:=FObjNode.Attributes.GetNamedItem('name').NodeValue;
 
488
  CompClassName:=FObjNode.Attributes.GetNamedItem('type').NodeValue;
 
489
  FCurNode := FObjNode.FirstChild;
 
490
  while assigned(FCurNode) and (FCurNode.NodeName<>'property') do
 
491
    FCurNode := FCurNode.NextSibling;
 
492
end;
 
493
 
 
494
function TXMLObjectReader.BeginProperty: String;
 
495
begin
 
496
  if FCurNode.NodeName<>'property' then
 
497
    raise exception.create('property-element expected but found '+FCurNode.NodeName);
 
498
  result := FCurNode.Attributes.GetNamedItem('name').NodeValue;
 
499
end;
 
500
 
 
501
procedure TXMLObjectReader.Read(var Buf; Count: LongInt);
 
502
begin
 
503
 
 
504
end;
 
505
 
 
506
procedure TXMLObjectReader.ReadBinary(const DestData: TMemoryStream);
 
507
begin
 
508
 
 
509
end;
 
510
 
 
511
function TXMLObjectReader.ReadCurrency: Currency;
 
512
begin
 
513
 
 
514
end;
 
515
 
 
516
function TXMLObjectReader.ReadIdent(ValueType: TValueType): String;
 
517
begin
 
518
  result := FCurValue;
 
519
end;
 
520
 
 
521
function TXMLObjectReader.ReadInt8: ShortInt;
 
522
begin
 
523
  result := strtoint(FCurValue);
 
524
end;
 
525
 
 
526
function TXMLObjectReader.ReadInt16: SmallInt;
 
527
begin
 
528
  result := strtoint(FCurValue);
 
529
end;
 
530
 
 
531
function TXMLObjectReader.ReadInt32: LongInt;
 
532
begin
 
533
  result := strtoint(FCurValue);
 
534
end;
 
535
 
 
536
function TXMLObjectReader.ReadInt64: Int64;
 
537
begin
 
538
  result := StrToInt64(FCurValue);
 
539
end;
 
540
 
 
541
function TXMLObjectReader.ReadSet(EnumType: Pointer): Integer;
 
542
begin
 
543
 
 
544
end;
 
545
 
 
546
function TXMLObjectReader.ReadStr: String;
 
547
begin
 
548
  result := FCurValue;
 
549
end;
 
550
 
 
551
function TXMLObjectReader.ReadString(StringType: TValueType): String;
 
552
begin
 
553
  result := FCurValue;
 
554
end;
 
555
 
 
556
function TXMLObjectReader.ReadWideString: WideString;
 
557
begin
 
558
  result := FCurValue;
 
559
end;
 
560
 
 
561
function TXMLObjectReader.ReadUnicodeString: UnicodeString;
 
562
begin
 
563
  result := FCurValue;
 
564
end;
 
565
 
 
566
procedure TXMLObjectReader.SkipComponent(SkipComponentInfos: Boolean);
 
567
begin
 
568
 
 
569
end;
 
570
 
 
571
procedure TXMLObjectReader.SkipValue;
 
572
begin
 
573
 
 
574
end;
 
575
 
 
576
{ TXMLReader }
 
577
 
 
578
function TXMLReader.CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectReader;
 
579
begin
 
580
  Result := TXMLObjectReader.Create(Stream);
 
581
end;
 
582
 
 
583
{ TXMLUnitResourcefileFormat }
 
584
 
 
585
class procedure TXMLUnitResourcefileFormat.QuickReadXML(s: TStream; out
 
586
  AComponentName, AClassName, ALCLVersion: string);
 
587
var
 
588
  AXMLDocument: TXMLDocument;
 
589
  ms: TStringStream;
 
590
  ObjNode: TDOMNode;
 
591
begin
 
592
  ReadXMLFile(AXMLDocument, s);
 
593
  try
 
594
    ObjNode := AXMLDocument.FindNode('lazarusinfo');
 
595
    if assigned(ObjNode) then
 
596
      begin
 
597
      ObjNode := ObjNode.FindNode('lclversion');
 
598
      if assigned(ObjNode) then
 
599
        ALCLVersion:=ObjNode.TextContent;
 
600
      end;
 
601
 
 
602
    ObjNode := AXMLDocument.FindNode('object');
 
603
    if not assigned(ObjNode) then
 
604
      raise EReadError.Create('Invalid XML-stream format: No object node found');
 
605
    AComponentName:=ObjNode.Attributes.GetNamedItem('name').NodeValue;
 
606
    AClassName:=ObjNode.Attributes.GetNamedItem('type').NodeValue;
 
607
 
 
608
  finally
 
609
    AXMLDocument.Free;
 
610
  end;
 
611
end;
 
612
 
 
613
class function TXMLUnitResourcefileFormat.FindResourceDirective(Source: TObject): boolean;
 
614
var
 
615
  cb: TCodeBuffer;
 
616
  nx,ny,nt: integer;
 
617
begin
 
618
//  result := CodeToolBoss.FindResourceDirective(Source as TCodeBuffer,1,1,cb,nx,ny,nt, ResourceDirectiveFilename,false);
 
619
end;
 
620
 
 
621
class function TXMLUnitResourcefileFormat.ResourceDirectiveFilename: string;
 
622
begin
 
623
  result := '*.xml';
 
624
end;
 
625
 
 
626
class function TXMLUnitResourcefileFormat.GetUnitResourceFilename(
 
627
  AUnitFilenae: string): string;
 
628
begin
 
629
  result := ChangeFileExt(AUnitFilenae,'.xml');
 
630
end;
 
631
 
 
632
class procedure TXMLUnitResourcefileFormat.TextStreamToBinStream(ATxtStream,
 
633
  ABinStream: TExtMemoryStream);
 
634
begin
 
635
  ABinStream.LoadFromStream(ATxtStream);
 
636
end;
 
637
 
 
638
class procedure TXMLUnitResourcefileFormat.BinStreamToTextStream(ABinStream,
 
639
  ATextStream: TExtMemoryStream);
 
640
begin
 
641
  ATextStream.LoadFromStream(ABinStream);
 
642
end;
 
643
 
 
644
class function TXMLUnitResourcefileFormat.GetClassNameFromStream(s: TStream;
 
645
  out IsInherited: Boolean): shortstring;
 
646
var
 
647
  AComponentName,
 
648
  AClassType,
 
649
  ALCLVersion: string;
 
650
begin
 
651
  IsInherited:=false;
 
652
  QuickReadXML(s, AComponentName, AClassType, ALCLVersion);
 
653
  s.Seek(0,soFromBeginning);
 
654
  result := AClassType;
 
655
end;
 
656
 
 
657
class function TXMLUnitResourcefileFormat.CreateReader(s: TStream;
 
658
  var DestroyDriver: boolean): TReader;
 
659
begin
 
660
  result := TXMLReader.Create(s,4096);
 
661
end;
 
662
 
 
663
class function TXMLUnitResourcefileFormat.CreateWriter(s: TStream;
 
664
  var DestroyDriver: boolean): TWriter;
 
665
var
 
666
  ADriver: TXMLObjectWriter;
 
667
begin
 
668
  ADriver:=TXMLObjectWriter.Create(s,4096);
 
669
  result := TWriter.Create(ADriver);
 
670
  DestroyDriver:=false;
 
671
end;
 
672
 
 
673
class function TXMLUnitResourcefileFormat.QuickCheckResourceBuffer(
 
674
  PascalBuffer, LFMBuffer: TObject; out LFMType, LFMComponentName,
 
675
  LFMClassName: string; out LCLVersion: string; out MissingClasses: TStrings
 
676
  ): TModalResult;
 
677
var
 
678
  ms: TStringStream;
 
679
begin
 
680
  ms := TStringStream.Create((LFMBuffer as TCodeBuffer).Source);
 
681
  try
 
682
    QuickReadXML(ms, LFMComponentName, LFMClassName, LCLVersion);
 
683
  finally
 
684
    ms.Free;
 
685
  end;
 
686
 
 
687
  LFMType:='unknown';
 
688
  MissingClasses := nil;
 
689
end;
 
690
 
 
691
end.
 
692
 
 
693
unit xmlresourcefile;
 
694
 
 
695
{$mode objfpc}{$H+}
 
696
 
 
697
interface
 
698
 
 
699
uses
 
700
  Classes, SysUtils,
 
701
  LCLMemManager, forms,
 
702
  dom, XMLRead,XMLWrite,
 
703
  ProjectIntf,
 
704
  UnitResources;
 
705
 
 
706
type
 
707
 
 
708
  { TXMLUnitResourcefileFormat }
 
709
 
 
710
  TXMLUnitResourcefileFormat = class(TUnitResourcefileFormat)
 
711
  private
 
712
    class procedure QuickReadXML(s: TStream; out AComponentName, AClassName, ALCLVersion: string);
 
713
  public
 
714
    class function FindResourceDirective(Source: TObject): boolean; override;
 
715
    class function ResourceDirectiveFilename: string; override;
 
716
    class function GetUnitResourceFilename(AUnitFilenae: string): string; override;
 
717
    class procedure TextStreamToBinStream(ATxtStream, ABinStream: TExtMemoryStream); override;
 
718
    class procedure BinStreamToTextStream(ABinStream, ATextStream: TExtMemoryStream); override;
 
719
    class function GetClassNameFromStream(s: TStream; out IsInherited: Boolean): shortstring; override;
 
720
    class function CreateReader(s: TStream; var DestroyDriver: boolean): TReader; override;
 
721
    class function CreateWriter(s: TStream; var DestroyDriver: boolean): TWriter; override;
 
722
    class function QuickCheckResourceBuffer(PascalBuffer, LFMBuffer: TObject;
 
723
      out LFMType, LFMComponentName, LFMClassName: string; out
 
724
      LCLVersion: string; out MissingClasses: TStrings): TModalResult; override;
 
725
  end;
 
726
 
 
727
  { TXMLReader }
 
728
 
 
729
  TXMLReader = class(TReader)
 
730
  protected
 
731
    function CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectReader; override;
 
732
  end;
 
733
 
 
734
  { TXMLObjectReader }
 
735
 
 
736
  TXMLObjectReader = class(TAbstractObjectReader)
 
737
  private
 
738
    FXMLDoc: TXMLDocument;
 
739
    FStream: TStream;
 
740
    FObjNode: TDOMNode;
 
741
    FCurNode: TDOMNode;
 
742
    FCurValue: string;
 
743
    FReadingChilds: Boolean;
 
744
  public
 
745
    constructor create(AStream: TStream); virtual;
 
746
    destructor Destroy; override;
 
747
    function NextValue: TValueType; override;
 
748
    function ReadValue: TValueType; override;
 
749
    procedure BeginRootComponent; override;
 
750
    procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer;
 
751
      var CompClassName, CompName: String); override;
 
752
    function BeginProperty: String; override;
 
753
 
 
754
    //Please don't use read, better use ReadBinary whenever possible
 
755
    procedure Read(var Buf; Count: LongInt); override;
 
756
    { All ReadXXX methods are called _after_ the value type has been read! }
 
757
    procedure ReadBinary(const DestData: TMemoryStream); override;
 
758
    function ReadCurrency: Currency; override;
 
759
    function ReadIdent(ValueType: TValueType): String; override;
 
760
    function ReadInt8: ShortInt; override;
 
761
    function ReadInt16: SmallInt; override;
 
762
    function ReadInt32: LongInt; override;
 
763
    function ReadInt64: Int64; override;
 
764
    function ReadSet(EnumType: Pointer): Integer; override;
 
765
    function ReadStr: String; override;
 
766
    function ReadString(StringType: TValueType): String; override;
 
767
    function ReadWideString: WideString;override;
 
768
    function ReadUnicodeString: UnicodeString;override;
 
769
    procedure SkipComponent(SkipComponentInfos: Boolean); override;
 
770
    procedure SkipValue; override;
 
771
  end;
 
772
 
 
773
  { TXMLWriter }
 
774
 
 
775
  TXMLWriter = class(TWriter)
 
776
  protected
 
777
    function CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectWriter; override;
 
778
  end;
 
779
 
 
780
  { TXMLObjectWriter }
 
781
 
 
782
  TXMLObjectWriter = class(TAbstractObjectWriter)
 
783
  private
 
784
    FXMLCreated: boolean;
 
785
    FXMLDoc: TXMLDocument;
 
786
    FListLevel: integer;
 
787
    FObjNode: TDOMNode;
 
788
    FCurNode: TDOMElement;
 
789
    FStream: TStream;
 
790
    FIsStreamingProps: boolean;
 
791
  private
 
792
    procedure CreateXML;
 
793
  public
 
794
    constructor Create(Stream: TStream; BufSize: Integer);
 
795
    destructor Destroy; override;
 
796
 
 
797
    procedure BeginCollection; override;
 
798
    procedure BeginComponent(Component: TComponent; Flags: TFilerFlags;
 
799
      ChildPos: Integer); override;
 
800
    procedure BeginList; override;
 
801
    procedure EndList; override;
 
802
    procedure BeginProperty(const PropName: String); override;
 
803
    procedure EndProperty; override;
 
804
 
 
805
    //Please don't use write, better use WriteBinary whenever possible
 
806
    procedure Write(const Buffer; Count: Longint); override;
 
807
    procedure WriteBinary(const Buffer; Count: LongInt); override;
 
808
    procedure WriteBoolean(Value: Boolean); override;
 
809
 
 
810
    procedure WriteCurrency(const Value: Currency); override;
 
811
    procedure WriteIdent(const Ident: string); override;
 
812
    procedure WriteInteger(Value: Int64); override;
 
813
    procedure WriteUInt64(Value: QWord); override;
 
814
    procedure WriteMethodName(const Name: String); override;
 
815
    procedure WriteSet(Value: LongInt; SetType: Pointer); override;
 
816
    procedure WriteString(const Value: String); override;
 
817
    procedure WriteWideString(const Value: WideString); override;
 
818
    procedure WriteUnicodeString(const Value: UnicodeString); override;
 
819
    procedure WriteVariant(const VarValue: Variant);override;
 
820
 
 
821
    procedure WriteFloat(const Value: Extended);  override;
 
822
    procedure WriteSingle(const Value: Single); override;
 
823
    procedure WriteDate(const Value: TDateTime); override;
 
824
 
 
825
 
 
826
  end;
 
827
 
 
828
  { TFileDescPascalUnitWithXMLResource }
 
829
 
 
830
  TFileDescPascalUnitWithXMLResource = class(TFileDescPascalUnitWithResource)
 
831
  public
 
832
    constructor Create; override;
 
833
    function GetLocalizedName: string; override;
 
834
    function GetLocalizedDescription: string; override;
 
835
    function GetImplementationSource(const Filename, SourceName, ResourceName: string): string; override;
 
836
  end;
 
837
 
 
838
 
 
839
procedure register;
 
840
 
 
841
implementation
 
842
 
 
843
uses
 
844
  FileUtil,
 
845
  RtlConsts,
 
846
  CodeCache;
 
847
 
 
848
procedure register;
 
849
begin
 
850
  RegisterUnitResourcefileFormat(TXMLUnitResourcefileFormat);
 
851
  RegisterProjectFileDescriptor(TFileDescPascalUnitWithXMLResource.Create,
 
852
                                FileDescGroupName);
 
853
end;
 
854
 
 
855
{ TFileDescPascalUnitWithXMLResource }
 
856
 
 
857
constructor TFileDescPascalUnitWithXMLResource.Create;
 
858
begin
 
859
  inherited Create;
 
860
  ResourceClass:=TForm;
 
861
end;
 
862
 
 
863
function TFileDescPascalUnitWithXMLResource.GetLocalizedName: string;
 
864
begin
 
865
  Result:='Form with XML resource file';
 
866
end;
 
867
 
 
868
function TFileDescPascalUnitWithXMLResource.GetLocalizedDescription: string;
 
869
begin
 
870
  Result:='Create a new unit with a LCL form with XML resource file.';
 
871
end;
 
872
 
 
873
function TFileDescPascalUnitWithXMLResource.GetImplementationSource(
 
874
  const Filename, SourceName, ResourceName: string): string;
 
875
var
 
876
  ResourceFilename: String;
 
877
  LE: String;
 
878
begin
 
879
  LE:=LineEnding;
 
880
  case GetResourceType of
 
881
    rtLRS:
 
882
      begin
 
883
        ResourceFilename:=TrimFilename(ExtractFilenameOnly(Filename)+DefaultResFileExt);
 
884
        Result:='initialization'+LE+'  {$I '+ResourceFilename+'}'+LE+LE;
 
885
      end;
 
886
    rtRes: Result := '{$R *.xml}'+LE+LE;
 
887
  end;
 
888
end;
 
889
 
 
890
{ TXMLObjectWriter }
 
891
 
 
892
procedure TXMLObjectWriter.CreateXML;
 
893
begin
 
894
  FXMLDoc := TXMLDocument.Create;
 
895
  FXMLCreated:=true;
 
896
end;
 
897
 
 
898
constructor TXMLObjectWriter.Create(Stream: TStream; BufSize: Integer);
 
899
begin
 
900
  inherited Create;
 
901
  FStream:=Stream;
 
902
end;
 
903
 
 
904
destructor TXMLObjectWriter.Destroy;
 
905
begin
 
906
  FXMLDoc.Free;
 
907
  inherited Destroy;
 
908
end;
 
909
 
 
910
procedure TXMLObjectWriter.BeginCollection;
 
911
begin
 
912
 
 
913
end;
 
914
 
 
915
procedure TXMLObjectWriter.BeginComponent(Component: TComponent;
 
916
  Flags: TFilerFlags; ChildPos: Integer);
 
917
var
 
918
  ANewNode : TDOMElement;
 
919
begin
 
920
  if not FXmlCreated then
 
921
    begin
 
922
    CreateXML;
 
923
    end;
 
924
  inc(FListLevel,2);
 
925
  ANewNode := FXMLDoc.CreateElement('object');
 
926
 
 
927
  ANewNode.AttribStrings['type'] := Component.ClassName;
 
928
  ANewNode.AttribStrings['name'] := Component.Name;
 
929
  if not assigned(FObjNode) then
 
930
    FXMLDoc.AppendChild(ANewNode)
 
931
  else
 
932
    FObjNode.AppendChild(ANewNode);
 
933
  FObjNode := ANewNode;
 
934
  FIsStreamingProps:=True;
 
935
end;
 
936
 
 
937
procedure TXMLObjectWriter.BeginList;
 
938
begin
 
939
  inc(FListLevel);
 
940
end;
 
941
 
 
942
procedure TXMLObjectWriter.EndList;
 
943
begin
 
944
  dec(FListLevel);
 
945
  if FIsStreamingProps then
 
946
    begin
 
947
    FIsStreamingProps:=false;
 
948
    end
 
949
  else
 
950
    FObjNode := FObjNode.ParentNode;
 
951
 
 
952
  if FListLevel=0 then
 
953
    WriteXMLFile(FXMLDoc,FStream);
 
954
end;
 
955
 
 
956
procedure TXMLObjectWriter.BeginProperty(const PropName: String);
 
957
begin
 
958
  FCurNode := FXMLDoc.CreateElement('property');
 
959
  FObjNode.AppendChild(FCurNode);
 
960
  FCurNode.AttribStrings['name'] := PropName;
 
961
end;
 
962
 
 
963
procedure TXMLObjectWriter.EndProperty;
 
964
begin
 
965
  // Do nothing
 
966
end;
 
967
 
 
968
procedure TXMLObjectWriter.Write(const Buffer; Count: Longint);
 
969
begin
 
970
 
 
971
end;
 
972
 
 
973
procedure TXMLObjectWriter.WriteBinary(const Buffer; Count: LongInt);
 
974
begin
 
975
 
 
976
end;
 
977
 
 
978
procedure TXMLObjectWriter.WriteBoolean(Value: Boolean);
 
979
begin
 
980
  if value then
 
981
    begin
 
982
    FCurNode.AttribStrings['type'] := 'vatrue';
 
983
    FCurNode.TextContent:='True';
 
984
    end
 
985
  else
 
986
    begin
 
987
    FCurNode.AttribStrings['type'] := 'vafalse';
 
988
    FCurNode.TextContent:='False';
 
989
    end
 
990
end;
 
991
 
 
992
procedure TXMLObjectWriter.WriteCurrency(const Value: Currency);
 
993
begin
 
994
 
 
995
end;
 
996
 
 
997
procedure TXMLObjectWriter.WriteIdent(const Ident: string);
 
998
begin
 
999
  FCurNode.AttribStrings['type'] := 'ident';
 
1000
  FCurNode.TextContent:=Ident;
 
1001
end;
 
1002
 
 
1003
procedure TXMLObjectWriter.WriteInteger(Value: Int64);
 
1004
begin
 
1005
  FCurNode.AttribStrings['type'] := 'int64';
 
1006
  FCurNode.TextContent:=inttostr(value);
 
1007
end;
 
1008
 
 
1009
procedure TXMLObjectWriter.WriteUInt64(Value: QWord);
 
1010
begin
 
1011
  FCurNode.AttribStrings['type'] := 'int64';
 
1012
  FCurNode.TextContent:=inttostr(value);
 
1013
end;
 
1014
 
 
1015
procedure TXMLObjectWriter.WriteMethodName(const Name: String);
 
1016
begin
 
1017
  FCurNode.AttribStrings['type'] := 'ident';
 
1018
  FCurNode.TextContent:=Name;
 
1019
end;
 
1020
 
 
1021
procedure TXMLObjectWriter.WriteSet(Value: LongInt; SetType: Pointer);
 
1022
begin
 
1023
 
 
1024
end;
 
1025
 
 
1026
procedure TXMLObjectWriter.WriteString(const Value: String);
 
1027
begin
 
1028
  FCurNode.AttribStrings['type'] := 'string';
 
1029
  FCurNode.TextContent:=value;
 
1030
end;
 
1031
 
 
1032
procedure TXMLObjectWriter.WriteWideString(const Value: WideString);
 
1033
begin
 
1034
 
 
1035
end;
 
1036
 
 
1037
procedure TXMLObjectWriter.WriteUnicodeString(const Value: UnicodeString);
 
1038
begin
 
1039
 
 
1040
end;
 
1041
 
 
1042
procedure TXMLObjectWriter.WriteVariant(const VarValue: Variant);
 
1043
begin
 
1044
 
 
1045
end;
 
1046
 
 
1047
procedure TXMLObjectWriter.WriteFloat(const Value: Extended);
 
1048
begin
 
1049
  //
 
1050
end;
 
1051
 
 
1052
procedure TXMLObjectWriter.WriteSingle(const Value: Single);
 
1053
begin
 
1054
  //
 
1055
end;
 
1056
 
 
1057
procedure TXMLObjectWriter.WriteDate(const Value: TDateTime);
 
1058
begin
 
1059
  //
 
1060
end;
 
1061
 
 
1062
{ TXMLWriter }
 
1063
 
 
1064
function TXMLWriter.CreateDriver(Stream: TStream; BufSize: Integer
 
1065
  ): TAbstractObjectWriter;
 
1066
begin
 
1067
  Result:=TXMLObjectWriter.Create(Stream,BufSize);
 
1068
end;
 
1069
 
 
1070
{ TXMLObjectReader }
 
1071
 
 
1072
constructor TXMLObjectReader.create(AStream: TStream);
 
1073
begin
 
1074
  inherited create;
 
1075
 
 
1076
  If (AStream=Nil) then
 
1077
    Raise EReadError.Create(SEmptyStreamIllegalReader);
 
1078
 
 
1079
  FStream := AStream;
 
1080
end;
 
1081
 
 
1082
destructor TXMLObjectReader.Destroy;
 
1083
begin
 
1084
  FXMLDoc.Free;
 
1085
  inherited Destroy;
 
1086
end;
 
1087
 
 
1088
function TXMLObjectReader.NextValue: TValueType;
 
1089
var
 
1090
  StoreNode,
 
1091
  StoreObjNode: TDOMNode;
 
1092
  StoreReadingChilds: boolean;
 
1093
begin
 
1094
  StoreNode := FCurNode;
 
1095
  StoreObjNode := FObjNode;
 
1096
  StoreReadingChilds := FReadingChilds;
 
1097
  result := ReadValue;
 
1098
  FCurNode:=StoreNode;
 
1099
  FObjNode:=StoreObjNode;
 
1100
  FReadingChilds:=StoreReadingChilds;
 
1101
end;
 
1102
 
 
1103
function TXMLObjectReader.ReadValue: TValueType;
 
1104
begin
 
1105
  result := vaNull;
 
1106
  if not assigned(FCurNode) then
 
1107
    begin
 
1108
    if not FReadingChilds then
 
1109
      begin
 
1110
      FCurNode := FObjNode.FirstChild;
 
1111
      while assigned(FCurNode) and (FCurNode.NodeName<>'object') do
 
1112
        FCurNode := FCurNode.NextSibling;
 
1113
      FReadingChilds:=true;
 
1114
      end
 
1115
    else
 
1116
      begin
 
1117
      if assigned(FObjNode.NextSibling) then
 
1118
        FCurNode := FObjNode.NextSibling
 
1119
      else if assigned(FObjNode.ParentNode) then
 
1120
        FObjNode := FObjNode.ParentNode;
 
1121
 
 
1122
      while assigned(FCurNode) and (FCurNode.NodeName<>'object') do
 
1123
        FCurNode := FCurNode.NextSibling;
 
1124
      end;
 
1125
    Exit;
 
1126
    end;
 
1127
 
 
1128
  if not FReadingChilds and (FCurNode.NodeName='property') then
 
1129
    begin
 
1130
    FCurValue := FCurNode.TextContent;
 
1131
    if FCurNode.Attributes.GetNamedItem('type').NodeValue='int16' then
 
1132
      result := vaInt16
 
1133
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='int64' then
 
1134
      result := vaInt32
 
1135
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='string' then
 
1136
      result := vaString
 
1137
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='vatrue' then
 
1138
      result := vaTrue
 
1139
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='vafalse' then
 
1140
      result := vaFalse
 
1141
    else if FCurNode.Attributes.GetNamedItem('type').NodeValue='ident' then
 
1142
      result := vaIdent
 
1143
    else
 
1144
      raise EReadError.CreateFmt('Unknown property type %s',[FCurNode.Attributes.GetNamedItem('type').NodeValue]);
 
1145
    end;
 
1146
 
 
1147
  if FReadingChilds and (FCurNode.NodeName='object') then
 
1148
    result := vaIdent;
 
1149
 
 
1150
  FCurNode := FCurNode.NextSibling;
 
1151
  while assigned(FCurNode) do
 
1152
    begin
 
1153
    if FReadingChilds and (FCurNode.NodeName='object') then
 
1154
      break;
 
1155
    if not FReadingChilds and (FCurNode.NodeName='property') then
 
1156
      break;
 
1157
    FCurNode := FCurNode.NextSibling;
 
1158
    end;
 
1159
end;
 
1160
 
 
1161
procedure TXMLObjectReader.BeginRootComponent;
 
1162
begin
 
1163
  FXMLDoc.Free;
 
1164
 
 
1165
  ReadXMLFile(FXMLDoc, FStream);
 
1166
  FCurNode := FXMLDoc.FindNode('object');
 
1167
  if not assigned(FCurNode) then
 
1168
    raise EReadError.Create('Invalid XML-stream format: No object node found');
 
1169
end;
 
1170
 
 
1171
procedure TXMLObjectReader.BeginComponent(var Flags: TFilerFlags;
 
1172
  var AChildPos: Integer; var CompClassName, CompName: String);
 
1173
begin
 
1174
  flags := [];
 
1175
  FReadingChilds:=false;
 
1176
 
 
1177
  assert(FObjNode.NodeName='object');
 
1178
  FObjNode:=FCurNode;
 
1179
  CompName:=FObjNode.Attributes.GetNamedItem('name').NodeValue;
 
1180
  CompClassName:=FObjNode.Attributes.GetNamedItem('type').NodeValue;
 
1181
  FCurNode := FObjNode.FirstChild;
 
1182
  while assigned(FCurNode) and (FCurNode.NodeName<>'property') do
 
1183
    FCurNode := FCurNode.NextSibling;
 
1184
end;
 
1185
 
 
1186
function TXMLObjectReader.BeginProperty: String;
 
1187
begin
 
1188
  if FCurNode.NodeName<>'property' then
 
1189
    raise exception.create('property-element expected but found '+FCurNode.NodeName);
 
1190
  result := FCurNode.Attributes.GetNamedItem('name').NodeValue;
 
1191
end;
 
1192
 
 
1193
procedure TXMLObjectReader.Read(var Buf; Count: LongInt);
 
1194
begin
 
1195
 
 
1196
end;
 
1197
 
 
1198
procedure TXMLObjectReader.ReadBinary(const DestData: TMemoryStream);
 
1199
begin
 
1200
 
 
1201
end;
 
1202
 
 
1203
function TXMLObjectReader.ReadCurrency: Currency;
 
1204
begin
 
1205
 
 
1206
end;
 
1207
 
 
1208
function TXMLObjectReader.ReadIdent(ValueType: TValueType): String;
 
1209
begin
 
1210
  result := FCurValue;
 
1211
end;
 
1212
 
 
1213
function TXMLObjectReader.ReadInt8: ShortInt;
 
1214
begin
 
1215
  result := strtoint(FCurValue);
 
1216
end;
 
1217
 
 
1218
function TXMLObjectReader.ReadInt16: SmallInt;
 
1219
begin
 
1220
  result := strtoint(FCurValue);
 
1221
end;
 
1222
 
 
1223
function TXMLObjectReader.ReadInt32: LongInt;
 
1224
begin
 
1225
  result := strtoint(FCurValue);
 
1226
end;
 
1227
 
 
1228
function TXMLObjectReader.ReadInt64: Int64;
 
1229
begin
 
1230
  result := StrToInt64(FCurValue);
 
1231
end;
 
1232
 
 
1233
function TXMLObjectReader.ReadSet(EnumType: Pointer): Integer;
 
1234
begin
 
1235
 
 
1236
end;
 
1237
 
 
1238
function TXMLObjectReader.ReadStr: String;
 
1239
begin
 
1240
  result := FCurValue;
 
1241
end;
 
1242
 
 
1243
function TXMLObjectReader.ReadString(StringType: TValueType): String;
 
1244
begin
 
1245
  result := FCurValue;
 
1246
end;
 
1247
 
 
1248
function TXMLObjectReader.ReadWideString: WideString;
 
1249
begin
 
1250
  result := FCurValue;
 
1251
end;
 
1252
 
 
1253
function TXMLObjectReader.ReadUnicodeString: UnicodeString;
 
1254
begin
 
1255
  result := FCurValue;
 
1256
end;
 
1257
 
 
1258
procedure TXMLObjectReader.SkipComponent(SkipComponentInfos: Boolean);
 
1259
begin
 
1260
 
 
1261
end;
 
1262
 
 
1263
procedure TXMLObjectReader.SkipValue;
 
1264
begin
 
1265
 
 
1266
end;
 
1267
 
 
1268
{ TXMLReader }
 
1269
 
 
1270
function TXMLReader.CreateDriver(Stream: TStream; BufSize: Integer): TAbstractObjectReader;
 
1271
begin
 
1272
  Result := TXMLObjectReader.Create(Stream);
 
1273
end;
 
1274
 
 
1275
{ TXMLUnitResourcefileFormat }
 
1276
 
 
1277
class procedure TXMLUnitResourcefileFormat.QuickReadXML(s: TStream; out
 
1278
  AComponentName, AClassName, ALCLVersion: string);
 
1279
var
 
1280
  AXMLDocument: TXMLDocument;
 
1281
  ms: TStringStream;
 
1282
  ObjNode: TDOMNode;
 
1283
begin
 
1284
  ReadXMLFile(AXMLDocument, s);
 
1285
  try
 
1286
    ObjNode := AXMLDocument.FindNode('lazarusinfo');
 
1287
    if assigned(ObjNode) then
 
1288
      begin
 
1289
      ObjNode := ObjNode.FindNode('lclversion');
 
1290
      if assigned(ObjNode) then
 
1291
        ALCLVersion:=ObjNode.TextContent;
 
1292
      end;
 
1293
 
 
1294
    ObjNode := AXMLDocument.FindNode('object');
 
1295
    if not assigned(ObjNode) then
 
1296
      raise EReadError.Create('Invalid XML-stream format: No object node found');
 
1297
    AComponentName:=ObjNode.Attributes.GetNamedItem('name').NodeValue;
 
1298
    AClassName:=ObjNode.Attributes.GetNamedItem('type').NodeValue;
 
1299
 
 
1300
  finally
 
1301
    AXMLDocument.Free;
 
1302
  end;
 
1303
end;
 
1304
 
 
1305
class function TXMLUnitResourcefileFormat.FindResourceDirective(Source: TObject): boolean;
 
1306
var
 
1307
  cb: TCodeBuffer;
 
1308
  nx,ny,nt: integer;
 
1309
begin
 
1310
//  result := CodeToolBoss.FindResourceDirective(Source as TCodeBuffer,1,1,cb,nx,ny,nt, ResourceDirectiveFilename,false);
 
1311
end;
 
1312
 
 
1313
class function TXMLUnitResourcefileFormat.ResourceDirectiveFilename: string;
 
1314
begin
 
1315
  result := '*.xml';
 
1316
end;
 
1317
 
 
1318
class function TXMLUnitResourcefileFormat.GetUnitResourceFilename(
 
1319
  AUnitFilenae: string): string;
 
1320
begin
 
1321
  result := ChangeFileExt(AUnitFilenae,'.xml');
 
1322
end;
 
1323
 
 
1324
class procedure TXMLUnitResourcefileFormat.TextStreamToBinStream(ATxtStream,
 
1325
  ABinStream: TExtMemoryStream);
 
1326
begin
 
1327
  ABinStream.LoadFromStream(ATxtStream);
 
1328
end;
 
1329
 
 
1330
class procedure TXMLUnitResourcefileFormat.BinStreamToTextStream(ABinStream,
 
1331
  ATextStream: TExtMemoryStream);
 
1332
begin
 
1333
  ATextStream.LoadFromStream(ABinStream);
 
1334
end;
 
1335
 
 
1336
class function TXMLUnitResourcefileFormat.GetClassNameFromStream(s: TStream;
 
1337
  out IsInherited: Boolean): shortstring;
 
1338
var
 
1339
  AComponentName,
 
1340
  AClassType,
 
1341
  ALCLVersion: string;
 
1342
begin
 
1343
  IsInherited:=false;
 
1344
  QuickReadXML(s, AComponentName, AClassType, ALCLVersion);
 
1345
  s.Seek(0,soFromBeginning);
 
1346
  result := AClassType;
 
1347
end;
 
1348
 
 
1349
class function TXMLUnitResourcefileFormat.CreateReader(s: TStream;
 
1350
  var DestroyDriver: boolean): TReader;
 
1351
begin
 
1352
  result := TXMLReader.Create(s,4096);
 
1353
end;
 
1354
 
 
1355
class function TXMLUnitResourcefileFormat.CreateWriter(s: TStream;
 
1356
  var DestroyDriver: boolean): TWriter;
 
1357
var
 
1358
  ADriver: TXMLObjectWriter;
 
1359
begin
 
1360
  ADriver:=TXMLObjectWriter.Create(s,4096);
 
1361
  result := TWriter.Create(ADriver);
 
1362
  DestroyDriver:=false;
 
1363
end;
 
1364
 
 
1365
class function TXMLUnitResourcefileFormat.QuickCheckResourceBuffer(
 
1366
  PascalBuffer, LFMBuffer: TObject; out LFMType, LFMComponentName,
 
1367
  LFMClassName: string; out LCLVersion: string; out MissingClasses: TStrings
 
1368
  ): TModalResult;
 
1369
var
 
1370
  ms: TStringStream;
 
1371
begin
 
1372
  ms := TStringStream.Create((LFMBuffer as TCodeBuffer).Source);
 
1373
  try
 
1374
    QuickReadXML(ms, LFMComponentName, LFMClassName, LCLVersion);
 
1375
  finally
 
1376
    ms.Free;
 
1377
  end;
 
1378
 
 
1379
  LFMType:='unknown';
 
1380
  MissingClasses := nil;
 
1381
end;
 
1382
 
 
1383
end.
 
1384