1{
2    This file is part of the Free Pascal run time library.
3    Copyright (c) 2008 by Giulio Bernardi
4
5    Resource reader for DFM files
6
7    See the file COPYING.FPC, included in this distribution,
8    for details about the copyright.
9
10    This program is distributed in the hope that it will be useful,
11    but WITHOUT ANY WARRANTY; without even the implied warranty of
12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************}
15
16unit dfmreader;
17
18{$MODE OBJFPC} {$H+}
19
20interface
21
22uses
23  Classes, SysUtils, resource;
24
25type
26
27  { TDfmResourceReader }
28
29  TDfmResourceReader = class (TAbstractResourceReader)
30  private
31    fExtensions : string;
32    fDescription : string;
33    fLine : string;
34    fLinePos : integer;
35    fObjectName : string;
36    dummyType : TResourceDesc;
37    dummyName : TResourceDesc;
38    fIsBinary : boolean;
39    function IsAlpha : boolean;
40    function IsNum : boolean;
41    function IsAlphaNum : boolean;
42    function IsSpace : boolean;
43    procedure SkipSpaces;
44    function GetIdent : string;
45    procedure ReadLine(aStream : TStream);
46
47    function CheckTextDfm(aStream : TStream) : boolean;
48    function CheckBinDfm(aStream : TStream) : boolean;
49  protected
50    function GetExtensions : string; override;
51    function GetDescription : string; override;
52    procedure Load(aResources : TResources; aStream : TStream); override;
53    function CheckMagic(aStream : TStream) : boolean; override;
54  public
55    constructor Create; override;
56    destructor Destroy; override;
57  end;
58
59
60implementation
61
62uses
63  resdatastream, resfactory;
64
65type
66  TSignature = array[0..3] of char;
67
68const
69  FilerSignature = 'TPF0';
70
71{ TDfmResourceReader }
72
73function TDfmResourceReader.IsAlpha: boolean;
74begin
75  Result:=pchar(fLine)[fLinePos] in ['_','A'..'Z','a'..'z'];
76end;
77
78function TDfmResourceReader.IsNum: boolean;
79begin
80  Result:=pchar(fLine)[fLinePos] in ['0'..'9'];
81end;
82
83function TDfmResourceReader.IsAlphaNum: boolean;
84begin
85  Result:=IsAlpha or IsNum;
86end;
87
88function TDfmResourceReader.IsSpace: boolean;
89const TAB = #9;
90begin
91  Result:=pchar(fLine)[fLinePos] in [' ',TAB];
92end;
93
94procedure TDfmResourceReader.SkipSpaces;
95begin
96  while IsSpace do inc(fLinePos);
97end;
98
99function TDfmResourceReader.GetIdent: string;
100begin
101  Result:='';
102  SkipSpaces;
103  if not IsAlpha then exit;
104  while IsAlphaNum do
105  begin
106    Result:=Result+pchar(fLine)[fLinePos];
107    inc(fLinePos);
108  end;
109end;
110
111procedure TDfmResourceReader.ReadLine(aStream : TStream);
112const CR = #13;
113      LF = #10;
114var c : char;
115begin
116  fLine:='';
117
118  repeat
119    aStream.ReadBuffer(c,1);
120    if not (c in [CR,LF,#0]) then
121      fLine:=fLine+c;
122  until c in [CR,LF,#0];
123  fLinePos:=0;
124end;
125
126(*should be:  object Name: Type  or inherited Name: Type*)
127function TDfmResourceReader.CheckTextDfm(aStream: TStream): boolean;
128var tmp : string;
129begin
130  Result:=false;
131  fLine:='';
132  while fLine='' do
133    ReadLine(aStream);
134  //skip UTF-8 BOM, if needed
135  if (copy(fLine,1,3)=(#$EF+#$BB+#$BF)) then
136    inc(fLinePos,3);
137  tmp:=lowercase(GetIdent);
138  if (tmp <> 'object') and (tmp<>'inherited') then exit;
139  if GetIdent='' then exit;
140  SkipSpaces;
141  if pchar(fLine)[fLinePos]<>':' then exit;
142  inc(fLinePos);
143  SkipSpaces;
144  fObjectName:=UpperCase(GetIdent);
145  if fObjectName='' then exit;
146  Result:=true;
147  fIsBinary:=false;
148end;
149
150function TDfmResourceReader.CheckBinDfm(aStream: TStream): boolean;
151var s : shortstring;
152    b : byte;
153begin
154  aStream.ReadBuffer(b,1);
155  s[0]:=Chr(b);
156  aStream.ReadBuffer(s[1],b);
157  fObjectName:=UpperCase(s);
158  Result:=fObjectName<>'';
159  fIsBinary:=true;
160end;
161
162function TDfmResourceReader.GetExtensions: string;
163begin
164  Result:=fExtensions;
165end;
166
167function TDfmResourceReader.GetDescription: string;
168begin
169  Result:=fDescription;
170end;
171
172procedure TDfmResourceReader.Load(aResources: TResources; aStream: TStream);
173var aRes : TAbstractResource;
174    RawData : TResourceDataStream;
175begin
176  if not CheckMagic(aStream) then
177    raise EResourceReaderWrongFormatException.Create('');
178
179  dummyName.Name:=fObjectName;
180  aRes:=TResourceFactory.CreateResource(dummyType,dummyName);
181  if fIsBinary then
182  begin
183    SetDataSize(aRes,aStream.Size-aStream.Position);
184    SetDataOffset(aRes,aStream.Position);
185    RawData:=TResourceDataStream.Create(aStream,aRes,aRes.DataSize,TCachedResourceDataStream);
186    SetRawData(aRes,RawData);
187  end
188  else
189    ObjectTextToBinary(aStream,aRes.RawData);
190
191  try
192    aResources.Add(aRes);
193  except
194    on e : EResourceDuplicateException do
195    begin
196      aRes.Free;
197      raise;
198    end;
199  end;
200end;
201
202function TDfmResourceReader.CheckMagic(aStream: TStream): boolean;
203var sig : TSignature;
204    orig : int64;
205begin
206  orig:=aStream.Position;
207  aStream.ReadBuffer(sig,4);
208  if sig=FilerSignature then Result:=CheckBinDfm(aStream)
209  else
210  begin
211    aStream.Seek(-4,soFromCurrent);
212    Result:=CheckTextDfm(aStream);
213  end;
214  aStream.Position:=orig;
215end;
216
217constructor TDfmResourceReader.Create;
218begin
219  fExtensions:='.dfm .xfm .lfm';
220  fDescription:='DFM resource reader';
221  fLine:='';
222  fLinePos:=0;
223  fObjectName:='';
224  fIsBinary:=false;
225  dummyType:=TResourceDesc.Create;
226  dummyType.ID:=RT_RCDATA;
227  dummyName:=TResourceDesc.Create;
228end;
229
230destructor TDfmResourceReader.Destroy;
231begin
232  dummyType.Free;
233  dummyName.Free;
234end;
235
236initialization
237  TResources.RegisterReader('.dfm',TDfmResourceReader);
238  TResources.RegisterReader('.xfm',TDfmResourceReader);
239  TResources.RegisterReader('.lfm',TDfmResourceReader);
240
241end.
242