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