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