unit Compiler.ExeUpdateFunc;
{
Inno Setup
Copyright (C) 1997-2026 Jordan Russell
Portions by Martijn Laan
For conditions of distribution and use, see LICENSE.TXT.
PE header and resource update functions used by the compiler only
}
interface
uses
Windows, SysUtils, Shared.FileClass, Shared.VerInfoFunc, Shared.Struct;
type
TUpdateIconsAndStyleFile = (uisfSetup, uisfSetupCustomStyle, uisfSetupLdr);
TUpdateIconsAndStyleOperation = (uisoIcoFileName, uisoWizardDarkStyle, uisoStyleFileName, uisoStyleFileNameDynamicDark, uisoDone);
TOnUpdateIconsAndStyle = procedure(const Operation: TUpdateIconsAndStyleOperation) of object;
EResUpdateError = class(Exception)
private
FErrorCode: DWORD;
public
property ErrorCode: DWORD read FErrorCode;
end;
function ReadSignatureAndChecksumFields(const F: TCustomFile;
var ASignatureAddress, ASignatureSize, AChecksum: DWORD): Boolean;
function SeekToResourceData(const F: TCustomFile; const ResType, ResId: Cardinal): Cardinal;
function UpdateSignatureAndChecksumFields(const F: TCustomFile;
const ASignatureAddress, ASignatureSize, AChecksum: DWORD): Boolean;
procedure UpdateSetupPEHeaderFields(const F: TCustomFile;
const IsTSAware, IsDEPCompatible, IsASLRCompatible: Boolean);
procedure UpdateIconsAndStyle(const FileName: String; const Uisf: TUpdateIconsAndStyleFile; const IcoFileName: String;
const WizardDarkStyle: TSetupWizardDarkStyle; const StyleFileName, StyleFileNameDynamicDark: String;
const OnUpdateIconsAndStyle: TOnUpdateIconsAndStyle);
procedure UpdateVersionInfo(const F: TCustomFile;
const NewBinaryFileVersion, NewBinaryProductVersion: TFileVersionNumbers;
const NewCompanyName, NewFileDescription, NewTextFileVersion, NewLegalCopyright,
NewProductName, NewTextProductVersion, NewOriginalFileName: String;
const SetFileVersionAndDescription: Boolean);
procedure PreventCOMCTL32Sideloading(const F: TCustomFile);
implementation
uses
Math,
UnsignedFunc;
const
IMAGE_NT_SIGNATURE = $00004550;
IMAGE_NT_OPTIONAL_HDR32_MAGIC = $10b;
IMAGE_NT_OPTIONAL_HDR64_MAGIC = $20b;
IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16;
IMAGE_SIZEOF_SHORT_NAME = 8;
IMAGE_DIRECTORY_ENTRY_RESOURCE = 2;
IMAGE_DIRECTORY_ENTRY_SECURITY = 4;
type
PImageFileHeader = ^TImageFileHeader;
TImageFileHeader = packed record
Machine: Word;
NumberOfSections: Word;
TimeDateStamp: DWORD;
PointerToSymbolTable: DWORD;
NumberOfSymbols: DWORD;
SizeOfOptionalHeader: Word;
Characteristics: Word;
end;
PImageDataDirectory = ^TImageDataDirectory;
TImageDataDirectory = record
VirtualAddress: DWORD;
Size: DWORD;
end;
TDataDirectory = packed array[0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES-1] of TImageDataDirectory;
PImageOptionalHeader = ^TImageOptionalHeader;
TImageOptionalHeader = packed record
{ Standard fields. }
Magic: Word;
MajorLinkerVersion: Byte;
MinorLinkerVersion: Byte;
SizeOfCode: DWORD;
SizeOfInitializedData: DWORD;
SizeOfUninitializedData: DWORD;
AddressOfEntryPoint: DWORD;
BaseOfCode: DWORD;
BaseOfData: DWORD;
{ NT additional fields. }
ImageBase: DWORD;
SectionAlignment: DWORD;
FileAlignment: DWORD;
MajorOperatingSystemVersion: Word;
MinorOperatingSystemVersion: Word;
MajorImageVersion: Word;
MinorImageVersion: Word;
MajorSubsystemVersion: Word;
MinorSubsystemVersion: Word;
Win32VersionValue: DWORD;
SizeOfImage: DWORD;
SizeOfHeaders: DWORD;
CheckSum: DWORD;
Subsystem: Word;
DllCharacteristics: Word;
SizeOfStackReserve: DWORD;
SizeOfStackCommit: DWORD;
SizeOfHeapReserve: DWORD;
SizeOfHeapCommit: DWORD;
LoaderFlags: DWORD;
NumberOfRvaAndSizes: DWORD;
DataDirectory: TDataDirectory;
end;
PImageOptionalHeader64 = ^TImageOptionalHeader64;
TImageOptionalHeader64 = packed record
{ Standard fields. }
Magic: Word;
MajorLinkerVersion: Byte;
MinorLinkerVersion: Byte;
SizeOfCode: DWORD;
SizeOfInitializedData: DWORD;
SizeOfUninitializedData: DWORD;
AddressOfEntryPoint: DWORD;
BaseOfCode: DWORD;
{ NT additional fields. }
ImageBase: Int64;
SectionAlignment: DWORD;
FileAlignment: DWORD;
MajorOperatingSystemVersion: Word;
MinorOperatingSystemVersion: Word;
MajorImageVersion: Word;
MinorImageVersion: Word;
MajorSubsystemVersion: Word;
MinorSubsystemVersion: Word;
Win32VersionValue: DWORD;
SizeOfImage: DWORD;
SizeOfHeaders: DWORD;
CheckSum: DWORD;
Subsystem: Word;
DllCharacteristics: Word;
SizeOfStackReserve: Int64;
SizeOfStackCommit: Int64;
SizeOfHeapReserve: Int64;
SizeOfHeapCommit: Int64;
LoaderFlags: DWORD;
NumberOfRvaAndSizes: DWORD;
DataDirectory: TDataDirectory;
end;
TISHMisc = packed record
case Integer of
0: (PhysicalAddress: DWORD);
1: (VirtualSize: DWORD);
end;
PImageSectionHeader = ^TImageSectionHeader;
TImageSectionHeader = packed record
Name: packed array[0..IMAGE_SIZEOF_SHORT_NAME-1] of Byte;
Misc: TISHMisc;
VirtualAddress: DWORD;
SizeOfRawData: DWORD;
PointerToRawData: DWORD;
PointerToRelocations: DWORD;
PointerToLinenumbers: DWORD;
NumberOfRelocations: Word;
NumberOfLinenumbers: Word;
Characteristics: DWORD;
end;
TImageResourceDirectory = packed record
Characteristics: DWORD;
TimeDateStamp: DWORD;
MajorVersion: Word;
MinorVersion: Word;
NumberOfNamedEntries: Word;
NumberOfIdEntries: Word;
end;
TImageResourceDirectoryEntry = packed record
Id: DWORD;
Offset: DWORD;
end;
TImageResourceDataEntry = packed record
OffsetToData: DWORD;
Size: DWORD;
CodePage: DWORD;
Reserved: DWORD;
end;
procedure Error(const Msg: String);
begin
raise Exception.Create('Resource update error: ' + Msg);
end;
function SeekToPEHeader(const F: TCustomFile): Boolean;
var
DosHeader: packed record
Sig: array[0..1] of AnsiChar;
Other: array[0..57] of Byte;
PEHeaderOffset: LongWord;
end;
Sig: DWORD;
begin
Result := False;
F.Seek(0);
if F.Read(DosHeader, SizeOf(DosHeader)) = SizeOf(DosHeader) then begin
if (DosHeader.Sig[0] = 'M') and (DosHeader.Sig[1] = 'Z') and
(DosHeader.PEHeaderOffset <> 0) then begin
F.Seek(DosHeader.PEHeaderOffset);
if F.Read(Sig, SizeOf(Sig)) = SizeOf(Sig) then
if Sig = IMAGE_NT_SIGNATURE then
Result := True;
end;
end;
end;
type
TOptionalHeader = (ohNone, oh32, oh64);
function SeekToAndReadPEOptionalHeader(const F: TCustomFile;
var OptHeader32: TImageOptionalHeader; var OptHeader64: TImageOptionalHeader64;
var OptHeaderOffset: Int64): TOptionalHeader;
begin
Result := ohNone;
if SeekToPEHeader(F) then begin
var Header: TImageFileHeader;
if (F.Read(Header, SizeOf(Header)) = SizeOf(Header)) and
((Header.SizeOfOptionalHeader = SizeOf(OptHeader32)) or
(Header.SizeOfOptionalHeader = SizeOf(OptHeader64))) then begin
OptHeaderOffset := F.Position;
if Header.SizeOfOptionalHeader = SizeOf(OptHeader32) then begin
if (F.Read(OptHeader32, SizeOf(OptHeader32)) = SizeOf(OptHeader32)) and
(OptHeader32.Magic = IMAGE_NT_OPTIONAL_HDR32_MAGIC) then
Result := oh32;
end else begin
if (F.Read(OptHeader64, SizeOf(OptHeader64)) = SizeOf(OptHeader64)) and
(OptHeader64.Magic = IMAGE_NT_OPTIONAL_HDR64_MAGIC) then
Result := oh64;
end;
end;
end;
end;
procedure FindResourceSection(const F: TCustomFile;
var SectionVirtualAddr, SectionPhysOffset, SectionPhysSize: Cardinal);
var
EXESig: Word;
PEHeaderOffset, PESig: Cardinal;
PEHeader: TImageFileHeader;
PEOptHeader: TImageOptionalHeader;
PEOptHeader64: TImageOptionalHeader64;
PESectionHeader: TImageSectionHeader;
I: Integer;
begin
{ Read DOS header }
F.Seek(0);
F.ReadBuffer(EXESig, SizeOf(EXESig));
if EXESig <> $5A4D {'MZ'} then
Error('File isn''t an EXE file (1)');
F.Seek($3C);
F.ReadBuffer(PEHeaderOffset, SizeOf(PEHeaderOffset));
if PEHeaderOffset = 0 then
Error('File isn''t a PE file (1)');
{ Read PE header & optional header }
F.Seek(PEHeaderOffset);
F.ReadBuffer(PESig, SizeOf(PESig));
if PESig <> $00004550 {'PE'#0#0} then
Error('File isn''t a PE file (2)');
F.ReadBuffer(PEHeader, SizeOf(PEHeader));
const PE32 = PEHeader.SizeOfOptionalHeader = SizeOf(PEOptHeader);
const PE32Plus = PEHeader.SizeOfOptionalHeader = SizeOf(PEOptHeader64);
if not PE32 and not PE32Plus then
Error('File isn''t a PE file (3)');
var DataDirectory: TDataDirectory;
if PE32 then begin
F.ReadBuffer(PEOptHeader, SizeOf(PEOptHeader));
if PEOptHeader.Magic <> IMAGE_NT_OPTIONAL_HDR32_MAGIC then
Error('File isn''t a PE file (4)');
DataDirectory := PEOptHeader.DataDirectory;
end else begin
F.ReadBuffer(PEOptHeader64, SizeOf(PEOptHeader64));
if PEOptHeader64.Magic <> IMAGE_NT_OPTIONAL_HDR64_MAGIC then
Error('File isn''t a PE file (5)');
DataDirectory := PEOptHeader64.DataDirectory;
end;
{ Scan section headers for resource section }
if (DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE].VirtualAddress = 0) or
(DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE].Size = 0) then
Error('No resources (1)');
SectionVirtualAddr := DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE].VirtualAddress;
SectionPhysOffset := 0;
for I := 0 to PEHeader.NumberOfSections-1 do begin
F.ReadBuffer(PESectionHeader, SizeOf(PESectionHeader));
if (PESectionHeader.VirtualAddress = SectionVirtualAddr) and
(PESectionHeader.SizeOfRawData <> 0) then begin
SectionPhysOffset := PESectionHeader.PointerToRawData;
SectionPhysSize := PESectionHeader.SizeOfRawData;
Break;
end;
end;
if SectionPhysOffset = 0 then
Error('No resources (2)');
end;
function FindResOffset(const F: TCustomFile; const AnyId: Boolean;
const Id: Cardinal; const FindSubdir: Boolean; var Offset: Cardinal): Boolean;
var
Dir: TImageResourceDirectory;
Entry: TImageResourceDirectoryEntry;
I: Integer;
begin
F.ReadBuffer(Dir, SizeOf(Dir));
{ Skip over named entries }
for I := 0 to Dir.NumberOfNamedEntries-1 do
F.ReadBuffer(Entry, SizeOf(Entry));
{ Now process ID entries }
Result := False;
for I := 0 to Dir.NumberOfIdEntries-1 do begin
F.ReadBuffer(Entry, SizeOf(Entry));
if (AnyId or (Entry.Id = Id)) and
((Entry.Offset and $80000000 <> 0) = FindSubdir) then begin
Offset := Entry.Offset and $7FFFFFFF;
Result := True;
Break;
end;
end;
end;
function SeekToResourceData(const F: TCustomFile; const ResType, ResId: Cardinal): Cardinal;
{ Seeks to the specified resource's data, and returns its size. Raises an
exception if the resource cannot be found. }
var
SectionVirtualAddr, SectionPhysOffset, SectionPhysSize, Ofs: Cardinal;
DataEntry: TImageResourceDataEntry;
begin
FindResourceSection(F, SectionVirtualAddr, SectionPhysOffset, SectionPhysSize);
{ Scan the resource directory }
F.Seek(SectionPhysOffset);
if not FindResOffset(F, False, ResType, True, Ofs) then
Error('Can''t find resource (1)');
F.Seek(SectionPhysOffset + Ofs);
if not FindResOffset(F, False, ResId, True, Ofs) then
Error('Can''t find resource (2)');
F.Seek(SectionPhysOffset + Ofs);
if not FindResOffset(F, True, 0, False, Ofs) then
Error('Can''t find resource (3).');
F.Seek(SectionPhysOffset + Ofs);
F.ReadBuffer(DataEntry, SizeOf(DataEntry));
{ Sanity check: DataEntry.OffsetToData is an RVA. It's technically possible
for the RVA to point to a different section, but we don't support that. }
if Cardinal(DataEntry.OffsetToData) < SectionVirtualAddr then
Error('Invalid resource (1)');
if Cardinal(DataEntry.OffsetToData - SectionVirtualAddr + DataEntry.Size) > SectionPhysSize then
Error('Invalid resource (2)');
{ Seek to the resource }
F.Seek(SectionPhysOffset + (DataEntry.OffsetToData - SectionVirtualAddr));
Result := DataEntry.Size;
end;
function ReadSignatureAndChecksumFields(const F: TCustomFile;
var ASignatureAddress, ASignatureSize, AChecksum: DWORD): Boolean;
{ Reads the signature and checksum fields in the specified file's header.
If the file is not a valid PE32 or PE32+ executable, False is returned. }
begin
var OptHeader32: TImageOptionalHeader;
var OptHeader64: TImageOptionalHeader64;
var OptHeaderOffset: Int64;
const OptHeader = SeekToAndReadPEOptionalHeader(F, OptHeader32, OptHeader64, OptHeaderOffset);
Result := OptHeader <> ohNone;
if Result then begin
if OptHeader = oh32 then begin
ASignatureAddress := OptHeader32.DataDirectory[IMAGE_DIRECTORY_ENTRY_SECURITY].VirtualAddress;
ASignatureSize := OptHeader32.DataDirectory[IMAGE_DIRECTORY_ENTRY_SECURITY].Size;
AChecksum := OptHeader32.CheckSum;
end else begin
ASignatureAddress := OptHeader64.DataDirectory[IMAGE_DIRECTORY_ENTRY_SECURITY].VirtualAddress;
ASignatureSize := OptHeader64.DataDirectory[IMAGE_DIRECTORY_ENTRY_SECURITY].Size;
AChecksum := OptHeader64.CheckSum;
end;
end;
end;
function UpdateSignatureAndChecksumFields(const F: TCustomFile;
const ASignatureAddress, ASignatureSize, AChecksum: DWORD): Boolean;
{ Sets the signature and checksum fields in the specified file's header.
If the file is not a valid PE32 or PE32+ executable, False is returned. }
begin
var OptHeader32: TImageOptionalHeader;
var OptHeader64: TImageOptionalHeader64;
var OptHeaderOffset: Int64;
const OptHeader = SeekToAndReadPEOptionalHeader(F, OptHeader32, OptHeader64, OptHeaderOffset);
Result := OptHeader <> ohNone;
if Result then begin
F.Seek(OptHeaderOffset);
if OptHeader = oh32 then begin
OptHeader32.DataDirectory[IMAGE_DIRECTORY_ENTRY_SECURITY].VirtualAddress := ASignatureAddress;
OptHeader32.DataDirectory[IMAGE_DIRECTORY_ENTRY_SECURITY].Size := ASignatureSize;
OptHeader32.CheckSum := AChecksum;
F.WriteBuffer(OptHeader32, SizeOf(OptHeader32));
end else begin
OptHeader64.DataDirectory[IMAGE_DIRECTORY_ENTRY_SECURITY].VirtualAddress := ASignatureAddress;
OptHeader64.DataDirectory[IMAGE_DIRECTORY_ENTRY_SECURITY].Size := ASignatureSize;
OptHeader64.CheckSum := AChecksum;
F.WriteBuffer(OptHeader64, SizeOf(OptHeader64));
end;
end;
end;
procedure UpdateSetupPEHeaderFields(const F: TCustomFile;
const IsTSAware, IsDEPCompatible, IsASLRCompatible: Boolean);
const
IMAGE_DLLCHARACTERISTICS_HIGH_ENTROPY_VA = $0020;
IMAGE_DLLCHARACTERISTICS_DYNAMIC_BASE = $0040;
IMAGE_DLLCHARACTERISTICS_NX_COMPAT = $0100;
IMAGE_DLLCHARACTERISTICS_TERMINAL_SERVER_AWARE = $8000;
OffsetOfDllCharacteristics = $46; { Valid for both PE32 and PE32+ }
var
Header: TImageFileHeader;
OptMagic, DllChars, OrigDllChars: Word;
begin
if SeekToPEHeader(F) then begin
if (F.Read(Header, SizeOf(Header)) = SizeOf(Header)) then begin
const PE32 = Header.SizeOfOptionalHeader = SizeOf(TImageOptionalHeader);
const PE32Plus = Header.SizeOfOptionalHeader = SizeOf(TImageOptionalHeader64);
if PE32 or PE32Plus then begin
const Ofs = F.Position;
if (F.Read(OptMagic, SizeOf(OptMagic)) = SizeOf(OptMagic)) and
((PE32 and (OptMagic = IMAGE_NT_OPTIONAL_HDR32_MAGIC)) or
(PE32Plus and (OptMagic = IMAGE_NT_OPTIONAL_HDR64_MAGIC))) then begin
{ Update DllCharacteristics }
F.Seek(Ofs + OffsetOfDllCharacteristics);
if F.Read(DllChars, SizeOf(DllChars)) = SizeOf(DllChars) then begin
OrigDllChars := DllChars;
if IsTSAware then
DllChars := DllChars or IMAGE_DLLCHARACTERISTICS_TERMINAL_SERVER_AWARE
else
DllChars := Word(DllChars and not IMAGE_DLLCHARACTERISTICS_TERMINAL_SERVER_AWARE);
if IsDEPCompatible then
DllChars := DllChars or IMAGE_DLLCHARACTERISTICS_NX_COMPAT
else
DllChars := Word(DllChars and not IMAGE_DLLCHARACTERISTICS_NX_COMPAT);
var ASLRFlags: Word := IMAGE_DLLCHARACTERISTICS_DYNAMIC_BASE;
if Header.Machine = IMAGE_FILE_MACHINE_AMD64 then
ASLRFlags := ASLRFlags or IMAGE_DLLCHARACTERISTICS_HIGH_ENTROPY_VA;
if IsASLRCompatible then
DllChars := DllChars or ASLRFlags
else
DllChars := DllChars and not ASLRFlags;
if DllChars <> OrigDllChars then begin
F.Seek(Ofs + OffsetOfDllCharacteristics);
F.WriteBuffer(DllChars, SizeOf(DllChars));
end;
Exit;
end;
end;
end;
end;
end;
raise Exception.Create('UpdateSetupPEHeaderFields failed');
end;
procedure ResUpdateError(const Msg: String; const ResourceName: String = ''; const ErrorCode: DWORD = ERROR_INVALID_DATA);
begin
var S: String;
if ResourceName <> '' then
S := Format('Resource %s update error: %s', [ResourceName, Msg])
else
S := Format('Resource update error: %s', [Msg]);
const E = EResUpdateError.Create(S);
E.FErrorCode := ErrorCode;
raise E;
end;
procedure ResUpdateErrorWithLastError(const Msg: String; const ResourceName: String = '');
begin
const ErrorCode = GetLastError;
ResUpdateError(Msg + ' (' + IntToStr(ErrorCode) + ')', ResourceName, ErrorCode);
end;
procedure UpdateVersionInfo(const F: TCustomFile;
const NewBinaryFileVersion, NewBinaryProductVersion: TFileVersionNumbers;
const NewCompanyName, NewFileDescription, NewTextFileVersion, NewLegalCopyright,
NewProductName, NewTextProductVersion, NewOriginalFileName: String;
const SetFileVersionAndDescription: Boolean);
function WideStrsEqual(P1, P2: PWideChar): Boolean;
function WideUpCase(C: WideChar): WideChar;
begin
Result := C;
if (Result >= 'a') and (Result <= 'z') then
Dec(Result, Ord('a') - Ord('A'));
end;
begin
while True do begin
if WideUpCase(P1^) <> WideUpCase(P2^) then begin
Result := False;
Exit;
end;
if P1^ = #0 then
Break;
Inc(P1);
Inc(P2);
end;
Result := True;
end;
procedure BumpToDWordBoundary(var P: Pointer);
begin
if NativeUInt(P) and 3 <> 0 then
NativeUInt(P) := (NativeUInt(P) or 3) + 1;
end;
function QueryValue(P: Pointer; Path: PWideChar; var Buf: Pointer;
var BufLen: Cardinal): Boolean;
var
EndP: Pointer;
ValueLength: Cardinal;
begin
Result := False;
EndP := PByte(P) + PWord(P)^;
Inc(PWord(P));
ValueLength := PWord(P)^;
Inc(PWord(P));
Inc(PWord(P));
if WideStrsEqual(PWideChar(P), Path) then begin
Inc(PWideChar(P), lstrlenW(P) + 1);
BumpToDWordBoundary(P);
Inc(Path, lstrlenW(Path) + 1);
if Path^ = #0 then begin
{ Found the requested value }
Buf := P;
BufLen := ValueLength;
Result := True;
end
else begin
{ Handle children.
Note: Like VerQueryValue, we always treat ValueLength as a byte count
when looking for child nodes. Many resource compilers, including
Borland's, wrongly set ValueLength to a *character* count on string
nodes. But since we never try to query for a child of a string node,
that doesn't matter here. }
Inc(PByte(P), ValueLength);
BumpToDWordBoundary(P);
while PByte(P) < PByte(EndP) do begin
Result := QueryValue(P, Path, Buf, BufLen);
if Result then
Exit;
Inc(PByte(P), PWord(P)^);
BumpToDWordBoundary(P);
end;
end;
end;
end;
procedure ReplaceWithRealCopyrightSymbols(const Value: PWideChar);
var
Len, I, J: Integer;
begin
Len := lstrlenW(Value);
for I := 0 to Len-3 do begin
if (Value[I] = '(') and (Value[I+1] = 'C') and (Value[I+2] = ')') then begin
Value[I] := WideChar($00A9);
{ Shift back two characters }
for J := I+1 to Len-3 do
Value[J] := Value[J+2];
Value[Len-2] := ' ';
Value[Len-1] := ' ';
end;
end;
end;
procedure UpdateStringValue(P: Pointer; const Path: PWideChar; NewValue: String);
var
Value: PWideChar;
ValueLen: Cardinal;
begin
if not QueryValue(P, Path, Pointer(Value), ValueLen) then
ResUpdateError('Unexpected version resource format (1)');
Move(Pointer(NewValue)^, Value^, (Min(Length(NewValue), lstrlenW(Value)))*SizeOf(Char));
ReplaceWithRealCopyrightSymbols(Value);
end;
procedure UpdateFixedFileInfo(P: Pointer; const Path: PWideChar;
const NewFileVersion, NewProductVersion: TFileVersionNumbers;
const SetFileVersion: Boolean);
var
FixedFileInfo: PVSFixedFileInfo;
ValueLen: Cardinal;
begin
if not QueryValue(P, Path, Pointer(FixedFileInfo), ValueLen) then
ResUpdateError('Unexpected version resource format (2)');
if FixedFileInfo.dwSignature <> $FEEF04BD then
ResUpdateError('Unexpected version resource format (3)');
if SetFileVersion then begin
FixedFileInfo.dwFileVersionLS := NewFileVersion.LS;
FixedFileInfo.dwFileVersionMS := NewFileVersion.MS;
end;
FixedFileInfo.dwProductVersionLS := NewProductVersion.LS;
FixedFileInfo.dwProductVersionMS := NewProductVersion.MS;
end;
var
ResSize: Cardinal;
VersRes: Pointer;
begin
{ Locate the resource }
ResSize := SeekToResourceData(F, Cardinal(RT_VERSION), 1);
const ResOffset = F.Position;
GetMem(VersRes, ResSize);
try
{ Read the resource }
F.ReadBuffer(VersRes^, ResSize);
{ Update the resource }
UpdateStringValue(VersRes, 'VS_VERSION_INFO'#0'StringFileInfo'#0'000004b0'#0'CompanyName'#0, NewCompanyName);
if SetFileVersionAndDescription then begin
UpdateStringValue(VersRes, 'VS_VERSION_INFO'#0'StringFileInfo'#0'000004b0'#0'FileDescription'#0, NewFileDescription);
UpdateStringValue(VersRes, 'VS_VERSION_INFO'#0'StringFileInfo'#0'000004b0'#0'FileVersion'#0, NewTextFileVersion);
end;
UpdateStringValue(VersRes, 'VS_VERSION_INFO'#0'StringFileInfo'#0'000004b0'#0'LegalCopyright'#0, NewLegalCopyright);
UpdateStringValue(VersRes, 'VS_VERSION_INFO'#0'StringFileInfo'#0'000004b0'#0'ProductName'#0, NewProductName);
UpdateStringValue(VersRes, 'VS_VERSION_INFO'#0'StringFileInfo'#0'000004b0'#0'OriginalFileName'#0, NewOriginalFileName);
UpdateStringValue(VersRes, 'VS_VERSION_INFO'#0'StringFileInfo'#0'000004b0'#0'ProductVersion'#0, NewTextProductVersion);
UpdateFixedFileInfo(VersRes, 'VS_VERSION_INFO'#0, NewBinaryFileVersion, NewBinaryProductVersion, SetFileVersionAndDescription);
{ Write the updated resource }
F.Seek(ResOffset);
F.WriteBuffer(VersRes^, ResSize);
finally
FreeMem(VersRes);
end;
end;
function EnumLangsFunc(M: HMODULE; lpType, lpName: PAnsiChar; wLanguage: Word; lParam: IntPtr): BOOL; stdcall;
begin
PWord(lParam)^ := wLanguage;
Result := False;
end;
function GetResourceLanguage(M: HMODULE; lpType, lpName: PChar; var wLanguage: Word): Boolean;
begin
wLanguage := 0;
EnumResourceLanguages(M, lpType, lpName, @EnumLangsFunc, IntPtr(@wLanguage));
Result := True;
end;
procedure UpdateIconsAndStyle(const FileName: String; const Uisf: TUpdateIconsAndStyleFile; const IcoFileName: String;
const WizardDarkStyle: TSetupWizardDarkStyle; const StyleFileName, StyleFileNameDynamicDark: String;
const OnUpdateIconsAndStyle: TOnUpdateIconsAndStyle);
type
PIcoItemHeader = ^TIcoItemHeader;
TIcoItemHeader = packed record
Width: Byte;
Height: Byte;
Colors: Byte;
Reserved: Byte;
Planes: Word;
BitCount: Word;
ImageSize: DWORD;
end;
PIcoItem = ^TIcoItem;
TIcoItem = packed record
Header: TIcoItemHeader;
Offset: DWORD;
end;
PIcoHeader = ^TIcoHeader;
TIcoHeader = packed record
Reserved: Word;
Typ: Word;
ItemCount: Word;
Items: array [0..MaxInt shr 4 - 1] of TIcoItem;
end;
PGroupIconDirItem = ^TGroupIconDirItem;
TGroupIconDirItem = packed record
Header: TIcoItemHeader;
Id: Word;
end;
PGroupIconDir = ^TGroupIconDir;
TGroupIconDir = packed record
Reserved: Word;
Typ: Word;
ItemCount: Word;
Items: array [0..MaxInt shr 4 - 1] of TGroupIconDirItem;
end;
procedure TriggerOnUpdateIconsAndStyle(const Operation: TUpdateIconsAndStyleOperation);
begin
if Assigned(OnUpdateIconsAndStyle) then
OnUpdateIconsAndStyle(Operation);
end;
function LoadFileIntoMemory(const FileName: String; var P: Pointer): Cardinal;
begin
const F = TFile.Create(FileName, fdOpenExisting, faRead, fsRead);
try
const N = F.CappedSize;
if Cardinal(N) > Cardinal($100000) then { sanity check }
ResUpdateError('File is too large', '', ERROR_INVALID_PARAMETER);
GetMem(P, N);
F.ReadBuffer(P^, N);
Result := N;
finally
F.Free;
end;
end;
function IsValidIcon(P: Pointer; Size: Cardinal): Boolean;
var
ItemCount: Cardinal;
begin
Result := False;
if Size < Cardinal(SizeOf(Word) * 3) then
Exit;
if (PChar(P)[0] = 'M') and (PChar(P)[1] = 'Z') then
Exit;
ItemCount := PIcoHeader(P).ItemCount;
if Size < Cardinal((SizeOf(Word) * 3) + (ItemCount * SizeOf(TIcoItem))) then
Exit;
P := @PIcoHeader(P).Items;
while ItemCount > Cardinal(0) do begin
if (Cardinal(PIcoItem(P).Offset + PIcoItem(P).Header.ImageSize) < Cardinal(PIcoItem(P).Offset)) or
(Cardinal(PIcoItem(P).Offset + PIcoItem(P).Header.ImageSize) > Cardinal(Size)) then
Exit;
Inc(PIcoItem(P));
Dec(ItemCount);
end;
Result := True;
end;
function LoadResourcePointer(const M: HMODULE; const ResourceType, ResourceName: PChar;
const WantSize: Boolean; out Size: DWORD): Pointer; overload;
begin
var R := FindResource(M, ResourceName, ResourceType);
if R = 0 then
ResUpdateErrorWithLastError('FindResource failed (1)', ResourceName);
if WantSize then begin
Size := SizeofResource(M, R);
if Size = 0 then
ResUpdateErrorWithLastError('SizeofResource failed (1)', ResourceName);
end;
var Res := LoadResource(M, R);
if Res = 0 then
ResUpdateErrorWithLastError('LoadResource failed (1)', ResourceName);
Result := LockResource(Res);
if Result = nil then
ResUpdateErrorWithLastError('LockResource failed (1)', ResourceName);
end;
function LoadResourcePointer(const M: HMODULE; const ResourceType, ResourceName: PChar): Pointer; overload;
begin
var Dummy: DWORD;
Result := LoadResourcePointer(M, ResourceType, ResourceName, False, Dummy);
end;
procedure DeleteResource(const H: THandle; const M: HMODULE; const ResourceType, ResourceName: PChar);
var
wLanguage: Word;
begin
if not GetResourceLanguage(M, ResourceType, ResourceName, wLanguage) then
ResUpdateError('GetResourceLanguage failed (1)', ResourceName);
if not UpdateResource(H, ResourceType, ResourceName, wLanguage, nil, 0) then
ResUpdateErrorWithLastError('UpdateResource failed (1)', ResourceName);
end;
procedure RenameResource(const H: THandle; const M: HMODULE; const ResourceType, OldResourceName, NewResourceName: PChar);
var
Size: DWORD;
P: Pointer;
wLanguage: Word;
begin
{ Load the resource }
P := LoadResourcePointer(M, ResourceType, OldResourceName, True, Size);
{ Create a copy resource with the new name }
if not GetResourceLanguage(M, ResourceType, OldResourceName, wLanguage) then
ResUpdateError('GetResourceLanguage failed (2)', OldResourceName);
if not UpdateResource(H, ResourceType, NewResourceName, wLanguage, P, Size) then
ResUpdateErrorWithLastError('UpdateResource failed (2)', NewResourceName);
{ Delete the old resource }
if not UpdateResource(H, ResourceType, OldResourceName, wLanguage, nil, 0) then
ResUpdateErrorWithLastError('UpdateResource failed (3)', OldResourceName);
end;
function DeleteIcon(const H: THandle; const M: HMODULE; const ResourceName: PChar): PGroupIconDir;
var
GroupIconDir: PGroupIconDir;
I: Integer;
wLanguage: Word;
begin
{ Load the group icon resource }
GroupIconDir := LoadResourcePointer(M, RT_GROUP_ICON, ResourceName);
{ Delete the group icon resource }
DeleteResource(H, M, RT_GROUP_ICON, ResourceName);
{ Delete the icon resources that belonged to the group }
for I := 0 to GroupIconDir.ItemCount-1 do begin
if not GetResourceLanguage(M, RT_ICON, MakeIntResource(GroupIconDir.Items[I].Id), wLanguage) then
ResUpdateError('GetResourceLanguage failed (3)', ResourceName);
if not UpdateResource(H, RT_ICON, MakeIntResource(GroupIconDir.Items[I].Id), wLanguage, nil, 0) then
ResUpdateErrorWithLastError('UpdateResource failed (4)', ResourceName);
end;
Result := GroupIconDir;
end;
function DeleteIconIfExists(const H: THandle; const M: HMODULE; const ResourceName: PChar): PGroupIconDir;
begin
if FindResource(M, ResourceName, RT_GROUP_ICON) <> 0 then
Result := DeleteIcon(H, M, ResourceName)
else
Result := nil;
end;
function RenameIconWithOverwrite(const H: THandle; const M: HMODULE; const OldResourceName, NewResourceName: PChar): PGroupIconDir;
var
GroupIconDir: PGroupIconDir;
GroupIconDirSize: DWORD;
wLanguage: Word;
begin
DeleteIconIfExists(H, M, NewResourceName);
{ Load the group icon resource }
GroupIconDir := LoadResourcePointer(M, RT_GROUP_ICON, OldResourceName);
GroupIconDirSize := Sizeof(Word)*3 + GroupIconDir.ItemCount*Sizeof(TGroupIconDirItem);
{ Create a copy group icon resource with the new name - existing icon resources will belong to
it automatically }
if not GetResourceLanguage(M, RT_GROUP_ICON, OldResourceName, wLanguage) then
ResUpdateError('GetResourceLanguage failed (4)', OldResourceName);
if not UpdateResource(H, RT_GROUP_ICON, NewResourceName, wLanguage, GroupIconDir, GroupIconDirSize) then
ResUpdateErrorWithLastError('UpdateResource failed (5)', NewResourceName);
{ Delete the old group icon resource }
if not UpdateResource(H, RT_GROUP_ICON, OldResourceName, wLanguage, nil, 0) then
ResUpdateErrorWithLastError('UpdateResource failed (6)', OldResourceName);
Result := GroupIconDir;
end;
function HandleBuiltinStyle(const M: HMODULE; const StyleFileName: String; var Vsf: Pointer; var VsfSize: Cardinal; const Dark: Boolean): Boolean;
begin
{ Also see DeleteResource calls below }
var StyleName: PChar := nil;
if SameText(StyleFileName, 'builtin:polar') then begin
if Dark then
StyleName := 'WINDOWSPOLARDARK'
else
StyleName := 'WINDOWSPOLARLIGHT';
end else if SameText(StyleFileName, 'builtin:windows11') then begin
if Dark then
StyleName := 'WINDOWSMODERNDARK'
else
StyleName := 'WINDOWSMODERNLIGHT';
end else if SameText(StyleFileName, 'builtin:slate') then
StyleName := 'SLATECLASSICO'
else if SameText(StyleFileName, 'builtin:zircon') then
StyleName := 'ZIRCON';
Result := StyleName <> nil;
if Result then
Vsf := LoadResourcePointer(M, 'VCLSTYLE', StyleName, True, VsfSize)
end;
var
H: THandle;
M: HMODULE;
OldGroupIconDir, NewGroupIconDir: PGroupIconDir;
I: Integer;
begin
var Ico: PIcoHeader := nil;
var Vsf := nil;
var ShouldFreeVsf := False;
var VsfDynamicDark := nil;
var ShouldFreeVsfDynamicDark := False;
try
if IcoFileName <> '' then begin
TriggerOnUpdateIconsAndStyle(uisoIcoFileName);
{ Load the icons }
var P: Pointer;
const IcoSize = LoadFileIntoMemory(IcoFileName, P);
Ico := P;
{ Ensure the icon is valid }
if not IsValidIcon(Ico, IcoSize) then
ResUpdateError('Icon file is invalid', '', ERROR_INVALID_PARAMETER);
end;
{ Update the resources }
var ChangedMainIcon := False;
H := BeginUpdateResource(PChar(FileName), False);
if H = 0 then
ResUpdateErrorWithLastError('BeginUpdateResource failed (1)');
try
M := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);
if M = 0 then
ResUpdateErrorWithLastError('LoadLibraryEx failed (1)');
try
{ Load the styles. Could be checked using TStyleManager.IsValidStyle but that requires using VCL units. }
var VsfSize: Cardinal := 0;
if StyleFileName <> '' then begin
TriggerOnUpdateIconsAndStyle(uisoStyleFileName);
if not HandleBuiltinStyle(M, StyleFileName, Vsf, VsfSize, WizardDarkStyle = wdsDark) then begin
VsfSize := LoadFileIntoMemory(StyleFileName, Vsf);
ShouldFreeVsf := True;
end;
end;
var VsfSizeDynamicDark: Cardinal := 0;
if StyleFileNameDynamicDark <> '' then begin
TriggerOnUpdateIconsAndStyle(uisoStyleFileNameDynamicDark);
if not HandleBuiltinStyle(M, StyleFileNameDynamicDark, VsfDynamicDark, VsfSizeDynamicDark, True) then begin
VsfSizeDynamicDark := LoadFileIntoMemory(StyleFileNameDynamicDark, VsfDynamicDark);
ShouldFreeVsfDynamicDark := True;
end;
end;
{ All of the following changes must be independent because updates are not immediate. For
example, if you call DeleteIcon followed by FindResource then resource will still be found,
until you call EndUpdateResource *and* reload the file using LoadLibrary }
if IcoFileName <> '' then begin
TriggerOnUpdateIconsAndStyle(uisoIcoFileName);
const ResourceName = 'MAINICON';
{ Delete default icons }
OldGroupIconDir := DeleteIcon(H, M, PChar(ResourceName));
DeleteIconIfExists(H, M, PChar(ResourceName + '_DARK'));
{ Build the new group icon resource }
const NewGroupIconDirSize: DWORD = 3*SizeOf(Word)+Ico.ItemCount*SizeOf(TGroupIconDirItem);
GetMem(NewGroupIconDir, NewGroupIconDirSize);
try
{ Build the new group icon resource }
NewGroupIconDir.Reserved := OldGroupIconDir.Reserved;
NewGroupIconDir.Typ := OldGroupIconDir.Typ;
NewGroupIconDir.ItemCount := Ico.ItemCount;
for I := 0 to NewGroupIconDir.ItemCount-1 do begin
NewGroupIconDir.Items[I].Header := Ico.Items[I].Header;
const Id = I+100; //start at 100 to avoid overwriting other icons that may exist
if Id > High(Word) then
ResUpdateErrorWithLastError('UpdateResource failed (7)', ResourceName);
NewGroupIconDir.Items[I].Id := Word(Id);
end;
{ Update 'MAINICON' }
for I := 0 to NewGroupIconDir.ItemCount-1 do
if not UpdateResource(H, RT_ICON, MakeIntResource(NewGroupIconDir.Items[I].Id), 1033, Pointer(PByte(Ico) + Ico.Items[I].Offset), Ico.Items[I].Header.ImageSize) then
ResUpdateErrorWithLastError('UpdateResource failed (8)', ResourceName);
{ Update the icons }
if not UpdateResource(H, RT_GROUP_ICON, 'MAINICON', 1033, NewGroupIconDir, NewGroupIconDirSize) then
ResUpdateErrorWithLastError('UpdateResource failed (9)', ResourceName);
ChangedMainIcon := True;
finally
FreeMem(NewGroupIconDir);
end;
end else begin
if WizardDarkStyle <> wdsDynamic then begin
TriggerOnUpdateIconsAndStyle(uisoWizardDarkStyle);
if WizardDarkStyle = wdsLight then begin
{ Forced light: remove dark main icon }
DeleteIconIfExists(H, M, 'MAINICON_DARK')
end else begin
{ Forced dark: rename dark main icon to be the regular main icon }
RenameIconWithOverwrite(H, M, 'MAINICON_DARK', 'MAINICON');
ChangedMainIcon := True;
end;
end; { Else keep both main icons }
end;
if Uisf in [uisfSetup, uisfSetupCustomStyle] then begin
const DeleteUninstallIcon = IcoFileName <> '';
if DeleteUninstallIcon then begin
TriggerOnUpdateIconsAndStyle(uisoIcoFileName);
{ Make UninstallProgressForm use the custom icon }
DeleteIcon(H, M, 'Z_UNINSTALLICON');
DeleteIconIfExists(H, M, 'Z_UNINSTALLICON_DARK');
end;
if WizardDarkStyle <> wdsDynamic then begin
TriggerOnUpdateIconsAndStyle(uisoWizardDarkStyle);
{ Unlike for MAINICON (for which we don't have the choice) here it always uses DeleteIcon
instead of also using RenameIcon, to avoid issues with Windows' icon cache }
var Postfix := '';
if WizardDarkStyle = wdsLight then
Postfix := '_DARK';
{ Delete the icons we don't need: either the light ones or the dark ones }
DeleteIconIfExists(H, M, PChar('Z_GROUPICON' + Postfix));
if not DeleteUninstallIcon then
DeleteIconIfExists(H, M, PChar('Z_UNINSTALLICON' + Postfix));
end;
if Uisf = uisfSetupCustomStyle then begin
if Vsf <> nil then begin
TriggerOnUpdateIconsAndStyle(uisoStyleFileName);
{ Add the regular custom style, used by forced light, forced dark and dynamic light }
if not UpdateResource(H, 'VCLSTYLE', 'MYSTYLE1', 1033, Vsf, VsfSize) then
ResUpdateErrorWithLastError('UpdateResource failed (10)', 'MYSTYLE1');
end;
if VsfDynamicDark <> nil then begin
TriggerOnUpdateIconsAndStyle(uisoStyleFileNameDynamicDark);
{ Add the dark custom style, used by dynamic dark only }
if not UpdateResource(H, 'VCLSTYLE', 'MYSTYLE1_DARK', 1033, VsfDynamicDark, VsfSizeDynamicDark) then
ResUpdateErrorWithLastError('UpdateResource failed (11)', 'MYSTYLE1_DARK');
end;
{ See if we need to keep the built-in dark style }
if (Vsf = nil) and (WizardDarkStyle = wdsDark) then begin
TriggerOnUpdateIconsAndStyle(uisoWizardDarkStyle);
{ Forced dark without a custom style: make the built-in dark style the regular one }
RenameResource(H, M, 'VCLSTYLE', 'WINDOWSMODERNDARK', 'MYSTYLE1');
end else if (VsfDynamicDark = nil) and (WizardDarkStyle = wdsDynamic) then begin
TriggerOnUpdateIconsAndStyle(uisoWizardDarkStyle);
{ Dynamic without a custom dark style: make the built-in dark style the dark one }
RenameResource(H, M, 'VCLSTYLE', 'WINDOWSMODERNDARK', 'MYSTYLE1_DARK');
end else begin
TriggerOnUpdateIconsAndStyle(uisoWizardDarkStyle);
{ Forced dark with a custom style: delete the built-in dark style
Or, dynamic with a custom dark style: same
Or, forced light with or without a custom style: same
Note: forced light without a custom style doesn't actually use SetupCustomStyle.e32/64 at the moment so won't get here }
DeleteResource(H, M, 'VCLSTYLE', 'WINDOWSMODERNDARK');
end;
{ Delete additional styles - they are handled above }
DeleteResource(H, M, 'VCLSTYLE', 'WINDOWSMODERNLIGHT');
DeleteResource(H, M, 'VCLSTYLE', 'WINDOWSPOLARLIGHT');
DeleteResource(H, M, 'VCLSTYLE', 'WINDOWSPOLARDARK');
DeleteResource(H, M, 'VCLSTYLE', 'SLATECLASSICO');
DeleteResource(H, M, 'VCLSTYLE', 'ZIRCON');
end;
end;
TriggerOnUpdateIconsAndStyle(uisoDone);
finally
FreeLibrary(M);
end;
except
EndUpdateResource(H, True); { discard changes }
raise;
end;
if not EndUpdateResource(H, False) then
if ChangedMainIcon then { Only allow errors (likely from faulty AV software) if the update actually is important }
ResUpdateErrorWithLastError('EndUpdateResource failed, try excluding the Output folder from your antivirus software');
finally
if ShouldFreeVsfDynamicDark then
FreeMem(VsfDynamicDark);
if ShouldFreeVsf then
FreeMem(Vsf);
if Ico <> nil then
FreeMem(Ico);
end;
end;
{ Replaces the entire comctl32 dependency section of the manifest with spaces, then inserts a
comctl32 file entry before the other entries. Intended for SetupLdr only. Note: The exact number
of spaces is calculated to allow seamless in-place editing. }
procedure PreventCOMCTL32Sideloading(const F: TCustomFile);
const
DependencyStartTag: AnsiString = '';
DependencyEndTag: AnsiString = '';
FileStartTag: AnsiString = ''#13#10;
var
S: AnsiString;
P,Q,R: Integer;
begin
{ Read the manifest resource into a string }
SetString(S, nil, SeekToResourceData(F, 24, 1));
var Offset := F.Position;
F.ReadBuffer(S[1], ULength(S));
{ Locate and update the tag }
P := Pos(DependencyStartTag, S);
if P = 0 then
ResUpdateError(' tag not found');
Q := Pos(DependencyEndTag, S);
if Q <= P then
ResUpdateError(' end tag not found');
Q := Q+Length(DependencyEndTag);
if Length(COMCTL32Entry) > Q-P then
ResUpdateError(' tag shorter than replacement');
R := Pos(FileStartTag, S);
if R <= Q then
ResUpdateError(' end tag after ?');
Inc(Offset, P-1);
F.Seek(Offset);
F.WriteAnsiString(AnsiString(Format('%*s', [Q-P-Length(COMCTL32Entry), ' '])));
F.WriteAnsiString(AnsiString(Copy(S, Q, R-Q)));
F.WriteAnsiString(COMCTL32Entry);
end;
end.