1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRALazResource;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 BGRAClasses, SysUtils, BGRAMultiFileType;
10
11 type
12 { TLazResourceEntry }
13
14 TLazResourceEntry = class(TMultiFileEntry)
15 private
16 procedure Serialize(ADestination: TStream);
17 protected
18 FName: utf8string;
19 FValueType: utf8string;
20 FContent: TStream;
GetNamenull21 function GetName: utf8string; override;
22 procedure SetName(AValue: utf8string); override;
GetExtensionnull23 function GetExtension: utf8string; override;
GetFileSizenull24 function GetFileSize: int64; override;
25 public
26 constructor Create(AContainer: TMultiFileContainer; AName: utf8string; AValueType: utf8string; AContent: TStream);
27 destructor Destroy; override;
CopyTonull28 function CopyTo(ADestination: TStream): int64; override;
GetStreamnull29 function GetStream: TStream; override;
30 end;
31
32 { TFormDataEntry }
33
34 TFormDataEntry = class(TLazResourceEntry)
35 protected
36 FTextContent: TStream;
37 procedure RequireTextContent;
GetExtensionnull38 function GetExtension: utf8string; override;
GetFileSizenull39 function GetFileSize: int64; override;
40 public
41 constructor Create(AContainer: TMultiFileContainer; AName: utf8string; ABinaryContent: TStream);
42 destructor Destroy; override;
CopyTonull43 function CopyTo(ADestination: TStream): int64; override;
44 end;
45
46 { TLazResourceContainer }
47
48 TLazResourceContainer = class(TMultiFileContainer)
49 protected
CreateEntrynull50 function CreateEntry(AName: utf8string; AExtension: utf8string; AContent: TStream): TMultiFileEntry; override;
51 public
52 procedure LoadFromStream(AStream: TStream); override;
53 procedure SaveToStream(ADestination: TStream); override;
54 end;
55
56 implementation
57
58 uses LResources, BGRAUTF8;
59
60 { TFormDataEntry }
61
62 procedure TFormDataEntry.RequireTextContent;
63 begin
64 if FTextContent = nil then
65 begin
66 FTextContent:= TMemoryStream.Create;
67 FContent.Position:= 0;
68 LRSObjectBinaryToText(FContent, FTextContent);
69 end;
70 end;
71
GetExtensionnull72 function TFormDataEntry.GetExtension: utf8string;
73 begin
74 Result:= 'lfm';
75 end;
76
TFormDataEntry.GetFileSizenull77 function TFormDataEntry.GetFileSize: int64;
78 begin
79 RequireTextContent;
80 Result:= FTextContent.Size;
81 end;
82
83 constructor TFormDataEntry.Create(AContainer: TMultiFileContainer;
84 AName: utf8string; ABinaryContent: TStream);
85 begin
86 inherited Create(AContainer,AName,'FORMDATA',ABinaryContent);
87 end;
88
89 destructor TFormDataEntry.Destroy;
90 begin
91 FreeAndNil(FTextContent);
92 inherited Destroy;
93 end;
94
TFormDataEntry.CopyTonull95 function TFormDataEntry.CopyTo(ADestination: TStream): int64;
96 begin
97 RequireTextContent;
98 if FTextContent.Size = 0 then
99 result := 0
100 else
101 begin
102 FTextContent.Position:= 0;
103 result := ADestination.CopyFrom(FTextContent,FTextContent.Size);
104 end;
105 end;
106
107 { TLazResourceEntry }
108
109 procedure TLazResourceEntry.Serialize(ADestination: TStream);
110 begin
111 FContent.Position := 0;
112 BinaryToLazarusResourceCode(FContent, ADestination, Name, FValueType);
113 end;
114
TLazResourceEntry.GetNamenull115 function TLazResourceEntry.GetName: utf8string;
116 begin
117 Result:= FName;
118 end;
119
120 procedure TLazResourceEntry.SetName(AValue: utf8string);
121 begin
122 if AValue = FName then exit;
123 if Container.IndexOf(AVAlue, Extension) <> -1 then
124 raise Exception.Create('Name is already used for this extension');
125 FName := AValue;
126 end;
127
TLazResourceEntry.GetExtensionnull128 function TLazResourceEntry.GetExtension: utf8string;
129 begin
130 Result:= FValueType;
131 end;
132
TLazResourceEntry.GetFileSizenull133 function TLazResourceEntry.GetFileSize: int64;
134 begin
135 Result:= FContent.Size;
136 end;
137
138 destructor TLazResourceEntry.Destroy;
139 begin
140 FreeAndNil(FContent);
141 inherited Destroy;
142 end;
143
144 constructor TLazResourceEntry.Create(AContainer: TMultiFileContainer; AName: utf8string; AValueType: utf8string;
145 AContent: TStream);
146 begin
147 inherited Create(AContainer);
148 FName := AName;
149 FValueType := UTF8UpperCase(AValueType);
150 FContent := AContent;
151 end;
152
TLazResourceEntry.CopyTonull153 function TLazResourceEntry.CopyTo(ADestination: TStream): int64;
154 begin
155 if FContent.Size = 0 then
156 result := 0
157 else
158 begin
159 FContent.Position:= 0;
160 result := ADestination.CopyFrom(FContent, FContent.Size);
161 end;
162 end;
163
TLazResourceEntry.GetStreamnull164 function TLazResourceEntry.GetStream: TStream;
165 begin
166 Result:= FContent;
167 end;
168
169 { TLazResourceContainer }
170
171 procedure TLazResourceContainer.LoadFromStream(AStream: TStream);
172 const
173 entryStart = 'LazarusResources.Add(';
174 entryEnd = ');';
175 whiteSpace = [' ',#9,#10,#13,#26];
176 var
177 fileContent: String;
178 filePos : integer;
179
180 procedure SkipWhitespace;
181 begin
182 while (filePos <= length(fileContent)) and (fileContent[filePos] in whiteSpace) do inc(filePos);
183 end;
184
185 procedure SkipComma;
186 begin
187 SkipWhitespace;
188 if (filePos <= length(fileContent)) and (fileContent[filePos] = ',') then
189 inc(filePos)
190 else
191 raise Exception.Create('Comma expected');
192 end;
193
ParseStringnull194 function ParseString(ignoreCommas: boolean): TStream;
195 var
196 expectPlus: boolean;
197
198 procedure AppendChar(c: char);
199 begin
200 result.WriteByte(ord(c));
201 end;
202
ParseNumbernull203 function ParseNumber: integer;
204 var numberStart, errPos: integer;
205 s: String;
206 begin
207 numberStart:= filePos;
208 if (filePos <= length(fileContent)) and (fileContent[filePos] = '$') then
209 begin
210 inc(filePos);
211 while (filePos <= length(fileContent)) and (fileContent[filePos] in['0'..'9','a'..'f','A'..'F']) do inc(filePos);
212 end else
213 begin
214 while (filePos <= length(fileContent)) and (fileContent[filePos] in['0'..'9']) do inc(filePos);
215 end;
216 s := copy(fileContent,numberStart,filePos-numberStart);
217 val(s, result, errPos);
218 if errPos <> 0 then
219 raise exception.Create('Invalid number "' + s + '"');
220 end;
221
ParseStringPartnull222 function ParseStringPart: boolean;
223 var charCode: integer;
224 begin
225 SkipWhitespace;
226 if filePos <= length(fileContent) then
227 begin
228 if expectPlus then
229 if fileContent[filePos] <> '+' then
230 begin
231 result := false;
232 expectPlus := false;
233 exit;
234 end else
235 inc(filePos);
236
237 case fileContent[filePos] of
238 '+': raise exception.Create('Unexpected "+"');
239 '''': begin
240 inc(filePos);
241 while (filePos <= length(fileContent)) do
242 begin
243 if fileContent[filePos] = '''' then
244 begin
245 inc(filePos);
246 if (filePos <= length(fileContent)) and (fileContent[filePos] = '''') then
247 begin
248 AppendChar('''');
249 inc(filePos);
250 end
251 else break;
252 end else
253 if fileContent[filePos] in[#10,#13] then
254 raise Exception.Create('Unexpected end of line')
255 else
256 begin
257 AppendChar(fileContent[filePos]);
258 inc(filePos);
259 end;
260 end;
261 if (filePos <= length(fileContent)) and (fileContent[filePos] = '#') then
262 expectPlus := false
263 else
264 expectPlus := true;
265 result := true;
266 end;
267 '#': begin
268 inc(filePos);
269 charCode := ParseNumber;
270 if (charCode < 0) or (charCode > 255) then
271 raise exception.Create('Character code out of bounds');
272 AppendChar(chr(charCode));
273 if (filePos <= length(fileContent)) and (fileContent[filePos] in['#','''']) then
274 expectPlus := false
275 else
276 expectPlus := true;
277 result := true;
278 end;
279 else
280 begin
281 result := false;
282 expectPlus := false;
283 end;
284 end;
285 end
286 else
287 begin
288 result := false;
289 expectPlus := false;
290 end;
291 end;
292
293 begin
294 result := TMemoryStream.Create;
295 expectPlus := false;
296 if not ParseStringPart then raise exception.Create('Expecting string');
297 repeat
298 if ignoreCommas then
299 begin
300 SkipWhitespace;
301 if (filePos <= length(fileContent)) and (fileContent[filePos] = ',') then
302 begin
303 inc(filePos);
304 expectPlus := false;
305 end;
306 end;
307 until not ParseStringPart;
308 end;
309
310 procedure ReadContent;
311 var
312 bytesRead: integer;
313 begin
314 setlength(fileContent,AStream.Size-AStream.Position);
315 bytesRead := AStream.Read(fileContent[1],length(fileContent));
316 setlength(fileContent, bytesRead);
317 filePos := 1;
318 end;
319
StreamToUTF8Stringnull320 function StreamToUTF8String(AStream: TStream): utf8String;
321 begin
322 setlength(result, AStream.Size);
323 AStream.Position := 0;
324 AStream.Read(result[1], length(result));
325 AStream.Free;
326 end;
327
328 var
329 entryName: utf8string;
330 entryType: utf8string;
331 entryContent: TStream;
332 inArray: boolean;
333
334 begin
335 Clear;
336 ReadContent;
337 while filePos <= length(fileContent) do
338 begin
339 if (upcase(fileContent[filePos]) = upcase(entryStart[1])) and
340 (CompareText(copy(fileContent,filePos,length(entryStart)),entryStart)=0) then
341 begin
342 inc(filePos, length(entryStart));
343 entryName := StreamToUTF8String(ParseString(false));
344 SkipComma;
345 entryType := StreamToUTF8String(ParseString(false));
346 SkipComma;
347
348 SkipWhitespace;
349 if (filePos <= length(fileContent)) and (fileContent[filePos] = '[') then
350 begin
351 inArray := true;
352 inc(filePos);
353 end else
354 inArray := false;
355 entryContent := ParseString(inArray);
356 SkipWhitespace;
357 if inArray then
358 begin
359 if (filePos <= length(fileContent)) and (fileContent[filePos] = ']') then
360 inc(filePos)
361 else
362 raise exception.Create('Expecting "]"');
363 end;
364
365 if entryType = 'FORMDATA' then
366 AddEntry(TFormDataEntry.Create(self,entryName,entryContent))
367 else
368 AddEntry(TLazResourceEntry.Create(self,entryName,entryType,entryContent));
369
370 if (filePos+length(entryEnd)-1 <= length(fileContent)) and (CompareText(copy(fileContent,filePos,length(entryEnd)),entryEnd)=0) then
371 inc(filePos,length(entryEnd))
372 else
373 raise exception.Create('Expecting "'+entryEnd+'"');
374 end else
375 if fileContent[filePos] in whiteSpace then
376 inc(filePos)
377 else
378 raise exception.Create('Unexpected character "'+fileContent[filePos]+'"');
379 end;
380 end;
381
CreateEntrynull382 function TLazResourceContainer.CreateEntry(AName: utf8string; AExtension: utf8string;
383 AContent: TStream): TMultiFileEntry;
384 var
385 binContent: TMemoryStream;
386 begin
387 if UTF8CompareText(AExtension,'lfm')=0 then
388 begin
389 binContent := TMemoryStream.Create;
390 try
391 AContent.Position:= 0;
392 LRSObjectTextToBinary(AContent, binContent);
393 result := TFormDataEntry.Create(self,AName,binContent);
394 except
395 on ex:Exception do
396 begin
397 binContent.Free;
398 result := nil;
399 end;
400 end;
401 AContent.Free;
402 end
403 else
404 result := TLazResourceEntry.Create(self,AName,UTF8UpperCase(AExtension),AContent);
405 end;
406
407 procedure TLazResourceContainer.SaveToStream(ADestination: TStream);
408 var
409 i: Integer;
410 begin
411 for i := 0 to Count-1 do
412 TLazResourceEntry(Entry[i]).Serialize(ADestination);
413 end;
414
415 end.
416
417