unit Setup.MainFunc; { Inno Setup Copyright (C) 1997-2025 Jordan Russell Portions by Martijn Laan For conditions of distribution and use, see LICENSE.TXT. Setup main functions and global variables } interface uses Windows, SysUtils, Messages, Classes, Graphics, Controls, Forms, Dialogs, Generics.Collections, StdCtrls, Shared.Struct, Shared.DebugStruct, Shared.CommonFunc.Vcl, Shared.CommonFunc, Shared.SetupTypes, Setup.ScriptRunner, RestartManager; type TEntryType = (seLanguage, seCustomMessage, sePermission, seType, seComponent, seTask, seDir, seISSigKey, seFile, seFileLocation, seIcon, seIni, seRegistry, seInstallDelete, seUninstallDelete, seRun, seUninstallRun); TShellFolderID = (sfDesktop, sfStartMenu, sfPrograms, sfStartup, sfSendTo, //these have common and user versions sfFonts, sfAppData, sfDocs, sfTemplates, // sfFavorites, sfLocalAppData, sfUserProgramFiles, sfUserCommonFiles, sfUserSavedGames); //these only have user versions TWizardImages = TObjectList; const EntryStrings: array[TEntryType] of Integer = (SetupLanguageEntryStrings, SetupCustomMessageEntryStrings, SetupPermissionEntryStrings, SetupTypeEntryStrings, SetupComponentEntryStrings, SetupTaskEntryStrings, SetupDirEntryStrings, SetupISSigKeyEntryStrings, SetupFileEntryStrings, SetupFileLocationEntryStrings, SetupIconEntryStrings, SetupIniEntryStrings, SetupRegistryEntryStrings, SetupDeleteEntryStrings, SetupDeleteEntryStrings, SetupRunEntryStrings, SetupRunEntryStrings); EntryAnsiStrings: array[TEntryType] of Integer = (SetupLanguageEntryAnsiStrings, SetupCustomMessageEntryAnsiStrings, SetupPermissionEntryAnsiStrings, SetupTypeEntryAnsiStrings, SetupComponentEntryAnsiStrings, SetupTaskEntryAnsiStrings, SetupDirEntryAnsiStrings, SetupISSigKeyEntryAnsiStrings, SetupFileEntryAnsiStrings, SetupFileLocationEntryAnsiStrings, SetupIconEntryAnsiStrings, SetupIniEntryAnsiStrings, SetupRegistryEntryAnsiStrings, SetupDeleteEntryAnsiStrings, SetupDeleteEntryAnsiStrings, SetupRunEntryAnsiStrings, SetupRunEntryAnsiStrings); { Exit codes that are assigned to the SetupExitCode variable. Note: SetupLdr also returns exit codes with the same numbers. } ecInitializationError = 1; { Setup failed to initialize. } ecCancelledBeforeInstall = 2; { User clicked Cancel before the actual installation started. } ecNextStepError = 3; { A fatal exception occurred while moving to the next step. } ecInstallationError = 4; { A fatal exception occurred during installation. } ecInstallationCancelled = 5; { User clicked Cancel during installation, or clicked Abort at an Abort-Retry-Ignore dialog. } ecKilledByDebugger = 6; { User killed the Setup process from within the debugger. } ecPrepareToInstallFailed = 7; { Stopped on Preparing to Install page; restart not needed. } ecPrepareToInstallFailedRestartNeeded = 8; { Stopped on Preparing to Install page; restart needed. } CodeRunnerNamingAttribute = 'Event'; var { Variables for command line parameters } SetupLdrMode: Boolean; SetupLdrOriginalFilename: String; SetupLdrOffset0, SetupLdrOffset1: Int64; SetupLdrWnd: HWND; SetupFirstProcessWnd: HWND; InitLang: String; InitDir, InitProgramGroup: String; InitLoadInf, InitSaveInf: String; InitNoIcons, InitSilent, InitVerySilent, InitNoRestart, InitCloseApplications, InitNoCloseApplications, InitForceCloseApplications, InitNoForceCloseApplications, InitLogCloseApplications, InitRestartApplications, InitNoRestartApplications, InitNoCancel, InitNoStyle, InitRedirectionGuard, InitNoRedirectionGuard: Boolean; InitSetupType: String; InitComponents, InitTasks: TStringList; InitComponentsSpecified: Boolean; InitDeselectAllTasks: Boolean; InitPassword: String; InitRestartExitCode: Integer; InitPrivilegesRequired: TSetupPrivilegesRequired; HasInitPrivilegesRequired: Boolean; InitSuppressMsgBoxes: Boolean; DetachedUninstMsgFile: Boolean; NewParamsForCode: TStringList; { Debugger } OriginalEntryIndexes: array[TEntryType] of TList; { 'Constants' } SourceDir, TempInstallDir, WinDir, WinSystemDir, WinSysWow64Dir, WinSysNativeDir, SystemDrive, ProgramFiles32Dir, CommonFiles32Dir, ProgramFiles64Dir, CommonFiles64Dir, CmdFilename, SysUserInfoName, SysUserInfoOrg, UninstallExeFilename: String; { Uninstall 'constants' } UninstallExpandedAppId, UninstallExpandedApp, UninstallExpandedGroup, UninstallExpandedGroupName, UninstallExpandedLanguage: String; UninstallSilent: Boolean; { Variables read in from the Setup.0 file } SetupEncryptionHeader: TSetupEncryptionHeader; SetupHeader: TSetupHeader; OrigSetupHeaderWizardBackColor: Integer; LangOptions: TSetupLanguageEntry; Entries: array[TEntryType] of TList; WizardImages, WizardSmallImages, WizardBackImages: TWizardImages; MainIconPostfix, WizardIconsPostfix: String; CloseApplicationsFilterList, CloseApplicationsFilterExcludesList: TStringList; ISSigAvailableKeys: TArrayOfECDSAKey; { User options } ActiveLanguage: Integer = -1; ActiveLicenseText, ActiveInfoBeforeText, ActiveInfoAfterText: AnsiString; WizardUserInfoName, WizardUserInfoOrg, WizardUserInfoSerial, WizardDirValue, WizardGroupValue: String; WizardNoIcons, WizardPreparingYesRadio: Boolean; WizardSetupType: PSetupTypeEntry; WizardComponents, WizardDeselectedComponents, WizardTasks, WizardDeselectedTasks: TStringList; NeedToAbortInstall: Boolean; { Check/BeforeInstall/AfterInstall 'constants' } CheckOrInstallCurrentFilename, CheckOrInstallCurrentSourceFilename: String; { RestartManager API state. Note: the handle and key might change while running, see TWizardForm.QueryRestartManager. } RmSessionStarted, RmFoundApplications, RmDoRestart: Boolean; RmSessionHandle: DWORD; RmSessionKey: array[0..CCH_RM_SESSION_KEY] of WideChar; RmRegisteredFilesCount: Integer; { Other } ShowLanguageDialog, MatchedLangParameter: Boolean; InstallMode: (imNormal, imSilent, imVerySilent); HasIcons, Is64BitInstallMode, IsAdmin, IsPowerUserOrAdmin, IsAdminInstallMode, NeedPassword, NeedSerial, NeedsRestart, RestartSystem, IsWinDark, IsDarkInstallMode, IsUninstaller, AllowUninstallerShutdown, AcceptedQueryEndSessionInProgress, CustomWizardBackground: Boolean; InstallDefaultDisableFsRedir, ScriptFuncDisableFsRedir: Boolean; InstallDefaultRegView: TRegView = rvDefault; HasCustomType, HasComponents, HasTasks: Boolean; ProcessorArchitecture: TSetupProcessorArchitecture = paUnknown; MachineTypesSupportedBySystem: TSetupProcessorArchitectures; WindowsVersion: Cardinal; NTServicePackLevel: Word; WindowsProductType: Byte; WindowsSuiteMask: Word; MinimumSpace: Int64; DeleteFilesAfterInstallList, DeleteDirsAfterInstallList: TStringList; ExpandedAppName, ExpandedAppVerName, ExpandedAppCopyright, ExpandedAppMutex: String; DisableCodeConsts: Integer; SetupExitCode: Integer; CreatedIcon: Boolean; RestartInitiatedByThisProcess, DownloadTemporaryFileOrExtractArchiveProcessMessages: Boolean; InstallModeRootKey: HKEY; CodeRunner: TScriptRunner; {$IFDEF WIN64} const IsWin64 = True; {$ELSE} var IsWin64: Boolean; {$ENDIF} function ApplyPathRedirRules(const A64Bit: Boolean; const APath: String): String; procedure CodeRunnerOnLog(const S: String); procedure CodeRunnerOnLogFmt(const S: String; const Args: array of const); function CodeRunnerOnDebug(const Position: LongInt; var ContinueStepOver: Boolean): Boolean; function CodeRunnerOnDebugIntermediate(const Position: LongInt; var ContinueStepOver: Boolean): Boolean; procedure CodeRunnerOnDllImport(var DllName: String; var ForceDelayLoad: Boolean); procedure CodeRunnerOnException(const Exception: AnsiString; const Position: LongInt); procedure CreateTempInstallDirAndExtract64BitHelper; procedure DebugNotifyEntry(EntryType: TEntryType; Number: NativeInt); procedure DeinitSetup(const AllowCustomSetupExitCode: Boolean); procedure DeleteResidualTempUninstallDirs; function ExitSetupMsgBox: Boolean; function ExpandConst(const S: String): String; function ExpandConstEx(const S: String; const CustomConsts: array of String): String; function ExpandConstEx2(const S: String; const CustomConsts: array of String; const DoExpandIndividualConst: Boolean): String; function ExpandConstIfPrefixed(const S: String): String; function GetCustomMessageValue(const AName: String; var AValue: String): Boolean; function GetShellFolder(const Common: Boolean; const ID: TShellFolderID): String; function GetShellFolderByCSIDL(Folder: Integer; const Create: Boolean): String; function GetUninstallRegKeyBaseName(const ExpandedAppId: String): String; function GetUninstallRegSubkeyName(const UninstallRegKeyBaseName: String): String; function GetPreviousData(const ExpandedAppID, ValueName, DefaultValueData: String): String; function GetPreviousLanguage(const ExpandedAppID: String): Integer; procedure InitializeAdminInstallMode(const AAdminInstallMode: Boolean); procedure Initialize64BitInstallMode(const A64BitInstallMode: Boolean); procedure Log64BitInstallMode; procedure LogArchiveExtractionModeOnce; procedure InitializeCommonVars; procedure InitializeSetup; procedure InitializeWizard; procedure InitMainNonSHFolderConsts; function InstallOnThisVersion(const MinVersion: TSetupVersionData; const OnlyBelowVersion: TSetupVersionData): TInstallOnThisVersionResult; function IsRecurseableDirectory(const FindData: TWin32FindData): Boolean; procedure LoadSHFolderDLL; function LoggedMsgBox(const Text, Caption: PChar; const Flags: Cardinal; const Suppressible: Boolean; const Default: Integer): Integer; overload; function LoggedMsgBox(const Text, Caption: String; const Typ: TMsgBoxType; const Buttons: Cardinal; const Suppressible: Boolean; const Default: Integer): Integer; overload; function LoggedTaskDialogMsgBox(const Icon, Instruction, Text, Caption: String; const Typ: TMsgBoxType; const Buttons: Cardinal; const ButtonLabels: array of String; const ShieldButton: Integer; const Suppressible: Boolean; const Default: Integer; const VerificationText: String = ''; const pfVerificationFlagChecked: PBOOL = nil): Integer; procedure LogWindowsVersion; procedure NotifyAfterInstallEntry(const AfterInstall: String); procedure NotifyAfterInstallFileEntry(const FileEntry: PSetupFileEntry); procedure NotifyBeforeInstallEntry(const BeforeInstall: String); procedure NotifyBeforeInstallFileEntry(const FileEntry: PSetupFileEntry); procedure RedirectionGuardConfigure(const AEnable: Boolean); function RedirectionGuardEnabled: Boolean; function PreviousInstallCompleted(const WizardComponents, WizardTasks: TStringList): Boolean; function CodeRegisterExtraCloseApplicationsResource(const DisableFsRedir: Boolean; const AFilename: String): Boolean; procedure RegisterResourcesWithRestartManager(const WizardComponents, WizardTasks: TStringList); procedure RemoveTempInstallDir; procedure SaveInf(const FileName: String); procedure SaveResourceToTempFile(const ResName, Filename: String); procedure SetActiveLanguage(const I: Integer); procedure ShellExecuteAsOriginalUser(hWnd: HWND; Operation, FileName, Parameters, Directory: LPWSTR; ShowCmd: Integer); stdcall; function ShouldDisableFsRedirForFileEntry(const FileEntry: PSetupFileEntry): Boolean; function ShouldDisableFsRedirForRunEntry(const RunEntry: PSetupRunEntry): Boolean; procedure ProcessRunEntry(const RunEntry: PSetupRunEntry); function EvalArchitectureIdentifier(const Name: String): Boolean; function EvalDirectiveCheck(const Expression: String): Boolean; function ShouldProcessEntry(const WizardComponents, WizardTasks: TStringList; const Components, Tasks, Languages, Check: String): Boolean; function ShouldProcessFileEntry(const WizardComponents, WizardTasks: TStringList; const FileEntry: PSetupFileEntry; const IgnoreCheck: Boolean): Boolean; function ShouldProcessIconEntry(const WizardComponents, WizardTasks: TStringList; const WizardNoIcons: Boolean; const IconEntry: PSetupIconEntry): Boolean; function ShouldProcessRunEntry(const WizardComponents, WizardTasks: TStringList; const RunEntry: PSetupRunEntry): Boolean; procedure UnloadSHFolderDLL; function WindowsVersionAtLeast(const AMajor, AMinor: Byte; const ABuild: Word = 0): Boolean; function IsWindows8: Boolean; function IsWindows10: Boolean; function IsWindows11: Boolean; function SelectBestImage(WizardImages: TWizardImages; TargetWidth, TargetHeight: Integer): TGraphic; implementation uses ShellAPI, ShlObj, StrUtils, ActiveX, RegStr, Imaging.pngimage, Themes, ChaCha20, ECDSA, ISSigFunc, NewCtrls, PathFunc, UnsignedFunc, FormBackgroundStyleHook, RichEditViewer, SetupLdrAndSetup.Messages, Shared.SetupMessageIDs, Setup.DownloadFileFunc, Setup.ExtractFileFunc, SetupLdrAndSetup.InstFunc, Setup.InstFunc, Setup.RedirFunc, Compression.Base, Compression.Zlib, Compression.bzlib, Compression.LZMADecompressor, Shared.SetupEntFunc, Shared.EncryptionFunc, Setup.SelectLanguageForm, Setup.WizardForm, Setup.DebugClient, Shared.VerInfoFunc, Setup.FileExtractor, Shared.FileClass, Setup.LoggingFunc, StringScanner, SimpleExpression, Setup.Helper, Setup.SpawnClient, Setup.SpawnServer, Setup.DotNetFunc, Shared.TaskDialogFunc, Setup.MainForm, Compression.SevenZipDecoder, Compression.SevenZipDLLDecoder, Setup.SetupForm; var ShellFolders: array[Boolean, TShellFolderID] of String; ShellFoldersRead: array[Boolean, TShellFolderID] of Boolean; SHFolderDLLHandle: HMODULE; SHGetFolderPathFunc: function(hwndOwner: HWND; nFolder: Integer; hToken: THandle; dwFlags: DWORD; pszPath: PChar): HRESULT; stdcall; SHGetKnownFolderPathFunc: function(const rfid: TGUID; dwFlags: DWORD; hToken: THandle; var ppszPath: PWideChar): HRESULT; stdcall; DecompressorDLLHandle, SevenZipDLLHandle: HMODULE; type TDummyClass = class public class function ExpandCheckOrInstallConstant(Sender: TSimpleExpression; const Constant: String): String; class function EvalInstallIdentifier(Sender: TSimpleExpression; const Name: String; const Parameters: array of const): Boolean; class function EvalArchitectureIdentifier(Sender: TSimpleExpression; const Name: String; const Parameters: array of const): Boolean; class function EvalComponentOrTaskIdentifier(Sender: TSimpleExpression; const Name: String; const Parameters: array of const): Boolean; class function EvalLanguageIdentifier(Sender: TSimpleExpression; const Name: String; const Parameters: array of const): Boolean; class function EvalCheckIdentifier(Sender: TSimpleExpression; const Name: String; const Parameters: array of const): Boolean; end; { Misc. functions } function SelectBestImage(WizardImages: TWizardImages; TargetWidth, TargetHeight: Integer): TGraphic; var TargetArea, Difference, SmallestDifference: Integer; begin if WizardImages.Count <> 1 then begin { Find the image with the smallest area difference compared to the target area. } TargetArea := TargetWidth*TargetHeight; SmallestDifference := -1; Result := nil; for var I := 0 to WizardImages.Count-1 do begin Difference := Abs(TargetArea-WizardImages[I].Width*WizardImages[I].Height); if (SmallestDifference = -1) or (Difference < SmallestDifference) then begin Result := WizardImages[I]; SmallestDifference := Difference; end; end; end else Result := WizardImages[0]; end; function WindowsVersionAtLeast(const AMajor, AMinor: Byte; const ABuild: Word): Boolean; begin Result := WindowsVersion >= Cardinal((AMajor shl 24) or (AMinor shl 16) or ABuild); end; function IsWindows8: Boolean; begin Result := WindowsVersionAtLeast(6, 2); end; function IsWindows10: Boolean; begin Result := WindowsVersionAtLeast(10, 0); end; function IsWindows11: Boolean; begin Result := WindowsVersionAtLeast(10, 0, 22000); end; function ApplyPathRedirRules(const A64Bit: Boolean; const APath: String): String; begin var NewPath := PathExpand(APath); if A64Bit then begin { system32 -> sysnative } if not IsWin64 then InternalError('ApplyPathRedirRules: A64Bit=True but IsWin64=False'); NewPath := ReplaceSystemDirWithSysNative(NewPath, IsWin64); end else begin { system32 -> syswow64 rule currently disabled; it's only really needed when the target process is 64-bit. } //NewPath := ReplaceSystemDirWithSysWow64(NewPath); end; Result := NewPath; end; function GetUninstallRegKeyBaseName(const ExpandedAppId: String): String; var UseAnsiCRC32: Boolean; S: AnsiString; I: Integer; begin { Set uninstall registry key base name } Result := ExpandedAppId; { Uninstall registry keys can only be up to 63 characters, otherwise Win95 ignores them. Limit to 57 since Setup will add _isXXX to the end later. } if Length(Result) > 57 then begin { Only keep the first 48 characters, then add an tilde and the CRC of the original string (to make the trimmed string unique). The resulting string is 57 characters long. On Unicode, only do this if we can get a CRC32 compatible with ANSI versions, else there's no point in shortening since Unicode doesn't run on Win95. } UseAnsiCRC32 := True; for I := 1 to Length(Result) do begin if Ord(Result[I]) > 126 then begin UseAnsiCRC32 := False; Break; end; end; if UseAnsiCRC32 then begin S := AnsiString(Result); FmtStr(Result, '%.48s~%.8x', [Result, GetCRC32(S[1], ULength(S)*SizeOf(S[1]))]); end; end; end; function GetUninstallRegSubkeyName(const UninstallRegKeyBaseName: String): String; begin Result := Format('%s\%s_is1', [REGSTR_PATH_UNINSTALL, UninstallRegKeyBaseName]); end; { Based on FindPreviousData in Wizard.pas } function GetPreviousData(const ExpandedAppID, ValueName, DefaultValueData: String): String; var H: HKEY; begin Result := DefaultValueData; if ExpandedAppId <> '' then begin if RegOpenKeyExView(InstallDefaultRegView, InstallModeRootKey, PChar(GetUninstallRegSubkeyName(GetUninstallRegKeyBaseName(ExpandedAppId))), 0, KEY_QUERY_VALUE, H) = ERROR_SUCCESS then begin try RegQueryStringValue (H, PChar(ValueName), Result); finally RegCloseKey (H); end; end; end; end; function GetPreviousLanguage(const ExpandedAppID: String): Integer; var PrevLang: String; begin { do not localize or change the following string } PrevLang := GetPreviousData(ExpandConst(SetupHeader.AppId), 'Inno Setup: Language', ''); if PrevLang <> '' then begin for var I := 0 to Entries[seLanguage].Count-1 do begin if CompareText(PrevLang, PSetupLanguageEntry(Entries[seLanguage][I]).Name) = 0 then begin Result := Integer(I); Exit; end; end; end; Result := -1; end; class function TDummyClass.ExpandCheckOrInstallConstant(Sender: TSimpleExpression; const Constant: String): String; begin Result := ExpandConst(Constant); end; class function TDummyClass.EvalInstallIdentifier(Sender: TSimpleExpression; const Name: String; const Parameters: array of const): Boolean; begin CodeRunner.RunProcedure(AnsiString(Name), Parameters, True); Result := True; { Result doesn't matter } end; procedure NotifyInstallEntry(const Install: String); procedure EvalInstall(const Expression: String); var SimpleExpression: TSimpleExpression; begin try SimpleExpression := TSimpleExpression.Create; try SimpleExpression.Expression := Expression; SimpleExpression.OnEvalIdentifier := TDummyClass.EvalInstallIdentifier; SimpleExpression.OnExpandConstant := TDummyClass.ExpandCheckOrInstallConstant; SimpleExpression.ParametersAllowed := True; SimpleExpression.SingleIdentifierMode := True; SimpleExpression.Eval; finally SimpleExpression.Free; end; except InternalError(Format('Expression error ''%s''', [GetExceptMessage])); end; end; begin if Install <> '' then begin try if CodeRunner = nil then InternalError('"BeforeInstall" or "AfterInstall" parameter with no CodeRunner'); EvalInstall(Install); except { Don't allow exceptions raised by Before/AfterInstall functions to be propagated out } Application.HandleException(nil); end; end; end; procedure NotifyBeforeInstallEntry(const BeforeInstall: String); begin NotifyInstallEntry(BeforeInstall); end; procedure NotifyBeforeInstallFileEntry(const FileEntry: PSetupFileEntry); begin CheckOrInstallCurrentFilename := FileEntry.DestName; CheckOrInstallCurrentSourceFilename := FileEntry.SourceFilename; NotifyInstallEntry(FileEntry.BeforeInstall); CheckOrInstallCurrentFilename := ''; CheckOrInstallCurrentSourceFilename := ''; end; procedure NotifyAfterInstallEntry(const AfterInstall: String); begin NotifyInstallEntry(AfterInstall); end; procedure NotifyAfterInstallFileEntry(const FileEntry: PSetupFileEntry); begin CheckOrInstallCurrentFilename := FileEntry.DestName; CheckOrInstallCurrentSourceFilename := FileEntry.SourceFilename; NotifyInstallEntry(FileEntry.AfterInstall); CheckOrInstallCurrentFilename := ''; CheckOrInstallCurrentSourceFilename := ''; end; function EvalArchitectureIdentifier(const Name: String): Boolean; type TArchIdentifierRec = record Name: String; Arch: TSetupProcessorArchitecture; Compatible: Boolean; end; const { Valid identifier 'win64' is not in this list but treated specially below } ArchIdentifiers: array[0..7] of TArchIdentifierRec = ( (Name: 'arm32compatible'; Arch: paArm32; Compatible: True), (Name: 'arm64'; Arch: paArm64; Compatible: False), (Name: 'x64'; Arch: paX64; Compatible: False), (Name: 'x64os'; Arch: paX64; Compatible: False), (Name: 'x64compatible'; Arch: paX64; Compatible: True), (Name: 'x86'; Arch: paX86; Compatible: False), (Name: 'x86os'; Arch: paX86; Compatible: False), (Name: 'x86compatible'; Arch: paX86; Compatible: True)); begin if Name = 'win64' then Exit(IsWin64); for var ArchIdentifier in ArchIdentifiers do if ArchIdentifier.Name = Name then begin if ArchIdentifier.Compatible then Exit(ArchIdentifier.Arch in MachineTypesSupportedBySystem) else { An exact match is requested instead of anything compatible, perhaps for a driver install or something similar } Exit(ProcessorArchitecture = ArchIdentifier.Arch); end; raise Exception.CreateFmt('Unknown architecture ''%s''', [Name]); end; class function TDummyClass.EvalArchitectureIdentifier(Sender: TSimpleExpression; const Name: String; const Parameters: array of const): Boolean; begin Result := Setup.MainFunc.EvalArchitectureIdentifier(Name); end; class function TDummyClass.EvalComponentOrTaskIdentifier(Sender: TSimpleExpression; const Name: String; const Parameters: array of const): Boolean; var WizardItems: TStringList; begin WizardItems := TStringList(Sender.Tag); Result := ListContains(WizardItems, Name); end; class function TDummyClass.EvalLanguageIdentifier(Sender: TSimpleExpression; const Name: String; const Parameters: array of const): Boolean; begin Result := CompareText(PSetupLanguageEntry(Entries[seLanguage][ActiveLanguage]).Name, Name) = 0; end; class function TDummyClass.EvalCheckIdentifier(Sender: TSimpleExpression; const Name: String; const Parameters: array of const): Boolean; begin Result := CodeRunner.RunBooleanFunction(AnsiString(Name), Parameters, True, False); end; function EvalCheck(const Expression: String): Boolean; var SimpleExpression: TSimpleExpression; begin try SimpleExpression := TSimpleExpression.Create; try SimpleExpression.Lazy := True; SimpleExpression.Expression := Expression; SimpleExpression.OnEvalIdentifier := TDummyClass.EvalCheckIdentifier; SimpleExpression.OnExpandConstant := TDummyClass.ExpandCheckOrInstallConstant; SimpleExpression.ParametersAllowed := True; SimpleExpression.SilentOrAllowed := False; SimpleExpression.SingleIdentifierMode := False; Result := SimpleExpression.Eval; finally SimpleExpression.Free; end; except InternalError(Format('Expression error ''%s''', [GetExceptMessage])); Result := False; end; end; function EvalDirectiveCheck(const Expression: String): Boolean; begin if not TryStrToBoolean(Expression, Result) then Result := EvalCheck(Expression); end; function EvalExpression(const Expression: String; OnEvalIdentifier: TSimpleExpressionOnEvalIdentifier; Tag: NativeInt = 0): Boolean; var SimpleExpression: TSimpleExpression; begin try SimpleExpression := TSimpleExpression.Create; try SimpleExpression.Lazy := True; SimpleExpression.Expression := Expression; SimpleExpression.OnEvalIdentifier := OnEvalIdentifier; SimpleExpression.ParametersAllowed := False; SimpleExpression.SilentOrAllowed := True; SimpleExpression.SingleIdentifierMode := False; SimpleExpression.Tag := Tag; Result := SimpleExpression.Eval; finally SimpleExpression.Free; end; except InternalError(Format('Expression error ''%s''', [GetExceptMessage])); Result := False; end; end; function ShouldProcessEntry(const WizardComponents, WizardTasks: TStringList; const Components, Tasks, Languages, Check: String): Boolean; var ProcessComponent, ProcessTask, ProcessLanguage: Boolean; begin if (Components <> '') or (Tasks <> '') or (Languages <> '') or (Check <> '') then begin if (Components <> '') and (WizardComponents <> nil) then ProcessComponent := EvalExpression(Components, TDummyClass.EvalComponentOrTaskIdentifier, NativeInt(WizardComponents)) else ProcessComponent := True; if (Tasks <> '') and (WizardTasks <> nil) then ProcessTask := EvalExpression(Tasks, TDummyClass.EvalComponentOrTaskIdentifier, NativeInt(WizardTasks)) else ProcessTask := True; if Languages <> '' then ProcessLanguage := EvalExpression(Languages, TDummyClass.EvalLanguageIdentifier) else ProcessLanguage := True; Result := ProcessComponent and ProcessTask and ProcessLanguage; if Result and (Check <> '') then begin try if CodeRunner = nil then InternalError('"Check" parameter with no CodeRunner'); Result := EvalCheck(Check); except { Don't allow exceptions raised by Check functions to be propagated out } Application.HandleException(nil); Result := False; end; end; end else Result := True; end; function ShouldProcessFileEntry(const WizardComponents, WizardTasks: TStringList; const FileEntry: PSetupFileEntry; const IgnoreCheck: Boolean): Boolean; begin if foDontCopy in FileEntry.Options then begin Result := False; Exit; end; CheckOrInstallCurrentFilename := FileEntry.DestName; CheckOrInstallCurrentSourceFilename := FileEntry.SourceFilename; if IgnoreCheck then Result := ShouldProcessEntry(WizardComponents, WizardTasks, FileEntry.Components, FileEntry.Tasks, FileEntry.Languages, '') else Result := ShouldProcessEntry(WizardComponents, WizardTasks, FileEntry.Components, FileEntry.Tasks, FileEntry.Languages, FileEntry.Check); CheckOrInstallCurrentFilename := ''; CheckOrInstallCurrentSourceFilename := ''; end; function ShouldProcessRunEntry(const WizardComponents, WizardTasks: TStringList; const RunEntry: PSetupRunEntry): Boolean; begin if (InstallMode <> imNormal) and (roSkipIfSilent in RunEntry.Options) then Result := False else if (InstallMode = imNormal) and (roSkipIfNotSilent in RunEntry.Options) then Result := False else Result := ShouldProcessEntry(WizardComponents, WizardTasks, RunEntry.Components, RunEntry.Tasks, RunEntry.Languages, RunEntry.Check); end; function ShouldProcessIconEntry(const WizardComponents, WizardTasks: TStringList; const WizardNoIcons: Boolean; const IconEntry: PSetupIconEntry): Boolean; begin if WizardNoIcons and (IconEntry.Tasks = '') and (Copy(IconEntry.IconName, 1, 8) = '{group}\') then Result := False else Result := ShouldProcessEntry(WizardComponents, WizardTasks, IconEntry.Components, IconEntry.Tasks, IconEntry.Languages, IconEntry.Check); end; function ShouldDisableFsRedirForFileEntry(const FileEntry: PSetupFileEntry): Boolean; begin Result := InstallDefaultDisableFsRedir; if fo32Bit in FileEntry.Options then Result := False; if fo64Bit in FileEntry.Options then begin if not IsWin64 then InternalError('Cannot install files to 64-bit locations on this version of Windows'); Result := True; end; end; function SlashesToBackslashes(const S: String): String; var I: Integer; begin Result := S; for I := 1 to Length(Result) do if Result[I] = '/' then Result[I] := '\'; end; procedure LoadInf(const FileName: String; var WantToSuppressMsgBoxes: Boolean); const Section = 'Setup'; var S: String; begin //saved infs InitLang := GetIniString(Section, 'Lang', InitLang, FileName); InitDir := GetIniString(Section, 'Dir', InitDir, FileName); InitProgramGroup := GetIniString(Section, 'Group', InitProgramGroup, FileName); InitNoIcons := GetIniBool(Section, 'NoIcons', InitNoIcons, FileName); InitSetupType := GetIniString(Section, 'SetupType', InitSetupType, FileName); S := GetIniString(Section, 'Components', '$', FileName); if S <> '$' then begin InitComponentsSpecified := True; SetStringsFromCommaString(InitComponents, SlashesToBackslashes(S)); end; S := GetIniString(Section, 'Tasks', '$', FileName); if S <> '$' then begin InitDeselectAllTasks := True; SetStringsFromCommaString(InitTasks, SlashesToBackslashes(S)); end; //non saved infs (=non user settable) InitSilent := GetIniBool(Section, 'Silent', InitSilent, FileName); InitVerySilent := GetIniBool(Section, 'VerySilent', InitVerySilent, FileName); InitNoRestart := GetIniBool(Section, 'NoRestart', InitNoRestart, FileName); InitCloseApplications := GetIniBool(Section, 'CloseApplications', InitCloseApplications, FileName); InitNoCloseApplications := GetIniBool(Section, 'NoCloseApplications', InitNoCloseApplications, FileName); InitForceCloseApplications := GetIniBool(Section, 'ForceCloseApplications', InitForceCloseApplications, FileName); InitNoForceCloseApplications := GetIniBool(Section, 'NoForceCloseApplications', InitNoForceCloseApplications, FileName); InitLogCloseApplications := GetIniBool(Section, 'LogCloseApplications', InitLogCloseApplications, FileName); InitRestartApplications := GetIniBool(Section, 'RestartApplications', InitRestartApplications, FileName); InitNoRestartApplications := GetIniBool(Section, 'NoRestartApplications', InitNoRestartApplications, FileName); InitNoCancel := GetIniBool(Section, 'NoCancel', InitNoCancel, FileName); InitNoStyle := GetIniBool(Section, 'NoStyle', InitNoStyle, FileName); InitRedirectionGuard := GetIniBool(Section, 'RedirectionGuard', InitRedirectionGuard, FileName); InitNoRedirectionGuard := GetIniBool(Section, 'NoRedirectionGuard', InitNoRedirectionGuard, FileName); InitPassword := GetIniString(Section, 'Password', InitPassword, FileName); InitRestartExitCode := GetIniInt(Section, 'RestartExitCode', InitRestartExitCode, 0, 0, FileName); WantToSuppressMsgBoxes := GetIniBool(Section, 'SuppressMsgBoxes', WantToSuppressMsgBoxes, FileName); InitSaveInf := GetIniString(Section, 'SaveInf', InitSaveInf, FileName); end; procedure SaveInf(const FileName: String); const Section = 'Setup'; begin SetIniString(Section, 'Lang', PSetupLanguageEntry(Entries[seLanguage][ActiveLanguage]).Name, FileName); SetIniString(Section, 'Dir', WizardDirValue, FileName); SetIniString(Section, 'Group', WizardGroupValue, FileName); SetIniBool(Section, 'NoIcons', WizardNoIcons, FileName); if WizardSetupType <> nil then begin SetIniString(Section, 'SetupType', WizardSetupType.Name, FileName); SetIniString(Section, 'Components', StringsToCommaString(WizardComponents), FileName); end else begin DeleteIniEntry(Section, 'SetupType', FileName); DeleteIniEntry(Section, 'Components', FileName); end; SetIniString(Section, 'Tasks', StringsToCommaString(WizardTasks), FileName); end; function GetCustomMessageValue(const AName: String; var AValue: String): Boolean; begin Result := False; for var I := 0 to Entries[seCustomMessage].Count-1 do begin with PSetupCustomMessageEntry(Entries[seCustomMessage][I])^ do begin if (CompareText(Name, AName) = 0) and ((LangIndex = -1) or (LangIndex = ActiveLanguage)) then begin Result := True; AValue := Value; { don't stop looping, last item counts } end; end; end; end; function ExpandIndividualConst(Cnst: String; const CustomConsts: array of String): String; { Cnst must be the name of a single constant, without the braces. For example: app IsPath is set to True if the result is a path which needs special trailing- backslash handling. } procedure HandleAutoConstants(var Cnst: String); const Actual: array [Boolean] of String = ('user', 'common'); begin if Copy(Cnst, 1, 4) = 'auto' then begin StringChange(Cnst, 'auto', Actual[IsAdminInstallMode]); if (Cnst = 'userpf32') or (Cnst = 'userpf64') or (Cnst = 'usercf32') or (Cnst = 'usercf64') then Delete(Cnst, Length(Cnst)-1, 2); end; end; procedure NoUninstallConstError(const C: String); begin InternalError(Format('Cannot evaluate "%s" constant during Uninstall', [C])); end; function ExpandEnvConst(C: String): String; var I: Integer; VarName, Default: String; begin Delete(C, 1, 1); I := ConstPos('|', C); { check for 'default' value } if I = 0 then I := Length(C)+1; VarName := Copy(C, 1, I-1); Default := Copy(C, I+1, Maxint); Result := ''; if ConvertConstPercentStr(VarName) and ConvertConstPercentStr(Default) then begin Result := GetEnv(ExpandConstEx(VarName, CustomConsts)); if Result = '' then Result := ExpandConstEx(Default, CustomConsts); end; end; function ExpandRegConst(C: String): String; { Expands a registry-value constant in the form: reg:HKxx\SubkeyName,ValueName|DefaultValue } type TKeyNameConst = packed record KeyName: String; KeyConst: HKEY; end; const KeyNameConsts: array[0..5] of TKeyNameConst = ( (KeyName: 'HKA'; KeyConst: HKEY_AUTO), (KeyName: 'HKCR'; KeyConst: HKEY_CLASSES_ROOT), (KeyName: 'HKCU'; KeyConst: HKEY_CURRENT_USER), (KeyName: 'HKLM'; KeyConst: HKEY_LOCAL_MACHINE), (KeyName: 'HKU'; KeyConst: HKEY_USERS), (KeyName: 'HKCC'; KeyConst: HKEY_CURRENT_CONFIG)); var Z, Subkey, Value, Default: String; I, J, L: Integer; RegView: TRegView; RootKey: HKEY; K: HKEY; begin Delete(C, 1, 4); { skip past 'reg:' } I := ConstPos('\', C); if I <> 0 then begin Z := Copy(C, 1, I-1); if Z <> '' then begin RegView := InstallDefaultRegView; L := Length(Z); if L >= 2 then begin { Check for '32' or '64' suffix } if (Z[L-1] = '3') and (Z[L] = '2') then begin RegView := rv32Bit; SetLength(Z, L-2); end else if (Z[L-1] = '6') and (Z[L] = '4') then begin if not IsWin64 then InternalError('Cannot access a 64-bit key in a "reg" constant on this version of Windows'); RegView := rv64Bit; SetLength(Z, L-2); end; end; RootKey := 0; for J := Low(KeyNameConsts) to High(KeyNameConsts) do if CompareText(KeyNameConsts[J].KeyName, Z) = 0 then begin RootKey := KeyNameConsts[J].KeyConst; if RootKey = HKEY_AUTO then RootKey := InstallModeRootKey; Break; end; if RootKey <> 0 then begin Z := Copy(C, I+1, Maxint); I := ConstPos('|', Z); { check for a 'default' data } if I = 0 then I := Length(Z)+1; Default := Copy(Z, I+1, Maxint); SetLength(Z, I-1); I := ConstPos(',', Z); { comma separates subkey and value } if I <> 0 then begin Subkey := Copy(Z, 1, I-1); Value := Copy(Z, I+1, Maxint); if ConvertConstPercentStr(Subkey) and ConvertConstPercentStr(Value) and ConvertConstPercentStr(Default) then begin Result := ExpandConstEx(Default, CustomConsts); if RegOpenKeyExView(RegView, RootKey, PChar(ExpandConstEx(Subkey, CustomConsts)), 0, KEY_QUERY_VALUE, K) = ERROR_SUCCESS then begin RegQueryStringValue(K, PChar(ExpandConstEx(Value, CustomConsts)), Result, True); { also allows REG_DWORD } RegCloseKey(K); end; Exit; end; end; end; end; end; { it will only reach here if there was a parsing error } InternalError('Failed to parse "reg" constant'); end; function ExpandIniConst(C: String): String; { Expands an INI-value constant in the form: filename,section,key|defaultvalue } var Z, Filename, Section, Key, Default: String; I: Integer; begin Delete(C, 1, 4); { skip past 'ini:' } I := ConstPos(',', C); if I <> 0 then begin Z := Copy(C, 1, I-1); if Z <> '' then begin Filename := Z; Z := Copy(C, I+1, Maxint); I := ConstPos('|', Z); { check for a 'default' data } if I = 0 then I := Length(Z)+1; Default := Copy(Z, I+1, Maxint); SetLength(Z, I-1); I := ConstPos(',', Z); { comma separates section and key } if I <> 0 then begin Section := Copy(Z, 1, I-1); Key := Copy(Z, I+1, Maxint); if ConvertConstPercentStr(Filename) and ConvertConstPercentStr(Section) and ConvertConstPercentStr(Key) and ConvertConstPercentStr(Default) then begin Filename := ExpandConstEx(Filename, CustomConsts); Section := ExpandConstEx(Section, CustomConsts); Key := ExpandConstEx(Key, CustomConsts); Default := ExpandConstEx(Default, CustomConsts); Result := GetIniString(Section, Key, Default, Filename); Exit; end; end; end; end; { it will only reach here if there was a parsing error } InternalError('Failed to parse "ini" constant'); end; function ExpandParamConst(C: String): String; { Expands an commandline-parameter-value constant in the form: parametername|defaultvalue } function GetParamString(const Param, Default: String): String; var I, PCount: Integer; Z: String; begin PCount := NewParamCount(); for I := 1 to PCount do begin Z := NewParamStr(I); if StrLIComp(PChar(Z), PChar('/'+Param+'='), ULength(Param)+2) = 0 then begin Delete(Z, 1, Length(Param)+2); Result := Z; Exit; end; end; Result := Default; end; var Z, Param, Default: String; I: Integer; begin Delete(C, 1, 6); { skip past 'param:' } Z := C; I := ConstPos('|', Z); { check for a 'default' data } if I = 0 then I := Length(Z)+1; Default := Copy(Z, I+1, Maxint); SetLength(Z, I-1); Param := Z; if ConvertConstPercentStr(Param) and ConvertConstPercentStr(Default) then begin Param := ExpandConstEx(Param, CustomConsts); Default := ExpandConstEx(Default, CustomConsts); Result := GetParamString(Param, Default); Exit; end; { it will only reach here if there was a parsing error } InternalError('Failed to parse "param" constant'); end; function ExpandCodeConst(C: String): String; { Expands an Pascal-script-value constant in the form: parametername|defaultvalue } function GetCodeString(const ScriptFunc, Default: String): String; begin if (CodeRunner <> nil) then Result := CodeRunner.RunStringFunction(AnsiString(ScriptFunc), [Default], True, Default) else begin InternalError('"code" constant with no CodeRunner'); Result := ''; end; end; var Z, ScriptFunc, Default: String; I: Integer; begin if DisableCodeConsts <> 0 then raise Exception.Create('Cannot evaluate "code" constant because of possible side effects'); Delete(C, 1, 5); { skip past 'code:' } Z := C; I := ConstPos('|', Z); { check for a 'default' data } if I = 0 then I := Length(Z)+1; Default := Copy(Z, I+1, Maxint); SetLength(Z, I-1); ScriptFunc := Z; if ConvertConstPercentStr(ScriptFunc) and ConvertConstPercentStr(Default) then begin Default := ExpandConstEx(Default, CustomConsts); Result := GetCodeString(ScriptFunc, Default); Exit; end; { it will only reach here if there was a parsing error } InternalError('Failed to parse "code" constant'); end; function ExpandDriveConst(C: String): String; begin Delete(C, 1, 6); { skip past 'drive:' } if ConvertConstPercentStr(C) then begin Result := PathExtractDrive(ExpandConstEx(C, CustomConsts)); Exit; end; { it will only reach here if there was a parsing error } InternalError('Failed to parse "drive" constant'); end; function ExpandCustomMessageConst(C: String): String; var I, ArgCount: Integer; MsgName: String; ArgValues: array[0..8] of String; { %1 through %9 } begin Delete(C, 1, 3); { skip past 'cm:' } I := ConstPos(',', C); if I = 0 then MsgName := C else MsgName := Copy(C, 1, I-1); { Prepare arguments. Excess arguments are ignored. } ArgCount := 0; while (I > 0) and (ArgCount <= High(ArgValues)) do begin Delete(C, 1, I); I := ConstPos(',', C); if I = 0 then ArgValues[ArgCount] := C else ArgValues[ArgCount] := Copy(C, 1, I-1); if not ConvertConstPercentStr(ArgValues[ArgCount]) then InternalError('Failed to parse "cm" constant'); ArgValues[ArgCount] := ExpandConstEx(ArgValues[ArgCount], CustomConsts); Inc(ArgCount); end; { Look up the message value } if not GetCustomMessageValue(MsgName, Result) then InternalError(Format('Unknown custom message name "%s" in "cm" constant', [MsgName])); { Expand the message } Result := FmtMessage(PChar(Result), Slice(ArgValues, ArgCount)); end; const FolderConsts: array[Boolean, TShellFolderID] of String = ( { Also see FolderIDs } { User } ('userdesktop', 'userstartmenu', 'userprograms', 'userstartup', 'usersendto', 'commonfonts', 'userappdata', 'userdocs', 'usertemplates', 'userfavorites', 'localappdata', 'userpf', 'usercf', 'usersavedgames'), { Common } ('commondesktop', 'commonstartmenu', 'commonprograms', 'commonstartup', 'usersendto', 'commonfonts', 'commonappdata', 'commondocs', 'commontemplates', 'commonfavorites' { not accepted anymore by the compiler }, '', '', '', '')); NoUninstallConsts: array[0..6] of String = ('src', 'srcexe', 'userinfoname', 'userinfoorg', 'userinfoserial', 'hwnd', 'wizardhwnd'); var OriginalCnst, ShellFolder: String; Common: Boolean; ShellFolderID: TShellFolderID; I: Integer; begin OriginalCnst := Cnst; HandleRenamedConstants(Cnst, nil); HandleAutoConstants(Cnst); if IsUninstaller then for I := Low(NoUninstallConsts) to High(NoUninstallConsts) do if NoUninstallConsts[I] = Cnst then NoUninstallConstError(NoUninstallConsts[I]); if Cnst = '\' then Result := '\' else if Cnst = 'app' then begin if IsUninstaller then begin if UninstallExpandedApp = '' then InternalError('An attempt was made to expand the "' + OriginalCnst + '" constant but Setup didn''t create the "app" dir'); Result := UninstallExpandedApp; end else begin if WizardDirValue = '' then InternalError('An attempt was made to expand the "' + OriginalCnst + '" constant before it was initialized'); Result := WizardDirValue; end; end else if Cnst = 'win' then Result := WinDir else if Cnst = 'sys' then Result := WinSystemDir else if Cnst = 'syswow64' then begin if WinSysWow64Dir <> '' then Result := WinSysWow64Dir else begin if IsWin64 then { sanity check } InternalError('Cannot expand "' + OriginalCnst + '" constant because there is no SysWOW64 directory'); Result := WinSystemDir; end; end else if Cnst = 'sysnative' then begin if WinSysNativeDir <> '' then Result := WinSysNativeDir else Result := WinSystemDir; end else if Cnst = 'src' then Result := SourceDir else if Cnst = 'srcexe' then Result := SetupLdrOriginalFilename else if Cnst = 'tmp' then Result := TempInstallDir else if Cnst = 'sd' then Result := SystemDrive else if Cnst = 'commonpf' then begin if Is64BitInstallMode then Result := ProgramFiles64Dir else Result := ProgramFiles32Dir; end else if Cnst = 'commoncf' then begin if Is64BitInstallMode then Result := CommonFiles64Dir else Result := CommonFiles32Dir; end else if Cnst = 'commonpf32' then Result := ProgramFiles32Dir else if Cnst = 'commoncf32' then Result := CommonFiles32Dir else if Cnst = 'commonpf64' then begin if IsWin64 then Result := ProgramFiles64Dir else InternalError('Cannot expand "' + OriginalCnst + '" constant on this version of Windows'); end else if Cnst = 'commoncf64' then begin if IsWin64 then Result := CommonFiles64Dir else InternalError('Cannot expand "' + OriginalCnst + '" constant on this version of Windows'); end else if Cnst = 'userfonts' then Result := ExpandConst('{localappdata}\Microsoft\Windows\Fonts') { supported by Windows 10 Version 1803 and newer. doesn't have a KNOWNFOLDERID. } else if Cnst = 'dao' then Result := ExpandConst('{cf}\Microsoft Shared\DAO') else if Cnst = 'cmd' then Result := CmdFilename else if Cnst = 'computername' then Result := GetComputerNameString else if Cnst = 'username' then Result := GetUserNameString else if Cnst = 'groupname' then begin if IsUninstaller then begin if UninstallExpandedGroupName = '' then InternalError('Cannot expand "' + OriginalCnst + '" constant because it was not available at install time'); Result := UninstallExpandedGroupName; end else begin if WizardGroupValue = '' then InternalError('An attempt was made to expand the "' + OriginalCnst + '" constant before it was initialized'); Result := WizardGroupValue; end; end else if Cnst = 'sysuserinfoname' then Result := SysUserInfoName else if Cnst = 'sysuserinfoorg' then Result := SysUserInfoOrg else if Cnst = 'userinfoname' then Result := WizardUserInfoName else if Cnst = 'userinfoorg' then Result := WizardUserInfoOrg else if Cnst = 'userinfoserial' then Result := WizardUserInfoSerial else if Cnst = 'uninstallexe' then Result := UninstallExeFilename else if Cnst = 'group' then begin if IsUninstaller then begin if UninstallExpandedGroup = '' then InternalError('Cannot expand "' + OriginalCnst + '" constant because it was not available at install time'); Result := UninstallExpandedGroup; end else begin if WizardGroupValue = '' then InternalError('An attempt was made to expand the "' + OriginalCnst + '" constant before it was initialized'); ShellFolder := GetShellFolder(not(shAlwaysUsePersonalGroup in SetupHeader.Options) and IsAdminInstallMode, sfPrograms); if ShellFolder = '' then InternalError('Failed to expand "' + OriginalCnst + '" constant'); Result := AddBackslash(ShellFolder) + WizardGroupValue; end; end else if Cnst = 'language' then begin if IsUninstaller then Result := UninstallExpandedLanguage else Result := PSetupLanguageEntry(Entries[seLanguage][ActiveLanguage]).Name end else if Cnst = 'wizardhwnd' then begin if Assigned(WizardForm) then Result := Format('%d', [UInt32(WizardForm.Handle)]) else Result := '0'; end else if Cnst = 'log' then Result := GetLogFileName else if Cnst = 'dotnet11' then Result := GetDotNetVersionInstallRoot(rv32Bit, netbase11) else if Cnst = 'dotnet20' then Result := GetDotNetVersionInstallRoot(InstallDefaultRegView, netbase20) else if Cnst = 'dotnet2032' then Result := GetDotNetVersionInstallRoot(rv32Bit, netbase20) else if Cnst = 'dotnet2064' then begin if IsWin64 then Result := GetDotNetVersionInstallRoot(rv64Bit, netbase20) else InternalError('Cannot expand "' + OriginalCnst + '" constant on this version of Windows'); end else if Cnst = 'dotnet40' then Result := GetDotNetVersionInstallRoot(InstallDefaultRegView, netbase40) else if Cnst = 'dotnet4032' then Result := GetDotNetVersionInstallRoot(rv32Bit, netbase40) else if Cnst = 'dotnet4064' then begin if IsWin64 then Result := GetDotNetVersionInstallRoot(rv64Bit, netbase40) else InternalError('Cannot expand "' + OriginalCnst + '" constant on this version of Windows'); end else if (Cnst <> '') and (Cnst[1] = '%') then Result := ExpandEnvConst(Cnst) else if StrLComp(PChar(Cnst), 'reg:', 4) = 0 then Result := ExpandRegConst(Cnst) else if StrLComp(PChar(Cnst), 'ini:', 4) = 0 then Result := ExpandIniConst(Cnst) else if StrLComp(PChar(Cnst), 'param:', 6) = 0 then Result := ExpandParamConst(Cnst) else if StrLComp(PChar(Cnst), 'code:', 5) = 0 then Result := ExpandCodeConst(Cnst) else if StrLComp(PChar(Cnst), 'drive:', 6) = 0 then Result := ExpandDriveConst(Cnst) else if StrLComp(PChar(Cnst), 'cm:', 3) = 0 then Result := ExpandCustomMessageConst(Cnst) else begin { Shell folder constants } if Cnst <> '' then for Common := False to True do for ShellFolderID := Low(ShellFolderID) to High(ShellFolderID) do if Cnst = FolderConsts[Common, ShellFolderID] then begin ShellFolder := GetShellFolder(Common, ShellFolderID); if ShellFolder = '' then InternalError(Format('Failed to expand shell folder constant "%s"', [OriginalCnst])); Result := ShellFolder; Exit; end; { Custom constants } if Cnst <> '' then begin I := 0; while I < High(CustomConsts) do begin if Cnst = CustomConsts[I] then begin Result := CustomConsts[I+1]; Exit; end; Inc(I, 2); end; end; { Unknown constant } InternalError(Format('Unknown constant "%s"', [OriginalCnst])); end; end; function ExpandConst(const S: String): String; begin Result := ExpandConstEx2(S, [''], True); end; function ExpandConstEx(const S: String; const CustomConsts: array of String): String; begin Result := ExpandConstEx2(S, CustomConsts, True); end; function ExpandConstEx2(const S: String; const CustomConsts: array of String; const DoExpandIndividualConst: Boolean): String; var I, Start: Integer; Cnst, ReplaceWith: String; begin Result := S; I := 1; while I <= Length(Result) do begin if Result[I] = '{' then begin if (I < Length(Result)) and (Result[I+1] = '{') then begin { Change '{{' to '{' if not in an embedded constant } Inc(I); Delete(Result, I, 1); end else begin Start := I; { Find the closing brace, skipping over any embedded constants } I := SkipPastConst(Result, I); if I = 0 then { unclosed constant? } InternalError('Unclosed constant'); Dec(I); { 'I' now points to the closing brace } if DoExpandIndividualConst then begin { Now translate the constant } Cnst := Copy(Result, Start+1, I-(Start+1)); ReplaceWith := ExpandIndividualConst(Cnst, CustomConsts); Delete(Result, Start, (I+1)-Start); Insert(ReplaceWith, Result, Start); I := Start + Length(ReplaceWith); if (ReplaceWith <> '') and (PathLastChar(ReplaceWith)^ = '\') and (I <= Length(Result)) and (Result[I] = '\') then Delete(Result, I, 1); end else Inc(I); { Skip closing brace } end; end else Inc(I); end; end; function ExpandConstIfPrefixed(const S: String): String; const ExpandPrefix = 'expand:'; begin if Pos(ExpandPrefix, S) = 1 then begin Inc(DisableCodeConsts); try Result := ExpandConst(Copy(S, Length(ExpandPrefix)+1, Maxint)); finally Dec(DisableCodeConsts); end; end else Result := S; end; procedure InitMainNonSHFolderConsts; function GetPath(const RegView: TRegView; const Name: PChar): String; var H: HKEY; begin if RegOpenKeyExView(RegView, HKEY_LOCAL_MACHINE, REGSTR_PATH_SETUP, 0, KEY_QUERY_VALUE, H) = ERROR_SUCCESS then begin if not RegQueryStringValue(H, Name, Result) then Result := ''; RegCloseKey(H); end else Result := ''; end; procedure ReadSysUserInfo; var RegView: TRegView; K: HKEY; begin { Windows 7 x64 (and later?) is bugged: the owner and organization are set to "Microsoft" on the 32-bit key. So on 64-bit Windows, read from the 64-bit key. (The bug doesn't exist on 64-bit XP or Server 2003, but it's safe to read the 64-bit key on those versions too.) } if IsWin64 then RegView := rv64Bit else RegView := rvDefault; if RegOpenKeyExView(RegView, HKEY_LOCAL_MACHINE, 'SOFTWARE\Microsoft\Windows NT\CurrentVersion', 0, KEY_QUERY_VALUE, K) = ERROR_SUCCESS then begin RegQueryStringValue(K, 'RegisteredOwner', SysUserInfoName); RegQueryStringValue(K, 'RegisteredOrganization', SysUserInfoOrg); RegCloseKey(K); end; end; begin { Read Windows and Windows System dirs } WinDir := GetWinDir; WinSystemDir := GetSystemDir; WinSysWow64Dir := GetSysWow64Dir; WinSysNativeDir := GetSysNativeDir(IsWin64); { Get system drive } SystemDrive := GetEnv('SystemDrive'); {don't localize} if SystemDrive = '' then begin SystemDrive := PathExtractDrive(WinDir); if SystemDrive = '' then { In some rare case that PathExtractDrive failed, just default to C } SystemDrive := 'C:'; end; { Get 32-bit Program Files and Common Files dirs } ProgramFiles32Dir := GetPath(rv32Bit, 'ProgramFilesDir'); if ProgramFiles32Dir = '' then ProgramFiles32Dir := SystemDrive + '\Program Files'; {don't localize} CommonFiles32Dir := GetPath(rv32Bit, 'CommonFilesDir'); if CommonFiles32Dir = '' then CommonFiles32Dir := AddBackslash(ProgramFiles32Dir) + 'Common Files'; {don't localize} { Get 64-bit Program Files and Common Files dirs } if IsWin64 then begin ProgramFiles64Dir := GetPath(rv64Bit, 'ProgramFilesDir'); if ProgramFiles64Dir = '' then InternalError('Failed to get path of 64-bit Program Files directory'); CommonFiles64Dir := GetPath(rv64Bit, 'CommonFilesDir'); if CommonFiles64Dir = '' then InternalError('Failed to get path of 64-bit Common Files directory'); end; { Get path of command interpreter } CmdFilename := AddBackslash(WinSystemDir) + 'cmd.exe'; { Get user info from system } ReadSysUserInfo; end; procedure SaveStreamToTempFile(const Strm: TCustomMemoryStream; const Filename: String); var ErrorCode: DWORD; begin try Strm.SaveToFile(Filename); except { Display more useful error message than 'Stream write error' etc. } on EStreamError do begin ErrorCode := GetLastError; raise Exception.Create(FmtSetupMessage(msgLastErrorMessage, [SetupMessages[msgLdrCannotCreateTemp], IntToStr(ErrorCode), Win32ErrorString(ErrorCode)])); end; end; end; procedure SaveResourceToTempFile(const ResName, Filename: String); var ResStrm: TResourceStream; begin ResStrm := TResourceStream.Create(HInstance, ResName, RT_RCDATA); try SaveStreamToTempFile(ResStrm, Filename); finally ResStrm.Free; end; end; procedure DeleteResidualTempUninstallDirs; var SelfExeFilename: String; function IsAttrDirectoryAndNotReparsePoint(const Attr: DWORD): Boolean; begin Result := (Attr and (FILE_ATTRIBUTE_DIRECTORY or FILE_ATTRIBUTE_REPARSE_POINT)) = FILE_ATTRIBUTE_DIRECTORY; end; function IsRecentFileTime(const AFileTime: TFileTime): Boolean; const ThresholdSecs = 5 * 60; { 5 minutes } begin var NowTime: TFileTime; GetSystemTimeAsFileTime(NowTime); const A = FileTimeToUInt64(AFileTime); const B = FileTimeToUInt64(NowTime); { Past and future times are both considered recent } var Diff: UInt64; if A > B then Diff := A - B else Diff := B - A; Result := Diff < ThresholdSecs * UInt64(10000000); end; function TryDeleteUninstallDir(const ADir: String): Boolean; begin Result := False; const UninsExeFilename = ADir + '\_unins.tmp'; { Quick out if it's our own process's directory } if PathSame(UninsExeFilename, SelfExeFilename) then Exit; { Open handle to the directory. This serves two purposes: - Avoid TOCTOU race in the reparse point check: We checked the attributes returned by FindFirstFile/FindNextFile, but it's *possible* that the directory was replaced with a reparse point (or a file) between then and now. By passing only FILE_SHARE_READ for the sharing mode, we block other processes from deleting the directory or changing it into a reparse point in-place. We can then re-check the attributes with no worries of them changing afterward, as long as the handle remains open. - It functions like a mutex: If two processes enter this function concurrently for the same directory, this CreateFile call will only succeed in one of them. The other will fail with ERROR_SHARING_VIOLATION, because FILE_SHARE_READ doesn't allow another handle to be opened for DELETE access. The docs for GetFileInformationByHandle (called below) don't specify what access rights, if any, are required. Even though the function succeeds with only DELETE access on Windows 11, we also include FILE_READ_ATTRIBUTES to be sure we aren't depending on undocumented implementation details. } const DirHandle = CreateFile(PChar(ADir), Windows._DELETE or FILE_READ_ATTRIBUTES, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT or FILE_FLAG_BACKUP_SEMANTICS, 0); if DirHandle <> INVALID_HANDLE_VALUE then begin try var Info: TByHandleFileInformation; if GetFileInformationByHandle(DirHandle, Info) and IsAttrDirectoryAndNotReparsePoint(Info.dwFileAttributes) then begin { Try to open _unins-done.tmp, which is an empty file created by Uninstall to signal to us that the directory needs deleting. It also serves as a lock: if the file exists, but opening it fails with ERROR_SHARING_VIOLATION, that means the Uninstall process is still running, so we shouldn't try to delete the directory at this time. (Uninstall holds the file open until it terminates, allowing only FILE_SHARE_READ sharing, which conflicts with the request for DELETE access here.) } const DoneFileHandle = CreateFile(PChar(ADir + '\_unins-done.tmp'), Windows._DELETE, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT, 0); if DoneFileHandle <> INVALID_HANDLE_VALUE then begin try Result := Windows.DeleteFile(PChar(UninsExeFilename)); if Result then begin LogFmt('Deleted file: %s', [UninsExeFilename]); if not DeleteFileOrDirByHandle(DoneFileHandle) then LogWithLastError('Failed to delete "_unins-done.tmp".'); end; finally CloseHandle(DoneFileHandle); end; end; { Try to remove the directory (if empty) in two cases: - If we just deleted files from it. (Any failure is logged.) - If it wasn't modified recently. It could be an empty directory that this function couldn't remove before because an AV or other process was holding handles to the directory or now-deleted files inside. Or, it could be an empty directory that Uninstall's RunFirstPhase couldn't remove because this function was running concurrently in another process and had it open (an unlikely race). The time check prevents removal of a directory that a concurrently-running Uninstall process just created (also an unlikely race). The time check is intentionally done first (often unnecessarily) just to ensure that code path gets regularly exercised. } if not IsRecentFileTime(Info.ftLastWriteTime) or Result then if not DeleteFileOrDirByHandle(DirHandle) then if Result then LogWithLastError('Failed to remove directory.'); end; finally CloseHandle(DirHandle); end; end; end; begin Log('Cleaning up any residual temporary files from previous Uninstall runs.'); SelfExeFilename := NewParamStr(0); var NumDirsFound: Cardinal := 0; var NumDirsChecked: Cardinal := 0; var NumFilesDeleted: Cardinal := 0; const ParentDir = AddBackslash(GetTempDir); var FindData: TWin32FindData; const H = FindFirstFile(PChar(ParentDir + 'is-*-uninstall.tmp'), FindData); if H = INVALID_HANDLE_VALUE then begin if GetLastError <> ERROR_FILE_NOT_FOUND then LogWithLastError('Failed to list directory.'); end else begin try var TimeLimitReached := False; var TimeLimitTimer: TOneShotTimer; TimeLimitTimer.Start(3000); repeat if IsAttrDirectoryAndNotReparsePoint(FindData.dwFileAttributes) then begin const BaseName: String = FindData.cFileName; { Scrutinize the name further } const SS = TStringScanner.Create(PathLowercase(BaseName)); const MatchingName = SS.Consume('is-') and (SS.ConsumeMulti(['0'..'9', 'a'..'z'], False, 10, 20) > 0) and SS.Consume('-uninstall.tmp') and SS.ReachedEnd; if MatchingName then begin Inc(NumDirsFound); if not TimeLimitReached then begin if (NumDirsChecked >= 10) and TimeLimitTimer.Expired then begin TimeLimitReached := True; Log('Stopping cleanup because it''s taking too long (>3s).'); end else begin Inc(NumDirsChecked); if TryDeleteUninstallDir(ParentDir + BaseName) then Inc(NumFilesDeleted); end; end; end; end; until not FindNextFile(H, FindData); finally Windows.FindClose(H); end; end; LogFmt('Cleanup finished (%u directories found, %u directories checked, %u files deleted).', [NumDirsFound, NumDirsChecked, NumFilesDeleted]); end; procedure CreateTempInstallDirAndExtract64BitHelper; { Initializes TempInstallDir and extracts the 64-bit helper into it if needed. This is called by Setup, Uninstall, and RegSvr. } begin var Protected: Boolean; TempInstallDir := CreateTempDir('.tmp', IsAdmin and not Debugging, Protected); LogFmt('Created %stemporary directory: %s', [IfThen(Protected, 'protected ', ''), TempInstallDir]); if Debugging then DebugNotifyTempDir(TempInstallDir); { Create _isetup subdirectory to hold our internally-used files to ensure they won't use any DLLs the install creator might've dumped into TempInstallDir } var Subdir := AddBackslash(TempInstallDir) + '_isetup'; if not CreateDirectory(PChar(Subdir), nil) then begin var ErrorCode := GetLastError; raise Exception.Create(FmtSetupMessage(msgLastErrorMessage, [FmtSetupMessage1(msgErrorCreatingDir, Subdir), IntToStr(ErrorCode), Win32ErrorString(ErrorCode)])); end; { Extract 64-bit helper EXE, if one is available for the current processor architecture } var ResName := GetHelperResourceName; if ResName <> '' then begin var Filename := Subdir + '\_setup64.tmp'; SaveResourceToTempFile(ResName, Filename); SetHelperExeFilename(Filename); end; end; function TempDeleteFileProc(const DisableFsRedir: Boolean; const FileName: String; const Param: Pointer): Boolean; var Elapsed: DWORD; label Retry; begin Retry: Result := DeleteFileRedir(DisableFsRedir, FileName); if not Result and (GetLastError <> ERROR_FILE_NOT_FOUND) and (GetLastError <> ERROR_PATH_NOT_FOUND) then begin { If we get here, the file is probably still in use. On an SMP machine, it's possible for an EXE to remain locked by Windows for a short time after it terminates, causing DeleteFile to fail with ERROR_ACCESS_DENIED. (I'm not sure this issue can really be seen here in practice; I could only reproduce it consistently by calling DeleteFile() *immediately* after waiting on the process handle.) Retry if fewer than 2 seconds have passed since DelTree started, otherwise assume the error must be permanent and give up. 2 seconds ought to be more than enough for the SMP case. } Elapsed := GetTickCount - DWORD(Param); if Cardinal(Elapsed) < Cardinal(2000) then begin Sleep(50); goto Retry; end; end; end; procedure RemoveTempInstallDir; { Removes TempInstallDir and all its contents. Stops the 64-bit helper first if necessary. } begin { Stop 64-bit helper if it's running } StopHelper(False); SetHelperExeFilename(''); if TempInstallDir <> '' then begin if Debugging then DebugNotifyTempDir(''); if not DelTree(False, TempInstallDir, True, True, True, False, nil, TempDeleteFileProc, Pointer(GetTickCount())) then Log('Failed to remove temporary directory: ' + TempInstallDir); end; end; procedure LoadSHFolderDLL; var Filename: String; const shfolder = 'shfolder.dll'; begin Filename := AddBackslash(GetSystemDir) + shfolder; { Ensure shell32.dll is pre-loaded so it isn't loaded/freed for each individual SHGetFolderPath call } SafeLoadLibrary(AddBackslash(GetSystemDir) + shell32, SEM_NOOPENFILEERRORBOX); SHFolderDLLHandle := SafeLoadLibrary(Filename, SEM_NOOPENFILEERRORBOX); if SHFolderDLLHandle = 0 then InternalError(Format('Failed to load DLL "%s"', [Filename])); @SHGetFolderPathFunc := GetProcAddress(SHFolderDLLHandle, 'SHGetFolderPathW'); if @SHGetFolderPathFunc = nil then InternalError('Failed to get address of SHGetFolderPath function'); end; procedure UnloadSHFolderDLL; begin @SHGetFolderPathFunc := nil; if SHFolderDLLHandle <> 0 then begin FreeLibrary(SHFolderDLLHandle); SHFolderDLLHandle := 0; end; end; function GetShellFolderByCSIDL(Folder: Integer; const Create: Boolean): String; const CSIDL_FLAG_CREATE = $8000; SHGFP_TYPE_CURRENT = 0; var Res: HRESULT; Buf: array[0..MAX_PATH-1] of Char; begin { Note: Must pass Create=True or else SHGetFolderPath fails if the specified CSIDL is valid but doesn't currently exist. } if Create then Folder := Folder or CSIDL_FLAG_CREATE; { Work around a nasty bug in Windows Vista and Windows Server 2008 and maybe later versions also: When a folder ID resolves to the root directory of a drive ('X:\') and the CSIDL_FLAG_CREATE flag is passed, SHGetFolderPath fails with code 0x80070005. So, first try calling the function without CSIDL_FLAG_CREATE. If and only if that fails, call it again with the flag. Note: The calls *must* be issued in this order; if it's called with the flag first, it seems to permanently cache the failure code, causing future calls that don't include the flag to fail as well. } if Folder and CSIDL_FLAG_CREATE <> 0 then Res := SHGetFolderPathFunc(0, Folder and not CSIDL_FLAG_CREATE, 0, SHGFP_TYPE_CURRENT, Buf) else Res := E_FAIL; { always issue the call below } if Res <> S_OK then Res := SHGetFolderPathFunc(0, Folder, 0, SHGFP_TYPE_CURRENT, Buf); if Res = S_OK then Result := RemoveBackslashUnlessRoot(PathExpand(Buf)) else begin Result := ''; LogFmt('Warning: SHGetFolderPath failed with code 0x%.8x on folder 0x%.4x', [Res, Folder]); end; end; function GetShellFolderByGUID(Folder: TGUID; const Create: Boolean): String; begin if Assigned(SHGetKnownFolderPathFunc) then begin var dwFlags: DWORD := 0; if Create then dwFlags := dwFlags or KF_FLAG_CREATE; var Path: PWideChar; { Note: Must pass Create=True or else SHGetKnownFolderPath fails if the specified GUID is valid but doesn't currently exist. } var Res := SHGetKnownFolderPathFunc(Folder, dwFlags, 0, Path); if Res = S_OK then begin Result := WideCharToString(Path); CoTaskMemFree(Path); end else begin Result := ''; LogFmt('Warning: SHGetKnownFolderPath failed with code 0x%.8x', [Res]); end; end else Result := ''; end; function GetShellFolder(const Common: Boolean; const ID: TShellFolderID): String; const CSIDL_COMMON_STARTMENU = $0016; CSIDL_COMMON_PROGRAMS = $0017; CSIDL_COMMON_STARTUP = $0018; CSIDL_COMMON_DESKTOPDIRECTORY = $0019; CSIDL_APPDATA = $001A; CSIDL_LOCAL_APPDATA = $001C; CSIDL_COMMON_FAVORITES = $001F; CSIDL_COMMON_APPDATA = $0023; CSIDL_COMMON_TEMPLATES = $002D; CSIDL_COMMON_DOCUMENTS = $002E; FolderIDs: array[Boolean, TShellFolderID] of Integer = ( { Values must match FolderConsts } { User } (CSIDL_DESKTOPDIRECTORY, CSIDL_STARTMENU, CSIDL_PROGRAMS, CSIDL_STARTUP, CSIDL_SENDTO, CSIDL_FONTS, CSIDL_APPDATA, CSIDL_PERSONAL, CSIDL_TEMPLATES, CSIDL_FAVORITES, CSIDL_LOCAL_APPDATA, 0, 0, 0), { Common } (CSIDL_COMMON_DESKTOPDIRECTORY, CSIDL_COMMON_STARTMENU, CSIDL_COMMON_PROGRAMS, CSIDL_COMMON_STARTUP, CSIDL_SENDTO, CSIDL_FONTS, CSIDL_COMMON_APPDATA, CSIDL_COMMON_DOCUMENTS, CSIDL_COMMON_TEMPLATES, CSIDL_COMMON_FAVORITES, 0, 0, 0, 0)); FOLDERID_UserProgramFiles: TGUID = (D1:$5CD7AEE2; D2:$2219; D3:$4A67; D4:($B8,$5D,$6C,$9C,$E1,$56,$60,$CB)); FOLDERID_UserProgramFilesCommon: TGUID = (D1:$BCBD3057; D2:$CA5C; D3:$4622; D4:($B4,$2D,$BC,$56,$DB,$0A,$E5,$16)); FOLDERID_SavedGames: TGUID = (D1:$4C5C32FF; D2:$BB9D; D3:$43B0; D4:($B5,$B4,$2D,$72,$E5,$4E,$AA,$A4)); var ShellFolder: String; begin if not ShellFoldersRead[Common, ID] then begin if ID = sfUserProgramFiles then begin ShellFolder := GetShellFolderByGUID(FOLDERID_UserProgramFiles, True); if ShellFolder = '' then { should happen on Wine only } ShellFolder := ExpandConst('{localappdata}\Programs'); { supply default, same as Windows } end else if ID = sfUserCommonFiles then begin ShellFolder := GetShellFolderByGUID(FOLDERID_UserProgramFilesCommon, True); if ShellFolder = '' then { should happen on Wine only } ShellFolder := ExpandConst('{localappdata}\Programs\Common'); { supply default, same as Windows } end else if ID = sfUserSavedGames then ShellFolder := GetShellFolderByGUID(FOLDERID_SavedGames, True) else ShellFolder := GetShellFolderByCSIDL(FolderIDs[Common, ID], True); ShellFolders[Common, ID] := ShellFolder; ShellFoldersRead[Common, ID] := True; end; Result := ShellFolders[Common, ID]; end; function InstallOnThisVersion(const MinVersion: TSetupVersionData; const OnlyBelowVersion: TSetupVersionData): TInstallOnThisVersionResult; var Ver, Ver2, MinVer, OnlyBelowVer: Cardinal; begin Ver := WindowsVersion; MinVer := MinVersion.NTVersion; OnlyBelowVer := OnlyBelowVersion.NTVersion; Result := irInstall; if MinVer = 0 then Result := irNotOnThisPlatform else begin if Ver < MinVer then Result := irVersionTooLow else if (LongRec(Ver).Hi = LongRec(MinVer).Hi) and (NTServicePackLevel < MinVersion.NTServicePack) then Result := irServicePackTooLow else begin if OnlyBelowVer <> 0 then begin Ver2 := Ver; { A build number of 0 on OnlyBelowVersion means 'match any build' } if LongRec(OnlyBelowVer).Lo = 0 then Ver2 := Ver2 and $FFFF0000; { set build number to zero on Ver2 also } { Note: When OnlyBelowVersion includes a service pack level, the version number test changes from a "<" to "<=" operation. Thus, on Windows 2000 SP4, 5.0 and 5.0.2195 will fail, but 5.0sp5 and 5.0.2195sp5 will pass. } if (Ver2 > OnlyBelowVer) or ((Ver2 = OnlyBelowVer) and (OnlyBelowVersion.NTServicePack = 0)) or ((LongRec(Ver).Hi = LongRec(OnlyBelowVer).Hi) and (OnlyBelowVersion.NTServicePack <> 0) and (NTServicePackLevel >= OnlyBelowVersion.NTServicePack)) then Result := irVerTooHigh; end; end; end; end; function GetSizeOfComponent(const ComponentName: String; const ExtraDiskSpaceRequired: Int64): Int64; var ComponentNameAsList: TStringList; FileEntry: PSetupFileEntry; begin Result := ExtraDiskSpaceRequired; ComponentNameAsList := TStringList.Create(); try ComponentNameAsList.Add(ComponentName); for var I := 0 to Entries[seFile].Count-1 do begin FileEntry := PSetupFileEntry(Entries[seFile][I]); with FileEntry^ do begin if (Components <> '') and ((Tasks = '') and (Check = '')) then begin {don't count tasks or scripted entries} if ShouldProcessFileEntry(ComponentNameAsList, nil, FileEntry, True) then begin if LocationEntry <> -1 then Inc(Result, PSetupFileLocationEntry(Entries[seFileLocation][LocationEntry])^.OriginalSize) else Inc(Result, ExternalSize); end; end; end; end; finally ComponentNameAsList.Free(); end; end; function GetSizeOfType(const TypeName: String; const IsCustom: Boolean): Int64; var ComponentTypes: TStringList; begin Result := 0; ComponentTypes := TStringList.Create(); for var I := 0 to Entries[seComponent].Count-1 do begin with PSetupComponentEntry(Entries[seComponent][I])^ do begin SetStringsFromCommaString(ComponentTypes, Types); { For custom types, only count fixed components. Otherwise count all. } if IsCustom then begin if (coFixed in Options) and ListContains(ComponentTypes, TypeName) then Inc(Result, Size); end else begin if ListContains(ComponentTypes, TypeName) then Inc(Result, Size); end; end; end; ComponentTypes.Free(); end; function IsRecurseableDirectory(const FindData: TWin32FindData): Boolean; { Returns True if FindData is a directory that may be recursed into. Intended only for use when processing external+recursesubdirs file entries. } begin Result := (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0) and (FindData.dwFileAttributes and FILE_ATTRIBUTE_HIDDEN = 0) and (StrComp(FindData.cFileName, '.') <> 0) and (StrComp(FindData.cFileName, '..') <> 0); end; type TEnumFilesProc = function(const DisableFsRedir: Boolean; const Filename: String; const Param: Pointer): Boolean; function DummyDeleteDirProc(const DisableFsRedir: Boolean; const Filename: String; const Param: Pointer): Boolean; begin { We don't actually want to delete the dir, so just return success. } Result := True; end; { Enumerates the files we're going to install and delete. Returns True on success. Likewise EnumFilesProc should return True on success and return False to break the enum and to cause EnumFiles to return False instead of True. } function EnumFiles(const EnumFilesProc: TEnumFilesProc; const WizardComponents, WizardTasks: TStringList; const Param: Pointer): Boolean; function RecurseExternalFiles(const DisableFsRedir: Boolean; const SearchBaseDir, SearchSubDir, SearchWildcard: String; const SourceIsWildcard: Boolean; const Excludes: TStrings; const CurFile: PSetupFileEntry): Boolean; begin { Also see RecurseExternalGetSizeOfFiles below and RecurseExternalCopyFiles in Setup.Install Also see RecurseExternalArchiveFiles directly below } Result := True; var FindData: TWin32FindData; var H := FindFirstFileRedir(DisableFsRedir, SearchBaseDir + SearchSubDir + SearchWildcard, FindData); if H <> INVALID_HANDLE_VALUE then begin try repeat if FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then begin if SourceIsWildcard then if FindData.dwFileAttributes and FILE_ATTRIBUTE_HIDDEN <> 0 then Continue; if IsExcluded(SearchSubDir + FindData.cFileName, Excludes) then Continue; { Note: CurFile^.DestName only includes a a filename if foCustomDestName is set, see TSetupCompiler.EnumFilesProc.ProcessFileList } var DestFile := ExpandConst(CurFile^.DestName); if not(foCustomDestName in CurFile^.Options) then DestFile := DestFile + SearchSubDir + FindData.cFileName else if SearchSubDir <> '' then DestFile := PathExtractPath(DestFile) + SearchSubDir + PathExtractName(DestFile); if not EnumFilesProc(DisableFsRedir, DestFile, Param) then begin Result := False; Exit; end; end; until not FindNextFile(H, FindData); finally Windows.FindClose(H); end; end; if foRecurseSubDirsExternal in CurFile^.Options then begin H := FindFirstFileRedir(DisableFsRedir, SearchBaseDir + SearchSubDir + '*', FindData); if H <> INVALID_HANDLE_VALUE then begin try repeat if IsRecurseableDirectory(FindData) then if not RecurseExternalFiles(DisableFsRedir, SearchBaseDir, SearchSubDir + FindData.cFileName + '\', SearchWildcard, SourceIsWildcard, Excludes, CurFile) then Exit(False); until not FindNextFile(H, FindData); finally Windows.FindClose(H); end; end; end; end; function RecurseExternalArchiveFiles(const DisableFsRedir: Boolean; const ArchiveFilename: String; const Excludes: TStrings; const CurFile: PSetupFileEntry): Boolean; begin { See above } Result := True; if not NewFileExistsRedir(DisableFsRedir, ArchiveFilename) then Exit; if foCustomDestName in CurFile^.Options then InternalError('Unexpected CustomDestName flag'); const DestDir = ExpandConst(CurFile^.DestName); var FindData: TWin32FindData; var H := ArchiveFindFirstFileRedir(DisableFsRedir, ArchiveFilename, DestDir, ExpandConst(CurFile^.ExtractArchivePassword), foRecurseSubDirsExternal in CurFile^.Options, False, FindData); if H <> INVALID_HANDLE_VALUE then begin try repeat if FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then begin if IsExcluded(FindData.cFileName, Excludes) then Continue; const DestFile = DestDir + FindData.cFileName; if not EnumFilesProc(DisableFsRedir, DestFile, Param) then Exit(False); end; until not ArchiveFindNextFile(H, FindData); finally ArchiveFindClose(H); end; end; end; var CurFile: PSetupFileEntry; DisableFsRedir: Boolean; SourceWildcard: String; begin Result := True; { [Files] } const Excludes = TStringList.Create; try Excludes.StrictDelimiter := True; Excludes.Delimiter := ','; for var I := 0 to Entries[seFile].Count-1 do begin CurFile := PSetupFileEntry(Entries[seFile][I]); if (CurFile^.FileType = ftUserFile) and ShouldProcessFileEntry(WizardComponents, WizardTasks, CurFile, False) then begin DisableFsRedir := ShouldDisableFsRedirForFileEntry(CurFile); if CurFile^.LocationEntry <> -1 then begin { Non-external file } if not EnumFilesProc(DisableFsRedir, ExpandConst(CurFile^.DestName), Param) then begin Result := False; Exit; end; end else begin { External file } if foDownload in CurFile^.Options then begin { Archive download should have been done already by Setup.WizardForm's DownloadArchivesToExtract } if foExtractArchive in CurFile^.Options then InternalError('Unexpected Download flag'); if not(foCustomDestName in CurFile^.Options) then InternalError('Expected CustomDestName flag'); { CurFile^.DestName now includes a filename, see TSetupCompiler.EnumFilesProc.ProcessFileList } if not EnumFilesProc(DisableFsRedir, ExpandConst(CurFile^.DestName), Param) then Exit(False); end else begin SourceWildcard := ExpandConst(CurFile^.SourceFilename); Excludes.DelimitedText := CurFile^.Excludes; if foExtractArchive in CurFile^.Options then begin try if not RecurseExternalArchiveFiles(DisableFsRedir, SourceWildcard, Excludes, CurFile) then Exit(False); except on E: ESevenZipError do { Ignore archive errors for now, will show up with proper UI during installation } end; end else begin if not RecurseExternalFiles(DisableFsRedir, PathExtractPath(SourceWildcard), '', PathExtractName(SourceWildcard), IsWildcard(SourceWildcard), Excludes, CurFile) then Exit(False); end; end; end; end; end; finally Excludes.Free; end; { [InstallDelete] } for var I := 0 to Entries[seInstallDelete].Count-1 do with PSetupDeleteEntry(Entries[seInstallDelete][I])^ do if ShouldProcessEntry(WizardComponents, WizardTasks, Components, Tasks, Languages, Check) then begin case DeleteType of dfFiles, dfFilesAndOrSubdirs: if not DelTree(InstallDefaultDisableFsRedir, ExpandConst(Name), False, True, DeleteType = dfFilesAndOrSubdirs, True, DummyDeleteDirProc, EnumFilesProc, Param) then begin Result := False; Exit; end; dfDirIfEmpty: if not DelTree(InstallDefaultDisableFsRedir, ExpandConst(Name), True, False, False, True, DummyDeleteDirProc, EnumFilesProc, Param) then begin Result := False; Exit; end; end; end; end; procedure EnumProc(const Filename: String; Param: Pointer); begin TStringList(Param).Add(PathLowercase(Filename)); end; var CheckForFileSL: TStringList; function CheckForFile(const DisableFsRedir: Boolean; const AFilename: String; const Param: Pointer): Boolean; var Filename: String; J: Integer; begin Filename := AFilename; if not DisableFsRedir then Filename := ReplaceSystemDirWithSysWow64(Filename); Filename := PathLowercase(Filename); for J := 0 to CheckForFileSL.Count-1 do begin if CheckForFileSL[J] = Filename then begin LogFmt('Found pending rename or delete that matches one of our files: %s', [Filename]); Result := False; { Break the enum, just need to know if any matches } Exit; end; end; Result := True; { Success! } end; { Checks if no file we're going to install or delete has a pending rename or delete. } function PreviousInstallCompleted(const WizardComponents, WizardTasks: TStringList): Boolean; begin Result := True; if Entries[seFile].Count = 0 then Exit; CheckForFileSL := TStringList.Create; try EnumFileReplaceOperationsFilenames(EnumProc, CheckForFileSL); if CheckForFileSL.Count = 0 then Exit; Result := EnumFiles(CheckForFile, WizardComponents, WizardTasks, nil); finally CheckForFileSL.Free; end; end; type TArrayOfPWideChar = array[0..(MaxInt div SizeOf(PWideChar))-1] of PWideChar; PArrayOfPWideChar = ^TArrayOfPWideChar; var RegisterFileBatchFilenames: PArrayOfPWideChar; RegisterFileFilenamesBatchMax, RegisterFileFilenamesBatchCount: Integer; function RegisterFile(const DisableFsRedir: Boolean; const AFilename: String; const Param: Pointer): Boolean; var Filename, Text: String; I, Len: Integer; CheckFilter, Match: Boolean; begin Filename := AFilename; { First: check filters and self. } if Filename <> '' then begin CheckFilter := Boolean(Param); if CheckFilter then begin Match := False; Text := PathLowercase(PathExtractName(Filename)); for I := 0 to CloseApplicationsFilterList.Count-1 do begin if WildcardMatch(PChar(Text), PChar(CloseApplicationsFilterList[I])) then begin Match := True; Break; end; end; if Match then begin for I := 0 to CloseApplicationsFilterExcludesList.Count-1 do begin if WildcardMatch(PChar(Text), PChar(CloseApplicationsFilterExcludesList[I])) then begin Match := False; Break; end; end; end; if not Match then begin { No match with filter so exit but don't return an error. } Result := True; Exit; end; end; if PathCompare(Filename, SetupLdrOriginalFilename) = 0 then begin { Don't allow self to be registered but don't return an error. } Result := True; Exit; end; end; { Secondly: check if we need to register this batch, either because the batch is full or because we're done scanning and have leftovers. } if ((Filename <> '') and (RegisterFileFilenamesBatchCount = RegisterFileFilenamesBatchMax)) or ((Filename = '') and (RegisterFileFilenamesBatchCount > 0)) then begin if RmRegisterResources(RmSessionHandle, UINT(RegisterFileFilenamesBatchCount), RegisterFileBatchFilenames, 0, nil, 0, nil) = ERROR_SUCCESS then begin for I := 0 to RegisterFileFilenamesBatchCount-1 do FreeMem(RegisterFileBatchFilenames[I]); RegisterFileFilenamesBatchCount := 0; end else begin RmEndSession(RmSessionHandle); RmSessionStarted := False; end; end; { Finally: add this file to the batch. } if RmSessionStarted and (FileName <> '') then begin { From MSDN: "Installers should not disable file system redirection before calling the Restart Manager API. This means that a 32-bit installer run on 64-bit Windows is unable register a file in the %windir%\system32 directory." This is incorrect, we can register such files by using the Sysnative alias. } if DisableFsRedir then Filename := ReplaceSystemDirWithSysNative(Filename, IsWin64); if InitLogCloseApplications then LogFmt('Found a file to register with RestartManager: %s', [Filename]); Len := Length(Filename); GetMem(RegisterFileBatchFilenames[RegisterFileFilenamesBatchCount], (Len + 1) * SizeOf(RegisterFileBatchFilenames[RegisterFileFilenamesBatchCount][0])); StrPCopy(RegisterFileBatchFilenames[RegisterFileFilenamesBatchCount], Filename); Inc(RegisterFileFilenamesBatchCount); Inc(RmRegisteredFilesCount); end; Result := RmSessionStarted; { Break the enum if there was an error, else continue. } end; { Helper function for [Code] to register extra files. } var AllowCodeRegisterExtraCloseApplicationsResource: Boolean; function CodeRegisterExtraCloseApplicationsResource(const DisableFsRedir: Boolean; const AFilename: String): Boolean; begin if AllowCodeRegisterExtraCloseApplicationsResource then Result := RegisterFile(DisableFsRedir, AFilename, Pointer(False)) else begin InternalError('Cannot call "RegisterExtraCloseApplicationsResource" function at this time'); Result := False; end; end; { Register all files we're going to install or delete. Ends RmSession on errors. } procedure RegisterResourcesWithRestartManager(const WizardComponents, WizardTasks: TStringList); var I: Integer; begin { Note: MSDN says we shouldn't call RmRegisterResources for each file because of speed, but calling it once for all files adds extra memory usage, so calling it in batches. } RegisterFileFilenamesBatchMax := 1000; GetMem(RegisterFileBatchFilenames, RegisterFileFilenamesBatchMax * SizeOf(RegisterFileBatchFilenames[0])); try { Register our files. } RmRegisteredFilesCount := 0; try EnumFiles(RegisterFile, WizardComponents, WizardTasks, Pointer(True)); except Log('EnumFiles(RegisterFile) raised an exception.'); Application.HandleException(nil); end; { Ask [Code] for more files. } if CodeRunner <> nil then begin AllowCodeRegisterExtraCloseApplicationsResource := True; try try CodeRunner.RunProcedures('RegisterExtraCloseApplicationsResources', [''], False); except Log('RegisterExtraCloseApplicationsResources raised an exception.'); Application.HandleException(nil); end; finally AllowCodeRegisterExtraCloseApplicationsResource := False; end; end; { Don't forget to register leftovers. } if RmSessionStarted then RegisterFile(False, '', nil); finally for I := 0 to RegisterFileFilenamesBatchCount-1 do FreeMem(RegisterFileBatchFilenames[I]); FreeMem(RegisterFileBatchFilenames); end; end; procedure DebugNotifyEntry(EntryType: TEntryType; Number: NativeInt); var Kind: TDebugEntryKind; B: Boolean; begin if not Debugging then Exit; case EntryType of seDir: Kind := deDir; seFile: Kind := deFile; seIcon: Kind := deIcon; seIni: Kind := deIni; seRegistry: Kind := deRegistry; seInstallDelete: Kind := deInstallDelete; seUninstallDelete: Kind := deUninstallDelete; seRun: Kind := deRun; seUninstallRun: Kind := deUninstallRun; else Exit; end; DebugNotify(Kind, Integer(OriginalEntryIndexes[EntryType][Number]), B); end; procedure CodeRunnerOnLog(const S: String); begin Log(S); end; procedure CodeRunnerOnLogFmt(const S: String; const Args: array of const); begin LogFmt(S, Args); end; procedure CodeRunnerOnDllImport(var DllName: String; var ForceDelayLoad: Boolean); var S, BaseName, FullName: String; FirstFile: Boolean; P: Integer; begin while True do begin if Pos('setup:', DllName) = 1 then begin if IsUninstaller then begin DllName := ''; ForceDelayLoad := True; Exit; end; Delete(DllName, 1, Length('setup:')); end else if Pos('uninstall:', DllName) = 1 then begin if not IsUninstaller then begin DllName := ''; ForceDelayLoad := True; Exit; end; Delete(DllName, 1, Length('uninstall:')); end else Break; end; if Pos('files:', DllName) = 1 then begin if IsUninstaller then begin { Uninstall doesn't do 'files:' } DllName := ''; ForceDelayLoad := True; end else begin S := Copy(DllName, Length('files:')+1, Maxint); FirstFile := True; repeat P := ConstPos(',', S); if P = 0 then BaseName := S else begin BaseName := Copy(S, 1, P-1); Delete(S, 1, P); end; BaseName := ExpandConst((BaseName)); FullName := AddBackslash(TempInstallDir) + BaseName; if not NewFileExists(FullName) then ExtractTemporaryFile(BaseName); if FirstFile then begin DllName := FullName; FirstFile := False; end; until P = 0; end; end else DllName := ExpandConst(DllName); end; function CodeRunnerOnDebug(const Position: LongInt; var ContinueStepOver: Boolean): Boolean; begin Result := DebugNotify(deCodeLine, Position, ContinueStepOver, CodeRunner.GetCallStack); end; function CodeRunnerOnDebugIntermediate(const Position: LongInt; var ContinueStepOver: Boolean): Boolean; begin Result := DebugNotifyIntermediate(deCodeLine, Position, ContinueStepOver); end; procedure CodeRunnerOnException(const Exception: AnsiString; const Position: LongInt); begin if Debugging then DebugNotifyException(String(Exception), deCodeLine, Position); end; procedure SetActiveLanguage(const I: Integer); { Activates the specified language } var LangEntry: PSetupLanguageEntry; begin if ActiveLanguage = I then Exit; LangEntry := Entries[seLanguage][I]; AssignSetupMessages(LangEntry.Data[1], ULength(LangEntry.Data)); { Remove outdated < and > markers from the Back and Next buttons. Done here for now to avoid a Default.isl change. } StringChange(SetupMessages[msgButtonBack], '< ', ''); StringChange(SetupMessages[msgButtonNext], ' >', ''); ActiveLanguage := I; Finalize(LangOptions); { prevent leak on D2 } LangOptions := LangEntry^; if LangEntry.LicenseText <> '' then ActiveLicenseText := LangEntry.LicenseText else ActiveLicenseText := SetupHeader.LicenseText; if LangEntry.InfoBeforeText <> '' then ActiveInfoBeforeText := LangEntry.InfoBeforeText else ActiveInfoBeforeText := SetupHeader.InfoBeforeText; if LangEntry.InfoAfterText <> '' then ActiveInfoAfterText := LangEntry.InfoAfterText else ActiveInfoAfterText := SetupHeader.InfoAfterText; SetMessageBoxRightToLeft(LangOptions.RightToLeft); SetMessageBoxCaption(mbInformation, PChar(SetupMessages[msgInformationTitle])); SetMessageBoxCaption(mbConfirmation, PChar(SetupMessages[msgConfirmTitle])); SetMessageBoxCaption(mbError, PChar(SetupMessages[msgErrorTitle])); SetMessageBoxCaption(mbCriticalError, PChar(SetupMessages[msgErrorTitle])); Application.Title := SetupMessages[msgSetupAppTitle]; for var J := 0 to Entries[seType].Count-1 do begin with PSetupTypeEntry(Entries[seType][J])^ do begin case Typ of ttDefaultFull: Description := SetupMessages[msgFullInstallation]; ttDefaultCompact: Description := SetupMessages[msgCompactInstallation]; ttDefaultCustom: Description := SetupMessages[msgCustomInstallation]; end; end; end; { Tell SetupLdr to change its language too. (It's possible for SetupLdr to display messages after Setup terminates, e.g. if it fails to restart the computer.) } if SetupLdrMode then SendNotifyMessage(SetupLdrWnd, WM_USER + 150, 10001, I); end; function GetLanguageEntryProc(Index: Integer; var Entry: PSetupLanguageEntry): Boolean; begin Result := False; if Index < Entries[seLanguage].Count then begin Entry := Entries[seLanguage][Index]; Result := True; end; end; procedure ActivateDefaultLanguage; { Auto-detects the most appropriate language and activates it. Also initializes the ShowLanguageDialog and MatchedLangParameter variables. Note: A like-named version of this function is also present in SetupLdr.dpr. } var I: Integer; begin MatchedLangParameter := False; case DetermineDefaultLanguage(GetLanguageEntryProc, SetupHeader.LanguageDetectionMethod, InitLang, I) of ddNoMatch: ShowLanguageDialog := (SetupHeader.ShowLanguageDialog <> slNo); ddMatch: ShowLanguageDialog := (SetupHeader.ShowLanguageDialog = slYes); else begin { ddMatchLangParameter } ShowLanguageDialog := False; MatchedLangParameter := True; end; end; SetActiveLanguage(I); end; var IsRedirectionGuardEnabled: Boolean; procedure RedirectionGuardConfigure(const AEnable: Boolean); const ProcessRedirectionTrustPolicy = TProcessMitigationPolicy(16); var SetProcessMitigationPolicyFunc: function(MitigationPolicy: TProcessMitigationPolicy; lpBuffer: PVOID; dwLength: SIZE_T): BOOL; stdcall; begin var Status: String; if AEnable then begin SetProcessMitigationPolicyFunc := GetProcAddress(GetModuleHandle(kernel32), PAnsiChar('SetProcessMitigationPolicy')); if Assigned(SetProcessMitigationPolicyFunc) then begin const Flags: DWORD = 1; { = EnforceRedirectionTrust bit set } if SetProcessMitigationPolicyFunc(ProcessRedirectionTrustPolicy, @Flags, SizeOf(Flags)) then begin IsRedirectionGuardEnabled := True; Status := 'Enabled in enforcing mode' end else begin const ErrorCode = GetLastError; Status := Format('Could not enable (SetProcessMitigationPolicy failed with error code %u)', [ErrorCode]); end; end else Status := 'Could not enable (SetProcessMitigationPolicy unavailable)'; end else Status := 'Not enabling'; LogFmt('RedirectionGuard status for current process: %s', [Status]); end; function RedirectionGuardEnabled: Boolean; begin Result := IsRedirectionGuardEnabled; end; procedure LogCompatibilityMode; var S: String; begin S := GetEnv('__COMPAT_LAYER'); if S <> '' then LogFmt('Compatibility mode: %s (%s)', [SYesNo[True], S]); end; procedure LogWindowsVersion; function ArchitecturesToStr(const Architectures: TSetupProcessorArchitectures; const Separator: String): String; procedure AppendArchitecture(var S: String; const Separator, L: String); begin if S <> '' then S := S + Separator + L else S := L; end; var I: TSetupProcessorArchitecture; begin Result := ''; for I := Low(I) to High(I) do if I in Architectures then AppendArchitecture(Result, Separator, SetupProcessorArchitectureNames[I]); end; const Bits: array [Boolean] of Integer = (32, 64); var SP: String; begin if NTServicePackLevel <> 0 then begin SP := ' SP' + IntToStr(Hi(NTServicePackLevel)); if Lo(NTServicePackLevel) <> 0 then SP := SP + '.' + IntToStr(Lo(NTServicePackLevel)); end; LogFmt('Windows version: %u.%u.%u%s', [WindowsVersion shr 24, (WindowsVersion shr 16) and $FF, WindowsVersion and $FFFF, SP]); LogFmt('Windows architecture: %s (%d-bit)', [SetupProcessorArchitectureNames[ProcessorArchitecture], Bits[IsWin64]]); LogFmt('Machine types supported by system: %s', [ArchitecturesToStr(MachineTypesSupportedBySystem, ' ')]); if IsAdmin then Log('User privileges: Administrative') else if IsPowerUserOrAdmin then Log('User privileges: Power User') else Log('User privileges: None'); end; function GetMessageBoxResultText(const AResult: Integer): String; begin case AResult of IDOK: Result := 'OK'; IDCANCEL: Result := 'Cancel'; IDABORT: Result := 'Abort'; IDRETRY: Result := 'Retry'; IDIGNORE: Result := 'Ignore'; IDYES: Result := 'Yes'; IDNO: Result := 'No'; IDTRYAGAIN: Result := 'Try Again'; IDCONTINUE: Result := 'Continue'; else Result := IntToStr(AResult); end; end; function GetButtonsText(const Buttons: Cardinal): String; const { We don't use this type, but end users are liable to in [Code]. Same applies to MB_ABORTRETRYIGNORE. } MB_CANCELTRYCONTINUE = $00000006; begin case Buttons and MB_TYPEMASK of MB_OK: Result := 'OK'; MB_OKCANCEL: Result := 'OK/Cancel'; MB_ABORTRETRYIGNORE: Result := 'Abort/Retry/Ignore'; MB_YESNOCANCEL: Result := 'Yes/No/Cancel'; MB_YESNO: Result := 'Yes/No'; MB_RETRYCANCEL: Result := 'Retry/Cancel'; MB_CANCELTRYCONTINUE: Result := 'Cancel/Try Again/Continue'; else Result := IntToStr(Buttons and MB_TYPEMASK); end; end; procedure LogSuppressedMsgBox(const Text: PChar; const Buttons: Cardinal; const Default: Integer); begin Log(Format('Defaulting to %s for suppressed message box (%s):' + SNewLine, [GetMessageBoxResultText(Default), GetButtonsText(Buttons)]) + Text); end; procedure LogMsgBox(const Text: PChar; const Buttons: Cardinal); begin Log(Format('Message box (%s):' + SNewLine, [GetButtonsText(Buttons)]) + Text); end; function LoggedMsgBox(const Text, Caption: PChar; const Flags: Cardinal; const Suppressible: Boolean; const Default: Integer): Integer; begin if InitSuppressMsgBoxes and Suppressible then begin LogSuppressedMsgBox(Text, Flags, Default); Result := Default; end else begin LogMsgBox(Text, Flags); Result := MsgBox(Text, Caption, Flags); if Result <> 0 then LogFmt('User chose %s.', [GetMessageBoxResultText(Result)]) else Log('MsgBox failed.'); end; end; function LoggedMsgBox(const Text, Caption: String; const Typ: TMsgBoxType; const Buttons: Cardinal; const Suppressible: Boolean; const Default: Integer): Integer; begin if InitSuppressMsgBoxes and Suppressible then begin LogSuppressedMsgBox(PChar(Text), Buttons, Default); Result := Default; end else begin LogMsgBox(PChar(Text), Buttons); Result := MsgBox(Text, Caption, Typ, Buttons); if Result <> 0 then LogFmt('User chose %s.', [GetMessageBoxResultText(Result)]) else Log('MsgBox failed.'); end; end; function LoggedTaskDialogMsgBox(const Icon, Instruction, Text, Caption: String; const Typ: TMsgBoxType; const Buttons: Cardinal; const ButtonLabels: array of String; const ShieldButton: Integer; const Suppressible: Boolean; const Default: Integer; const VerificationText: String = ''; const pfVerificationFlagChecked: PBOOL = nil): Integer; begin if InitSuppressMsgBoxes and Suppressible then begin LogSuppressedMsgBox(PChar(Text), Buttons, Default); Result := Default; end else begin LogMsgBox(PChar(Text), Buttons); Result := TaskDialogMsgBox(Icon, Instruction, Text, Caption, Typ, Buttons, ButtonLabels, ShieldButton, VerificationText, pfVerificationFlagChecked); if Result <> 0 then begin LogFmt('User chose %s.', [GetMessageBoxResultText(Result)]); if pfVerificationFlagChecked <> nil then LogFmt('User chose %s for the verification.', [SYesNo[pfVerificationFlagChecked^]]); end else Log('TaskDialogMsgBox failed.'); end; end; procedure RestartComputerFromThisProcess; begin RestartInitiatedByThisProcess := True; { Note: Depending on the OS, RestartComputer may not return if successful } if not RestartComputer then begin LoggedMsgBox(SetupMessages[msgErrorRestartingComputer], '', mbError, MB_OK, True, IDOK); end; end; procedure RespawnSetupElevated(const AParams: String); { Starts a new, elevated Setup(Ldr) process and waits until it terminates. Does not return; either calls Halt or raises an exception. } var Cancelled: Boolean; Server: TSpawnServer; RespawnResults: record ExitCode: Integer; end; begin Cancelled := False; try Server := TSpawnServer.Create; try var FirstWnd := SetupLdrWnd; if not SetupLdrMode then FirstWnd := Server.Wnd; { The UInt32 casts prevent sign extension } RespawnSelfElevated(SetupLdrOriginalFilename, Format('/SPAWNWND=$%x /FIRSTWND=$%x ', [UInt32(Server.Wnd), UInt32(FirstWnd)]) + AParams, Server, RespawnResults.ExitCode); finally Server.Free; end; except { If the user clicked Cancel on the dialog, halt with special exit code } if ExceptObject is EAbort then Cancelled := True else raise; end; if Cancelled then Halt(ecCancelledBeforeInstall); System.ExitCode := RespawnResults.ExitCode; Halt; end; procedure InitializeCommonVars; { Initializes variables shared between Setup and Uninstall } begin IsAdmin := IsAdminLoggedOn; IsPowerUserOrAdmin := IsAdmin or IsPowerUserLoggedOn; end; procedure InitializeAdminInstallMode(const AAdminInstallMode: Boolean); { Initializes IsAdminInstallMode and other global variables that depend on it } const RootKeys: array[Boolean] of HKEY = (HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE); begin LogFmt('Administrative install mode: %s', [SYesNo[AAdminInstallMode]]); IsAdminInstallMode := AAdminInstallMode; InstallModeRootKey := RootKeys[AAdminInstallMode]; LogFmt('Install mode root key: %s', [GetRegRootKeyName(InstallModeRootKey)]); end; procedure Initialize64BitInstallMode(const A64BitInstallMode: Boolean); { Initializes Is64BitInstallMode and other global variables that depend on it } begin Is64BitInstallMode := A64BitInstallMode; InstallDefaultDisableFsRedir := A64BitInstallMode; ScriptFuncDisableFsRedir := A64BitInstallMode; if A64BitInstallMode then InstallDefaultRegView := rv64Bit else InstallDefaultRegView := rv32Bit; end; procedure Log64BitInstallMode; begin LogFmt('64-bit install mode: %s', [SYesNo[Is64BitInstallMode]]); end; var LoggedArchiveExtractionMode: Boolean; procedure LogArchiveExtractionModeOnce; begin if not LoggedArchiveExtractionMode then begin LogFmt('Archive extraction mode: %s', [IfThen(SetupHeader.SevenZipLibraryName <> '', Format('Using %s', [SetupHeader.SevenZipLibraryName]), 'Basic')]); LoggedArchiveExtractionMode := True; end; end; procedure InitializeSetup; { Initializes various vars used by the setup. This is called in the project source. } var DecompressorDLL, SevenZipDLL: TMemoryStream; function ExtractInt64(var S: String): Int64; begin const P = Pos(',', S); if P = 0 then raise Exception.Create('Error parsing command line: Missing comma'); Result := StrToInt64Def(Copy(S, 1, P-1), -1); if Result < 0 then raise Exception.Create('Error parsing command line: Invalid value'); Delete(S, 1, P); end; procedure AbortInit(const Msg: TSetupMessageID); overload; begin LoggedMsgBox(SetupMessages[Msg], '', mbCriticalError, MB_OK, True, IDOK); Abort; end; procedure AbortInit(const Msg: String); overload; begin LoggedMsgBox(Msg, '', mbCriticalError, MB_OK, True, IDOK); Abort; end; procedure AbortInitFmt1(const Msg: TSetupMessageID; const Arg1: String); begin LoggedMsgBox(FmtSetupMessage(Msg, [Arg1]), '', mbCriticalError, MB_OK, True, IDOK); Abort; end; procedure AbortInitServicePackRequired(const ServicePack: Word); begin LoggedMsgBox(FmtSetupMessage(msgWindowsServicePackRequired, ['Windows', IntToStr(Hi(ServicePack))]), '', mbCriticalError, MB_OK, True, IDOK); Abort; end; procedure ReadFileIntoStream(const Reader: TCompressedBlockReader; const Stream: TStream); type PBuffer = ^TBuffer; TBuffer = array[0..8191] of Byte; var Buf: PBuffer; begin New(Buf); try var BytesLeft: Cardinal; Reader.Read(BytesLeft, SizeOf(BytesLeft)); while BytesLeft > 0 do begin var Bytes := BytesLeft; if Bytes > SizeOf(Buf^) then Bytes := SizeOf(Buf^); Reader.Read(Buf^, Bytes); if Stream <> nil then Stream.WriteBuffer(Buf^, Bytes); Dec(BytesLeft, Bytes); end; finally Dispose(Buf); end; end; function ReadWizardImage(const Reader: TCompressedBlockReader): TGraphic; begin const MemStream = TMemoryStream.Create; try ReadFileIntoStream(Reader, MemStream); MemStream.Seek(0, soFromBeginning); if TPngImage.CanLoadFromStream(MemStream) then Result := TPngImage.Create else begin Result := TBitmap.Create; TBitmap(Result).AlphaFormat := TAlphaFormat(SetupHeader.WizardImageAlphaFormat); end; Result.LoadFromStream(MemStream); finally MemStream.Free; end; end; procedure ReadWizardImages(const Reader: TCompressedBlockReader; const WizardImages: TWizardImages; const WantImages: Boolean); begin var Count: Integer; Reader.Read(Count, SizeOf(Integer)); if Count = -1 then { True if DynamicDark images were same as 'regular' images } Exit; if WantImages then WizardImages.Clear; { This is to clear 'regular' images which have been read already } for var I := 0 to Count-1 do begin if WantImages then WizardImages.Add(ReadWizardImage(Reader)) else ReadFileIntoStream(Reader, nil); end; end; procedure LoadDecompressorDLL; var Filename: String; begin Filename := AddBackslash(TempInstallDir) + '_isetup\_isdecmp.dll'; SaveStreamToTempFile(DecompressorDLL, Filename); FreeAndNil(DecompressorDLL); DecompressorDLLHandle := SafeLoadLibrary(Filename, SEM_NOOPENFILEERRORBOX); if DecompressorDLLHandle = 0 then InternalError(Format('Failed to load DLL "%s"', [Filename])); case SetupHeader.CompressMethod of cmZip: if not ZlibInitDecompressFunctions(DecompressorDLLHandle) then InternalError('ZlibInitDecompressFunctions failed'); cmBzip: if not BZInitDecompressFunctions(DecompressorDLLHandle) then InternalError('BZInitDecompressFunctions failed'); end; end; procedure LoadSevenZipDLL; var Filename: String; begin Filename := AddBackslash(TempInstallDir) + '_isetup\_is7z.dll'; SaveStreamToTempFile(SevenZipDLL, Filename); FreeAndNil(SevenZipDLL); SevenZipDLLHandle := SafeLoadLibrary(Filename, SEM_NOOPENFILEERRORBOX); if SevenZipDLLHandle = 0 then InternalError(Format('Failed to load DLL "%s"', [Filename])) else begin var VersionNumbers: TFileVersionNumbers; if not GetVersionNumbers(Filename, VersionNumbers) then FillChar(VersionNumbers, SizeOf(VersionNumbers), 0); if not SevenZipDLLInit(SevenZipDLLHandle, VersionNumbers) then InternalError('SevenZipDLLInit failed'); end; end; procedure ReadEntriesWithoutVersion(const Reader: TCompressedBlockReader; const EntryType: TEntryType; const Count: Integer; const Size: Integer); var I: Integer; P: Pointer; begin Entries[EntryType].Capacity := Count; for I := 0 to Count-1 do begin P := AllocMem(Size); SECompressedBlockRead(Reader, P^, Cardinal(Size), EntryStrings[EntryType], EntryAnsiStrings[EntryType]); Entries[EntryType].Add(P); end; end; procedure ReadEntries(Reader: TCompressedBlockReader; const EntryType: TEntryType; const Count: Integer; const Size: Integer; const MinVersionOfs, OnlyBelowVersionOfs: Integer); var I: Integer; P: Pointer; begin if Debugging then begin OriginalEntryIndexes[EntryType] := TList.Create; OriginalEntryIndexes[EntryType].Capacity := Count; end; Entries[EntryType].Capacity := Count; for I := 0 to Count-1 do begin P := AllocMem(Size); SECompressedBlockRead(Reader, P^, Cardinal(Size), EntryStrings[EntryType], EntryAnsiStrings[Entrytype]); if (MinVersionOfs = -1) or (InstallOnThisVersion(PSetupVersionData(PByte(P) + MinVersionOfs)^, PSetupVersionData(PByte(P) + OnlyBelowVersionOfs)^) = irInstall) then begin Entries[EntryType].Add(P); if Debugging then OriginalEntryIndexes[EntryType].Add(Pointer(I)); end else SEFreeRec(P, EntryStrings[EntryType], EntryAnsiStrings[EntryType]); end; end; function ShouldEnableRedirectionGuard: Boolean; begin Result := InitRedirectionGuard or ((shRedirectionGuard in SetupHeader.Options) and not InitNoRedirectionGuard); end; function HandleInitPassword(const NeedPassword: Boolean): Boolean; { Handles InitPassword and returns the updated value of NeedPassword } { Also see WizardForm.CheckPassword } begin Result := NeedPassword; if NeedPassword and (InitPassword <> '') then begin var PasswordOk := False; var S := InitPassword; var CryptKey: TSetupEncryptionKey; GenerateEncryptionKey(S, SetupEncryptionHeader.KDFSalt, SetupEncryptionHeader.KDFIterations, CryptKey); if shPassword in SetupHeader.Options then PasswordOk := TestPassword(CryptKey, SetupEncryptionHeader.BaseNonce, SetupEncryptionHeader.PasswordTest); if not PasswordOk and (CodeRunner <> nil) then PasswordOk := CodeRunner.RunBooleanFunctions('CheckPassword', [S], bcTrue, False, PasswordOk); if PasswordOk then begin Result := False; if SetupEncryptionHeader.EncryptionUse = euFiles then FileExtractor.CryptKey := CryptKey; end; end; end; procedure SetupInstallMode; begin if InitVerySilent then InstallMode := imVerySilent else if InitSilent then InstallMode := imSilent; end; function RecurseExternalGetSizeOfFiles(const DisableFsRedir: Boolean; const SearchBaseDir, SearchSubDir, SearchWildcard: String; const SourceIsWildcard: Boolean; const Excludes: TStrings; const RecurseSubDirs: Boolean): Int64; begin { Also see RecurseExternalFiles above and RecurseExternalCopyFiles in Setup.Install Also see RecurseExternalArchiveGetSizeOfFiles directly below } Result := 0; var FindData: TWin32FindData; var H := FindFirstFileRedir(DisableFsRedir, SearchBaseDir + SearchSubDir + SearchWildcard, FindData); if H <> INVALID_HANDLE_VALUE then begin repeat if FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then begin if SourceIsWildcard then if FindData.dwFileAttributes and FILE_ATTRIBUTE_HIDDEN <> 0 then Continue; if IsExcluded(SearchSubDir + FindData.cFileName, Excludes) then Continue; Inc(Result, FindDataFileSizeToInt64(FindData)); end; until not FindNextFile(H, FindData); Windows.FindClose(H); end; if RecurseSubDirs then begin H := FindFirstFileRedir(DisableFsRedir, SearchBaseDir + SearchSubDir + '*', FindData); if H <> INVALID_HANDLE_VALUE then begin try repeat if IsRecurseableDirectory(FindData) then begin var I := RecurseExternalGetSizeOfFiles(DisableFsRedir, SearchBaseDir, SearchSubDir + FindData.cFileName + '\', SearchWildcard, SourceIsWildcard, Excludes, RecurseSubDirs); Inc(Result, I); end; until not FindNextFile(H, FindData); finally Windows.FindClose(H); end; end; end; end; function RecurseExternalArchiveGetSizeOfFiles(const DisableFsRedir: Boolean; const ArchiveFilename, Password: String; const Excludes: TStrings; const RecurseSubDirs: Boolean): Int64; begin { See above } Result := 0; if not NewFileExistsRedir(DisableFsRedir, ArchiveFilename) then Exit; var FindData: TWin32FindData; var H := ArchiveFindFirstFileRedir(DisableFsRedir, ArchiveFilename, AddBackslash(TempInstallDir), { DestDir isn't known yet, pass a placeholder } Password, RecurseSubDirs, False, FindData); if H <> INVALID_HANDLE_VALUE then begin try repeat if FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then begin if IsExcluded(FindData.cFileName, Excludes) then Continue; Inc(Result, FindDataFileSizeToInt64(FindData)); end; until not ArchiveFindNextFile(H, FindData); finally ArchiveFindClose(H); end; end; end; { Also see Install.pas } function ExistingInstallationAt(const RootKey: HKEY; const SubkeyName: String): Boolean; var K: HKEY; begin if RegOpenKeyExView(InstallDefaultRegView, RootKey, PChar(SubkeyName), 0, KEY_QUERY_VALUE, K) = ERROR_SUCCESS then begin Result := True; RegCloseKey(K); end else Result := False; end; procedure HandlePrivilegesRequiredOverrides(var ExtraRespawnParam: String); var ExistingAtAdminInstallMode, ExistingAtNonAdminInstallMode, DesireAnInstallMode, DesireAdminInstallMode: Boolean; SubkeyName, AppName: String; begin if HasInitPrivilegesRequired and (proCommandLine in SetupHeader.PrivilegesRequiredOverridesAllowed) then begin SetupHeader.PrivilegesRequired := InitPrivilegesRequired; { We don't need to set ExtraRespawnParam since the existing command line already contains the needed parameters and it will automatically be passed on to any respawned Setup(Ldr). } end else if proDialog in SetupHeader.PrivilegesRequiredOverridesAllowed then begin if shUsePreviousPrivileges in SetupHeader.Options then begin { Note: if proDialog is used and UsePreviousPrivileges is set to "yes" then the compiler does not allow AppId to include constants but we should still call ExpandConst to handle any '{{'. } SubkeyName := GetUninstallRegSubkeyName(GetUninstallRegKeyBaseName(ExpandConst(SetupHeader.AppID))); ExistingAtAdminInstallMode := ExistingInstallationAt(HKEY_LOCAL_MACHINE, SubkeyName); ExistingAtNonAdminInstallMode := ExistingInstallationAt(HKEY_CURRENT_USER, SubkeyName); end else begin ExistingAtAdminInstallMode := False; ExistingAtNonAdminInstallMode := False; end; DesireAnInstallMode := True; DesireAdminInstallMode := False; { Silence compiler } if ExistingAtAdminInstallMode and not ExistingAtNonAdminInstallMode then DesireAdminInstallMode := True else if not ExistingAtAdminInstallMode and ExistingAtNonAdminInstallMode then DesireAdminInstallMode := False else if not InitSuppressMsgBoxes then begin { Ask user. Doesn't log since logging hasn't started yet. Also doesn't use ExpandedAppName since it isn't set yet. Afterwards we need to tell any respawned Setup(Ldr) about the user choice (and avoid asking again). Will use the command line parameter for this. Allowing proDialog forces allowing proCommandLine, so we can count on the parameter to work. } if shAppNameHasConsts in SetupHeader.Options then AppName := PathChangeExt(PathExtractName(SetupLdrOriginalFilename), '') else AppName := SetupHeader.AppName; if SetupHeader.PrivilegesRequired = prLowest then begin case TaskDialogMsgBox('MAINICON' + MainIconPostfix, SetupMessages[msgPrivilegesRequiredOverrideInstruction], FmtSetupMessage(msgPrivilegesRequiredOverrideText2, [AppName]), SetupMessages[msgPrivilegesRequiredOverrideTitle], mbInformation, MB_YESNOCANCEL, [SetupMessages[msgPrivilegesRequiredOverrideCurrentUserRecommended], SetupMessages[msgPrivilegesRequiredOverrideAllUsers]], IDNO) of IDYES: DesireAdminInstallMode := False; IDNO: DesireAdminInstallMode := True; IDCANCEL: Abort; end; end else begin case TaskDialogMsgBox('MAINICON' + MainIconPostfix, SetupMessages[msgPrivilegesRequiredOverrideInstruction], FmtSetupMessage(msgPrivilegesRequiredOverrideText1, [AppName]), SetupMessages[msgPrivilegesRequiredOverrideTitle], mbInformation, MB_YESNOCANCEL, [SetupMessages[msgPrivilegesRequiredOverrideAllUsersRecommended], SetupMessages[msgPrivilegesRequiredOverrideCurrentUser]], IDYES) of IDYES: DesireAdminInstallMode := True; IDNO: DesireAdminInstallMode := False; IDCANCEL: Abort; end; end; end else DesireAnInstallMode := False; { No previous found and msgboxes are suppressed, just keep things as they are. } if DesireAnInstallMode then begin if DesireAdminInstallMode then begin SetupHeader.PrivilegesRequired := prAdmin; ExtraRespawnParam := '/ALLUSERS'; end else begin SetupHeader.PrivilegesRequired := prLowest; ExtraRespawnParam := '/CURRENTUSER'; end; end; end; end; var ParamName, ParamValue: String; ParamIsAutomaticInternal: Boolean; StartParam: Integer; IsRespawnedProcess, EnableLogging, WantToSuppressMsgBoxes, Res: Boolean; DebugServerWnd: HWND; LogFilename: String; SetupFile: TFile; TestID: TSetupID; NameAndVersionMsg: String; NextAllowedLevel: Integer; LastShownComponentEntry, ComponentEntry: PSetupComponentEntry; SourceWildcard: String; ExpandedSetupMutex, ExtraRespawnParam, RespawnParams: String; begin InitializeCommonVars; { NewParamsForCode will hold all params except automatic internal ones like /SL5= and /DEBUGWND= Also see Uninstall.ProcessCommandLine } NewParamsForCode.Add(NewParamStr(0)); { Based on SetupLdr or not? Parameters for launching SetupLdr-based installation are: /SL5=",, ," } SplitNewParamStr(1, ParamName, ParamValue); if SameText(ParamName, '/SL5=') then begin StartParam := 2; SetupLdrMode := True; SetupLdrWnd := UInt32(ExtractInt64(ParamValue)); SetupLdrOffset0 := ExtractInt64(ParamValue); SetupLdrOffset1 := ExtractInt64(ParamValue); SetupLdrOriginalFilename := ParamValue; end else begin StartParam := 1; SetupLdrOriginalFilename := NewParamStr(0); end; SourceDir := PathExtractDir(SetupLdrOriginalFilename); IsRespawnedProcess := False; EnableLogging := False; WantToSuppressMsgBoxes := False; DebugServerWnd := 0; for var I := StartParam to NewParamCount do begin SplitNewParamStr(I, ParamName, ParamValue); ParamIsAutomaticInternal := False; if SameText(ParamName, '/Log') then begin EnableLogging := True; LogFilename := ''; end else if SameText(ParamName, '/Log=') then begin EnableLogging := True; LogFilename := ParamValue; end else if SameText(ParamName, '/Silent') then InitSilent := True else if SameText(ParamName, '/VerySilent') then InitVerySilent := True else if SameText(ParamName, '/NoRestart') then InitNoRestart := True else if SameText(ParamName, '/CloseApplications') then InitCloseApplications := True else if SameText(ParamName, '/NoCloseApplications') then InitNoCloseApplications := True else if SameText(ParamName, '/ForceCloseApplications') then InitForceCloseApplications := True else if SameText(ParamName, '/NoForceCloseApplications') then InitNoForceCloseApplications := True else if SameText(ParamName, '/LogCloseApplications') then InitLogCloseApplications := True else if SameText(ParamName, '/RestartApplications') then InitRestartApplications := True else if SameText(ParamName, '/NoRestartApplications') then InitNoRestartApplications := True else if SameText(ParamName, '/RedirectionGuard') then InitRedirectionGuard := True else if SameText(ParamName, '/NoRedirectionGuard') then InitNoRedirectionGuard := True else if SameText(ParamName, '/NoIcons') then InitNoIcons := True else if SameText(ParamName, '/NoCancel') then InitNoCancel := True else if SameText(ParamName, '/NoStyle') then InitNoStyle := True else if SameText(ParamName, '/Lang=') then InitLang := ParamValue else if SameText(ParamName, '/Type=') then InitSetupType := ParamValue else if SameText(ParamName, '/Components=') then begin InitComponentsSpecified := True; SetStringsFromCommaString(InitComponents, SlashesToBackslashes(ParamValue)); end else if SameText(ParamName, '/Tasks=') then begin InitDeselectAllTasks := True; SetStringsFromCommaString(InitTasks, SlashesToBackslashes(ParamValue)); end else if SameText(ParamName, '/MergeTasks=') then begin InitDeselectAllTasks := False; SetStringsFromCommaString(InitTasks, SlashesToBackslashes(ParamValue)); end else if SameText(ParamName, '/LoadInf=') then InitLoadInf := PathExpand(ParamValue) else if SameText(ParamName, '/SaveInf=') then InitSaveInf := PathExpand(ParamValue) else if SameText(ParamName, '/DIR=') then InitDir := ParamValue else if SameText(ParamName, '/GROUP=') then InitProgramGroup := ParamValue else if SameText(ParamName, '/Password=') then InitPassword := ParamValue else if SameText(ParamName, '/RestartExitCode=') then InitRestartExitCode := StrToIntDef(ParamValue, 0) else if SameText(ParamName, '/SuppressMsgBoxes') then WantToSuppressMsgBoxes := True else if SameText(ParamName, '/DETACHEDMSG') then { for debugging } DetachedUninstMsgFile := True else if SameText(ParamName, '/SPAWNWND=') then begin ParamIsAutomaticInternal := True; { sent by RespawnSetupElevated } IsRespawnedProcess := True; InitializeSpawnClient(StrToWnd(ParamValue)); end else if SameText(ParamName, '/FIRSTWND=') then begin ParamIsAutomaticInternal := True; { sent by RespawnSetupElevated } SetupFirstProcessWnd := StrToWnd(ParamValue); end else if SameText(ParamName, '/DebugSpawnServer') then { for debugging } EnterSpawnServerDebugMode { does not return } else if SameText(ParamName, '/DEBUGWND=') then begin ParamIsAutomaticInternal := True; { sent by IDE.MainForm's StartProcess } DebugServerWnd := StrToWnd(ParamValue); end else if SameText(ParamName, '/ALLUSERS') then begin InitPrivilegesRequired := prAdmin; HasInitPrivilegesRequired := True; end else if SameText(ParamName, '/CURRENTUSER') then begin InitPrivilegesRequired := prLowest; HasInitPrivilegesRequired := True; end; if not ParamIsAutomaticInternal then NewParamsForCode.Add(NewParamStr(I)); end; if InitLoadInf <> '' then LoadInf(InitLoadInf, WantToSuppressMsgBoxes); if WantToSuppressMsgBoxes and (InitSilent or InitVerySilent) then InitSuppressMsgBoxes := True; { Assign some default messages that may be used before the messages are read } SetupMessages[msgSetupFileMissing] := SSetupFileMissing; SetupMessages[msgSetupFileCorrupt] := SSetupFileCorrupt; SetupMessages[msgSetupFileCorruptOrWrongVer] := SSetupFileCorruptOrWrongVer; { Read setup-0.bin, or from EXE } var SetupFilename: String; if not SetupLdrMode then begin SetupFilename := PathChangeExt(SetupLdrOriginalFilename, '') + '-0.bin'; {$IFDEF DEBUG} { Also see TFileExtractor.FindSliceFilename } SetupFileName := SetupFileName.Replace('SetupCustomStyle', 'Setup'); {$ENDIF} if not NewFileExists(SetupFilename) then AbortInitFmt1(msgSetupFileMissing, PathExtractName(SetupFilename)); end else SetupFilename := SetupLdrOriginalFilename; SetupFile := TFile.Create(SetupFilename, fdOpenExisting, faRead, fsRead); try SetupFile.Seek(SetupLdrOffset0); if SetupFile.Read(TestID, SizeOf(TestID)) <> SizeOf(TestID) then AbortInit(msgSetupFileCorruptOrWrongVer); if TestID <> SetupID then AbortInit(msgSetupFileCorruptOrWrongVer); var SetupEncryptionHeaderCRC: Longint; if (SetupFile.Read(SetupEncryptionHeaderCRC, SizeOf(SetupEncryptionHeaderCRC)) <> SizeOf(SetupEncryptionHeaderCRC)) or (SetupFile.Read(SetupEncryptionHeader, SizeOf(SetupEncryptionHeader)) <> SizeOf(SetupEncryptionHeader)) then AbortInit(msgSetupFileCorrupt); if SetupEncryptionHeaderCRC <> GetCRC32(SetupEncryptionHeader, SizeOf(SetupEncryptionHeader)) then AbortInit(msgSetupFileCorrupt); var CryptKey: TSetupEncryptionKey; if SetupEncryptionHeader.EncryptionUse = euFull then begin if InitPassword = '' then AbortInit(SMissingPassword); GenerateEncryptionKey(InitPassword, SetupEncryptionHeader.KDFSalt, SetupEncryptionHeader.KDFIterations, CryptKey); if not TestPassword(CryptKey, SetupEncryptionHeader.BaseNonce, SetupEncryptionHeader.PasswordTest) then AbortInit(SIncorrectPassword); { FileExtractor (a function!) requires SetupHeader.CompressMethod to be set, so delaying setting FileExtractor.CryptKey until SetupHeader is read below } end; try var Reader := TCompressedBlockReader.Create(SetupFile, TLZMA1Decompressor); try if SetupEncryptionHeader.EncryptionUse = euFull then Reader.InitDecryption(CryptKey, SetupEncryptionHeader.BaseNonce, sccCompressedBlocks1); { Header } SECompressedBlockRead(Reader, SetupHeader, SizeOf(SetupHeader), SetupHeaderStrings, SetupHeaderAnsiStrings); if SetupEncryptionHeader.EncryptionUse = euFull then FileExtractor.CryptKey := CryptKey; { See above } { SetupHeader.WizardBackColor may be overwritten below, and we need to keep the original value for Uninstall } OrigSetupHeaderWizardBackColor := SetupHeader.WizardBackColor; { Language entries } ReadEntriesWithoutVersion(Reader, seLanguage, SetupHeader.NumLanguageEntries, SizeOf(TSetupLanguageEntry)); { CustomMessage entries } ReadEntriesWithoutVersion(Reader, seCustomMessage, SetupHeader.NumCustomMessageEntries, SizeOf(TSetupCustomMessageEntry)); { Permission entries } ReadEntriesWithoutVersion(Reader, sePermission, SetupHeader.NumPermissionEntries, SizeOf(TSetupPermissionEntry)); { Type entries } ReadEntries(Reader, seType, SetupHeader.NumTypeEntries, SizeOf(TSetupTypeEntry), Integer(@PSetupTypeEntry(nil).MinVersion), Integer(@PSetupTypeEntry(nil).OnlyBelowVersion)); ActivateDefaultLanguage; { Apply style - also see Setup.Uninstall's RunSecondPhase Must be ordered after ActivateDefaultLanguage since TTaskDialogForm and its parent TSetupForm use LangOptions and SetupMessages. Note: when debugging Setup.e32 or SetupCustomStyle.e32 it will see the default resources, instead of the ones prepared by the compiler. This is because the .e32 is started, and not the .exe prepared by the compiler. This is not noticable except for the VCL style resources: the MYSTYLE1 and MYSTYLE1_DARK styles will always be missing. In this case it will use the ZIRCON style, see below. This does *not* mean Uninstall will then also use ZIRCON. To test Uninstall styling use a real Setup compiled by the compiler. } var WantWizardImagesDynamicDark := False; IsWinDark := DarkModeActive; if not HighContrastActive and not InitNoStyle then begin const IsDynamicDark = (SetupHeader.WizardDarkStyle = wdsDynamic) and IsWinDark; const IsForcedDark = SetupHeader.WizardDarkStyle = wdsDark; if IsDynamicDark then begin SetupHeader.WizardImageBackColor := SetupHeader.WizardImageBackColorDynamicDark; SetupHeader.WizardSmallImageBackColor := SetupHeader.WizardSmallImageBackColorDynamicDark; SetupHeader.WizardBackColor := SetupHeader.WizardBackColorDynamicDark; MainIconPostfix := '_DARK'; { If the main icon is custom, a dark version will not be available, so check for this } if FindResource(HInstance, PChar('MAINICON' + MainIconPostfix), RT_GROUP_ICON) = 0 then MainIconPostfix := ''; WantWizardImagesDynamicDark := True; { Handled below } end; if IsDynamicDark or IsForcedDark then begin IsDarkInstallMode := True; WizardIconsPostfix := '_DARK'; end; TStyleManager.AutoDiscoverStyleResources := False; { Also see comment above } var StyleName := 'MYSTYLE1'; if IsDynamicDark then StyleName := StyleName + '_DARK'; var Handle: TStyleManager.TStyleServicesHandle; if TStyleManager.TryLoadFromResource(HInstance, StyleName, 'VCLSTYLE', Handle) {$IFDEF DEBUG} or TStyleManager.TryLoadFromResource(HInstance, 'ZIRCON', 'VCLSTYLE', Handle) { Comment the line above to activate WINDOWSPOLARDARK instead of ZIRCON } or TStyleManager.TryLoadFromResource(HInstance, 'WINDOWSPOLARDARK', 'VCLSTYLE', Handle) {$ENDIF} then begin TStyleManager.SetStyle(Handle); if not (shWizardBorderStyled in SetupHeader.Options) then TStyleManager.FormBorderStyle := fbsSystemStyle; CustomWizardBackground := SetupHeader.WizardBackColor <> clNone; if CustomWizardBackground then begin TCustomStyleEngine.RegisterStyleHook(TSetupForm, TFormBackgroundStyleHook); TFormBackgroundStyleHook.BackColor := SetupHeader.WizardBackColor; end; end; end; { Set Is64BitInstallMode if we're on Win64 and the processor architecture is one on which a "64-bit mode" install should be performed. Doing this early so that UsePreviousPrivileges knows where to look. Will log later. } if (SetupHeader.ArchitecturesInstallIn64BitMode <> '') and EvalExpression(SetupHeader.ArchitecturesInstallIn64BitMode, TDummyClass.EvalArchitectureIdentifier) then begin if not IsWin64 then begin { The script writer made a mistake: their expression matched a 32-bit system. Obviously that can't be allowed. With "not" there are lots of ways that could happen without explicitly specifying a 32-bit architecture in the expression. One example: "not win64" } InternalError('ArchitecturesInstallIn64BitMode expression matched 32-bit system'); end; Initialize64BitInstallMode(True); end else Initialize64BitInstallMode(False); HandlePrivilegesRequiredOverrides(ExtraRespawnParam); { Start a new, elevated Setup(Ldr) process if needed } if not IsRespawnedProcess and NeedToRespawnSelfElevated(not (SetupHeader.PrivilegesRequired in [prNone, prLowest]), SetupHeader.PrivilegesRequired <> prLowest) then begin FreeAndNil(Reader); FreeAndNil(SetupFile); RedirectionGuardConfigure(ShouldEnableRedirectionGuard); RespawnParams := GetCmdTailEx(StartParam); if ExtraRespawnParam <> '' then RespawnParams := RespawnParams + ' ' + ExtraRespawnParam; RespawnSetupElevated(RespawnParams); { Note: RespawnSetupElevated does not return; it either calls Halt or raises an exception. } end; { Application.Handle is now known to be the main window. Set the shutdown block reason. } ShutdownBlockReasonCreate(Application.Handle, SetupMessages[msgWizardInstalling]); { Initialize debug client (client=Setup, server=debugger/IDE) } if DebugServerWnd <> 0 then SetDebugServerWnd(DebugServerWnd, False); { Initialize logging } if EnableLogging or (shSetupLogging in SetupHeader.Options) then begin try if LogFilename = '' then StartLogging('Setup') else StartLoggingWithFixedFilename(LogFilename); except on E: Exception do begin E.Message := 'Error creating log file:' + SNewLine2 + E.Message; raise; end; end; end; Log('Setup version: ' + SetupTitle + ' version ' + SetupVersion); Log('Original Setup EXE: ' + SetupLdrOriginalFilename); Log('Setup command line: ' + GetCmdTail); LogCompatibilityMode; LogWindowsVersion; NeedPassword := (SetupEncryptionHeader.EncryptionUse <> euFull) and (shPassword in SetupHeader.Options); NeedSerial := False; NeedsRestart := shAlwaysRestart in SetupHeader.Options; { Component entries } ReadEntries(Reader, seComponent, SetupHeader.NumComponentEntries, SizeOf(TSetupComponentEntry), -1, -1); { Task entries } ReadEntries(Reader, seTask, SetupHeader.NumTaskEntries, SizeOf(TSetupTaskEntry), -1, -1); { Dir entries } ReadEntries(Reader, seDir, SetupHeader.NumDirEntries, SizeOf(TSetupDirEntry), Integer(@PSetupDirEntry(nil).MinVersion), Integer(@PSetupDirEntry(nil).OnlyBelowVersion)); { ISSigKey entries } ReadEntriesWithoutVersion(Reader, seISSigKey, SetupHeader.NumISSigKeyEntries, SizeOf(TSetupISSigKeyEntry)); { File entries } ReadEntries(Reader, seFile, SetupHeader.NumFileEntries, SizeOf(TSetupFileEntry), Integer(@PSetupFileEntry(nil).MinVersion), Integer(@PSetupFileEntry(nil).OnlyBelowVersion)); { Icon entries } ReadEntries(Reader, seIcon, SetupHeader.NumIconEntries, SizeOf(TSetupIconEntry), Integer(@PSetupIconEntry(nil).MinVersion), Integer(@PSetupIconEntry(nil).OnlyBelowVersion)); { INI entries } ReadEntries(Reader, seIni, SetupHeader.NumIniEntries, SizeOf(TSetupIniEntry), Integer(@PSetupIniEntry(nil).MinVersion), Integer(@PSetupIniEntry(nil).OnlyBelowVersion)); { Registry entries } ReadEntries(Reader, seRegistry, SetupHeader.NumRegistryEntries, SizeOf(TSetupRegistryEntry), Integer(@PSetupRegistryEntry(nil).MinVersion), Integer(@PSetupRegistryEntry(nil).OnlyBelowVersion)); { InstallDelete entries } ReadEntries(Reader, seInstallDelete, SetupHeader.NumInstallDeleteEntries, SizeOf(TSetupDeleteEntry), Integer(@PSetupDeleteEntry(nil).MinVersion), Integer(@PSetupDeleteEntry(nil).OnlyBelowVersion)); { UninstallDelete entries } ReadEntries(Reader, seUninstallDelete, SetupHeader.NumUninstallDeleteEntries, SizeOf(TSetupDeleteEntry), Integer(@PSetupDeleteEntry(nil).MinVersion), Integer(@PSetupDeleteEntry(nil).OnlyBelowVersion)); { Run entries } ReadEntries(Reader, seRun, SetupHeader.NumRunEntries, SizeOf(TSetupRunEntry), Integer(@PSetupRunEntry(nil).MinVersion), Integer(@PSetupRunEntry(nil).OnlyBelowVersion)); { UninstallRun entries } ReadEntries(Reader, seUninstallRun, SetupHeader.NumUninstallRunEntries, SizeOf(TSetupRunEntry), Integer(@PSetupRunEntry(nil).MinVersion), Integer(@PSetupRunEntry(nil).OnlyBelowVersion)); { Wizard images } ReadWizardImages(Reader, WizardImages, True); { If WantWizardImagesDynamicDark is True, then these might be overwritten below } ReadWizardImages(Reader, WizardSmallImages, True); { Same } ReadWizardImages(Reader, WizardBackImages, True); { Same } ReadWizardImages(Reader, WizardImages, WantWizardImagesDynamicDark); ReadWizardImages(Reader, WizardSmallImages, WantWizardImagesDynamicDark); ReadWizardImages(Reader, WizardBackImages, WantWizardImagesDynamicDark); { Decompressor DLL } DecompressorDLL := nil; if SetupHeader.CompressMethod in [cmZip, cmBzip] then begin DecompressorDLL := TMemoryStream.Create; ReadFileIntoStream(Reader, DecompressorDLL); end; { SevenZip DLL } SevenZipDLL := nil; if SetupHeader.SevenZipLibraryName <> '' then begin SevenZipDLL := TMemoryStream.Create; ReadFileIntoStream(Reader, SevenZipDLL); end; finally Reader.Free; end; Reader := TCompressedBlockReader.Create(SetupFile, TLZMA1Decompressor); try if SetupEncryptionHeader.EncryptionUse = euFull then Reader.InitDecryption(CryptKey, SetupEncryptionHeader.BaseNonce, sccCompressedBlocks2); { File location entries } ReadEntriesWithoutVersion(Reader, seFileLocation, SetupHeader.NumFileLocationEntries, SizeOf(TSetupFileLocationEntry)); finally Reader.Free; end; except on ECompressDataError do AbortInit(msgSetupFileCorrupt); end; finally SetupFile.Free; end; InitializeAdminInstallMode(IsAdmin and (SetupHeader.PrivilegesRequired <> prLowest)); Log64BitInstallMode; RedirectionGuardConfigure(ShouldEnableRedirectionGuard); { Test code. Originally planned to call DeleteResidualTempUninstallDirs during Setup's startup too, but decided against it; it's not really necessary and could slow down the startup (slightly). } (* for var Z := 1 to 5 do begin const TD = CreateTempDir('-uninstall.tmp', IsAdmin); TFile.Create(TD + '\_unins.tmp', fdCreateNew, faWrite, fsNone).Free; TFile.Create(TD + '\_unins-done.tmp', fdCreateNew, faWrite, fsNone).Free; end; DeleteResidualTempUninstallDirs; *) { Show "Select Language" dialog if necessary - requires "64-bit mode" to be initialized else it might query the previous language from the wrong registry view } if Entries[seLanguage].Count > 1 then begin if ShowLanguageDialog and not InitSilent and not InitVerySilent then begin if not AskForLanguage then Abort; end else if not MatchedLangParameter and (shUsePreviousLanguage in SetupHeader.Options) then begin { Replicate the dialog's UsePreviousLanguage functionality. } { Note: if UsePreviousLanguage is set to "yes" then the compiler does not allow AppId to include constants but we should still call ExpandConst to handle any '{{'. } const I = GetPreviousLanguage(ExpandConst(SetupHeader.AppId)); if I <> -1 then SetActiveLanguage(I); end; end; { Check unsupported Itanium - must be on Windows Server 2008 R2 so remove once this becomes unsupported as well and Windows 8 (6.2+) becomes the new minimum } var SysInfo: TSystemInfo; GetNativeSystemInfo(SysInfo); if SysInfo.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_IA64 then AbortInit(msgWindowsVersionNotSupported); { Check allowed processor architectures } if (SetupHeader.ArchitecturesAllowed <> '') and not EvalExpression(SetupHeader.ArchitecturesAllowed, TDummyClass.EvalArchitectureIdentifier) then AbortInit(msgWindowsVersionNotSupported); { Check Windows version } case InstallOnThisVersion(SetupHeader.MinVersion, SetupHeader.OnlyBelowVersion) of irInstall: ; irServicePackTooLow: AbortInitServicePackRequired(SetupHeader.MinVersion.NTServicePack); else AbortInit(msgWindowsVersionNotSupported); end; { Check if the user lacks the required privileges } case SetupHeader.PrivilegesRequired of prPowerUser: if not IsPowerUserOrAdmin then AbortInit(msgPowerUserPrivilegesRequired); prAdmin: if not IsAdmin then AbortInit(msgAdminPrivilegesRequired); end; { Init main constants, not depending on shfolder.dll/_shfoldr.dll } InitMainNonSHFolderConsts; { Create temporary directory and extract 64-bit helper EXE if necessary } CreateTempInstallDirAndExtract64BitHelper; { Load system's "shfolder.dll", and load it } LoadSHFolderDLL; { Save DecompressorDLL stream as "_isdecmp.dll" in TempInstallDir, and load it } if SetupHeader.CompressMethod in [cmZip, cmBzip] then LoadDecompressorDLL; { Save SevenZipDll stream as "_is7z.dll" in TempInstallDir, and load it } if SetupHeader.SevenZipLibraryName <> '' then LoadSevenZipDLL; { Start RestartManager session } if InitCloseApplications or ((shCloseApplications in SetupHeader.Options) and not InitNoCloseApplications) then begin InitRestartManagerLibrary; { Note from Old New Thing: "The RmStartSession function doesn't properly null-terminate the session key <...>. To work around this bug, we pre-fill the buffer with null characters <...>." Our key is pre-filled too since it's global. } if UseRestartManager and (RmStartSession(@RmSessionHandle, 0, RmSessionKey) = ERROR_SUCCESS) then begin RmSessionStarted := True; SetStringsFromCommaString(CloseApplicationsFilterList, SetupHeader.CloseApplicationsFilter); SetStringsFromCommaString(CloseApplicationsFilterExcludesList, SetupHeader.CloseApplicationsFilterExcludes); end; end; { Set install mode } SetupInstallMode; { Init ISSigAvailableKeys } SetLength(ISSigAvailableKeys, Entries[seISSigKey].Count); for var I := 0 to Entries[seISSigKey].Count-1 do begin var ISSigKeyEntry := PSetupISSigKeyEntry(Entries[seISSigKey][I]); ISSigAvailableKeys[I] := TECDSAKey.Create; if ISSigImportPublicKey(ISSigAvailableKeys[I], '', ISSigKeyEntry.PublicX, ISSigKeyEntry.PublicY) <> ikrSuccess then InternalError('ISSigImportPublicKey failed') end; { Load and initialize code } if SetupHeader.CompiledCodeText <> '' then begin CodeRunner := TScriptRunner.Create(); try CodeRunner.NamingAttribute := CodeRunnerNamingAttribute; CodeRunner.OnLog := CodeRunnerOnLog; CodeRunner.OnLogFmt := CodeRunnerOnLogFmt; CodeRunner.OnDllImport := CodeRunnerOnDllImport; CodeRunner.OnDebug := CodeRunnerOnDebug; CodeRunner.OnDebugIntermediate := CodeRunnerOnDebugIntermediate; CodeRunner.OnException := CodeRunnerOnException; CodeRunner.LoadScript(SetupHeader.CompiledCodeText, DebugClientCompiledCodeDebugInfo); if not NeedPassword then NeedPassword := CodeRunner.FunctionExists('CheckPassword', True); NeedPassword := HandleInitPassword(NeedPassword); if not NeedSerial then NeedSerial := CodeRunner.FunctionExists('CheckSerial', True); except { Don't let DeinitSetup see a partially-initialized CodeRunner } FreeAndNil(CodeRunner); raise; end; try Res := CodeRunner.RunBooleanFunctions('InitializeSetup', [''], bcFalse, False, True); except Log('InitializeSetup raised an exception (fatal).'); raise; end; if not Res then begin Log('InitializeSetup returned False; aborting.'); Abort; end; end else NeedPassword := HandleInitPassword(NeedPassword); { Expand AppName, AppVerName, and AppCopyright now since they're used often, especially by the background window painting. } ExpandedAppName := ExpandConst(SetupHeader.AppName); if SetupHeader.AppVerName <> '' then ExpandedAppVerName := ExpandConst(SetupHeader.AppVerName) else begin if not GetCustomMessageValue('NameAndVersion', NameAndVersionMsg) then NameAndVersionMsg := '%1 %2'; { just in case } ExpandedAppVerName := FmtMessage(PChar(NameAndVersionMsg), [ExpandedAppName, ExpandConst(SetupHeader.AppVersion)]); end; ExpandedAppCopyright := ExpandConst(SetupHeader.AppCopyright); ExpandedAppMutex := ExpandConst(SetupHeader.AppMutex); ExpandedSetupMutex := ExpandConst(SetupHeader.SetupMutex); { Update the shutdown block reason now that we have ExpandedAppName. } ShutdownBlockReasonCreate(Application.Handle, FmtSetupMessage1(msgShutdownBlockReasonInstallingApp, ExpandedAppName)); { Check if app is running } while CheckForMutexes(ExpandedAppMutex) do if LoggedMsgBox(FmtSetupMessage1(msgSetupAppRunningError, ExpandedAppName), SetupMessages[msgSetupAppTitle], mbError, MB_OKCANCEL, True, IDCANCEL) <> IDOK then Abort; { Check if Setup is running and if not create mutexes } while CheckForMutexes(ExpandedSetupMutex) do if LoggedMsgBox(FmtSetupMessage1(msgSetupAppRunningError, SetupMessages[msgSetupAppTitle]), SetupMessages[msgSetupAppTitle], mbError, MB_OKCANCEL, True, IDCANCEL) <> IDOK then Abort; CreateMutexes(ExpandedSetupMutex); { Remove types that fail their 'languages' or 'check'. Can't do this earlier because the InitializeSetup call above can't be done earlier. } for var I := 0 to Entries[seType].Count-1 do begin if not ShouldProcessEntry(nil, nil, '', '', PSetupTypeEntry(Entries[seType][I]).Languages, PSetupTypeEntry(Entries[seType][I]).CheckOnce) then begin SEFreeRec(Entries[seType][I], EntryStrings[seType], EntryAnsiStrings[seType]); { Don't delete it yet so that the entries can be processed sequentially } Entries[seType][I] := nil; end; end; { Delete the nil-ed items now } Entries[seType].Pack(); { Remove components } NextAllowedLevel := 0; LastShownComponentEntry := nil; for var I := 0 to Entries[seComponent].Count-1 do begin ComponentEntry := PSetupComponentEntry(Entries[seComponent][I]); if (ComponentEntry.Level <= NextAllowedLevel) and (InstallOnThisVersion(ComponentEntry.MinVersion, ComponentEntry.OnlyBelowVersion) = irInstall) and ShouldProcessEntry(nil, nil, '', '', ComponentEntry.Languages, ComponentEntry.CheckOnce) then begin NextAllowedLevel := ComponentEntry.Level + 1; LastShownComponentEntry := ComponentEntry; end else begin { Not showing } if Assigned(LastShownComponentEntry) and (ComponentEntry.Level = LastShownComponentEntry.Level) and (CompareText(ComponentEntry.Name, LastShownComponentEntry.Name) = 0) then begin { It's a duplicate of the last shown item. Leave NextAllowedLevel alone, so that any child items that follow can attach to the last shown item. } end else begin { Not a duplicate of the last shown item, so the next item must be at the same level or less } if NextAllowedLevel > ComponentEntry.Level then NextAllowedLevel := ComponentEntry.Level; { Clear LastShownComponentEntry so that no subsequent item can be considered a duplicate of it. Needed in this case: foo (shown) foo\childA (not shown) foo (not shown) foo\childB "foo\childB" should be hidden, not made a child of "foo" #1. } LastShownComponentEntry := nil; end; Entries[seComponent][I] := nil; SEFreeRec(ComponentEntry, EntryStrings[seComponent], EntryAnsiStrings[seComponent]); end; end; Entries[seComponent].Pack(); { Set misc. variables } HasCustomType := False; for var I := 0 to Entries[seType].Count-1 do begin if toIsCustom in PSetupTypeEntry(Entries[seType][I]).Options then begin HasCustomType := True; Break; end; end; HasComponents := Entries[seComponent].Count <> 0; HasIcons := Entries[seIcon].Count <> 0; HasTasks := Entries[seTask].Count <> 0; { Calculate minimum disk space. If there are setup types, find the smallest type and add the size of all files that don't belong to any component. Otherwise calculate minimum disk space by adding all of the file's sizes. Also for each "external" file, check the file size now, and store it the ExternalSize field of the TSetupFileEntry record, except if an ExternalSize was specified by the script. } MinimumSpace := SetupHeader.ExtraDiskSpaceRequired; const LExcludes = TStringList.Create; try LExcludes.StrictDelimiter := True; LExcludes.Delimiter := ','; for var I := 0 to Entries[seFile].Count-1 do begin with PSetupFileEntry(Entries[seFile][I])^ do begin if LocationEntry <> -1 then begin { not an "external" file } if Components = '' then { no types or a file that doesn't belong to any component } if (Tasks = '') and (Check = '') then {don't count tasks and scripted entries} Inc(MinimumSpace, PSetupFileLocationEntry(Entries[seFileLocation][LocationEntry])^.OriginalSize) end else begin if not(foExternalSizePreset in Options) then begin if foDownload in Options then InternalError('Unexpected download flag'); try LExcludes.DelimitedText := Excludes; if foExtractArchive in Options then begin ExternalSize := RecurseExternalArchiveGetSizeOfFiles( ShouldDisableFsRedirForFileEntry(PSetupFileEntry(Entries[seFile][I])), ExpandConst(SourceFilename), ExpandConst(ExtractArchivePassword), LExcludes, foRecurseSubDirsExternal in Options); end else begin if FileType <> ftUserFile then SourceWildcard := NewParamStr(0) else SourceWildcard := ExpandConst(SourceFilename); ExternalSize := RecurseExternalGetSizeOfFiles( ShouldDisableFsRedirForFileEntry(PSetupFileEntry(Entries[seFile][I])), PathExtractPath(SourceWildcard), '', PathExtractName(SourceWildcard), IsWildcard(SourceWildcard), LExcludes, foRecurseSubDirsExternal in Options); end; except { Ignore exceptions. Two notable exceptions we want to ignore are the one about "app" not being initialized and also archive errors (ESevenZipError). Also see EnumFiles. } end; end; if Components = '' then { no types or a file that doesn't belong to any component } if (Tasks = '') and (Check = '') then {don't count tasks or scripted entries} Inc(MinimumSpace, ExternalSize); end; end; end; finally LExcludes.Free; end; for var I := 0 to Entries[seComponent].Count-1 do with PSetupComponentEntry(Entries[seComponent][I])^ do Size := GetSizeOfComponent(Name, ExtraDiskSpaceRequired); if Entries[seType].Count > 0 then begin var MinimumTypeSpace: Int64 := 0; for var I := 0 to Entries[seType].Count-1 do begin with PSetupTypeEntry(Entries[seType][I])^ do begin Size := GetSizeOfType(Name, toIsCustom in Options); if (I = 0) or (Size < MinimumTypeSpace) then MinimumTypeSpace := Size; end; end; Inc(MinimumSpace, MinimumTypeSpace); end; end; procedure InitializeWizard; begin WizardForm := AppCreateForm(TWizardForm) as TWizardForm; if CodeRunner <> nil then begin try CodeRunner.RunProcedures('InitializeWizard', [''], False); except Log('InitializeWizard raised an exception (fatal).'); raise; end; end; WizardForm.FlipAndCenterIfNeeded(False, nil, False); WizardForm.SetCurPage(wpWelcome); if InstallMode = imNormal then begin WizardForm.ClickToStartPage; { this won't go past wpReady } WizardForm.Visible := True; end else WizardForm.ClickThroughPages; end; procedure DeinitSetup(const AllowCustomSetupExitCode: Boolean); procedure StopNonElevatedSetupProcesses; begin var ProcessHandle: THandle := 0; try { The "first process" is usually the non-elevated SetupLdr process, but if UseSetupLdr=no, it's the non-elevated Setup process. } var PID: DWORD; if GetWindowThreadProcessId(SetupFirstProcessWnd, PID) = 0 then LogWithLastError('Failed to get PID of first process.') else begin ProcessHandle := OpenProcess(SYNCHRONIZE, False, PID); if ProcessHandle = 0 then LogWithLastError('Failed to open handle to first process.'); end; { Tell the non-elevated Setup process (which hosts the spawn server) to exit now, instead of waiting for its child process to terminate. Once it does, the non-elevated SetupLdr process (if UseSetupLdr=yes) will also exit. } LogFmt('Instructing parent Setup process to exit with exit code %d.', [SetupExitCode]); if not StopSpawnServerProcess(DWORD(SetupExitCode)) then LogWithLastError('Failed to send message.'); Log('Waiting for first process to exit.'); if ProcessHandle <> 0 then begin const WaitResult = WaitForSingleObject(ProcessHandle, 5000); case WaitResult of WAIT_OBJECT_0: Log('Wait successful.'); WAIT_TIMEOUT: Log('Wait timed out.'); WAIT_FAILED: LogWithLastError('Wait failed.'); else Log('Wait result invalid.'); end; end else begin { Shouldn't get here normally. Since we don't know if the first process is running or not, only give it 2 seconds to exit (shorter than the wait timeout above). } Log('Unable to wait; sleeping instead.'); Sleep(2000); end; finally if ProcessHandle <> 0 then CloseHandle(ProcessHandle); end; end; begin Log('Deinitializing Setup.'); if Assigned(CodeRunner) then begin if AllowCustomSetupExitCode then begin try SetupExitCode := CodeRunner.RunIntegerFunctions('GetCustomSetupExitCode', [''], bcNonZero, False, SetupExitCode); except Log('GetCustomSetupExitCode raised an exception.'); Application.HandleException(nil); end; end; try CodeRunner.RunProcedures('DeinitializeSetup', [''], False); except Log('DeinitializeSetup raised an exception.'); Application.HandleException(nil); end; FreeAndNil(CodeRunner); end; for var I := 0 to DeleteFilesAfterInstallList.Count-1 do DeleteFileRedir(DeleteFilesAfterInstallList.Objects[I] <> nil, DeleteFilesAfterInstallList[I]); DeleteFilesAfterInstallList.Clear; for var I := DeleteDirsAfterInstallList.Count-1 downto 0 do RemoveDirectoryRedir(DeleteDirsAfterInstallList.Objects[I] <> nil, DeleteDirsAfterInstallList[I]); DeleteDirsAfterInstallList.Clear; for var I := 0 to Length(ISSigAvailableKeys)-1 do ISSigAvailableKeys[I].Free; FreeFileExtractor; { End RestartManager session } if RmSessionStarted then RmEndSession(RmSessionHandle); { Free the _isdecmp.dll and _is7z.dll handles } if DecompressorDLLHandle <> 0 then FreeLibrary(DecompressorDLLHandle); if SevenZipDLLHandle <> 0 then begin SevenZipDLLDeInit; FreeLibrary(SevenZipDLLHandle); end; { Free the shfolder.dll handle } UnloadSHFolderDLL; { Remove TempInstallDir, stopping the 64-bit helper first if necessary } RemoveTempInstallDir; { An attempt to restart while debugging is most likely an accident; don't allow it } if RestartSystem and Debugging then begin Log('Not restarting Windows because Setup is being run from the debugger.'); RestartSystem := False; end; EndDebug; ShutdownBlockReasonDestroy(Application.Handle); if RestartSystem then begin { On Windows Server, by default, a process can only initiate a restart if it has the Administrators group in its access token. So we have to initiate the restart from one of our elevated processes. But first, we need to stop the non-elevated processes to ensure they don't try to block the shutdown, and also to keep them from being terminated uncleanly by Windows (which could leave behind temporary files). Note, however, that if the installer never requested elevation (e.g., because PrivilegesRequired=lowest is set) and also wasn't started using "Run as administrator", then the restart will fail on Windows Server for standard user accounts and admin accounts that have UAC enabled (by default, UAC is disabled on the built-in Administrator account). } if IsSpawnServerPresent then begin Log('Need to stop other Setup processes before restarting Windows.'); StopNonElevatedSetupProcesses; end; Log('Restarting Windows.'); if SetupLdrMode then begin { Send a special message back to SetupLdr telling it to restart the system after Setup returns } SendNotifyMessage(SetupLdrWnd, WM_USER + 150, 10000, 0); end else begin { There is no other instance, so initiate the restart ourself. Note: Depending on the OS, this may not return if successful. } RestartComputerFromThisProcess; end; end; end; function ExitSetupMsgBox: Boolean; begin Result := LoggedMsgBox(SetupMessages[msgExitSetupMessage], SetupMessages[msgExitSetupTitle], mbConfirmation, MB_YESNO or MB_DEFBUTTON2, False, 0) = IDYES; end; procedure ProcessMessagesProc; far; begin Application.ProcessMessages; end; procedure RunExecLog(const S: String; const Error, FirstLine: Boolean; const Data: NativeInt); begin if not Error and FirstLine then Log('Output:'); Log(S); end; function ShouldDisableFsRedirForRunEntry(const RunEntry: PSetupRunEntry): Boolean; begin Result := InstallDefaultDisableFsRedir; if roRun32Bit in RunEntry.Options then Result := False; if roRun64Bit in RunEntry.Options then begin if not IsWin64 then InternalError('Cannot run files in 64-bit locations on this version of Windows'); Result := True; end; end; procedure ProcessRunEntry(const RunEntry: PSetupRunEntry); var RunAsOriginalUser: Boolean; ExpandedFilename, ExpandedParameters: String; Wait: TExecWait; DisableFsRedir: Boolean; begin try Log('-- Run entry --'); RunAsOriginalUser := (roRunAsOriginalUser in RunEntry.Options); if RunAsOriginalUser then Log('Run as: Original user') else Log('Run as: Current user'); if not(roShellExec in RunEntry.Options) then Log('Type: Exec') else Log('Type: ShellExec'); ExpandedFilename := ExpandConst(RunEntry.Name); Log('Filename: ' + ExpandedFilename); ExpandedParameters := ExpandConst(RunEntry.Parameters); if not(roDontLogParameters in RunEntry.Options) and (ExpandedParameters <> '') then Log('Parameters: ' + ExpandedParameters); Wait := ewWaitUntilTerminated; case RunEntry.Wait of rwNoWait: Wait := ewNoWait; rwWaitUntilIdle: Wait := ewWaitUntilIdle; end; if not(roShellExec in RunEntry.Options) then begin DisableFsRedir := ShouldDisableFsRedirForRunEntry(RunEntry); if not(roSkipIfDoesntExist in RunEntry.Options) or NewFileExistsRedir(DisableFsRedir, ExpandedFilename) then begin var OutputReader: TCreateProcessOutputReader := nil; try if GetLogActive and (roLogOutput in RunEntry.Options) then OutputReader := TCreateProcessOutputReader.Create(RunExecLog, 0); var ErrorCode: DWORD; if not InstExecEx(RunAsOriginalUser, DisableFsRedir, ExpandedFilename, ExpandedParameters, ExpandConst(RunEntry.WorkingDir), Wait, RunEntry.ShowCmd, ProcessMessagesProc, OutputReader, ErrorCode) then raise Exception.Create(FmtSetupMessage1(msgErrorExecutingProgram, ExpandedFilename) + SNewLine2 + FmtSetupMessage(msgErrorFunctionFailedWithMessage, ['CreateProcess', IntToStr(ErrorCode), Win32ErrorString(ErrorCode)])); if Wait = ewWaitUntilTerminated then Log(Format('Process exit code: %u', [ErrorCode])); finally OutputReader.Free; end; end else Log('File doesn''t exist. Skipping.'); end else begin if not(roSkipIfDoesntExist in RunEntry.Options) or FileOrDirExists(ExpandedFilename) then begin var ErrorCode: DWORD; if not InstShellExecEx(RunAsOriginalUser, ExpandConst(RunEntry.Verb), ExpandedFilename, ExpandedParameters, ExpandConst(RunEntry.WorkingDir), Wait, RunEntry.ShowCmd, ProcessMessagesProc, ErrorCode) then raise Exception.Create(FmtSetupMessage1(msgErrorExecutingProgram, ExpandedFilename) + SNewLine2 + FmtSetupMessage(msgErrorFunctionFailedWithMessage, ['ShellExecuteEx', IntToStr(ErrorCode), Win32ErrorString(ErrorCode)])); end else Log('File/directory doesn''t exist. Skipping.'); end; except Application.HandleException(nil); end; end; procedure ShellExecuteAsOriginalUser(hWnd: HWND; Operation, FileName, Parameters, Directory: LPWSTR; ShowCmd: Integer); stdcall; begin var ErrorCode: DWORD; InstShellExecEx(True, Operation, Filename, Parameters, Directory, ewNoWait, ShowCmd, ProcessMessagesProc, ErrorCode); end; procedure InitIsWin64AndProcessorArchitectureAndMachineTypesSupportedBySystem; const PROCESSOR_ARCHITECTURE_ARM64 = 12; IMAGE_FILE_MACHINE_ARM64 = $AA64; IMAGE_FILE_MACHINE_ARMNT = $01C4; UserEnabled = $1; var KernelModule: HMODULE; {$IFNDEF WIN64} IsWow64ProcessFunc: function(hProcess: THandle; var Wow64Process: BOOL): BOOL; stdcall; {$ENDIF} IsWow64Process2Func: function(hProcess: THandle; var pProcessMachine, pNativeMachine: USHORT): BOOL; stdcall; GetMachineTypeAttributesFunc: function(Machine: USHORT; var MachineTypeAttributes: Integer): HRESULT; stdcall; IsWow64GuestMachineSupportedFunc: function(WowGuestMachine: USHORT; var MachineIsSupported: BOOL): HRESULT; stdcall; SysInfo: TSystemInfo; begin KernelModule := GetModuleHandle(kernel32); { 64-bit build: IsWin64 is a constant and always True. We do still need to get the processor architecture, and this is done below. 32-bit build: The system is considered a "Win64" system if all of the following conditions are true: 1. One of the following two is true: a. IsWow64Process2 is available, and returns True for the current process. b. IsWow64Process is available, and returns True for the current process. 2. Wow64DisableWow64FsRedirection is available. 3. Wow64RevertWow64FsRedirection is available. 4. GetSystemWow64DirectoryA is available. 5. RegDeleteKeyExA is available. The system does not have to be one of the known 64-bit architectures to be considered a "Win64" system. } {$IFNDEF WIN64} IsWin64 := False; {$ENDIF} IsWow64Process2Func := GetProcAddress(KernelModule, 'IsWow64Process2'); var ProcessMachine, NativeMachine: USHORT; if Assigned(IsWow64Process2Func) and IsWow64Process2Func(GetCurrentProcess, ProcessMachine, NativeMachine) then begin {$IFNDEF WIN64} if ProcessMachine <> IMAGE_FILE_MACHINE_UNKNOWN then IsWin64 := True; {$ENDIF} case NativeMachine of IMAGE_FILE_MACHINE_I386: ProcessorArchitecture := paX86; IMAGE_FILE_MACHINE_AMD64: ProcessorArchitecture := paX64; IMAGE_FILE_MACHINE_ARM64: ProcessorArchitecture := paArm64; else ProcessorArchitecture := paUnknown; end; end else begin {$IFNDEF WIN64} IsWow64ProcessFunc := GetProcAddress(KernelModule, 'IsWow64Process'); var Wow64Process: BOOL; if Assigned(IsWow64ProcessFunc) and IsWow64ProcessFunc(GetCurrentProcess, Wow64Process) and Wow64Process then IsWin64 := True; {$ENDIF} GetNativeSystemInfo(SysInfo); case SysInfo.wProcessorArchitecture of PROCESSOR_ARCHITECTURE_INTEL: ProcessorArchitecture := paX86; PROCESSOR_ARCHITECTURE_AMD64: ProcessorArchitecture := paX64; PROCESSOR_ARCHITECTURE_ARM64: ProcessorArchitecture := paArm64; else ProcessorArchitecture := paUnknown; end; end; {$IFNDEF WIN64} if IsWin64 and not (AreFsRedirectionFunctionsAvailable and (GetProcAddress(KernelModule, 'GetSystemWow64DirectoryA') <> nil) and (GetProcAddress(GetModuleHandle(advapi32), 'RegDeleteKeyExA') <> nil)) then IsWin64 := False; {$ENDIF} { Setup MachineTypesSupportedBySystem. The result should end up being: - 32-bit x86: [paX86] - x64: [paX86, paX64] (but not paX86 if Windows was installed without support for x86 binaries (which is possible with Windows Server)) - Arm64 Windows 10: [paX86, paArm64, paArm32] (Arm32 support detected, not just assumed) - Arm64 Windows 11: [paX86, paX64, paArm64, paArm32] (X64 and Arm32 support detected, not just assumed) } {$IFDEF CPUX86} MachineTypesSupportedBySystem := [paX86]; {$ELSE} {$IFDEF CPUX64} MachineTypesSupportedBySystem := [paX64]; {$ELSE} {$MESSAGE ERROR 'This needs updating for non-x86/x64 builds'} {$ENDIF} {$ENDIF} if ProcessorArchitecture <> paUnknown then Include(MachineTypesSupportedBySystem, ProcessorArchitecture); { Check if Arm32 and x86 are supported extra using IsWow64GuestMachineSupported } IsWow64GuestMachineSupportedFunc := GetProcAddress(KernelModule, 'IsWow64GuestMachineSupported'); if Assigned(IsWow64GuestMachineSupportedFunc) then begin var MachineIsSupported: BOOL; if (IsWow64GuestMachineSupportedFunc(IMAGE_FILE_MACHINE_ARMNT, MachineIsSupported) = S_OK) and MachineIsSupported then Include(MachineTypesSupportedBySystem, paArm32); if not (paX86 in MachineTypesSupportedBySystem) and (IsWow64GuestMachineSupportedFunc(IMAGE_FILE_MACHINE_I386, MachineIsSupported) = S_OK) and MachineIsSupported then Include(MachineTypesSupportedBySystem, paX86); end else if not (paX86 in MachineTypesSupportedBySystem) then begin {$IFDEF WIN64} { Detect x86 support by checking if SysWOW64\kernel32.dll exists } const Dir = GetSysWow64Dir; if (Dir <> '') and NewFileExists(AddBackslash(Dir) + 'kernel32.dll') then Include(MachineTypesSupportedBySystem, paX86); {$ENDIF} end; if not (paX64 in MachineTypesSupportedBySystem) then begin { On Windows 11 we can check if x64 is supported extra using GetMachineTypeAttributes } GetMachineTypeAttributesFunc := GetProcAddress(KernelModule, 'GetMachineTypeAttributes'); if Assigned(GetMachineTypeAttributesFunc) then begin var MachineTypeAttributes: Integer; if (GetMachineTypeAttributesFunc(IMAGE_FILE_MACHINE_AMD64, MachineTypeAttributes) = S_OK) and ((MachineTypeAttributes and UserEnabled) <> 0) then Include(MachineTypesSupportedBySystem, paX64); end; end; end; procedure InitWindowsVersion; var OSVersionInfo: TOSVersionInfo; OSVersionInfoEx: TOSVersionInfoEx; begin OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo); if GetVersionEx(OSVersionInfo) then begin WindowsVersion := (Byte(OSVersionInfo.dwMajorVersion) shl 24) or (Byte(OSVersionInfo.dwMinorVersion) shl 16) or Word(OSVersionInfo.dwBuildNumber); { ^ Note: We MUST clip dwBuildNumber to 16 bits for Win9x compatibility } OSVersionInfoEx.dwOSVersionInfoSize := SizeOf(OSVersionInfoEx); if GetVersionEx(POSVersionInfo(@OSVersionInfoEx)^) then begin NTServicePackLevel := Word((Byte(OSVersionInfoEx.wServicePackMajor) shl 8) or Byte(OSVersionInfoEx.wServicePackMinor)); WindowsProductType := OSVersionInfoEx.wProductType; WindowsSuiteMask := OSVersionInfoEx.wSuiteMask; end; end; end; procedure CreateEntryLists; var I: TEntryType; begin for I := Low(I) to High(I) do Entries[I] := TList.Create; end; procedure FreeEntryLists; var I: TEntryType; List: TList; P: Pointer; begin for I := High(I) downto Low(I) do begin List := Entries[I]; if Assigned(List) then begin Entries[I] := nil; for var J := List.Count-1 downto 0 do begin P := List[J]; if EntryStrings[I] <> 0 then SEFreeRec(P, EntryStrings[I], EntryAnsiStrings[I]) else FreeMem(P); end; List.Free; end; FreeAndNil(OriginalEntryIndexes[I]); end; end; procedure FreeWizardImages; begin FreeAndNil(WizardBackImages); FreeAndNil(WizardSmallImages); FreeAndNil(WizardImages); end; initialization InitIsWin64AndProcessorArchitectureAndMachineTypesSupportedBySystem; InitWindowsVersion; InitComponents := TStringList.Create(); InitTasks := TStringList.Create(); NewParamsForCode := TStringList.Create(); WizardComponents := TStringList.Create(); WizardDeselectedComponents := TStringList.Create(); WizardTasks := TStringList.Create(); WizardDeselectedTasks := TStringList.Create(); CreateEntryLists; DeleteFilesAfterInstallList := TStringList.Create; DeleteDirsAfterInstallList := TStringList.Create; CloseApplicationsFilterList := TStringList.Create; CloseApplicationsFilterExcludesList := TStringList.Create; WizardImages := TWizardImages.Create; WizardSmallImages := TWizardImages.Create; WizardBackImages := TWizardImages.Create; SHGetKnownFolderPathFunc := GetProcAddress(SafeLoadLibrary(AddBackslash(GetSystemDir) + shell32, SEM_NOOPENFILEERRORBOX), 'SHGetKnownFolderPath'); finalization FreeWizardImages; FreeAndNil(CloseApplicationsFilterExcludesList); FreeAndNil(CloseApplicationsFilterList); FreeAndNil(DeleteDirsAfterInstallList); FreeAndNil(DeleteFilesAfterInstallList); FreeEntryLists; FreeAndNil(WizardDeselectedTasks); FreeAndNil(WizardTasks); FreeAndNil(WizardDeselectedComponents); FreeAndNil(WizardComponents); FreeAndNil(NewParamsForCode); FreeAndNil(InitTasks); FreeAndNil(InitComponents); end.