1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRAWinResource;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 BGRAClasses, SysUtils, BGRAMultiFileType, BGRABitmapTypes, BGRAReadBMP;
10
11 const
12 RT_CURSOR = 1;
13 RT_BITMAP = 2;
14 RT_ICON = 3;
15
16 RT_MENU = 4;
17 RT_DIALOG = 5;
18 RT_STRING = 6;
19 RT_FONTDIR = 7;
20 RT_FONT = 8;
21 RT_ACCELERATOR = 9;
22 RT_RCDATA = 10;
23 RT_MESSAGETABLE = 11;
24
25 RT_GROUP = 11;
26 RT_GROUP_CURSOR = RT_GROUP + RT_CURSOR;
27 RT_GROUP_ICON = RT_GROUP + RT_ICON;
28
29 RT_VERSION = 16;
30 RT_ANICURSOR = 21;
31 RT_ANIICON = 22;
32 RT_HTML = 23;
33 RT_MANIFEST = 24;
34
35 ICON_OR_CURSOR_FILE_ICON_TYPE = 1;
36 ICON_OR_CURSOR_FILE_CURSOR_TYPE = 2;
37
38 type
39 TNameOrId = record
40 Id: integer;
41 Name: utf8string;
42 end;
43
44 { TResourceInfo }
45
46 TResourceInfo = object
47 DataVersion: LongWord;
48 MemoryFlags: Word;
49 LanguageId: Word;
50 Version: LongWord;
51 Characteristics: LongWord;
52 procedure SwapIfNecessary;
53 end;
54
55 TWinResourceContainer = class;
56
57 { TCustomResourceEntry }
58
59 TCustomResourceEntry = class(TMultiFileEntry)
60 private
GetNextEntrynull61 class function GetNextEntry(AContainer: TMultiFileContainer; AStream: TStream): TCustomResourceEntry; static;
62 procedure Serialize(ADestination: TStream);
63 protected
64 FTypeNameOrId: TNameOrId;
65 FEntryNameOrId: TNameOrId;
66 FResourceInfo: TResourceInfo;
67 FReferenceCount: integer;
GetNamenull68 function GetName: utf8string; override;
69 procedure SetName(AValue: utf8string); override;
GetIdnull70 function GetId: integer;
71 procedure SetId(AValue: integer);
GetTypeIdnull72 function GetTypeId: integer;
GetTypeNamenull73 function GetTypeName: utf8string;
74 procedure IncrementReferences; virtual;
75 procedure DecrementReferences; virtual;
76 procedure SerializeHeader(ADestination: TStream); virtual;
77 procedure SerializeData(ADestination: TStream); virtual; abstract;
GetDataSizenull78 function GetDataSize: integer; virtual; abstract;
GetLanguageIdnull79 function GetLanguageId: integer;
80 procedure SetLanguageId(AValue: integer);
81 public
82 constructor Create(AContainer: TMultiFileContainer; ATypeNameOrId: TNameOrId; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo);
GetStreamnull83 function GetStream: TStream; override;
84 property Id: integer read GetId write SetId;
85 property TypeName: utf8string read GetTypeName;
86 property TypeId: integer read GetTypeId;
87 property LanguageId: integer read GetLanguageId write SetLanguageId;
88 end;
89
90 { TUnformattedResourceEntry }
91
92 TUnformattedResourceEntry = class(TCustomResourceEntry)
93 protected
94 FDataStream: TStream;
GetFileSizenull95 function GetFileSize: int64; override;
GetDataSizenull96 function GetDataSize: integer; override;
97 procedure SerializeData(ADestination: TStream); override;
GetExtensionnull98 function GetExtension: utf8string; override;
99 public
100 constructor Create(AContainer: TMultiFileContainer; ATypeNameOrId: TNameOrId; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo; ADataStream: TStream);
101 destructor Destroy; override;
CopyTonull102 function CopyTo(ADestination: TStream): int64; override;
GetStreamnull103 function GetStream: TStream; override;
104 end;
105
106 { TBitmapResourceEntry }
107
108 TBitmapResourceEntry = class(TUnformattedResourceEntry)
109 protected
GetFileSizenull110 function GetFileSize: int64; override;
GetExtensionnull111 function GetExtension: utf8string; override;
112 public
113 constructor Create(AContainer: TMultiFileContainer; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo; ADataStream: TStream);
CopyTonull114 function CopyTo(ADestination: TStream): int64; override;
115 procedure CopyFrom(ASource: TStream);
116 end;
117
118 { TGroupIconHeader }
119
120 TGroupIconHeader = object
121 Reserved, ResourceType, ImageCount: Word;
122 procedure SwapIfNecessary;
123 end;
124 TGroupIconDirEntry = packed record
125 Width, Height, Colors, Reserved: byte;
126 //stored in little endian
127 case byte of
128 0: (Variable: LongWord; ImageSize: LongWord; ImageId: Word);
129 1: (Planes, BitsPerPixel: Word);
130 2: (HotSpotX, HotSpotY: Word);
131 end;
132 TIconFileDirEntry = packed record
133 Width, Height, Colors, Reserved: byte;
134 //stored in little endian
135 case byte of
136 0: (Variable: LongWord; ImageSize: LongWord; ImageOffset: LongWord);
137 1: (Planes, BitsPerPixel: Word);
138 2: (HotSpotX, HotSpotY: Word);
139 end;
140
141 { TGroupIconOrCursorEntry }
142
143 TGroupIconOrCursorEntry = class(TCustomResourceEntry)
144 private
GetNbIconsnull145 function GetNbIcons: integer;
146 protected
147 FGroupIconHeader: TGroupIconHeader;
148 FDirectory: packed array of TGroupIconDirEntry;
GetFileSizenull149 function GetFileSize: int64; override;
GetDataSizenull150 function GetDataSize: integer; override;
151 procedure SerializeData(ADestination: TStream); override;
152 procedure IncrementReferences; override;
153 procedure DecrementReferences; override;
ExpectedResourceTypenull154 function ExpectedResourceType: word; virtual; abstract;
155 public
156 constructor Create(AContainer: TMultiFileContainer; ATypeNameOrId: TNameOrId; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo; ADataStream: TStream);
157 constructor Create(AContainer: TMultiFileContainer; ATypeNameOrId: TNameOrId; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo);
158 procedure Clear;
CopyTonull159 function CopyTo(ADestination: TStream): int64; override;
160 procedure CopyFrom(ASource: TStream);
161 property NbIcons: integer read GetNbIcons;
162 end;
163
164 { TGroupIconEntry }
165
166 TGroupIconEntry = class(TGroupIconOrCursorEntry)
167 protected
GetExtensionnull168 function GetExtension: utf8string; override;
ExpectedResourceTypenull169 function ExpectedResourceType: word; override;
170 public
171 constructor Create(AContainer: TMultiFileContainer; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo; ADataStream: TStream);
172 constructor Create(AContainer: TMultiFileContainer; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo);
173 end;
174
175 { TGroupCursorEntry }
176
177 TGroupCursorEntry = class(TGroupIconOrCursorEntry)
178 protected
GetExtensionnull179 function GetExtension: utf8string; override;
ExpectedResourceTypenull180 function ExpectedResourceType: word; override;
181 public
182 constructor Create(AContainer: TMultiFileContainer; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo; ADataStream: TStream);
183 constructor Create(AContainer: TMultiFileContainer; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo);
184 end;
185
186 { TWinResourceContainer }
187
188 TWinResourceContainer = class(TMultiFileContainer)
189 private
InternalFindnull190 function InternalFind(const AEntry: TNameOrId; const AType: TNameOrId; ALanguageId: integer = 0): TCustomResourceEntry;
191 procedure AddHidden(AEntry: TCustomResourceEntry);
GetMaxIdnull192 function GetMaxId(AType: TNameOrId): integer;
193 procedure IncrementReferenceOf(ANameId, ATypeId: integer);
194 procedure DecrementReferenceOf(ANameId, ATypeId: integer);
195 protected
196 FHiddenEntries: TMultiFileEntryList;
197 procedure Init; override;
198 procedure ClearHiddenEntries;
199 procedure RemoveHidden(AEntry: TCustomResourceEntry);
CreateEntrynull200 function CreateEntry(AName: utf8string; AExtension: utf8string; AContent: TStream; ALanguageId: integer): TMultiFileEntry; overload;
CreateEntrynull201 function CreateEntry(AName: utf8string; AExtension: utf8string; AContent: TStream): TMultiFileEntry; override;
202 public
203 procedure Clear; override;
204 destructor Destroy; override;
205 procedure Delete(AIndex: integer); override;
206 procedure LoadFromStream(AStream: TStream); override;
IndexOfnull207 function IndexOf(AName: utf8string; AExtenstion: utf8string; ACaseSensitive: boolean = True): integer; override;
IndexOfnull208 function IndexOf(AName: utf8string; AExtenstion: utf8string; ALanguageId: integer; ACaseSensitive: boolean = True): integer; overload;
209 procedure SaveToStream(ADestination: TStream); override;
210 end;
211
212 implementation
213
214 uses Math, BGRAUTF8;
215
216 operator =(const ANameOrId1, ANameOrId2: TNameOrId): boolean;
217 begin
218 if (ANameOrId1.Id < 0) then
219 result := (ANameOrId2.Id < 0) and (ANameOrId2.Name = ANameOrId1.Name)
220 else
221 result := ANameOrId2.Id = ANameOrId1.Id;
222 end;
223
NameOrIdnull224 function NameOrId(AName: string): TNameOrId; overload;
225 begin
226 result.Id := -1;
227 result.Name := AName;
228 end;
229
NameOrIdnull230 function NameOrId(AId: integer): TNameOrId; overload;
231 begin
232 result.Id := AId;
233 result.Name := IntToStr(AId);
234 end;
235
236 { TGroupCursorEntry }
237
TGroupCursorEntry.GetExtensionnull238 function TGroupCursorEntry.GetExtension: utf8string;
239 begin
240 Result:= 'cur';
241 end;
242
ExpectedResourceTypenull243 function TGroupCursorEntry.ExpectedResourceType: word;
244 begin
245 result := ICON_OR_CURSOR_FILE_CURSOR_TYPE;
246 end;
247
248 constructor TGroupCursorEntry.Create(AContainer: TMultiFileContainer;
249 AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo;
250 ADataStream: TStream);
251 begin
252 inherited Create(AContainer,NameOrId(RT_GROUP_CURSOR),AEntryNameOrId,AResourceInfo,ADataStream);
253 end;
254
255 constructor TGroupCursorEntry.Create(AContainer: TMultiFileContainer;
256 AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo);
257 begin
258 inherited Create(AContainer,NameOrId(RT_GROUP_CURSOR),AEntryNameOrId,AResourceInfo);
259 end;
260
261 { TGroupIconEntry }
262
TGroupIconEntry.GetExtensionnull263 function TGroupIconEntry.GetExtension: utf8string;
264 begin
265 Result:= 'ico';
266 end;
267
TGroupIconEntry.ExpectedResourceTypenull268 function TGroupIconEntry.ExpectedResourceType: word;
269 begin
270 result := ICON_OR_CURSOR_FILE_ICON_TYPE;
271 end;
272
273 constructor TGroupIconEntry.Create(AContainer: TMultiFileContainer;
274 AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo;
275 ADataStream: TStream);
276 begin
277 inherited Create(AContainer,NameOrId(RT_GROUP_ICON),AEntryNameOrId,AResourceInfo,ADataStream);
278 end;
279
280 constructor TGroupIconEntry.Create(AContainer: TMultiFileContainer;
281 AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo);
282 begin
283 inherited Create(AContainer,NameOrId(RT_GROUP_ICON),AEntryNameOrId,AResourceInfo);
284 end;
285
286 { TGroupIconHeader }
287
288 procedure TGroupIconHeader.SwapIfNecessary;
289 begin
290 Reserved := LEtoN(Reserved);
291 ResourceType := LEtoN(ResourceType);
292 ImageCount := LEtoN(ImageCount);
293 end;
294
295 { TGroupIconOrCursorEntry }
296
TGroupIconOrCursorEntry.GetNbIconsnull297 function TGroupIconOrCursorEntry.GetNbIcons: integer;
298 begin
299 result := FGroupIconHeader.ImageCount;
300 end;
301
TGroupIconOrCursorEntry.GetFileSizenull302 function TGroupIconOrCursorEntry.GetFileSize: int64;
303 var
304 i: Integer;
305 begin
306 Result:= sizeof(FGroupIconHeader) + sizeof(TIconFileDirEntry)*NbIcons;
307 for i := 0 to NbIcons-1 do
308 inc(Result, LEtoN(FDirectory[i].ImageSize) );
309 end;
310
GetDataSizenull311 function TGroupIconOrCursorEntry.GetDataSize: integer;
312 begin
313 result := sizeof(FGroupIconHeader) + sizeof(TGroupIconDirEntry)*NbIcons;
314 end;
315
316 procedure TGroupIconOrCursorEntry.SerializeData(ADestination: TStream);
317 begin
318 FGroupIconHeader.SwapIfNecessary;
319 try
320 ADestination.WriteBuffer(FGroupIconHeader, sizeof(FGroupIconHeader));
321 finally
322 FGroupIconHeader.SwapIfNecessary;
323 end;
324 ADestination.WriteBuffer(FDirectory[0], sizeof(TGroupIconDirEntry)*NbIcons);
325 end;
326
327 procedure TGroupIconOrCursorEntry.IncrementReferences;
328 var
329 i: Integer;
330 begin
331 for i := 0 to NbIcons-1 do
332 TWinResourceContainer(Container).IncrementReferenceOf(LEtoN(FDirectory[i].ImageId), TypeId - RT_GROUP);
333 end;
334
335 procedure TGroupIconOrCursorEntry.DecrementReferences;
336 var
337 i: Integer;
338 begin
339 for i := 0 to NbIcons-1 do
340 TWinResourceContainer(Container).DecrementReferenceOf(LEtoN(FDirectory[i].ImageId), TypeId - RT_GROUP);
341 end;
342
343 constructor TGroupIconOrCursorEntry.Create(AContainer: TMultiFileContainer;
344 ATypeNameOrId: TNameOrId; AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo;
345 ADataStream: TStream);
346 begin
347 inherited Create(AContainer,ATypeNameOrId,AEntryNameOrId,AResourceInfo);
348
349 ADataStream.ReadBuffer(FGroupIconHeader, sizeof(FGroupIconHeader));
350 FGroupIconHeader.SwapIfNecessary;
351 if FGroupIconHeader.ResourceType <> ExpectedResourceType then
352 raise exception.Create('Unexpected group type');
353
354 if ADataStream.Position + NbIcons*sizeof(TGroupIconDirEntry) > ADataStream.Size then
355 raise exception.Create('Directory dimension mismatch');
356 setlength(FDirectory, NbIcons);
357 ADataStream.ReadBuffer(FDirectory[0], NbIcons*sizeof(TGroupIconDirEntry));
358 ADataStream.Free;
359 end;
360
361 constructor TGroupIconOrCursorEntry.Create(AContainer: TMultiFileContainer;
362 ATypeNameOrId: TNameOrId; AEntryNameOrId: TNameOrId;
363 const AResourceInfo: TResourceInfo);
364 begin
365 inherited Create(AContainer,ATypeNameOrId,AEntryNameOrId,AResourceInfo);
366
367 FGroupIconHeader.Reserved := 0;
368 FGroupIconHeader.ResourceType := ExpectedResourceType;
369 FGroupIconHeader.ImageCount := 0;
370 end;
371
372 procedure TGroupIconOrCursorEntry.Clear;
373 begin
374 DecrementReferences;
375 FDirectory := nil;
376 FGroupIconHeader.ImageCount := 0;
377 end;
378
TGroupIconOrCursorEntry.CopyTonull379 function TGroupIconOrCursorEntry.CopyTo(ADestination: TStream): int64;
380 var
381 fileDir: packed array of TIconFileDirEntry;
382 offset, written, i: integer;
383 iconEntry: TCustomResourceEntry;
384 iconEntrySize: LongWord;
385 iconData: TMemoryStream;
386 copyCount: Int64;
387 subType: TNameOrId;
388
389 procedure FillZero(ACount: integer);
390 var
391 Zero: packed array[0..255] of byte;
392 begin
393 if ACount <= 0 then exit;
394 FillChar({%H-}Zero, Sizeof(Zero), 0);
395 while ACount > 0 do
396 begin
397 ADestination.WriteBuffer(Zero, Min(ACount, sizeof(Zero)));
398 Dec(ACount, Min(ACount, sizeof(Zero)));
399 end;
400 end;
401
402 begin
403 result:= 0;
404 FGroupIconHeader.SwapIfNecessary;
405 try
406 ADestination.WriteBuffer(FGroupIconHeader, sizeof(FGroupIconHeader));
407 finally
408 FGroupIconHeader.SwapIfNecessary;
409 end;
410 Inc(result, sizeof(FGroupIconHeader));
411
412 offset := result+sizeof(TIconFileDirEntry)*NbIcons;
413 setlength(fileDir, NbIcons);
414 for i := 0 to NbIcons-1 do
415 begin
416 move(FDirectory[i], fileDir[i], 12);
417 fileDir[i].ImageOffset := NtoLE(offset);
418 inc(offset, fileDir[i].ImageSize);
419 end;
420
421 ADestination.WriteBuffer(fileDir[0], sizeof(TIconFileDirEntry)*NbIcons);
422 inc(result, sizeof(TIconFileDirEntry)*NbIcons);
423
424 subType := NameOrId(TypeId - RT_GROUP);
425 for i := 0 to NbIcons-1 do
426 begin
427 iconEntry := (Container as TWinResourceContainer).InternalFind(NameOrId(LEtoN(FDirectory[i].ImageId)),subType); //no language for icons
428 iconEntrySize := LEtoN(FDirectory[i].ImageSize);
429 if iconEntry = nil then
430 FillZero(iconEntrySize) else
431 begin
432 iconData := TMemoryStream.Create;
433 try
434 iconEntry.CopyTo(IconData);
435 iconData.Position:= 0;
436 copyCount := Min(IconData.Size, iconEntrySize);
437 if copyCount > 0 then written := ADestination.CopyFrom(IconData, copyCount)
438 else written := 0;
439 FillZero(iconEntrySize-written);
440 finally
441 IconData.Free;
442 end;
443 end;
444 inc(result, iconEntrySize);
445 end;
446 end;
447
448 procedure TGroupIconOrCursorEntry.CopyFrom(ASource: TStream);
449 var
450 tempGroup: TGroupIconHeader;
451 fileDir: packed array of TIconFileDirEntry;
452 iconStream: array of TMemoryStream;
453 startPos: int64;
454 maxId, i: integer;
455 iconEntry: TUnformattedResourceEntry;
456 resourceInfo: TResourceInfo;
457 subType: TNameOrId;
458 begin
459 startPos := ASource.Position;
460 ASource.ReadBuffer({%H-}tempGroup, sizeof(tempGroup));
461 tempGroup.SwapIfNecessary;
462 if tempGroup.ResourceType <> ExpectedResourceType then
463 raise exception.Create('Unexpected resource type');
464
465 if ASource.Position + sizeof(TIconFileDirEntry)*tempGroup.ImageCount > ASource.Size then
466 raise exception.Create('Directory dimension mismatch');
467
468 setlength(fileDir, tempGroup.ImageCount);
469 ASource.ReadBuffer(fileDir[0], sizeof(TIconFileDirEntry)*tempGroup.ImageCount);
470
471 try
472 setlength(iconStream, tempGroup.ImageCount);
473 for i := 0 to tempGroup.ImageCount-1 do
474 begin
475 ASource.Position:= startPos + LEtoN(fileDir[i].ImageOffset);
476 iconStream[i] := TMemoryStream.Create;
477 iconStream[i].CopyFrom(ASource, LEtoN(fileDir[i].ImageSize));
478 end;
479
480 subType := NameOrId(self.TypeId - RT_GROUP);
481 maxId := TWinResourceContainer(Container).GetMaxId(subType);
482
483 Clear;
484 FGroupIconHeader.ImageCount := tempGroup.ImageCount;
485 setlength(FDirectory, tempGroup.ImageCount);
486 fillchar({%H-}resourceInfo,sizeof(resourceInfo),0);
487 for i := 0 to tempGroup.ImageCount-1 do
488 begin
489 move(fileDir[i], FDirectory[i], 12);
490 inc(maxId);
491 FDirectory[i].ImageId := maxId;
492 iconEntry := TUnformattedResourceEntry.Create(Container, subType, NameOrId(maxId), resourceInfo, iconStream[i]);
493 iconStream[i] := nil;
494 TWinResourceContainer(Container).AddHidden(iconEntry);
495 end;
496
497 finally
498 for i := 0 to high(iconStream) do
499 iconStream[i].Free;
500 iconStream := nil;
501 end;
502 end;
503
504 { TBitmapResourceEntry }
505
TBitmapResourceEntry.GetFileSizenull506 function TBitmapResourceEntry.GetFileSize: int64;
507 begin
508 result := sizeof(TBitMapFileHeader)+FDataStream.Size;
509 end;
510
TBitmapResourceEntry.GetExtensionnull511 function TBitmapResourceEntry.GetExtension: utf8string;
512 begin
513 Result:= 'bmp';
514 end;
515
516 constructor TBitmapResourceEntry.Create(AContainer: TMultiFileContainer;
517 AEntryNameOrId: TNameOrId; const AResourceInfo: TResourceInfo;
518 ADataStream: TStream);
519 begin
520 inherited Create(AContainer, NameOrId(RT_BITMAP), AEntryNameOrId, AResourceInfo, ADataStream);
521 end;
522
TBitmapResourceEntry.CopyTonull523 function TBitmapResourceEntry.CopyTo(ADestination: TStream): int64;
524 var fileHeader: TBitMapFileHeader;
525 begin
526 result := 0;
527 FDataStream.Position := 0;
528 fileHeader := MakeBitmapFileHeader(FDataStream);
529 ADestination.WriteBuffer(fileHeader, sizeof(fileHeader));
530 inc(result, sizeof(fileHeader) );
531 FDataStream.Position := 0;
532 inc(result, ADestination.CopyFrom(FDataStream, FDataStream.Size) );
533 end;
534
535 procedure TBitmapResourceEntry.CopyFrom(ASource: TStream);
536 var
537 fileHeader: TBitMapFileHeader;
538 dataSize: integer;
539 begin
540 ASource.ReadBuffer({%H-}fileHeader, sizeof(fileHeader));
541 if fileHeader.bfType <> Word('BM') then
542 raise exception.Create('Invalid file header');
543 dataSize := LEtoN(fileHeader.bfSize) - sizeof(fileHeader);
544 if ASource.Position + dataSize > ASource.Size then
545 raise exception.Create('Invalid file size');
546
547 FDataStream.Free;
548 FDataStream := TMemoryStream.Create;
549 FDataStream.CopyFrom(ASource, dataSize);
550 end;
551
552 { TUnformattedResourceEntry }
553
TUnformattedResourceEntry.GetFileSizenull554 function TUnformattedResourceEntry.GetFileSize: int64;
555 begin
556 Result:= FDataStream.Size;
557 end;
558
GetDataSizenull559 function TUnformattedResourceEntry.GetDataSize: integer;
560 begin
561 result := FDataStream.Size;
562 end;
563
564 procedure TUnformattedResourceEntry.SerializeData(ADestination: TStream);
565 begin
566 if FDataStream.Size > 0 then
567 begin
568 FDataStream.Position := 0;
569 ADestination.CopyFrom(FDataStream, FDataStream.Size);
570 end;
571 end;
572
TUnformattedResourceEntry.GetExtensionnull573 function TUnformattedResourceEntry.GetExtension: utf8string;
574 var format: TBGRAImageFormat;
575 begin
576 case TypeId of
577 RT_MANIFEST: result := 'manifest';
578 RT_HTML: result := 'html';
579 RT_RCDATA:
580 begin
581 FDataStream.Position:= 0;
582 format := DetectFileFormat(FDataStream);
583 if format = ifUnknown then
584 result := 'dat'
585 else
586 result := SuggestImageExtension(format);
587 end;
588 RT_ANICURSOR: result := 'ani';
589 else
590 if TypeName = 'ANICURSOR' then
591 result := 'ani'
592 else
593 result := '';
594 end;
595 end;
596
597 constructor TUnformattedResourceEntry.Create(AContainer: TMultiFileContainer;
598 ATypeNameOrId: TNameOrId; AEntryNameOrId: TNameOrId;
599 const AResourceInfo: TResourceInfo; ADataStream: TStream);
600 begin
601 inherited Create(AContainer,ATypeNameOrId,AEntryNameOrId,AResourceInfo);
602 FDataStream := ADataStream;
603 end;
604
605 destructor TUnformattedResourceEntry.Destroy;
606 begin
607 FreeAndNil(FDataStream);
608 inherited Destroy;
609 end;
610
CopyTonull611 function TUnformattedResourceEntry.CopyTo(ADestination: TStream): int64;
612 begin
613 if FDataStream.Size > 0 then
614 begin
615 FDataStream.Position := 0;
616 result := ADestination.CopyFrom(FDataStream, FDataStream.Size)
617 end
618 else
619 result := 0;
620 end;
621
GetStreamnull622 function TUnformattedResourceEntry.GetStream: TStream;
623 begin
624 Result:= FDataStream;
625 end;
626
627 { TResourceInfo }
628
629 procedure TResourceInfo.SwapIfNecessary;
630 begin
631 DataVersion := LEtoN(DataVersion);
632 MemoryFlags := LEtoN(MemoryFlags);
633 LanguageId := LEtoN(LanguageId);
634 Version := LEtoN(Version);
635 Characteristics := LEtoN(Characteristics);
636 end;
637
638 { TCustomResourceEntry }
639
TCustomResourceEntry.GetIdnull640 function TCustomResourceEntry.GetId: integer;
641 begin
642 result := FEntryNameOrId.Id;
643 end;
644
GetTypeIdnull645 function TCustomResourceEntry.GetTypeId: integer;
646 begin
647 result := FTypeNameOrId.Id;
648 end;
649
GetDWordnull650 function GetDWord(var ASource: PByte; var ARemainingBytes: Integer): LongWord;
651 begin
652 if ARemainingBytes >= 4 then
653 begin
654 result := LEtoN(PLongWord(ASource)^);
655 inc(ASource, 4);
656 dec(ARemainingBytes, 4);
657 end else
658 begin
659 result := 0;
660 inc(ASource, ARemainingBytes);
661 ARemainingBytes:= 0;
662 end;
663 end;
664
GetWordnull665 function GetWord(var ASource: PByte; var ARemainingBytes: Integer): Word;
666 begin
667 if ARemainingBytes >= 2 then
668 begin
669 result := LEtoN(PWord(ASource)^);
670 inc(ASource, 2);
671 dec(ARemainingBytes, 2);
672 end else
673 begin
674 result := 0;
675 inc(ASource, ARemainingBytes);
676 ARemainingBytes:= 0;
677 end;
678 end;
679
GetNameOrIdnull680 function GetNameOrId(var ASource: PByte; var ARemainingBytes: Integer): TNameOrId;
681 var curChar: Word;
682 pstart: PByte;
683 begin
684 pstart := ASource;
685 curChar := GetWord(ASource,ARemainingBytes);
686 if curChar = $ffff then
687 begin
688 result.Id := GetWord(ASource,ARemainingBytes);
689 result.Name := IntToStr(result.Id);
690 end else
691 begin
692 while curChar <> 0 do
693 curChar := GetWord(ASource,ARemainingBytes);
694 result.Id := -1;
695 result.Name := UTF8Encode(WideCharLenToString(PWideChar(pstart), (ASource-pstart) div 2 -1));
696 end;
697 end;
698
GetLanguageIdnull699 function TCustomResourceEntry.GetLanguageId: integer;
700 begin
701 result := FResourceInfo.LanguageId;
702 end;
703
TCustomResourceEntry.GetNextEntrynull704 class function TCustomResourceEntry.GetNextEntry(AContainer: TMultiFileContainer; AStream: TStream): TCustomResourceEntry;
705 var
706 entrySize, headerSize, remaining, padding: Integer;
707 headerData: Pointer;
708 pHeaderData: PByte;
709 typeNameOrId: TNameOrId;
710 entryNameOrId: TNameOrId;
711 info: TResourceInfo;
712 dataStream: TMemoryStream;
713 dummy: LongWord;
714 begin
715 result := nil;
716 if AStream.Position + 16 < AStream.Size then
717 begin
718 entrySize := LEtoN(AStream.ReadDWord);
719 headerSize := LEtoN(AStream.ReadDWord);
720 if headerSize < 16 then
721 raise exception.Create('Header too small');
722 remaining := ((headerSize-8) + 3) and not 3;
723 if AStream.Position + remaining + entrySize > AStream.Size then
724 raise exception.Create('Data would be outside of stream');
725
726 GetMem(headerData, remaining);
727 try
728 AStream.ReadBuffer(headerData^, remaining);
729 pHeaderData := PByte(headerData);
730 typeNameOrId := GetNameOrId(pHeaderData, remaining);
731 entryNameOrId := GetNameOrId(pHeaderData, remaining);
732 padding := (4 - (PtrUInt(pHeaderData-PByte(headerData)) and 3)) and 3;
733 inc(pHeaderData, padding);
734 dec(remaining, padding);
735
736 FillChar({%H-}info, SizeOf(info), 0);
737 Move(pHeaderData^, info, Min(Sizeof(info), remaining));
738 info.SwapIfNecessary;
739
740 dataStream := TMemoryStream.Create;
741 if entrySize > 0 then dataStream.CopyFrom(AStream, entrySize);
742 padding := ((entrySize+3) and not 3) - entrySize;
743 if padding > 0 then AStream.Read({%H-}dummy, padding);
744 finally
745 FreeMem(headerData);
746 end;
747
748 dataStream.Position := 0;
749 case typeNameOrId.Id of
750 RT_BITMAP: result := TBitmapResourceEntry.Create(AContainer,entryNameOrId,info,dataStream);
751 RT_GROUP_ICON: result := TGroupIconEntry.Create(AContainer,entryNameOrId,info,dataStream);
752 RT_GROUP_CURSOR: result := TGroupCursorEntry.Create(AContainer,entryNameOrId,info,dataStream);
753 else
754 result := TUnformattedResourceEntry.Create(AContainer,typeNameOrId,entryNameOrId,info,dataStream);
755 end;
756 end;
757 end;
758
759 procedure WriteNameOrId(ADestination: TStream; ANameOrId: TNameOrId);
760 var buffer: PUnicodeChar;
761 maxLen,actualLen: integer;
762 begin
763 if ANameOrId.Id < 0 then
764 begin
765 maxLen := length(ANameOrId.Name)*2 + 1;
766 getmem(buffer, maxLen*sizeof(UnicodeChar));
767 try
768 fillchar(buffer^, maxLen*sizeof(UnicodeChar), 0);
769 actualLen := Utf8ToUnicode(buffer, maxLen, @ANameOrId.Name[1], length(ANameOrId.Name));
770 ADestination.WriteBuffer(buffer^, actualLen*sizeof(UnicodeChar));
771 finally
772 freemem(buffer);
773 end;
774 end else
775 begin
776 ADestination.WriteWord($ffff);
777 ADestination.WriteWord(NtoLE(Word(ANameOrId.Id)));
778 end;
779 end;
780
781 procedure TCustomResourceEntry.Serialize(ADestination: TStream);
782 var zero: LongWord;
783 padding: integer;
784 begin
785 SerializeHeader(ADestination);
786 SerializeData(ADestination);
787 padding := (4-(GetDataSize and 3)) and 3;
788 if padding > 0 then
789 begin
790 zero := 0;
791 ADestination.WriteBuffer(zero, padding);
792 end;
793 end;
794
795 procedure TCustomResourceEntry.SetLanguageId(AValue: integer);
796 begin
797 if (AValue >= 0) and (AValue <= 65535) then
798 begin
799 if AValue = LanguageId then exit;
800 if FTypeNameOrId.Id >= 0 then
801 begin
802 if TWinResourceContainer(Container).InternalFind(FEntryNameOrId, FTypeNameOrId, AValue) <> nil then
803 raise exception.Create('Language id already used for this resource');
804 end else
805 raise exception.Create('Language id cannot be specified for custom types');
806 FEntryNameOrId.Id := AValue;
807 FEntryNameOrId.Name := IntToStr(AValue);
808 end
809 else
810 raise ERangeError.Create('Id out of bounds');
811 end;
812
813 procedure TCustomResourceEntry.SerializeHeader(ADestination: TStream);
814 var
815 entryHeader: record
816 EntrySize: integer;
817 HeaderSize: integer;
818 end;
819 headerStream: TMemoryStream;
820 begin
821 entryHeader.EntrySize := LEtoN(GetDataSize);
822 headerStream := TMemoryStream.Create;
823 try
824 WriteNameOrId(headerStream,FTypeNameOrId);
825 WriteNameOrId(headerStream,FEntryNameOrId);
826 if headerStream.Position and 3 = 2 then headerStream.WriteWord(0);
827 FResourceInfo.SwapIfNecessary;
828 try
829 headerStream.WriteBuffer(FResourceInfo, sizeof(FResourceInfo));
830 finally
831 FResourceInfo.SwapIfNecessary;
832 end;
833 entryHeader.HeaderSize := LEtoN(integer(headerStream.Size+8));
834 headerStream.Position:= 0;
835 ADestination.WriteBuffer(entryHeader, sizeof(entryHeader));
836 ADestination.CopyFrom(headerStream, headerStream.Size);
837 if headerStream.Size and 3 = 2 then ADestination.WriteWord(0);
838 finally
839 headerStream.Free;
840 end;
841 end;
842
843 constructor TCustomResourceEntry.Create(AContainer: TMultiFileContainer;
844 ATypeNameOrId: TNameOrId; AEntryNameOrId: TNameOrId;
845 const AResourceInfo: TResourceInfo);
846 begin
847 inherited Create(AContainer);
848 FTypeNameOrId := ATypeNameOrId;
849 FEntryNameOrId := AEntryNameOrId;
850 FResourceInfo := AResourceInfo;
851 end;
852
TCustomResourceEntry.GetStreamnull853 function TCustomResourceEntry.GetStream: TStream;
854 begin
855 result := nil;
856 raise exception.Create('Stream not available');
857 end;
858
859 procedure TCustomResourceEntry.SetId(AValue: integer);
860 begin
861 if (AValue >= 0) and (AValue <= 65535) then
862 begin
863 if AValue = FEntryNameOrId.Id then exit;
864 if TWinResourceContainer(Container).InternalFind(NameOrId(AValue), FTypeNameOrId, LanguageId) <> nil then
865 raise exception.Create('Id already used for this resource type');
866 FEntryNameOrId.Id := AValue;
867 FEntryNameOrId.Name := IntToStr(AValue);
868 end
869 else
870 raise ERangeError.Create('Id out of bounds');
871 end;
872
TCustomResourceEntry.GetNamenull873 function TCustomResourceEntry.GetName: utf8string;
874 begin
875 Result:= FEntryNameOrId.Name;
876 end;
877
878 procedure TCustomResourceEntry.SetName(AValue: utf8string);
879 begin
880 if FEntryNameOrId = NameOrId(AValue) then exit;
881 if TWinResourceContainer(Container).InternalFind(NameOrId(AValue), FTypeNameOrId, LanguageId) <> nil then
882 raise exception.Create('Name already used for this resource type');
883 FEntryNameOrId.Name := AValue;
884 FEntryNameOrId.Id := -1;
885 end;
886
TCustomResourceEntry.GetTypeNamenull887 function TCustomResourceEntry.GetTypeName: utf8string;
888 begin
889 result := FTypeNameOrId.Name;
890 end;
891
892 procedure TCustomResourceEntry.IncrementReferences;
893 begin
894 //nothing
895 end;
896
897 procedure TCustomResourceEntry.DecrementReferences;
898 begin
899 //nothing
900 end;
901
902 { TWinResourceContainer }
903
904 procedure TWinResourceContainer.LoadFromStream(AStream: TStream);
905 var curEntry: TCustomResourceEntry;
906 i: Integer;
907 begin
908 Clear;
909 repeat
910 curEntry := TCustomResourceEntry.GetNextEntry(self, AStream);
911 if curEntry <> nil then
912 begin
913 if curEntry.TypeId in [RT_ICON,RT_CURSOR] then
914 FHiddenEntries.Add(curEntry)
915 else
916 AddEntry(curEntry);
917 end;
918 until curEntry = nil;
919 for i := 0 to Count-1 do
920 TCustomResourceEntry(Entry[i]).IncrementReferences;
921 end;
922
IndexOfnull923 function TWinResourceContainer.IndexOf(AName: utf8string; AExtenstion: utf8string; ACaseSensitive: boolean): integer;
924 begin
925 result := IndexOf(AName, AExtenstion, 0, ACaseSensitive);
926 end;
927
IndexOfnull928 function TWinResourceContainer.IndexOf(AName: utf8string; AExtenstion: utf8string;
929 ALanguageId: integer; ACaseSensitive: boolean): integer;
930 var
931 i: Integer;
932 entryId, errPos: integer;
933 begin
934 if AExtenstion = '' then
935 begin
936 result := -1;
937 exit;
938 end;
939 if ACaseSensitive then
940 begin
941 for i := 0 to Count-1 do
942 if (TCustomResourceEntry(Entry[i]).FEntryNameOrId.Id < 0) and
943 (TCustomResourceEntry(Entry[i]).FEntryNameOrId.Name = AName) and
944 (UTF8CompareText(Entry[i].Extension,AExtenstion) = 0) and
945 (TCustomResourceEntry(Entry[i]).LanguageId = ALanguageId) then
946 begin
947 result := i;
948 exit;
949 end;
950 end else
951 for i := 0 to Count-1 do
952 if (TCustomResourceEntry(Entry[i]).FEntryNameOrId.Id < 0) and
953 (UTF8CompareText(TCustomResourceEntry(Entry[i]).FEntryNameOrId.Name,AName) = 0) and
954 (UTF8CompareText(Entry[i].Extension,AExtenstion) = 0) and
955 (TCustomResourceEntry(Entry[i]).LanguageId = ALanguageId) then
956 begin
957 result := i;
958 exit;
959 end;
960 val(AName, entryId, errPos);
961 if (errPos = 0) and (entryId >= 0) then
962 begin
963 for i := 0 to Count-1 do
964 if (TCustomResourceEntry(Entry[i]).FEntryNameOrId.Id = entryId) and
965 (UTF8CompareText(Entry[i].Extension,AExtenstion) = 0) and
966 (TCustomResourceEntry(Entry[i]).LanguageId = ALanguageId) then
967 begin
968 result := i;
969 exit;
970 end;
971 end;
972 result := -1;
973 end;
974
975 procedure TWinResourceContainer.Init;
976 begin
977 inherited Init;
978 FHiddenEntries := TMultiFileEntryList.Create;
979 end;
980
981 procedure TWinResourceContainer.ClearHiddenEntries;
982 var i: integer;
983 begin
984 if Assigned(FHiddenEntries) then
985 begin
986 for i := 0 to FHiddenEntries.Count-1 do
987 FHiddenEntries[i].Free;
988 FHiddenEntries.Clear;
989 end;
990 end;
991
992 procedure TWinResourceContainer.RemoveHidden(AEntry: TCustomResourceEntry);
993 var
994 index: LongInt;
995 begin
996 if Assigned(FHiddenEntries) then
997 begin
998 index := FHiddenEntries.IndexOf(AEntry);
999 if index <> -1 then
1000 begin
1001 AEntry.Free;
1002 FHiddenEntries.Delete(index);
1003 end;
1004 end;
1005 end;
1006
TWinResourceContainer.CreateEntrynull1007 function TWinResourceContainer.CreateEntry(AName: utf8string; AExtension: utf8string;
1008 AContent: TStream; ALanguageId: integer): TMultiFileEntry;
1009 var
1010 resourceInfo: TResourceInfo;
1011 entryName: TNameOrId;
1012 errPos: integer;
1013 begin
1014 FillChar({%H-}resourceInfo, sizeof(resourceInfo), 0);
1015 resourceInfo.LanguageId := ALanguageId;
1016 val(AName, entryName.Id, errPos);
1017 if (errPos = 0) and (entryName.Id >= 0) then
1018 entryName.Name := IntToStr(entryName.Id)
1019 else
1020 begin
1021 entryName.Id := -1;
1022 entryName.Name := AName;
1023 end;
1024
1025 case UTF8LowerCase(AExtension) of
1026 'ico': begin
1027 result := TGroupIconEntry.Create(self, entryName, resourceInfo);
1028 AContent.Position:= 0;
1029 TGroupIconEntry(result).CopyFrom(AContent);
1030 AContent.Free;
1031 end;
1032 'cur': begin
1033 result := TGroupCursorEntry.Create(self, entryName, resourceInfo);
1034 AContent.Position:= 0;
1035 TGroupCursorEntry(result).CopyFrom(AContent);
1036 AContent.Free;
1037 end;
1038 'bmp': begin
1039 result := TBitmapResourceEntry.Create(self, entryName, resourceInfo, AContent);
1040 AContent.Position:= 0;
1041 TBitmapResourceEntry(result).CopyFrom(AContent);
1042 AContent.Free;
1043 end;
1044 'dat': result := TUnformattedResourceEntry.Create(self, NameOrId(RT_RCDATA), entryName, resourceInfo, AContent);
1045 'html','htm': result := TUnformattedResourceEntry.Create(self, NameOrId(RT_HTML), entryName, resourceInfo, AContent);
1046 'manifest': result := TUnformattedResourceEntry.Create(self, NameOrId(RT_MANIFEST), entryName, resourceInfo, AContent);
1047 'ani': result := TUnformattedResourceEntry.Create(self, NameOrId(RT_ANICURSOR), entryName, resourceInfo, AContent);
1048 else
1049 case SuggestImageFormat('.'+AExtension) of
1050 ifUnknown: raise exception.Create('Unhandled file extension');
1051 else
1052 result := TUnformattedResourceEntry.Create(self, NameOrId(RT_RCDATA), entryName, resourceInfo, AContent);
1053 end;
1054 end;
1055 end;
1056
TWinResourceContainer.CreateEntrynull1057 function TWinResourceContainer.CreateEntry(AName: utf8string; AExtension: utf8string;
1058 AContent: TStream): TMultiFileEntry;
1059 begin
1060 result := CreateEntry(AName, AExtension, AContent, 0);
1061 end;
1062
1063 procedure TWinResourceContainer.Clear;
1064 begin
1065 ClearHiddenEntries;
1066 inherited Clear;
1067 end;
1068
1069 destructor TWinResourceContainer.Destroy;
1070 begin
1071 ClearHiddenEntries;
1072 FreeAndNil(FHiddenEntries);
1073 inherited Destroy;
1074 end;
1075
1076 procedure TWinResourceContainer.Delete(AIndex: integer);
1077 begin
1078 if (AIndex >= 0) and (AIndex < Count) then
1079 TCustomResourceEntry(Entry[AIndex]).DecrementReferences;
1080 inherited Delete(AIndex);
1081 end;
1082
1083 procedure TWinResourceContainer.SaveToStream(ADestination: TStream);
1084 var
1085 i: Integer;
1086 begin
1087 for i := 0 to Count-1 do
1088 TCustomResourceEntry(Entry[i]).Serialize(ADestination);
1089 for i := 0 to FHiddenEntries.Count-1 do
1090 TCustomResourceEntry(FHiddenEntries.Items[i]).Serialize(ADestination);
1091 end;
1092
InternalFindnull1093 function TWinResourceContainer.InternalFind(const AEntry: TNameOrId;
1094 const AType: TNameOrId; ALanguageId: integer): TCustomResourceEntry;
1095 var i: integer;
1096 begin
1097 if Assigned(FHiddenEntries) and (ALanguageId = 0) and (AType.Id >= 0) then
1098 begin
1099 for i := 0 to FHiddenEntries.Count-1 do
1100 if (TCustomResourceEntry(FHiddenEntries.Items[i]).FEntryNameOrId = AEntry) and
1101 (TCustomResourceEntry(FHiddenEntries.Items[i]).FTypeNameOrId = AType) then
1102 begin
1103 result := TCustomResourceEntry(FHiddenEntries.Items[i]);
1104 exit;
1105 end;
1106 end;
1107 for i := 0 to Count-1 do
1108 if (TCustomResourceEntry(Entry[i]).FEntryNameOrId = AEntry) and
1109 (TCustomResourceEntry(Entry[i]).FTypeNameOrId = AType) and
1110 (TCustomResourceEntry(Entry[i]).LanguageId = ALanguageId) then
1111 begin
1112 result := TCustomResourceEntry(Entry[i]);
1113 exit;
1114 end;
1115 result := nil;
1116 end;
1117
1118 procedure TWinResourceContainer.AddHidden(AEntry: TCustomResourceEntry);
1119 begin
1120 FHiddenEntries.Add(AEntry);
1121 end;
1122
TWinResourceContainer.GetMaxIdnull1123 function TWinResourceContainer.GetMaxId(AType: TNameOrId): integer;
1124 var i: integer;
1125 begin
1126 result := 0;
1127 if Assigned(FHiddenEntries) and (AType.Id >= 0) then
1128 begin
1129 for i := 0 to FHiddenEntries.Count-1 do
1130 if (TCustomResourceEntry(FHiddenEntries.Items[i]).FTypeNameOrId = AType) then
1131 begin
1132 if TCustomResourceEntry(FHiddenEntries.Items[i]).Id > result then result := TCustomResourceEntry(FHiddenEntries.Items[i]).Id;
1133 end;
1134 end;
1135 for i := 0 to Count-1 do
1136 if (TCustomResourceEntry(Entry[i]).FTypeNameOrId = AType) then
1137 begin
1138 if TCustomResourceEntry(Entry[i]).Id > result then result := TCustomResourceEntry(Entry[i]).Id;
1139 end;
1140 end;
1141
1142 procedure TWinResourceContainer.IncrementReferenceOf(ANameId, ATypeId: integer);
1143 var
1144 item: TCustomResourceEntry;
1145 begin
1146 item := InternalFind(NameOrId(ANameId), NameOrId(ATypeId));
1147 if Assigned(item) then inc(item.FReferenceCount);
1148 end;
1149
1150 procedure TWinResourceContainer.DecrementReferenceOf(ANameId, ATypeId: integer);
1151 var
1152 item: TCustomResourceEntry;
1153 begin
1154 item := InternalFind(NameOrId(ANameId), NameOrId(ATypeId));
1155 if Assigned(item) then
1156 begin
1157 if item.FReferenceCount > 1 then
1158 dec(item.FReferenceCount)
1159 else
1160 RemoveHidden(item);
1161 end;
1162 end;
1163
1164 end.
1165
1166