├── CBSEnum.res ├── CBSEnum_Icon.ico ├── Docs └── cbsenum-0.8-screen.png ├── .hgignore ├── CBSEnum.dpr ├── CBSEnum_JobProcessor.dfm ├── WildcardMatching.pas ├── DecouplePackagesJob.pas ├── README.md ├── OsUtils.pas ├── TakeOwnershipJob.pas ├── CBSEnum_JobProcessor.pas ├── AclHelpers.pas ├── CBSEnum_Main.dfm ├── CBSEnum.dproj └── CBSEnum_Main.pas /CBSEnum.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/himselfv/cbsenum/HEAD/CBSEnum.res -------------------------------------------------------------------------------- /CBSEnum_Icon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/himselfv/cbsenum/HEAD/CBSEnum_Icon.ico -------------------------------------------------------------------------------- /Docs/cbsenum-0.8-screen.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/himselfv/cbsenum/HEAD/Docs/cbsenum-0.8-screen.png -------------------------------------------------------------------------------- /.hgignore: -------------------------------------------------------------------------------- 1 | syntax:glob 2 | 3 | __history/* 4 | *.local 5 | *.dcu 6 | *.rsm 7 | *.identcache 8 | *.vlb 9 | 10 | # Binary 11 | *.dll 12 | *.exe 13 | 14 | # Releases 15 | Win32/* 16 | Win64/* -------------------------------------------------------------------------------- /CBSEnum.dpr: -------------------------------------------------------------------------------- 1 | program CBSEnum; 2 | 3 | uses 4 | Vcl.Forms, 5 | CBSEnum_Main in 'CBSEnum_Main.pas' {MainForm}, 6 | CBSEnum_JobProcessor in 'CBSEnum_JobProcessor.pas' {JobProcessorForm}, 7 | AclHelpers in 'AclHelpers.pas', 8 | CommonResources in '..\ManifestEnum\CommonResources.pas' {ResourceModule}, 9 | DelayLoadTree in '..\ManifestEnum\Views\DelayLoadTree.pas', 10 | TakeOwnershipJob in 'TakeOwnershipJob.pas', 11 | DecouplePackagesJob in 'DecouplePackagesJob.pas', 12 | WildcardMatching in 'WildcardMatching.pas'; 13 | 14 | {$R *.res} 15 | 16 | begin 17 | Application.Initialize; 18 | Application.MainFormOnTaskbar := True; 19 | Application.CreateForm(TMainForm, MainForm); 20 | Application.CreateForm(TJobProcessorForm, JobProcessorForm); 21 | Application.Run; 22 | end. 23 | -------------------------------------------------------------------------------- /CBSEnum_JobProcessor.dfm: -------------------------------------------------------------------------------- 1 | object JobProcessorForm: TJobProcessorForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'Processing' 5 | ClientHeight = 336 6 | ClientWidth = 527 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | OnClose = FormClose 15 | OnCloseQuery = FormCloseQuery 16 | OnCreate = FormCreate 17 | OnDestroy = FormDestroy 18 | PixelsPerInch = 96 19 | TextHeight = 13 20 | object mmLog: TMemo 21 | Left = 0 22 | Top = 0 23 | Width = 527 24 | Height = 336 25 | Align = alClient 26 | ReadOnly = True 27 | ScrollBars = ssVertical 28 | TabOrder = 0 29 | OnChange = mmLogChange 30 | end 31 | object UpdateTimer: TTimer 32 | Enabled = False 33 | Interval = 200 34 | OnTimer = UpdateTimerTimer 35 | Left = 8 36 | Top = 8 37 | end 38 | end 39 | -------------------------------------------------------------------------------- /WildcardMatching.pas: -------------------------------------------------------------------------------- 1 | unit WildcardMatching; 2 | 3 | interface 4 | 5 | function WildcardMatchCase(a, w: PChar): boolean; 6 | 7 | implementation 8 | 9 | function WildcardMatchCase(a, w: PChar): boolean; 10 | label new_segment, test_match; 11 | var i: integer; 12 | star: boolean; 13 | begin 14 | new_segment: 15 | star := false; 16 | if w^='*' then begin 17 | star := true; 18 | repeat Inc(w) until w^ <> '*'; 19 | end; 20 | 21 | test_match: 22 | i := 0; 23 | while (w[i]<>#00) and (w[i]<>'*') do 24 | if a[i] <> w[i] then begin 25 | if a[i]=#00 then begin 26 | Result := false; 27 | exit; 28 | end; 29 | if (w[i]='?') and (a[i] <> '.') then begin 30 | Inc(i); 31 | continue; 32 | end; 33 | if not star then begin 34 | Result := false; 35 | exit; 36 | end; 37 | Inc(a); 38 | goto test_match; 39 | end else 40 | Inc(i); 41 | 42 | if w[i]='*' then begin 43 | Inc(a, i); 44 | Inc(w, i); 45 | goto new_segment; 46 | end; 47 | 48 | if a[i]=#00 then begin 49 | Result := true; 50 | exit; 51 | end; 52 | 53 | if (i > 0) and (w[i-1]='*') then begin 54 | Result := true; 55 | exit; 56 | end; 57 | 58 | if not star then begin 59 | Result := false; 60 | exit; 61 | end; 62 | 63 | Inc(a); 64 | goto test_match; 65 | end; 66 | 67 | end. 68 | -------------------------------------------------------------------------------- /DecouplePackagesJob.pas: -------------------------------------------------------------------------------- 1 | unit DecouplePackagesJob; 2 | 3 | interface 4 | uses Windows, CBSEnum_JobProcessor, UniStrUtils; 5 | 6 | type 7 | TDecouplePackagesJob = class(TProcessingThread) 8 | protected 9 | FPackageNames: TStringArray; 10 | procedure DecouplePackages(const AKey: string; const APackageNames: TStringArray); 11 | public 12 | constructor Create(const APackageNames: TStringArray); 13 | procedure Execute; override; 14 | end; 15 | 16 | implementation 17 | uses SysUtils, Classes, Registry, CBSEnum_Main; 18 | 19 | constructor TDecouplePackagesJob.Create(const APackageNames: TStringArray); 20 | begin 21 | inherited Create; 22 | Self.FPackageNames := APackageNames; 23 | end; 24 | 25 | //Ownership has to be already taken. 26 | //PackageNames: list of packages to be decoupled from their parents. Lowercase. Empty == all packages. 27 | procedure TDecouplePackagesJob.DecouplePackages(const AKey: string; const APackageNames: TStringArray); 28 | var reg: TRegistry; 29 | subkeys: TStringList; 30 | subkey: string; 31 | begin 32 | Log('Trying '+AKey+'...'); 33 | subkeys := nil; 34 | reg := TRegistry.Create; 35 | try 36 | reg.RootKey := hkCbsRoot; 37 | if not reg.OpenKey(AKey, false) then begin 38 | Log('No such key.'); 39 | exit; //no key, whatever 40 | end; 41 | 42 | subkeys := TStringList.Create; 43 | reg.GetKeyNames(subkeys); 44 | 45 | for subkey in subkeys do begin 46 | if Terminated then break; 47 | Log(subkey+'...'); 48 | if (Length(APackageNames) = 0) or IsPackageInList(APackageNames, subkey) then try 49 | reg.DeleteKey(subkey+'\Owners'); 50 | Log('Owners removed.'); 51 | except 52 | on E: EOSError do 53 | if E.ErrorCode = ERROR_FILE_NOT_FOUND then 54 | continue 55 | else 56 | raise; 57 | end; 58 | end; 59 | 60 | finally 61 | FreeAndNil(subkeys); 62 | FreeAndNil(reg); 63 | end; 64 | end; 65 | 66 | procedure TDecouplePackagesJob.Execute; 67 | begin 68 | DecouplePackages(sCbsKey+'\Packages', FPackageNames); 69 | DecouplePackages(sCbsKey+'\PackageNames', FPackageNames); 70 | end; 71 | 72 | end. 73 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CBSEnum # 2 | 3 | CBSEnum is a tool to view and manage Windows Component-Based Servicing packages. 4 | 5 | Component-Based Servicing is a technology since Windows Vista which most resembles Linux-style package managers. It builds upon WinSxS (Side by side assemblies) to allow installation, deinstallation and updating of numerous Windows components independently. 6 | 7 | It presents a moderately componentized view into Windows and allows uninstalling parts of system which outside of Windows Embedded were previously seen as monolithic. 8 | 9 | In Windows, this technology is hidden from general public. There's a command-line tool dism.exe to manage CBS packages, but most packages are marked as hidden even from DISM. 10 | 11 | ![CBSEnum screenshot](Docs/cbsenum-0.8-screen.png) 12 | 13 | CBSEnum is a graphical interface for DISM which presents packages in a visually simple format, allows to uninstall or mass-uninstall any. It also shows hidden packages, lets you make them visible or restore to original visibility state. 14 | 15 | ### Requirements and warnings ### 16 | 17 | CBSEnum must be run as administrator. 18 | 19 | Before anything can be done with packages, you will have to take ownership of `HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Component Based Servicing` registry key and all subkeys and give yourself write permissions. CBSEnum can do this for you: choose "Edit -> Take Ownership". 20 | 21 | Before most packages can be deleted, they have to be detached from their mothership package ("Windows Home", "Windows Professional" or "Windows Enterprise"). This can be done with [install_wim_tweak tool](http://www.wincert.net/forum/topic/12021-install-wim-tweakexe/) but now CBSEnum supports this too: "Edit -> Decouple all packages". 22 | 23 | Before DISM will work with most packages, they have to be made DISM-visible. This can be done from CBSEnum by right-clicking any package and doing "Visibility -> Make visible". You can also make all packages Visible from Edit menu. 24 | 25 | CBSEnum preserves original package visibility in the same way instal_wim_tweak does, in DefVis keys. 26 | 27 | When uninstalling packages, exert your usual caution. Uninstalled packages cannot be installed back without their source cabs, which most people don't have. Save for reinstalling the OS, your best bet would be system repair from installation media. 28 | 29 | ### Bulk removal ### 30 | 31 | Starting with 0.9, CBSEnum supports bulk removal scripts. Each line is a package mask: 32 | 33 | ``` 34 | # Telemetry 35 | Microsoft-OneCore-AllowTelemetry* 36 | Microsoft-Windows-Prerelease* 37 | Microsoft-Windows-DiagTrack* 38 | # Microsoft-WindowsFeedback* # Feedback is a useful app to have, but may be seen as telemetry 39 | Microsoft-OneCore-TroubleShooting* # Some consider this also part of telemetry. 40 | Microsoft-Windows-TroubleShooting* 41 | Microsoft-Windows-ContactSupport* # Contact Microsoft support 42 | ``` 43 | 44 | Such scripts, listing all that you feel needs to be removed with comments about the reasons, can be tested in a virtual machine until a satisfying configuration is achieved and then deployed to the actual target. -------------------------------------------------------------------------------- /OsUtils.pas: -------------------------------------------------------------------------------- 1 | unit OsUtils; 2 | 3 | interface 4 | uses SysUtils, Windows; 5 | 6 | function GetSystemDir: string; 7 | function GetWindowsDir: string; 8 | function GetModuleFilenameStr(hModule: HMODULE = 0): string; 9 | function AppFolder: string; 10 | 11 | function StartProcess(const AProgramName, ACommandLine: string): TProcessInformation; 12 | procedure RegeditOpenAndNavigate(const ARegistryPath: string); 13 | procedure ShellOpen(const sCommand: string; const sParams: string = ''); 14 | procedure ExplorerAtFile(const AFilename: string); 15 | 16 | 17 | implementation 18 | uses Registry, ShellAPI; 19 | 20 | function GetSystemDir: string; 21 | var 22 | Buffer: array[0..MAX_PATH] of Char; 23 | begin 24 | GetSystemDirectory(Buffer, MAX_PATH - 1); 25 | SetLength(Result, StrLen(Buffer)); 26 | Result := Buffer; 27 | end; 28 | 29 | function GetWindowsDir: string; 30 | var 31 | Buffer: array[0..MAX_PATH] of Char; 32 | begin 33 | GetWindowsDirectory(Buffer, MAX_PATH - 1); 34 | SetLength(Result, StrLen(Buffer)); 35 | Result := Buffer; 36 | end; 37 | 38 | //Max length, in symbols, of supported image path size. 39 | const 40 | MAX_PATH_LEN = 8192; 41 | 42 | function GetModuleFilenameStr(hModule: HMODULE = 0): string; 43 | var nSize, nRes: dword; 44 | begin 45 | nSize := 256; 46 | SetLength(Result, nSize); 47 | 48 | nRes := GetModuleFilenameW(hModule, @Result[1], nSize); 49 | while (nRes <> 0) and (nRes >= nSize) and (nSize < MAX_PATH_LEN) do begin 50 | nSize := nSize * 2; 51 | SetLength(Result, nSize); 52 | nRes := GetModuleFilenameW(hModule, @Result[1], nSize); 53 | end; 54 | 55 | if nRes = 0 then begin 56 | Result := ''; 57 | exit; 58 | end; 59 | 60 | if nRes >= nSize then begin 61 | Result := ''; 62 | exit; 63 | end; 64 | 65 | SetLength(Result, nRes); 66 | end; 67 | 68 | function AppFolder: string; 69 | begin 70 | Result := GetModuleFilenameStr(); 71 | if Result <> '' then 72 | Result := SysUtils.ExtractFilePath(Result); 73 | end; 74 | 75 | function StartProcess(const AProgramName, ACommandLine: string): TProcessInformation; 76 | var startupInfo: TStartupInfo; 77 | begin 78 | FillChar(startupInfo, SizeOf(startupInfo), 0); 79 | FillChar(Result, SizeOf(Result), 0); 80 | if not CreateProcess(PChar(AProgramName), PChar(ACommandLine), 81 | nil, nil, false, 0, nil, nil, startupInfo, Result) then 82 | RaiseLastOsError(); 83 | end; 84 | 85 | procedure RegeditOpenAndNavigate(const ARegistryPath: string); 86 | var reg: TRegistry; 87 | begin 88 | //That's the only damn way 89 | //Well, there's also regjump.exe from SysInternals but it shows EULA and it's 90 | //a dependency. 91 | //It can also be done directly using UI automation. 92 | reg := TRegistry.Create; 93 | try 94 | reg.RootKey := HKEY_CURRENT_USER; 95 | if not reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Applets\Regedit', true) then 96 | raise Exception.Create('Cannot point regedit at a key.'); 97 | reg.WriteString('LastKey', ARegistryPath); 98 | finally 99 | FreeAndNil(reg); 100 | end; 101 | StartProcess(GetWindowsDir()+'\regedit.exe', 'regedit.exe'); 102 | end; 103 | 104 | procedure ShellOpen(const sCommand: string; const sParams: string = ''); 105 | begin 106 | ShellExecute(0, 'open', PChar(sCommand), PChar(sParams), '', SW_SHOW); 107 | end; 108 | 109 | procedure ExplorerAtFile(const AFilename: string); 110 | begin 111 | ShellExecute(0, '', PChar('explorer.exe'), PChar('/select,"'+AFilename+'"'), 112 | '', SW_SHOW); 113 | end; 114 | 115 | end. 116 | -------------------------------------------------------------------------------- /TakeOwnershipJob.pas: -------------------------------------------------------------------------------- 1 | unit TakeOwnershipJob; 2 | 3 | interface 4 | uses Windows, Registry, AccCtrl, CBSEnum_JobProcessor; 5 | 6 | {$IFDEF DEBUG} 7 | //{$DEFINE DEBUG_HELPER} 8 | {$ENDIF} 9 | 10 | type 11 | TTakeOwnershipJob = class(TProcessingThread) 12 | protected 13 | {$IFDEF DEBUG_HELPER} 14 | procedure AclHelpersLog(const AMsg: string); 15 | {$ENDIF} 16 | procedure TakeRegistryOwnership(); 17 | procedure TakeRegistryOwnershipOfKey(AReg: TRegistry; const AKey: string; ANewOwner: PSID); 18 | public 19 | procedure Execute; override; 20 | end; 21 | 22 | implementation 23 | uses SysUtils, Classes, AclHelpers, CBSEnum_Main; 24 | 25 | {$IFDEF DEBUG_HELPER} 26 | procedure TTakeOwnershipJob.AclHelpersLog(const AMsg: string); 27 | begin 28 | Self.Log(AMsg); 29 | end; 30 | {$ENDIF} 31 | 32 | procedure TTakeOwnershipJob.Execute; 33 | begin 34 | {$IFDEF DEBUG_HELPER} 35 | AclHelpers.OnLog := Self.AclHelpersLog; 36 | {$ENDIF} 37 | TakeRegistryOwnership(); 38 | {$IFDEF DEBUG_HELPER} 39 | AclHelpers.OnLog := nil; 40 | {$ENDIF} 41 | end; 42 | 43 | procedure TTakeOwnershipJob.TakeRegistryOwnership(); 44 | var hProcToken: THandle; 45 | pSidAdmin: PSID; 46 | reg: TRegistry; 47 | begin 48 | pSidAdmin := nil; 49 | 50 | //Before we take ownership, we need to claim that privilege 51 | Log('Opening process token'); 52 | if not OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES, hProcToken) then 53 | RaiseLastOsError(); 54 | Log('Setting SE_TAKE_OWNERSHIP_NAME'); 55 | if not SetPrivilege(hProcToken, SE_TAKE_OWNERSHIP_NAME, true) then 56 | RaiseLastOsError(); 57 | 58 | //Clear and release the handles later 59 | try 60 | Log('Getting BUILTIN\Administrators reference'); 61 | //We're going to give ownership to BUILTIN\Administrators, this is comparatively safe + fits our needs 62 | pSidAdmin := AllocateSidBuiltinAdministrators(); 63 | 64 | reg := TRegistry.Create; 65 | try 66 | reg.RootKey := hkCbsRoot; 67 | reg.Access := KEY_READ; 68 | TakeRegistryOwnershipOfKey(reg, '\'+sCbsKey, pSidAdmin); 69 | finally 70 | FreeAndNil(reg); 71 | end; 72 | 73 | finally 74 | if pSIDAdmin <> nil then 75 | FreeSid(pSIDAdmin); 76 | 77 | Log('Clearing SE_TAKE_OWNERSHIP_NAME'); 78 | SetPrivilege(hProcToken, SE_TAKE_OWNERSHIP_NAME, false); 79 | CloseHandle(hProcToken); 80 | end; 81 | Log('Done.'); 82 | end; 83 | 84 | //Called for every child key, recursively. Sets its owner to ANewOwner and gives the previous owner full rights. 85 | //Key must start with / 86 | procedure TTakeOwnershipJob.TakeRegistryOwnershipOfKey(AReg: TRegistry; const AKey: string; ANewOwner: PSID); 87 | var subkeys: TStringList; 88 | subkey: string; 89 | err: cardinal; 90 | pSidPreviousOwner: PSID; 91 | pPreviousOwnerDescriptor: PSECURITY_DESCRIPTOR; 92 | begin 93 | Log('Processing key '+AKey); 94 | //There's no way to "go one level upper" with TRegistry so we're stuck with non-efficient "open each key from the root" 95 | if not AReg.OpenKey(AKey, false) then 96 | RaiseLastOsError(); 97 | 98 | err := SwitchOwnership(sCbsRootSec+AKey, SE_REGISTRY_KEY, ANewOwner, pSIDPreviousOwner, 99 | pPreviousOwnerDescriptor); 100 | if err <> ERROR_SUCCESS then RaiseLastOsError(err); 101 | 102 | if pSidPreviousOwner <> nil then try 103 | Log('...ownership taken, granting permissions to previous owner'); 104 | //Give explicit full permissions to the previous owner 105 | err := AddExplicitPermissions(sCbsRootSec+AKey, SE_REGISTRY_KEY, pSidPreviousOwner, KEY_ALL_ACCESS); 106 | if err <> ERROR_SUCCESS then 107 | RaiseLastOsError(err); 108 | 109 | finally 110 | LocalFree(NativeUInt(pPreviousOwnerDescriptor)); 111 | pPreviousOwnerDescriptor := nil; 112 | pSidPreviousOwner := nil; 113 | end else 114 | Log('...already owned.'); 115 | 116 | //Give new owner full access (if they don't have it) 117 | err := AddExplicitPermissions(sCbsRootSec+AKey, SE_REGISTRY_KEY, ANewOwner, KEY_ALL_ACCESS); 118 | if err <> ERROR_SUCCESS then 119 | RaiseLastOsError(err); 120 | 121 | //Process subkeys 122 | subkeys := TStringList.Create; 123 | try 124 | AReg.GetKeyNames(subkeys); 125 | for subkey in subkeys do begin 126 | TakeRegistryOwnershipOfKey(AReg, AKey+'\'+subkey, ANewOwner); 127 | if Terminated then break; 128 | end; 129 | finally 130 | FreeAndNil(subkeys); 131 | end; 132 | end; 133 | 134 | 135 | end. 136 | -------------------------------------------------------------------------------- /CBSEnum_JobProcessor.pas: -------------------------------------------------------------------------------- 1 | unit CBSEnum_JobProcessor; 2 | // Runs threaded jobs 3 | 4 | interface 5 | 6 | uses 7 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 8 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls; 9 | 10 | type 11 | TLogEvent = procedure(const AMessage: string) of object; 12 | TProcessingThread = class(TThread) 13 | protected 14 | FOnLog: TLogEvent; 15 | procedure Log(const AMessage: string); 16 | public 17 | constructor Create; 18 | property OnLog: TLogEvent read FOnLog write FOnLog; 19 | end; 20 | 21 | TJobProcessorForm = class(TForm) 22 | mmLog: TMemo; 23 | UpdateTimer: TTimer; 24 | procedure FormClose(Sender: TObject; var Action: TCloseAction); 25 | procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); 26 | procedure UpdateTimerTimer(Sender: TObject); 27 | procedure FormCreate(Sender: TObject); 28 | procedure FormDestroy(Sender: TObject); 29 | procedure mmLogChange(Sender: TObject); 30 | protected 31 | FThread: TProcessingThread; 32 | FLogSync: TRtlCriticalSection; 33 | FNewLogLines: TStringList; 34 | procedure ProcessingThreadLog(const AMessage: string); 35 | procedure PostLogEntries; 36 | public 37 | procedure Log(const msg: string); 38 | procedure Process(AJob: TProcessingThread); 39 | procedure EndProcessing; 40 | end; 41 | 42 | var 43 | JobProcessorForm: TJobProcessorForm; 44 | 45 | implementation 46 | 47 | {$R *.dfm} 48 | 49 | constructor TProcessingThread.Create; 50 | begin 51 | inherited Create({Suspended=}true); //always create suspended 52 | end; 53 | 54 | procedure TProcessingThread.Log(const AMessage: string); 55 | begin 56 | if Assigned(FOnLog) then 57 | FOnLog(AMessage); 58 | end; 59 | 60 | procedure TJobProcessorForm.FormCreate(Sender: TObject); 61 | begin 62 | InitializeCriticalSection(FLogSync); 63 | FNewLogLines := TStringList.Create; 64 | end; 65 | 66 | procedure TJobProcessorForm.FormDestroy(Sender: TObject); 67 | begin 68 | FreeAndNil(FNewLogLines); 69 | DeleteCriticalSection(FLogSync); 70 | end; 71 | 72 | procedure TJobProcessorForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); 73 | begin 74 | CanClose := (not Assigned(FThread)) 75 | or (MessageBox(Self.Handle, PChar('The operation is still in progress, do you want to abort it?'), 76 | PChar('Confirm abort'), MB_ICONQUESTION + MB_YESNO) = ID_YES); 77 | end; 78 | 79 | procedure TJobProcessorForm.FormClose(Sender: TObject; var Action: TCloseAction); 80 | begin 81 | EndProcessing; 82 | end; 83 | 84 | procedure TJobProcessorForm.Process(AJob: TProcessingThread); 85 | begin 86 | if Assigned(FThread) then 87 | raise Exception.Create('Operation is still in progress'); 88 | FThread := AJob; 89 | FThread.OnLog := ProcessingThreadLog; 90 | FThread.Start; 91 | UpdateTimer.Enabled := true; 92 | end; 93 | 94 | procedure TJobProcessorForm.EndProcessing; 95 | begin 96 | if Assigned(FThread) then begin 97 | FThread.Terminate; 98 | FThread.WaitFor; 99 | FreeAndNil(FThread); 100 | end; 101 | UpdateTimer.Enabled := false; 102 | PostLogEntries(); //in case there's anything pending 103 | end; 104 | 105 | procedure TJobProcessorForm.UpdateTimerTimer(Sender: TObject); 106 | begin 107 | PostLogEntries; 108 | 109 | if FThread = nil then begin 110 | UpdateTimer.Enabled := false; 111 | exit; 112 | end; 113 | 114 | if FThread.FatalException <> nil then begin 115 | Log('Fatal exception '+FThread.FatalException.ClassName+': '+Exception(FThread.FatalException).Message); 116 | EndProcessing(); 117 | exit; 118 | end; 119 | 120 | if FThread.Finished then 121 | EndProcessing; 122 | end; 123 | 124 | procedure TJobProcessorForm.ProcessingThreadLog(const AMessage: string); 125 | begin 126 | EnterCriticalSection(FLogSync); 127 | try 128 | FNewLogLines.Add(AMessage); 129 | finally 130 | LeaveCriticalSection(FLogSync); 131 | end; 132 | end; 133 | 134 | procedure TJobProcessorForm.PostLogEntries; 135 | var line: string; 136 | begin 137 | EnterCriticalSection(FLogSync); 138 | try 139 | mmLog.Lines.BeginUpdate; 140 | for line in FNewLogLines do 141 | mmLog.Lines.Add(line); 142 | FNewLogLines.Clear; 143 | mmLog.Lines.EndUpdate; 144 | mmLog.Refresh; 145 | finally 146 | LeaveCriticalSection(FLogSync); 147 | end; 148 | end; 149 | 150 | procedure TJobProcessorForm.Log(const msg: string); 151 | begin 152 | mmLog.Lines.Add(msg); 153 | end; 154 | 155 | 156 | procedure TJobProcessorForm.mmLogChange(Sender: TObject); 157 | begin 158 | SendMessage(mmLog.Handle, EM_LINESCROLL, 0, mmLog.Lines.Count); 159 | end; 160 | 161 | end. 162 | -------------------------------------------------------------------------------- /AclHelpers.pas: -------------------------------------------------------------------------------- 1 | unit AclHelpers; 2 | //Windows security-related functions helper 3 | 4 | interface 5 | uses Windows, AccCtrl; 6 | 7 | const 8 | SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5)); 9 | 10 | SECURITY_BUILTIN_DOMAIN_RID = $00000020; 11 | 12 | DOMAIN_ALIAS_RID_ADMINS = $00000220; 13 | 14 | SE_TAKE_OWNERSHIP_NAME = 'SeTakeOwnershipPrivilege'; 15 | SE_BACKUP_NAME = 'SeBackupPrivilege'; 16 | SE_RESTORE_NAME = 'SeRestorePrivilege'; 17 | SE_SECURITY_NAME = 'SeSecurityPrivilege'; 18 | 19 | OBJECT_INHERIT_ACE = 1; 20 | CONTAINER_INHERIT_ACE = 2; 21 | 22 | ACCESS_ALLOWED_ACE_TYPE = 0; 23 | 24 | type 25 | TLuid = TLargeInteger; 26 | 27 | ACE_HEADER = record 28 | AceType: BYTE; 29 | AceFlags: BYTE; 30 | AceSize: WORD; 31 | end; 32 | PACE_HEADER = ^ACE_HEADER; 33 | 34 | ACCESS_ALLOWED_ACE = record 35 | Header: ACE_HEADER; 36 | Mask: ACCESS_MASK; 37 | SidStart: DWORD; 38 | end; 39 | PACCESS_ALLOWED_ACE = ^ACCESS_ALLOWED_ACE; 40 | 41 | {$IFDEF DEBUG} 42 | type 43 | TMsgEvent = procedure(const AMessage: string) of object; 44 | 45 | var 46 | OnLog: TMsgEvent; 47 | {$ENDIF} 48 | 49 | function LookupPrivilegeValue(lpSystemName, lpName: LPCWSTR): TLuid; 50 | 51 | function SetPrivilege(hToken: THandle; const APrivilege: TLuid; const AValue: boolean): boolean; overload; 52 | function SetPrivilege(hToken: THandle; const APrivilege: string; const AValue: boolean): boolean; overload; 53 | 54 | { 55 | This is a sort of a wrapper shortcut. Usage: 56 | if ClaimPrivilege(SE_PRIVILEGE_NAME, hPriv) <> 0 then begin 57 | ... 58 | ReleasePrivilege(hPriv); 59 | end; 60 | } 61 | type 62 | TPrivToken = record 63 | hProcToken: THandle; 64 | luid: TLuid; 65 | end; 66 | 67 | function ClaimPrivilege(const APrivilege: TLuid; out AToken: TPrivToken): boolean; overload; 68 | function ClaimPrivilege(const APrivilege: string; out AToken: TPrivToken): boolean; overload; inline; 69 | procedure ReleasePrivilege(const AToken: TPrivToken); overload; 70 | 71 | 72 | function AllocateSidBuiltin(Group: DWORD): PSID; 73 | function AllocateSidBuiltinAdministrators: PSID; 74 | 75 | function IsUserInBuiltinGroup(Group: DWORD): BOOL; 76 | function IsUserAdmin: BOOL; 77 | 78 | //pDescriptor has to be LocalFree()d, other out-parameters don't. 79 | function SetOwnership(const AObjectName: string; AObjectType: SE_OBJECT_TYPE; aNewOwner: PSID): cardinal; 80 | function SwitchOwnership(const AObjectName: string; AObjectType: SE_OBJECT_TYPE; 81 | aNewOwner: PSID; out aPreviousOwner: PSID; out pDescriptor: PSECURITY_DESCRIPTOR): cardinal; 82 | 83 | function AddExplicitPermissions(const AObjectName: string; AObjectType: SE_OBJECT_TYPE; aTrustee: PSID; 84 | APermissions: cardinal; APreviousPermissions: PCardinal = nil): cardinal; 85 | 86 | 87 | implementation 88 | uses SysUtils, AclAPI; 89 | 90 | {$IFDEF DEBUG} 91 | procedure Log(const msg: string); 92 | begin 93 | if Assigned(OnLog) then 94 | OnLog(msg); 95 | end; 96 | {$ELSE} 97 | procedure Log(const msg: string); 98 | begin 99 | end; 100 | {$ENDIF} 101 | 102 | function CheckTokenMembership(TokenHandle: THandle; SidToCheck: PSID; 103 | out IsMember: BOOL): BOOL; stdcall; external advapi32; 104 | 105 | 106 | //A version of LookupPrivilegeValue which handles failure by throwing error 107 | function LookupPrivilegeValue(lpSystemName, lpName: LPCWSTR): TLuid; 108 | begin 109 | if not Windows.LookupPrivilegeValue(lpSystemName, lpName, Result) then 110 | RaiseLastOsError(); 111 | end; 112 | 113 | function SetPrivilege(hToken: THandle; const APrivilege: TLuid; const AValue: boolean): boolean; overload; 114 | var tp: TOKEN_PRIVILEGES; 115 | begin 116 | tp.PrivilegeCount := 1; 117 | tp.Privileges[0].Luid := APrivilege; 118 | if AValue then 119 | tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED 120 | else 121 | tp.Privileges[0].Attributes := 0; //disabled 122 | 123 | Result := AdjustTokenPrivileges(hToken, false, tp, sizeof(tp), PTokenPrivileges(nil)^, PCardinal(nil)^); 124 | end; 125 | 126 | function SetPrivilege(hToken: THandle; const APrivilege: string; const AValue: boolean): boolean; 127 | var sePrivilege: TLuid; 128 | begin 129 | if not Windows.LookupPrivilegeValue(nil, PChar(APrivilege), sePrivilege) then 130 | Result := false 131 | else 132 | Result := SetPrivilege(hToken, sePrivilege, AValue); 133 | end; 134 | 135 | function ClaimPrivilege(const APrivilege: TLuid; out AToken: TPrivToken): boolean; 136 | var err: integer; 137 | begin 138 | AToken.luid := APrivilege; 139 | if not OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES, AToken.hProcToken) then begin 140 | Result := false; 141 | exit; 142 | end; 143 | if not SetPrivilege(AToken.hProcToken, APrivilege, true) then begin 144 | err := GetLastError(); 145 | CloseHandle(AToken.hProcToken); //can modify LastError 146 | AToken.hProcToken := 0; 147 | SetLastError(err); 148 | Result := false; 149 | end; 150 | Result := true; 151 | end; 152 | 153 | function ClaimPrivilege(const APrivilege: string; out AToken: TPrivToken): boolean; overload; 154 | var sePrivilege: TLuid; 155 | begin 156 | if not Windows.LookupPrivilegeValue(nil, PChar(APrivilege), sePrivilege) then begin 157 | Result := false; 158 | exit; 159 | end; 160 | Result := ClaimPrivilege(sePrivilege, AToken); 161 | end; 162 | 163 | procedure ReleasePrivilege(const AToken: TPrivToken); overload; 164 | begin 165 | if AToken.hProcToken = 0 then exit; 166 | SetPrivilege(AToken.hProcToken, AToken.luid, false); 167 | CloseHandle(AToken.hProcToken); 168 | end; 169 | 170 | 171 | //Allocates a SID for a BUILTIN group. SID has to be freed with FreeSid 172 | function AllocateSidBuiltin(Group: DWORD): PSID; 173 | var SIDAuthNT: SID_IDENTIFIER_AUTHORITY; 174 | begin 175 | SIDAuthNT := SECURITY_NT_AUTHORITY; 176 | if not AllocateAndInitializeSid(@SIDAuthNT, 2, SECURITY_BUILTIN_DOMAIN_RID, 177 | Group, 0, 0, 0, 0, 0, 0, Result) then 178 | RaiseLastOsError(); 179 | end; 180 | 181 | //Allocates a SID for BUILTIN\Administrators. SID has to be freed with FreeSid. 182 | function AllocateSidBuiltinAdministrators: PSID; 183 | var SIDAuthNT: SID_IDENTIFIER_AUTHORITY; 184 | begin 185 | SIDAuthNT := SECURITY_NT_AUTHORITY; 186 | if not AllocateAndInitializeSid(@SIDAuthNT, 2, SECURITY_BUILTIN_DOMAIN_RID, 187 | DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, Result) then 188 | RaiseLastOsError(); 189 | end; 190 | 191 | //Returns true if the user is a member of a given builtin group 192 | function IsUserInBuiltinGroup(Group: DWORD): BOOL; 193 | var sidGroup: PSID; 194 | begin 195 | sidGroup := AllocateSidBuiltin(Group); 196 | try 197 | if not CheckTokenMembership(0, sidGroup, Result) then 198 | Result := False; 199 | finally 200 | FreeSid(sidGroup); 201 | end; 202 | end; 203 | 204 | //Returns true if you are currently running with admin privileges 205 | //Under Vista+ will return false when non-elevated. 206 | function IsUserAdmin: BOOL; 207 | var sidAdmin: PSID; 208 | begin 209 | sidAdmin := AllocateSidBuiltinAdministrators; 210 | try 211 | if not CheckTokenMembership(0, sidAdmin, Result) then 212 | Result := False; 213 | finally 214 | FreeSid(sidAdmin); 215 | end; 216 | end; 217 | 218 | 219 | //Replaces ownership for the object 220 | function SetOwnership(const AObjectName: string; AObjectType: SE_OBJECT_TYPE; aNewOwner: PSID): cardinal; 221 | begin 222 | Result := SetNamedSecurityInfo(PChar(AObjectName), AObjectType, OWNER_SECURITY_INFORMATION, 223 | @aNewOwner, nil, nil, nil); 224 | end; 225 | 226 | //Replaces ownership for the object, returns the previous owner or nil if no change was needed. 227 | function SwitchOwnership(const AObjectName: string; AObjectType: SE_OBJECT_TYPE; aNewOwner: PSID; 228 | out aPreviousOwner: PSID; out pDescriptor: PSECURITY_DESCRIPTOR): cardinal; 229 | begin 230 | Log('GetNamedSecurityInfo: '+AObjectName); 231 | Result := GetNamedSecurityInfo(PChar(AObjectName), AObjectType, OWNER_SECURITY_INFORMATION, 232 | @aPreviousOwner, nil, nil, nil, pDescriptor); 233 | if Result <> ERROR_SUCCESS then exit; 234 | 235 | if EqualSid(aPreviousOwner, aNewOwner) then begin 236 | LocalFree(NativeUInt(pDescriptor)); 237 | aPreviousOwner := nil; 238 | Result := ERROR_SUCCESS; 239 | exit; 240 | end; 241 | 242 | Log('SetNamedSecurityInfo: '+AObjectName); 243 | Result := SetNamedSecurityInfo(PChar(AObjectName), AObjectType, OWNER_SECURITY_INFORMATION, 244 | aNewOwner, nil, nil, nil); 245 | end; 246 | 247 | //Adds access permissions for a trustee, if those were not already present. 248 | function AddExplicitPermissions(const AObjectName: string; AObjectType: SE_OBJECT_TYPE; aTrustee: PSID; 249 | APermissions: cardinal; APreviousPermissions: PCardinal): cardinal; 250 | var pDescriptor: PSecurityDescriptor; 251 | pDacl: PACL; 252 | i: integer; 253 | pAce: PACE_HEADER; 254 | pNewDacl: PACL; 255 | pNewAccess: EXPLICIT_ACCESS; 256 | begin 257 | pNewDacl := nil; 258 | pDescriptor := nil; 259 | 260 | Log('GetNamedSecurityInfo: '+AObjectName); 261 | Result := GetNamedSecurityInfo(PChar(AObjectName), AObjectType, DACL_SECURITY_INFORMATION, 262 | nil, nil, @pDacl, nil, pointer(pDescriptor)); 263 | if Result <> ERROR_SUCCESS then exit; 264 | try 265 | Log('Checking entries...'); 266 | for i := 0 to pDacl.AceCount-1 do begin 267 | if not GetAce(pDacl, i, pointer(pAce)) then begin 268 | Result := GetLastError(); //we could continue and try to write anyway, but let's not take risks 269 | exit; 270 | end; 271 | 272 | if pAce.AceType = ACCESS_ALLOWED_ACE_TYPE then 273 | Log('Entry: Type='+IntToStr(pAce.AceType)+', mask='+IntToStr(PACCESS_ALLOWED_ACE(pAce)^.Mask)) 274 | else 275 | Log('Entry: Type='+IntToStr(pAce.AceType)); 276 | 277 | //we only settle on "all required rights in one go" because otherwise it's just too unstable 278 | //we also don't care if there's explicit "deny" or "re-set to less" afterwards, whoever placed it it's their problem 279 | if pAce.AceType <> ACCESS_ALLOWED_ACE_TYPE then continue; 280 | if PACCESS_ALLOWED_ACE(pAce)^.Mask and APermissions <> APermissions then continue; 281 | if not EqualSid(PSID(@PACCESS_ALLOWED_ACE(pAce).SidStart), aTrustee) then continue; 282 | 283 | Log('Existing grant_entry found'); 284 | //Entry exist! 285 | if APreviousPermissions <> nil then 286 | APreviousPermissions^ := PACCESS_ALLOWED_ACE(pAce)^.Mask; 287 | Result := ERROR_SUCCESS; 288 | exit; 289 | end; 290 | 291 | Log('Adding new grant_entry'); 292 | //No granting entry found, add explicitly 293 | pNewAccess.grfAccessPermissions := APermissions; 294 | pNewAccess.grfAccessMode := GRANT_ACCESS; 295 | pNewAccess.grfInheritance := CONTAINER_INHERIT_ACE or OBJECT_INHERIT_ACE; 296 | pNewAccess.Trustee.pMultipleTrustee := nil; 297 | pNewAccess.Trustee.MultipleTrusteeOperation := NO_MULTIPLE_TRUSTEE; 298 | pNewAccess.Trustee.TrusteeForm := TRUSTEE_IS_SID; 299 | pNewAccess.Trustee.TrusteeType := TRUSTEE_IS_UNKNOWN; 300 | pNewAccess.Trustee.ptstrName := PChar(aTrustee); 301 | 302 | Log('SetEntriesInAcl'); 303 | Result := SetEntriesInAcl(1, @pNewAccess, pDacl, pNewDacl); 304 | if Result <> ERROR_SUCCESS then exit; 305 | 306 | Log('SetNamedSecurityInfo'); 307 | Result := SetNamedSecurityInfo(PChar(AObjectName), AObjectType, DACL_SECURITY_INFORMATION, 308 | nil, nil, pNewDacl, nil); 309 | 310 | if APreviousPermissions <> nil then 311 | APreviousPermissions^ := 0; 312 | finally 313 | LocalFree(NativeUInt(pDescriptor)); 314 | if pNewDacl <> nil then 315 | LocalFree(NativeUInt(pNewDacl)); 316 | end; 317 | end; 318 | 319 | end. 320 | -------------------------------------------------------------------------------- /CBSEnum_Main.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 0 3 | Top = 0 4 | Caption = 'Packages' 5 | ClientHeight = 578 6 | ClientWidth = 686 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | Menu = MainMenu 14 | OldCreateOrder = False 15 | OnCreate = FormCreate 16 | OnDestroy = FormDestroy 17 | OnShow = FormShow 18 | PixelsPerInch = 96 19 | TextHeight = 13 20 | object Panel1: TPanel 21 | Left = 501 22 | Top = 0 23 | Width = 185 24 | Height = 360 25 | Align = alRight 26 | BevelOuter = bvNone 27 | TabOrder = 0 28 | DesignSize = ( 29 | 185 30 | 360) 31 | object Label1: TLabel 32 | Left = 8 33 | Top = 8 34 | Width = 30 35 | Height = 13 36 | Caption = 'Show:' 37 | end 38 | object Label2: TLabel 39 | Left = 6 40 | Top = 106 41 | Width = 33 42 | Height = 13 43 | Caption = 'Group:' 44 | end 45 | object cbShowWOW64: TCheckBox 46 | Left = 6 47 | Top = 50 48 | Width = 171 49 | Height = 17 50 | Anchors = [akLeft, akTop, akRight] 51 | Caption = 'WOW64 versions' 52 | Checked = True 53 | State = cbChecked 54 | TabOrder = 0 55 | OnClick = cbShowWOW64Click 56 | end 57 | object cbShowKb: TCheckBox 58 | Left = 6 59 | Top = 73 60 | Width = 171 61 | Height = 17 62 | Anchors = [akLeft, akTop, akRight] 63 | Caption = 'KB updates' 64 | TabOrder = 1 65 | OnClick = cbShowWOW64Click 66 | end 67 | object pnlGroupMode: TPanel 68 | Left = 0 69 | Top = 125 70 | Width = 185 71 | Height = 62 72 | Anchors = [akLeft, akTop, akRight] 73 | BevelOuter = bvNone 74 | TabOrder = 2 75 | DesignSize = ( 76 | 185 77 | 62) 78 | object rbGroupEachPart: TRadioButton 79 | Left = 6 80 | Top = 0 81 | Width = 171 82 | Height = 17 83 | Anchors = [akLeft, akTop, akRight] 84 | Caption = 'By each part of the name' 85 | TabOrder = 0 86 | OnClick = rbGroupEachPartClick 87 | end 88 | object rbGroupDistinctParts: TRadioButton 89 | Left = 6 90 | Top = 23 91 | Width = 171 92 | Height = 17 93 | Anchors = [akLeft, akTop, akRight] 94 | Caption = 'By distinct parts' 95 | Checked = True 96 | TabOrder = 1 97 | TabStop = True 98 | OnClick = rbGroupEachPartClick 99 | end 100 | object rbGroupFlat: TRadioButton 101 | Left = 6 102 | Top = 46 103 | Width = 171 104 | Height = 17 105 | Anchors = [akLeft, akTop, akRight] 106 | Caption = 'Flat list' 107 | TabOrder = 2 108 | OnClick = rbGroupEachPartClick 109 | end 110 | end 111 | object cbShowHidden: TCheckBox 112 | Left = 6 113 | Top = 27 114 | Width = 171 115 | Height = 17 116 | Anchors = [akLeft, akTop, akRight] 117 | Caption = 'Hidden packages' 118 | Checked = True 119 | State = cbChecked 120 | TabOrder = 3 121 | OnClick = cbShowWOW64Click 122 | end 123 | end 124 | object Panel3: TPanel 125 | Left = 0 126 | Top = 0 127 | Width = 501 128 | Height = 360 129 | Align = alClient 130 | BevelOuter = bvNone 131 | TabOrder = 1 132 | object vtPackages: TVirtualStringTree 133 | Left = 0 134 | Top = 24 135 | Width = 501 136 | Height = 336 137 | Align = alClient 138 | BorderWidth = 1 139 | Header.AutoSizeIndex = 0 140 | Header.Font.Charset = DEFAULT_CHARSET 141 | Header.Font.Color = clWindowText 142 | Header.Font.Height = -11 143 | Header.Font.Name = 'Tahoma' 144 | Header.Font.Style = [] 145 | Header.MainColumn = -1 146 | PopupMenu = PopupMenu 147 | TabOrder = 0 148 | TreeOptions.MiscOptions = [toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick] 149 | TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toShowRoot, toShowTreeLines, toThemeAware, toUseBlendedImages] 150 | TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect, toRightClickSelect] 151 | OnFocusChanged = vtPackagesFocusChanged 152 | OnFreeNode = vtPackagesFreeNode 153 | OnGetText = vtPackagesGetText 154 | OnPaintText = vtPackagesPaintText 155 | OnGetNodeDataSize = vtPackagesGetNodeDataSize 156 | OnInitNode = vtPackagesInitNode 157 | Columns = <> 158 | end 159 | object edtFilter: TEdit 160 | Left = 0 161 | Top = 0 162 | Width = 501 163 | Height = 24 164 | Align = alTop 165 | BevelInner = bvNone 166 | Font.Charset = DEFAULT_CHARSET 167 | Font.Color = clWindowText 168 | Font.Height = -13 169 | Font.Name = 'Tahoma' 170 | Font.Style = [] 171 | ParentFont = False 172 | TabOrder = 1 173 | OnChange = edtFilterChange 174 | OnKeyDown = edtFilterKeyDown 175 | end 176 | end 177 | object pcPageInfo: TPageControl 178 | Left = 0 179 | Top = 360 180 | Width = 686 181 | Height = 218 182 | ActivePage = tsInfo 183 | Align = alBottom 184 | TabOrder = 2 185 | object tsInfo: TTabSheet 186 | Caption = 'Info' 187 | OnEnter = tsInfoEnter 188 | DesignSize = ( 189 | 678 190 | 190) 191 | object lblDescription: TLabel 192 | Left = 6 193 | Top = 3 194 | Width = 669 195 | Height = 54 196 | Anchors = [akLeft, akTop, akRight] 197 | AutoSize = False 198 | ExplicitWidth = 585 199 | end 200 | object lbUpdates: TListBox 201 | Left = 3 202 | Top = 63 203 | Width = 671 204 | Height = 97 205 | Anchors = [akLeft, akTop, akRight] 206 | ItemHeight = 13 207 | TabOrder = 0 208 | end 209 | end 210 | object tsResources: TTabSheet 211 | Caption = 'Resources' 212 | ImageIndex = 1 213 | OnEnter = tsResourcesEnter 214 | end 215 | end 216 | object PopupMenu: TPopupMenu 217 | OnPopup = PopupMenuPopup 218 | Left = 144 219 | Top = 16 220 | object pmCopySubmenu: TMenuItem 221 | Caption = 'Copy' 222 | object pmCopyPackageNames: TMenuItem 223 | Caption = 'Package names' 224 | Hint = 'Copy all selected package names into clipboard' 225 | ShortCut = 16451 226 | OnClick = pmCopyPackageNamesClick 227 | end 228 | object pmCopyUninstallationCommands: TMenuItem 229 | Caption = 'Uninstallation commands' 230 | Hint = 231 | 'Copy DISM command for uninstalling all selected packages into cl' + 232 | 'ipboard' 233 | OnClick = pmCopyUninstallationCommandsClick 234 | end 235 | end 236 | object Saveselectedpackagelist1: TMenuItem 237 | Caption = 'Save selected package list...' 238 | OnClick = Saveselectedpackagelist1Click 239 | end 240 | object pmVisibility: TMenuItem 241 | Caption = 'Visibility' 242 | object pmMakeVisible: TMenuItem 243 | Caption = 'Make visible' 244 | OnClick = pmMakeVisibleClick 245 | end 246 | object pmMakeInvisible: TMenuItem 247 | Caption = 'Make invisible' 248 | OnClick = pmMakeInvisibleClick 249 | end 250 | object pmRestoreDefaultVisibility: TMenuItem 251 | Caption = 'Restore default visibility' 252 | OnClick = pmRestoreDefaultVisibilityClick 253 | end 254 | end 255 | object pmManageSubmenu: TMenuItem 256 | Caption = 'Manage' 257 | object pmDecouplePackages: TMenuItem 258 | Caption = 'Decouple' 259 | OnClick = pmDecouplePackagesClick 260 | end 261 | end 262 | object pmUninstall: TMenuItem 263 | Caption = 'Uninstall' 264 | Hint = 'Uninstall selected package' 265 | OnClick = pmUninstallAllClick 266 | end 267 | object pmUninstallAll: TMenuItem 268 | Caption = 'Uninstall all' 269 | Hint = 'Uninstall all selected packages' 270 | OnClick = pmUninstallAllClick 271 | end 272 | object N1: TMenuItem 273 | Caption = '-' 274 | end 275 | object pmReload: TMenuItem 276 | Caption = 'Reload' 277 | OnClick = pmReloadClick 278 | end 279 | end 280 | object ImageList1: TImageList 281 | Left = 80 282 | Top = 16 283 | end 284 | object MainMenu: TMainMenu 285 | Left = 16 286 | Top = 16 287 | object File1: TMenuItem 288 | Caption = 'File' 289 | object pmSavePackageList: TMenuItem 290 | Caption = 'Save package list...' 291 | OnClick = pmSavePackageListClick 292 | end 293 | object pmUninstallByList: TMenuItem 294 | Caption = 'Uninstall by list...' 295 | OnClick = pmUninstallByListClick 296 | end 297 | object N2: TMenuItem 298 | Caption = '-' 299 | end 300 | object Exit1: TMenuItem 301 | Caption = 'Exit' 302 | OnClick = Exit1Click 303 | end 304 | end 305 | object Edit1: TMenuItem 306 | Caption = 'Edit' 307 | object pmTakeRegistryOwnership: TMenuItem 308 | Caption = 'Take registry ownership' 309 | Hint = 'Take ownership of CBS registry key in a safe manner' 310 | OnClick = pmTakeRegistryOwnershipClick 311 | end 312 | object pmDecoupleAllPackages: TMenuItem 313 | Caption = 'Decouple all packages' 314 | Hint = 315 | 'Decouple all packages from their configured parents so that they' + 316 | ' can be uninstalled separately from the whole system' 317 | OnClick = pmDecoupleAllPackagesClick 318 | end 319 | object N3: TMenuItem 320 | Caption = '-' 321 | end 322 | object pmMakeAllVisibile: TMenuItem 323 | Caption = 'Make all visible' 324 | OnClick = pmMakeAllVisibileClick 325 | end 326 | object pmMakeAllInvisible: TMenuItem 327 | Caption = 'Make all invisible' 328 | OnClick = pmMakeAllInvisibleClick 329 | end 330 | object pmRestoreDefaltVisibilityAll: TMenuItem 331 | Caption = 'Restore default visibility for all' 332 | OnClick = pmRestoreDefaltVisibilityAllClick 333 | end 334 | object N4: TMenuItem 335 | Caption = '-' 336 | end 337 | object Rebuildassemblydatabase1: TMenuItem 338 | Caption = 'Rebuild assembly database' 339 | OnClick = Rebuildassemblydatabase1Click 340 | end 341 | end 342 | object Service1: TMenuItem 343 | Caption = 'Service' 344 | object pmOpenCBSRegistry: TMenuItem 345 | Caption = 'Open CBS registry...' 346 | Hint = 'Open registry editor at a CBS key' 347 | OnClick = pmOpenCBSRegistryClick 348 | end 349 | object Diskcleanup1: TMenuItem 350 | Caption = 'Disk cleanup...' 351 | Hint = 'Run disk cleanup utility' 352 | OnClick = Diskcleanup1Click 353 | end 354 | object DismCleanup1: TMenuItem 355 | Caption = 'DISM image cleanup...' 356 | OnClick = DismCleanup1Click 357 | end 358 | object Optionalfeatures1: TMenuItem 359 | Caption = 'Optional features...' 360 | Hint = 'Enable or disalbe optional Windows features' 361 | OnClick = Optionalfeatures1Click 362 | end 363 | end 364 | end 365 | object UninstallListOpenDialog: TOpenDialog 366 | Filter = 'All files (*.*)|*.*' 367 | Title = 'Select uninstall list' 368 | Left = 56 369 | Top = 72 370 | end 371 | object PackageListSaveDialog: TSaveTextFileDialog 372 | DefaultExt = '*.*' 373 | Filter = 'Text files (*.txt)|*.txt|All files (*.*)|*.*' 374 | Title = 'Save package list' 375 | Left = 56 376 | Top = 136 377 | end 378 | end 379 | -------------------------------------------------------------------------------- /CBSEnum.dproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | {111B137F-7161-4FF6-A8FC-19B75BE726D6} 4 | 14.3 5 | VCL 6 | CBSEnum.dpr 7 | True 8 | Debug 9 | Win64 10 | 3 11 | Application 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | Base 29 | true 30 | 31 | 32 | true 33 | Cfg_1 34 | true 35 | true 36 | 37 | 38 | true 39 | Cfg_1 40 | true 41 | true 42 | 43 | 44 | true 45 | Base 46 | true 47 | 48 | 49 | ..\ManifestEnum;$(SHARE)\Lib\sqlite3;..\ManifestEnum\Views;..\ManifestEnum\Db;$(DCC_UnitSearchPath) 50 | None 51 | CompanyName=;FileDescription=CBSEnum tool;FileVersion=0.9.0.0;InternalName=;LegalCopyright=me@boku.ru;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=A tool to view and manage CBS packages on Windows 52 | true 53 | 9 54 | 0 55 | 1049 56 | CBSEnum_Icon.ico 57 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) 58 | .\$(Platform)\$(Config) 59 | .\$(Platform)\$(Config) 60 | false 61 | false 62 | false 63 | false 64 | false 65 | 66 | 67 | $(BDS)\bin\default_app.manifest 68 | JvGlobus;JvMM;JvManagedThreads;DBXSqliteDriver;JvDlgs;IndySystem;JvCrypt;StubPanelPkgD17;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;JvNet;DataSnapProviderClient;JvDotNetCtrls;DBXSybaseASEDriver;DbxCommonDriver;vclimg;VirtualTreesD14;dbxcds;JaletControls;MetropolisUILiveTile;JvXPCtrls;vcldb;vcldsnap;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;JvCore;vclribbon;dsnap;IndyIPServer;IndyCore;vcl;IndyIPCommon;CloudService;DBXMSSQLDriver;JvAppFrm;JvDB;JvRuntimeDesign;inetdbxpress;webdsnap;JclDeveloperTools;JvDocking;adortl;JvWizards;JvHMI;bindcompfmx;JvBands;vcldbx;rtl;dbrtl;DbxClientDriver;bindcomp;inetdb;JvPluginSystem;JclContainers;DBXOdbcDriver;JvCmp;JvSystem;xmlrtl;svnui;ibxpress;JvTimeFramework;JvControls;IndyProtocols;DBXMySQLDriver;vclactnband;bindengine;soaprtl;bindcompdbx;JvJans;JvPageComps;bindcompvcl;JvStdCtrls;JvCustom;Jcl;vclie;JvPrintPreview;vcltouch;websnap;VclSmp;DBXInformixDriver;DataSnapConnectors;dsnapcon;DBXFirebirdDriver;inet;JclVcl;JvPascalInterpreter;vclx;svn;DBXSybaseASADriver;bdertl;dbexpress;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) 69 | true 70 | 1033 71 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 72 | 73 | 74 | $(BDS)\bin\default_app.manifest 75 | true 76 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) 77 | 1033 78 | DBXSqliteDriver;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;vcldb;vcldsnap;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;dsnap;IndyIPServer;IndyCore;vcl;IndyIPCommon;DBXMSSQLDriver;inetdbxpress;webdsnap;adortl;bindcompfmx;rtl;dbrtl;DbxClientDriver;bindcomp;inetdb;DBXOdbcDriver;xmlrtl;IndyProtocols;DBXMySQLDriver;vclactnband;bindengine;soaprtl;bindcompdbx;bindcompvcl;vclie;vcltouch;websnap;VclSmp;DBXInformixDriver;dsnapcon;DBXFirebirdDriver;inet;vclx;DBXSybaseASADriver;dbexpress;DataSnapIndy10ServerTransport;IndyIPClient;$(DCC_UsePackage) 79 | 80 | 81 | DEBUG;$(DCC_Define) 82 | true 83 | false 84 | true 85 | true 86 | true 87 | 88 | 89 | false 90 | 91 | 92 | $(BDS)\bin\default_app.manifest 93 | 1033 94 | 95 | 96 | false 97 | RELEASE;$(DCC_Define) 98 | 0 99 | false 100 | 101 | 102 | 103 | MainSource 104 | 105 | 106 |
MainForm
107 | dfm 108 | 109 | 110 |
JobProcessorForm
111 | 112 | 113 | 114 |
ResourceModule
115 | 116 | 117 | 118 | 119 | 120 | 121 | Cfg_2 122 | Base 123 | 124 | 125 | Base 126 | 127 | 128 | Cfg_1 129 | Base 130 | 131 | 132 | 133 | Delphi.Personality.12 134 | 135 | 136 | 137 | 138 | False 139 | False 140 | 1 141 | 0 142 | 0 143 | 0 144 | False 145 | False 146 | False 147 | False 148 | False 149 | 1049 150 | 1251 151 | 152 | 153 | 154 | 155 | 1.0.0.0 156 | 157 | 158 | 159 | 160 | 161 | 1.0.0.0 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | CBSEnum.dpr 174 | 175 | 176 | Microsoft Office 2000 Sample Automation Server Wrapper Components 177 | Microsoft Office XP Sample Automation Server Wrapper Components 178 | Embarcadero C++Builder Office 2000 Servers Package 179 | Embarcadero C++Builder Office XP Servers Package 180 | 181 | 182 | 183 | 184 | True 185 | True 186 | 187 | 188 | 12 189 | 190 | 191 | 192 | 193 | -------------------------------------------------------------------------------- /CBSEnum_Main.pas: -------------------------------------------------------------------------------- 1 | unit CBSEnum_Main; 2 | 3 | interface 4 | 5 | uses 6 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Menus, 7 | StdCtrls, ExtCtrls, ImgList, ComCtrls, ExtDlgs, VirtualTrees, Generics.Collections, Registry, 8 | UniStrUtils, AssemblyDb, AssemblyDb.Assemblies, AssemblyResourcesView; 9 | 10 | type 11 | TPackage = class 12 | Name: string; //full package name 13 | DisplayName: string; //display name 14 | Variation: string; //base/WOW64 15 | CbsVisibility: integer; 16 | DefaultCbsVisibility: integer; //if preserved in DefVis key by anyone 17 | end; 18 | 19 | TPackageArray = array of TPackage; 20 | PPackageArray = ^TPackageArray; 21 | 22 | TPackageGroup = class 23 | protected 24 | Name: string; 25 | Subgroups: TObjectList; 26 | Packages: TObjectList; 27 | public 28 | constructor Create; 29 | destructor Destroy; override; 30 | procedure AddPackage(APackageName: string; APackage: TPackage); overload; 31 | function AddPackage(AFullPackageName: string): TPackage; overload; 32 | function FindSubgroup(const AGroupName: string): TPackageGroup; 33 | function NeedSubgroup(const AGroupName: string): TPackageGroup; 34 | procedure CompactNames; 35 | function SelectMatching(const AMask: string): TPackageArray; overload; 36 | procedure SelectMatching(AMask: string; var AArray: TPackageArray); overload; 37 | end; 38 | 39 | TNdPackageData = record 40 | DisplayName: string; //display name 41 | Package: TPackage; //if assigned 42 | IsVisible: boolean; 43 | end; 44 | PNdPackageData = ^TNdPackageData; 45 | 46 | TMainForm = class(TForm) 47 | Panel1: TPanel; 48 | Label1: TLabel; 49 | cbShowWOW64: TCheckBox; 50 | PopupMenu: TPopupMenu; 51 | cbShowKb: TCheckBox; 52 | pmUninstall: TMenuItem; 53 | N1: TMenuItem; 54 | pmReload: TMenuItem; 55 | Label2: TLabel; 56 | pnlGroupMode: TPanel; 57 | rbGroupEachPart: TRadioButton; 58 | rbGroupDistinctParts: TRadioButton; 59 | Panel3: TPanel; 60 | vtPackages: TVirtualStringTree; 61 | edtFilter: TEdit; 62 | pmUninstallAll: TMenuItem; 63 | ImageList1: TImageList; 64 | pmCopyPackageNames: TMenuItem; 65 | pcPageInfo: TPageControl; 66 | tsInfo: TTabSheet; 67 | lblDescription: TLabel; 68 | lbUpdates: TListBox; 69 | MainMenu: TMainMenu; 70 | File1: TMenuItem; 71 | Service1: TMenuItem; 72 | Diskcleanup1: TMenuItem; 73 | Exit1: TMenuItem; 74 | Optionalfeatures1: TMenuItem; 75 | pmCopyUninstallationCommands: TMenuItem; 76 | pmOpenCBSRegistry: TMenuItem; 77 | Edit1: TMenuItem; 78 | rbGroupFlat: TRadioButton; 79 | pmMakeVisible: TMenuItem; 80 | pmMakeInvisible: TMenuItem; 81 | pmRestoreDefaultVisibility: TMenuItem; 82 | pmVisibility: TMenuItem; 83 | pmMakeAllVisibile: TMenuItem; 84 | pmMakeAllInvisible: TMenuItem; 85 | pmRestoreDefaltVisibilityAll: TMenuItem; 86 | cbShowHidden: TCheckBox; 87 | pmUninstallByList: TMenuItem; 88 | N2: TMenuItem; 89 | UninstallListOpenDialog: TOpenDialog; 90 | pmSavePackageList: TMenuItem; 91 | PackageListSaveDialog: TSaveTextFileDialog; 92 | Saveselectedpackagelist1: TMenuItem; 93 | pmTakeRegistryOwnership: TMenuItem; 94 | pmDecoupleAllPackages: TMenuItem; 95 | pmDecouplePackages: TMenuItem; 96 | N3: TMenuItem; 97 | pmCopySubmenu: TMenuItem; 98 | pmManageSubmenu: TMenuItem; 99 | N4: TMenuItem; 100 | Rebuildassemblydatabase1: TMenuItem; 101 | DismCleanup1: TMenuItem; 102 | tsResources: TTabSheet; 103 | procedure FormShow(Sender: TObject); 104 | procedure vtPackagesGetNodeDataSize(Sender: TBaseVirtualTree; 105 | var NodeDataSize: Integer); 106 | procedure vtPackagesFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); 107 | procedure vtPackagesGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; 108 | Column: TColumnIndex; TextType: TVSTTextType; var CellText: string); 109 | procedure vtPackagesInitNode(Sender: TBaseVirtualTree; ParentNode, 110 | Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates); 111 | procedure cbShowWOW64Click(Sender: TObject); 112 | procedure vtPackagesPaintText(Sender: TBaseVirtualTree; 113 | const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; 114 | TextType: TVSTTextType); 115 | procedure PopupMenuPopup(Sender: TObject); 116 | procedure pmReloadClick(Sender: TObject); 117 | procedure rbGroupEachPartClick(Sender: TObject); 118 | procedure edtFilterChange(Sender: TObject); 119 | procedure edtFilterKeyDown(Sender: TObject; var Key: Word; 120 | Shift: TShiftState); 121 | procedure pmUninstallAllClick(Sender: TObject); 122 | procedure pmCopyPackageNamesClick(Sender: TObject); 123 | procedure vtPackagesFocusChanged(Sender: TBaseVirtualTree; 124 | Node: PVirtualNode; Column: TColumnIndex); 125 | procedure tsInfoEnter(Sender: TObject); 126 | procedure Exit1Click(Sender: TObject); 127 | procedure Diskcleanup1Click(Sender: TObject); 128 | procedure Optionalfeatures1Click(Sender: TObject); 129 | procedure pmCopyUninstallationCommandsClick(Sender: TObject); 130 | procedure pmOpenCBSRegistryClick(Sender: TObject); 131 | procedure pmMakeVisibleClick(Sender: TObject); 132 | procedure pmMakeInvisibleClick(Sender: TObject); 133 | procedure pmRestoreDefaultVisibilityClick(Sender: TObject); 134 | procedure pmMakeAllVisibileClick(Sender: TObject); 135 | procedure pmMakeAllInvisibleClick(Sender: TObject); 136 | procedure pmRestoreDefaltVisibilityAllClick(Sender: TObject); 137 | procedure pmUninstallByListClick(Sender: TObject); 138 | procedure Saveselectedpackagelist1Click(Sender: TObject); 139 | procedure pmSavePackageListClick(Sender: TObject); 140 | procedure pmDecoupleAllPackagesClick(Sender: TObject); 141 | procedure pmDecouplePackagesClick(Sender: TObject); 142 | procedure pmTakeRegistryOwnershipClick(Sender: TObject); 143 | procedure FormCreate(Sender: TObject); 144 | procedure FormDestroy(Sender: TObject); 145 | procedure Rebuildassemblydatabase1Click(Sender: TObject); 146 | procedure DismCleanup1Click(Sender: TObject); 147 | procedure tsResourcesEnter(Sender: TObject); 148 | protected 149 | FPackages: TPackageGroup; 150 | FTotalPackages: integer; 151 | 152 | protected 153 | FVisiblePackages: integer; 154 | procedure ReloadPackageTree(AGroup: TPackageGroup; ATreeNode: PVirtualNode); 155 | function CreateNode(AParent: PVirtualNode; ADisplayName: string; APackage: TPackage): PVirtualNode; 156 | function FindNode(AParent: PVirtualNode; ADisplayName: string): PVirtualNode; 157 | procedure UpdateNodeVisibility(); 158 | procedure ResetVisibility_Callback(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean); 159 | procedure UpdatePackageVisibility_Callback(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean); 160 | procedure ApplyVisibility_Callback(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean); 161 | procedure CountVisiblePackages_Callback(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean); 162 | function IsPackageNodeVisible(ANode: PVirtualNode): boolean; 163 | protected 164 | function GetAllPackages: TPackageArray; 165 | function GetSelectedPackages: TPackageArray; 166 | function GetChildPackages(ANode: PVirtualNode): TPackageArray; 167 | procedure GetPackages_Callback(Sender: TBaseVirtualTree; Node: PVirtualNode; 168 | Data: Pointer; var Abort: Boolean); 169 | function GetSelectedPackageNames: TStringArray; 170 | function GetChildPackageNames(ANode: PVirtualNode): TStringArray; 171 | 172 | protected 173 | procedure DismUninstall(const APackageName: string); overload; 174 | procedure DismUninstall(const APackageNames: TStringArray); overload; 175 | procedure SetCbsVisibility(const AKey: string; APackages: TPackageArray; AVisibility: integer); overload; 176 | procedure SetCbsVisibility(APackages: TPackageArray; AVisibility: integer); overload; 177 | procedure SavePackageList(APackageNames: TStringArray); 178 | 179 | protected //Assembly database 180 | FDb: TAssemblyDb; 181 | FResources: TAssemblyResourcesForm; 182 | 183 | protected 184 | procedure UpdateFormCaption; 185 | public 186 | procedure Reload; 187 | 188 | end; 189 | 190 | var 191 | MainForm: TMainForm; 192 | 193 | const 194 | hkCbsRoot = HKEY_LOCAL_MACHINE; 195 | sCbsRootSec = 'MACHINE'; //for security-related functions 196 | sCbsKey = 'Software\Microsoft\Windows\CurrentVersion\Component Based Servicing'; 197 | 198 | const 199 | CBS_E_INVALID_PACKAGE = $800F0805; 200 | 201 | function IsPackageInList(const AList: TPackageArray; APackage: TPackage): boolean; inline; overload; 202 | function IsPackageInList(const AList: TStringArray; APackageName: string): boolean; inline; overload; 203 | 204 | implementation 205 | uses Clipbrd, XmlDoc, XmlIntf, AccCtrl, OsUtils, AclHelpers, CBSEnum_JobProcessor, TakeOwnershipJob, 206 | DecouplePackagesJob, FilenameUtils, AssemblyDbBuilder, Generics.Defaults, WildcardMatching; 207 | 208 | {$R *.dfm} 209 | 210 | resourcestring 211 | sCannotOpenCbsRegistry = 'Cannot open registry key for packages. Perpahs ' 212 | +'you''re not running the app with administrator rights? Or the Windows ' 213 | +'version is incompatible.'; 214 | 215 | 216 | function IsPackageInList(const AList: TPackageArray; APackage: TPackage): boolean; inline; overload; 217 | var i: integer; 218 | begin 219 | Result := false; 220 | for i := 0 to Length(AList)-1 do 221 | if AList[i]=APackage then begin 222 | Result := true; 223 | break; 224 | end; 225 | end; 226 | 227 | function IsPackageInList(const AList: TStringArray; APackageName: string): boolean; inline; overload; 228 | var i: integer; 229 | begin 230 | Result := false; 231 | for i := 0 to Length(AList)-1 do 232 | if SameText(AList[i], APackageName) then begin 233 | Result := true; 234 | break; 235 | end; 236 | end; 237 | 238 | function PackagesToPackageNames(APackages: TPackageArray): TStringArray; 239 | var i: integer; 240 | begin 241 | SetLength(Result, Length(APackages)); 242 | for i := 0 to Length(APackages)-1 do 243 | Result[i] := APackages[i].Name; 244 | end; 245 | 246 | 247 | constructor TPackageGroup.Create; 248 | begin 249 | inherited; 250 | Subgroups := TObjectList.Create; 251 | Packages := TObjectList.Create; 252 | end; 253 | 254 | destructor TPackageGroup.Destroy; 255 | begin 256 | FreeAndNil(Packages); 257 | FreeAndNil(Subgroups); 258 | inherited; 259 | end; 260 | 261 | //Mostly used internally to route package to appropriate group 262 | procedure TPackageGroup.AddPackage(APackageName: string; APackage: TPackage); 263 | var pos_minus, pos_tilde: integer; 264 | AGroupName: string; 265 | AGroup: TPackageGroup; 266 | begin 267 | //Eat one part of the name. Mind names like Microsoft-Windows-Defender~ru-RU (note last minus) 268 | pos_tilde := pos('~', APackageName); 269 | repeat 270 | pos_minus := pos('-', APackageName); 271 | if (pos_minus <= 0) or ((pos_tilde > 0) and (pos_tilde < pos_minus)) then 272 | break; //last part 273 | 274 | AGroupName := copy(APackageName, 1, pos_minus-1); 275 | delete(APackageName, 1, pos_minus); 276 | pos_tilde := pos_tilde - pos_minus; //since we've eaten some chars 277 | 278 | if SameText(AGroupName, 'WOW64') then begin 279 | APackage.Variation := 'WOW64'; 280 | APackageName := APackageName + ' (WOW64)'; //could be made properly, on display 281 | continue; //chew another part 282 | end; 283 | 284 | AGroup := Self.NeedSubgroup(AGroupName); 285 | AGroup.AddPackage(APackageName, APackage); 286 | exit; 287 | until false; 288 | 289 | //Most package names end with -Package. Ignore this. 290 | if (pos_tilde > 0) and SameText(copy(APackageName, 1, pos_tilde-1), 'Package') then 291 | delete(APackageName, 1, pos_tilde); 292 | APackage.DisplayName := APackageName; 293 | Packages.Add(APackage); 294 | end; 295 | 296 | //Mostly call this from outside 297 | function TPackageGroup.AddPackage(AFullPackageName: string): TPackage; 298 | begin 299 | Result := TPackage.Create; 300 | Result.Name := AFullPackageName; 301 | Self.AddPackage(AFullPackageName, Result); 302 | end; 303 | 304 | function TPackageGroup.FindSubgroup(const AGroupName: string): TPackageGroup; 305 | var group: TPackageGroup; 306 | begin 307 | Result := nil; 308 | for group in Subgroups do 309 | if SameText(group.Name, AGroupName) then begin 310 | Result := group; 311 | break; 312 | end; 313 | end; 314 | 315 | function TPackageGroup.NeedSubgroup(const AGroupName: string): TPackageGroup; 316 | begin 317 | Result := FindSubgroup(AGroupName); 318 | if Result = nil then begin 319 | Result := TPackageGroup.Create; 320 | Result.Name := AGroupName; 321 | Self.Subgroups.Add(Result); 322 | end; 323 | end; 324 | 325 | procedure TPackageGroup.CompactNames; 326 | var group: TPackageGroup; 327 | subpkg: TPackage; 328 | i: integer; 329 | begin 330 | for i := Subgroups.Count-1 downto 0 do begin 331 | Subgroups[i].CompactNames; 332 | if (Subgroups[i].Packages.Count=1) and (Subgroups[i].Subgroups.Count=0) then begin 333 | subpkg := Subgroups[i].Packages[0]; 334 | subpkg.DisplayName := Subgroups[i].Name + '-' + subpkg.DisplayName; 335 | Self.Packages.Add(subpkg); 336 | Subgroups[i].Packages.Extract(subpkg); 337 | Self.Subgroups.Remove(Subgroups[i]); 338 | end; 339 | end; 340 | 341 | if (Self.Subgroups.Count = 1) and (Self.Packages.Count = 0) then begin 342 | group := Self.Subgroups[0]; 343 | Self.Subgroups.Extract(group); 344 | for i := group.Subgroups.Count-1 downto 0 do begin 345 | Self.Subgroups.Add(group.Subgroups[i]); 346 | group.Subgroups.Extract(group.Subgroups[i]); 347 | end; 348 | for i := group.Packages.Count-1 downto 0 do begin 349 | Self.Packages.Add(group.Packages[i]); 350 | group.Packages.Extract(group.Packages[i]); 351 | end; 352 | Self.Name := Self.Name + '-' + group.Name; 353 | FreeAndNil(group); 354 | end; 355 | end; 356 | 357 | function TPackageGroup.SelectMatching(const AMask: string): TPackageArray; 358 | begin 359 | SetLength(Result, 0); 360 | SelectMatching(AMask, Result); 361 | end; 362 | 363 | procedure TPackageGroup.SelectMatching(AMask: string; var AArray: TPackageArray); 364 | var i: integer; 365 | begin 366 | AMask := AMask.ToLower; 367 | for i := 0 to Packages.Count-1 do 368 | if WildcardMatchCase(PChar(Packages[i].Name.ToLower), PChar(AMask)) 369 | and not IsPackageInList(AArray, Packages[i]) then begin 370 | SetLength(AArray, Length(AArray)+1); 371 | AArray[Length(AArray)-1] := Packages[i]; 372 | end; 373 | 374 | for i := 0 to Subgroups.Count-1 do 375 | Subgroups[i].SelectMatching(AMask, AArray); 376 | end; 377 | 378 | 379 | 380 | //Sets Visibility parameter for all packages from the list where applicable. 381 | //Preserves old value in DefVis if none yet preserved (like other tools do). 382 | //Skips packages where no changes are needed. 383 | //-1 is a special value meaning "restore to DefVis". 384 | procedure TMainForm.SetCbsVisibility(const AKey: string; APackages: TPackageArray; AVisibility: integer); 385 | var package: TPackage; 386 | reg: TRegistry; 387 | curDefVis: integer; 388 | begin 389 | reg := TRegistry.Create; 390 | try 391 | reg.RootKey := hkCbsRoot; 392 | for package in APackages do try 393 | if (AVisibility >= 0) and (package.CbsVisibility = AVisibility) then 394 | continue; //nothing to change 395 | if (AVisibility < 0) and (package.CbsVisibility = package.DefaultCbsVisibility) then 396 | continue; 397 | //And there's no point in querying the registry again. Even if someone 398 | //changed it in the background, just Refresh() and do this again. 399 | 400 | //We want to store DefVis once, and then never touch it because it contains 401 | //original value, whatever changes happen later 402 | if not reg.OpenKey(AKey+'\'+Package.Name, false) then exit; //no key, whatever 403 | try 404 | curDefVis := reg.ReadInteger('DefVis'); 405 | except 406 | //Only write if we can't read, no key. Otherwise leave alone 407 | on E: ERegistryException do begin 408 | //if there's no key then we set DefaultCbsVisibility to CbsVisibility on load 409 | reg.WriteInteger('DefVis', package.DefaultCbsVisibility); 410 | curDefVis := package.DefaultCbsVisibility; 411 | end; 412 | end; 413 | 414 | package.DefaultCbsVisibility := curDefVis; //we've read it anyway 415 | if AVisibility >= 0 then 416 | package.CbsVisibility := AVisibility 417 | else 418 | package.CbsVisibility := package.DefaultCbsVisibility; 419 | reg.WriteInteger('Visibility', package.CbsVisibility); 420 | reg.CloseKey; 421 | except 422 | on E: ERegistryException do begin 423 | reg.CloseKey; 424 | if MessageBox(Self.Handle, 425 | PChar('Cannot process package '+Package.Name+':'#13+E.Message+'. ' 426 | +'Continue with other packages nevertheless?'), 427 | PChar('Error'), MB_ICONERROR+MB_YESNO) <> ID_YES then break; 428 | //else continue, whatever 429 | end; 430 | end; 431 | 432 | finally 433 | FreeAndNil(reg); 434 | end; 435 | end; 436 | 437 | procedure TMainForm.SetCbsVisibility(APackages: TPackageArray; AVisibility: integer); 438 | begin 439 | SetCbsVisibility(sCbsKey+'\Packages', APackages, AVisibility); 440 | SetCbsVisibility(sCbsKey+'\PackagesPending', APackages, AVisibility); 441 | 442 | UpdateNodeVisibility(); //update everywhere because it's easier than figuring out who's whose parent and whatnot 443 | vtPackages.InvalidateChildren(nil, false); 444 | vtPackages.Repaint; 445 | end; 446 | 447 | 448 | 449 | procedure TMainForm.FormCreate(Sender: TObject); 450 | begin 451 | FDb := TAssemblyDb.Create; 452 | FDb.Open(AppFolder+'\assembly.db'); 453 | FResources := TAssemblyResourcesForm.Create(Self); 454 | FResources.ShowDependencies := true; 455 | FResources.Db := FDb; 456 | FResources.ManualDock(tsResources, tsResources, alClient); 457 | FResources.Align := alClient; 458 | FResources.Visible := true; 459 | end; 460 | 461 | procedure TMainForm.FormDestroy(Sender: TObject); 462 | begin 463 | FreeAndNil(FResources); 464 | FreeAndNil(FDb); 465 | end; 466 | 467 | procedure TMainForm.FormShow(Sender: TObject); 468 | begin 469 | Reload; 470 | end; 471 | 472 | procedure TMainForm.Reload; 473 | var reg: TRegistry; 474 | packages: TStringList; 475 | package: TPackage; 476 | i: integer; 477 | begin 478 | FreeAndNil(FPackages); 479 | FPackages := TPackageGroup.Create; 480 | FTotalPackages := 0; 481 | vtPackages.Clear; 482 | FVisiblePackages := 0; //will be set in first UpdateNodeVisibility 483 | 484 | reg := TRegistry.Create; 485 | packages := TStringList.Create; 486 | try 487 | reg.RootKey := HKEY_LOCAL_MACHINE; 488 | reg.Access := KEY_READ; 489 | if not reg.OpenKey(sCbsKey+'\Packages', false) then 490 | raise Exception.Create(sCannotOpenCbsRegistry); 491 | reg.GetKeyNames(packages); 492 | FTotalPackages := packages.Count; 493 | for i := 0 to packages.Count-1 do begin 494 | if rbGroupFlat.Checked then begin 495 | package := TPackage.Create; 496 | package.Name := packages[i]; 497 | package.DisplayName := packages[i]; 498 | FPackages.Packages.Add(package); 499 | end else 500 | package := FPackages.AddPackage(packages[i]); 501 | reg.CloseKey; 502 | if not reg.OpenKey(sCbsKey+'\Packages\'+packages[i], false) then 503 | continue; //because whatever 504 | try 505 | package.CbsVisibility := reg.ReadInteger('Visibility'); 506 | except 507 | on E: ERegistryException do //don't break on each missing property 508 | package.CbsVisibility := 1; //assume visible 509 | end; 510 | try 511 | package.DefaultCbsVisibility := reg.ReadInteger('DefVis'); 512 | except 513 | on E: ERegistryException do 514 | package.DefaultCbsVisibility := package.CbsVisibility; //assume current 515 | end; 516 | end; 517 | 518 | finally 519 | FreeAndNil(reg); 520 | end; 521 | 522 | if rbGroupDistinctParts.Checked then 523 | FPackages.CompactNames; 524 | 525 | vtPackages.BeginUpdate; 526 | try 527 | ReloadPackageTree(FPackages, nil); 528 | if rbGroupFlat.Checked then 529 | vtPackages.TreeOptions.PaintOptions := vtPackages.TreeOptions.PaintOptions - [toShowRoot] 530 | else 531 | vtPackages.TreeOptions.PaintOptions := vtPackages.TreeOptions.PaintOptions + [toShowRoot]; 532 | finally 533 | vtPackages.EndUpdate; 534 | end; 535 | 536 | //Have to do it again because just setting Node visibility one by one doesn't 537 | //take care of parent nodes becoming visible as needed when child nodes are 538 | //visible. 539 | UpdateNodeVisibility; 540 | end; 541 | 542 | procedure TMainForm.UpdateFormCaption; 543 | begin 544 | Self.Caption := IntToStr(FVisiblePackages) + ' packages ('+IntToStr(FTotalPackages) + ' total)'; 545 | end; 546 | 547 | procedure TMainForm.ReloadPackageTree(AGroup: TPackageGroup; ATreeNode: PVirtualNode); 548 | var group: TPackageGroup; 549 | pkg: TPackage; 550 | node: PVirtualNode; 551 | begin 552 | for group in AGroup.Subgroups do begin 553 | node := CreateNode(ATreeNode, group.Name, nil); 554 | ReloadPackageTree(group, node); 555 | end; 556 | for pkg in AGroup.Packages do 557 | CreateNode(ATreeNode, pkg.DisplayName, pkg); 558 | end; 559 | 560 | function TMainForm.CreateNode(AParent: PVirtualNode; ADisplayName: string; 561 | APackage: TPackage): PVirtualNode; 562 | var AData: PNdPackageData; 563 | begin 564 | Result := vtPackages.AddChild(AParent); 565 | vtPackages.ReinitNode(Result, false); 566 | AData := vtPackages.GetNodeData(Result); 567 | AData.DisplayName := ADisplayName; 568 | AData.Package := APackage; 569 | vtPackages.IsVisible[Result] := IsPackageNodeVisible(Result); //not enough though, see UpdateNodeVisibility 570 | end; 571 | 572 | function TMainForm.FindNode(AParent: PVirtualNode; ADisplayName: string): PVirtualNode; 573 | var node: PVirtualNode; 574 | NodeData: PNdPackageData; 575 | begin 576 | Result := nil; 577 | for node in vtPackages.ChildNodes(AParent) do begin 578 | NodeData := vtPackages.GetNodeData(Node); 579 | if SameText(NodeData.DisplayName, ADisplayName) then begin 580 | Result := node; 581 | break; 582 | end; 583 | end; 584 | end; 585 | 586 | procedure TMainForm.vtPackagesGetNodeDataSize(Sender: TBaseVirtualTree; 587 | var NodeDataSize: Integer); 588 | begin 589 | NodeDataSize := SizeOf(TNdPackageData); 590 | end; 591 | 592 | procedure TMainForm.vtPackagesInitNode(Sender: TBaseVirtualTree; ParentNode, 593 | Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates); 594 | var Data: PNdPackageData; 595 | begin 596 | Data := Sender.GetNodeData(Node); 597 | Initialize(Data^); 598 | end; 599 | 600 | procedure TMainForm.vtPackagesFreeNode(Sender: TBaseVirtualTree; 601 | Node: PVirtualNode); 602 | var Data: PNdPackageData; 603 | begin 604 | Data := Sender.GetNodeData(Node); 605 | Finalize(Data^); 606 | end; 607 | 608 | procedure TMainForm.vtPackagesGetText(Sender: TBaseVirtualTree; 609 | Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; 610 | var CellText: string); 611 | var Data: PNdPackageData; 612 | begin 613 | if TextType <> ttNormal then exit; 614 | Data := Sender.GetNodeData(Node); 615 | case Column of 616 | 0, NoColumn: 617 | CellText := Data.DisplayName; 618 | end; 619 | end; 620 | 621 | procedure TMainForm.vtPackagesPaintText(Sender: TBaseVirtualTree; 622 | const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; 623 | TextType: TVSTTextType); 624 | var Data: PNdPackageData; 625 | begin 626 | Data := Sender.GetNodeData(Node); 627 | if Data.Package <> nil then //is a package 628 | if Data.Package.CbsVisibility=1 then //visible 629 | TargetCanvas.Font.Color := clBlue 630 | else 631 | TargetCanvas.Font.Color := RGB(135, 153, 255) //light blue 632 | else 633 | TargetCanvas.Font.Color := clBlack; 634 | end; 635 | 636 | procedure TMainForm.cbShowWOW64Click(Sender: TObject); 637 | begin 638 | UpdateNodeVisibility(); 639 | end; 640 | 641 | procedure TMainForm.rbGroupEachPartClick(Sender: TObject); 642 | begin 643 | Reload; 644 | end; 645 | 646 | procedure TMainForm.UpdateNodeVisibility(); 647 | begin 648 | //Big idea with visibility: 649 | //Leaf nodes (packages) are visible or invisible according to a set of rules - 650 | //see IsPackageNodeVisible. 651 | //Group nodes are by default all invisible, but are made visible as required 652 | //to show all visible leaf nodes. 653 | //It is therefore hard to update visibility on just one leaf node, as this can 654 | //potentially change visibility on group nodes up to the top. 655 | vtPackages.BeginUpdate; 656 | try 657 | //Groups have to stay visible when one of their child nodes is visible, 658 | //thus this complicated 3-step way 659 | vtPackages.IterateSubtree(nil, ResetVisibility_Callback, nil); 660 | vtPackages.IterateSubtree(nil, UpdatePackageVisibility_Callback, nil); 661 | vtPackages.IterateSubtree(nil, ApplyVisibility_Callback, nil); 662 | finally 663 | vtPackages.EndUpdate; 664 | end; 665 | 666 | FVisiblePackages := 0; 667 | vtPackages.IterateSubtree(nil, CountVisiblePackages_Callback, @FVisiblePackages); 668 | UpdateFormCaption; 669 | end; 670 | 671 | procedure TMainForm.ResetVisibility_Callback(Sender: TBaseVirtualTree; Node: PVirtualNode; 672 | Data: Pointer; var Abort: Boolean); 673 | var NodeData: PNdPackageData; 674 | begin 675 | NodeData := Sender.GetNodeData(Node); 676 | NodeData.IsVisible := false; 677 | end; 678 | 679 | procedure TMainForm.UpdatePackageVisibility_Callback(Sender: TBaseVirtualTree; Node: PVirtualNode; 680 | Data: Pointer; var Abort: Boolean); 681 | var NodeData: PNdPackageData; 682 | begin 683 | NodeData := Sender.GetNodeData(Node); 684 | if (NodeData.Package <> nil) and IsPackageNodeVisible(Node) then begin //save on re-scanning the parents when nothing changed 685 | NodeData.IsVisible := True; 686 | Node := Node.Parent; 687 | while (Node <> nil) and (Node <> Sender.RootNode) do begin 688 | NodeData := Sender.GetNodeData(Node); 689 | if NodeData <> nil then 690 | NodeData.IsVisible := true; 691 | Node := Node.Parent; 692 | end; 693 | end; 694 | end; 695 | 696 | procedure TMainForm.ApplyVisibility_Callback(Sender: TBaseVirtualTree; Node: PVirtualNode; 697 | Data: Pointer; var Abort: Boolean); 698 | var NodeData: PNdPackageData; 699 | begin 700 | NodeData := Sender.GetNodeData(Node); 701 | Sender.IsVisible[Node] := NodeData.IsVisible; 702 | end; 703 | 704 | function TMainForm.IsPackageNodeVisible(ANode: PVirtualNode): boolean; 705 | var NodeData: PNdPackageData; 706 | begin 707 | NodeData := vtPackages.GetNodeData(ANode); 708 | Result := true; 709 | if (not cbShowHidden.Checked) and (NodeData.Package <> nil) and (NodeData.Package.CbsVisibility <> 1) then 710 | Result := false; 711 | if (not cbShowWOW64.Checked) and (NodeData.Package <> nil) and SameText(NodeData.Package.Variation, 'WOW64') then 712 | Result := false; 713 | if (not cbShowKB.Checked) and NodeData.DisplayName.StartsWith('Package_') then 714 | Result := false; 715 | if (edtFilter.Text <> '') and (pos(LowerCase(edtFilter.Text), LowerCase(NodeData.DisplayName))<=0) 716 | and ((NodeData.Package=nil) or (pos(LowerCase(edtFilter.Text), LowerCase(NodeData.Package.Name))<=0)) then 717 | Result := false; 718 | end; 719 | 720 | procedure TMainForm.CountVisiblePackages_Callback(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean); 721 | var NodeData: PNdPackageData; 722 | begin 723 | NodeData := Sender.GetNodeData(Node); 724 | if (NodeData.Package <> nil) and Sender.IsVisible[Node] then 725 | Inc(PInteger(Data)^); 726 | end; 727 | 728 | 729 | //Returns a list of all Packages in the tree 730 | function TMainForm.GetAllPackages: TPackageArray; 731 | begin 732 | SetLength(Result, 0); 733 | vtPackages.IterateSubtree(nil, GetPackages_Callback, @Result) 734 | end; 735 | 736 | //Returns a list of all Packages in all selected nodes and its subnodes 737 | function TMainForm.GetSelectedPackages: TPackageArray; 738 | var node: PVirtualNode; 739 | begin 740 | SetLength(Result, 0); 741 | for node in vtPackages.SelectedNodes() do 742 | vtPackages.IterateSubtree(node, GetPackages_Callback, @Result, [vsVisible]); 743 | end; 744 | 745 | //Returns a list of all Packages in this node and its children 746 | function TMainForm.GetChildPackages(ANode: PVirtualNode): TPackageArray; 747 | begin 748 | SetLength(Result, 0); 749 | vtPackages.IterateSubtree(ANode, GetPackages_Callback, @Result, [vsVisible]) 750 | end; 751 | 752 | procedure TMainForm.GetPackages_Callback(Sender: TBaseVirtualTree; Node: PVirtualNode; 753 | Data: Pointer; var Abort: Boolean); 754 | var List: PPackageArray absolute Data; 755 | NodeData: PNdPackageData; 756 | begin 757 | NodeData := Sender.GetNodeData(Node); 758 | if NodeData.Package <> nil then begin 759 | //This is required if we allow multiselect on different levels 760 | //Both parent and one of its children can be selected independently => doubles 761 | if IsPackageInList(List^, NodeData.Package) then 762 | exit; 763 | SetLength(List^, Length(List^)+1); 764 | List^[Length(List^)-1] := NodeData.Package; 765 | end; 766 | end; 767 | 768 | //Returns a list of package names for all Packages in all selected nodes and its subnodes 769 | function TMainForm.GetSelectedPackageNames: TStringArray; 770 | begin 771 | Result := PackagesToPackageNames(GetSelectedPackages()); 772 | end; 773 | 774 | //Returns a list of package names for all Packages in this node and its children 775 | function TMainForm.GetChildPackageNames(ANode: PVirtualNode): TStringArray; 776 | begin 777 | Result := PackagesToPackageNames(GetChildPackages(ANode)); 778 | end; 779 | 780 | 781 | //Saves a list of package names into a file of user choosing 782 | procedure TMainForm.SavePackageList(APackageNames: TStringArray); 783 | var sl: TStringList; 784 | item: string; 785 | begin 786 | if not PackageListSaveDialog.Execute then exit; 787 | 788 | TArray.Sort(APackageNames); 789 | 790 | sl := TStringList.Create; 791 | try 792 | for item in APackageNames do 793 | sl.Add(item); 794 | sl.SaveToFile(PackageListSaveDialog.Filename); 795 | finally 796 | FreeAndNil(sl); 797 | end; 798 | end; 799 | 800 | procedure TMainForm.pmSavePackageListClick(Sender: TObject); 801 | begin 802 | SavePackageList(PackagesToPackageNames(GetAllPackages())); 803 | end; 804 | 805 | 806 | procedure TMainForm.PopupMenuPopup(Sender: TObject); 807 | var Packages: TPackageArray; 808 | HaveVisible, HaveInvisible: boolean; 809 | HaveVisibilityChanged: boolean; 810 | i: integer; 811 | begin 812 | Packages := GetSelectedPackages(); 813 | pmCopyPackageNames.Visible := Length(Packages)>=1; 814 | pmCopyUninstallationCommands.Visible := Length(Packages)>=1; 815 | pmUninstall.Visible := Length(Packages)=1; 816 | pmUninstallAll.Visible := Length(Packages)>1; 817 | 818 | HaveVisible := false; 819 | HaveInvisible := false; 820 | HaveVisibilityChanged := false; 821 | for i := 0 to Length(Packages)-1 do begin 822 | if Packages[i].CbsVisibility=1 then 823 | HaveVisible := true 824 | else 825 | HaveInvisible := true; 826 | if Packages[i].DefaultCbsVisibility <> Packages[i].CbsVisibility then 827 | HaveVisibilityChanged := true; 828 | end; 829 | pmMakeVisible.Visible := HaveInvisible; 830 | pmMakeInvisible.Visible := HaveVisible; 831 | pmRestoreDefaultVisibility.Visible := HaveVisibilityChanged; 832 | pmVisibility.Visible := pmMakeVisible.Visible or pmMakeInvisible.Visible 833 | or pmRestoreDefaultVisibility.Visible; 834 | end; 835 | 836 | procedure TMainForm.pmReloadClick(Sender: TObject); 837 | begin 838 | Reload; 839 | end; 840 | 841 | procedure TMainForm.pmCopyPackageNamesClick(Sender: TObject); 842 | var PackageNames: TStringArray; 843 | begin 844 | PackageNames := GetSelectedPackageNames(); 845 | if Length(PackageNames) <= 0 then exit; 846 | Clipboard.SetTextBuf(PChar(SepJoin(PackageNames, #13))); 847 | end; 848 | 849 | procedure TMainForm.DismUninstall(const APackageName: string); 850 | var ANames: TStringArray; 851 | begin 852 | SetLength(ANames, 1); 853 | ANames[0] := APackageName; 854 | DismUninstall(ANames); 855 | end; 856 | 857 | procedure TMainForm.DismUninstall(const APackageNames: TStringArray); 858 | var processInfo: TProcessInformation; 859 | err: cardinal; 860 | APackageNamesStr: string; 861 | AName: string; 862 | begin 863 | APackageNamesStr := ''; 864 | for AName in APackageNames do 865 | APackageNamesStr := APackageNamesStr + ' /Packagename='+AName; 866 | processInfo := StartProcess(GetSystemDir()+'\dism.exe', 867 | PChar('dism.exe /Online /Remove-Package '+APackageNamesStr)); 868 | try 869 | WaitForSingleObject(processInfo.hProcess, INFINITE); 870 | if not GetExitCodeProcess(processInfo.hProcess, err) then 871 | RaiseLastOsError; 872 | case err of 873 | 0: begin end; // OK 874 | ERROR_SUCCESS_REBOOT_REQUIRED: begin end; 875 | CBS_E_INVALID_PACKAGE: 876 | MessageBox(Self.Handle, PChar('Uninstall says there''s no such package. Perhaps refresh? '+ 877 | 'Or maybe you have forgotten to make packages visible. This also sometimes happens when the '+ 878 | 'package is marked for deletion until reboot.'), 879 | PChar('Uninstall failed'), MB_ICONERROR); 880 | else 881 | MessageBox(Self.Handle, PChar('Uninstall seems to have failed with error code '+IntToStr(err)), 882 | PChar('Uninstall failed'), MB_ICONERROR); 883 | end; 884 | 885 | finally 886 | CloseHandle(processInfo.hProcess); 887 | CloseHandle(processInfo.hThread); 888 | end; 889 | end; 890 | 891 | procedure TMainForm.pmUninstallAllClick(Sender: TObject); 892 | var PackageNames: TStringArray; 893 | AConfirmationText: string; 894 | begin 895 | PackageNames := GetSelectedPackageNames(); 896 | if Length(PackageNames) <= 0 then exit; 897 | 898 | //Sort the array in reverse, so that packages with ~EN_us suffixes are deleted earlier (otherwise they get dependency-deleted first) 899 | //Ideally we should just check dependencies and skip stuff already in it 900 | TArray.Sort(PackageNames, TDelegatedComparer.Construct( 901 | function(const Left, Right: string): Integer 902 | begin 903 | Result := CompareText(Left, Right); 904 | end)); 905 | 906 | if Length(PackageNames) = 1 then 907 | AConfirmationText := 'Do you really want to uninstall'#13 908 | +PackageNames[0]+'?'+#13 909 | +'After uninstalling, it will be impossible to install again without repairing Windows.' 910 | else 911 | AConfirmationText := 'Do you really want to uninstall '+IntToStr(Length(PackageNames))+' packages?'#13 912 | +SepJoin(PackageNames, #13)+#13 913 | +'After uninstalling, it will be impossible to install again without repairing Windows.'; 914 | 915 | if MessageBox(Self.Handle, PChar(AConfirmationText), 916 | PChar('Confirm uninstall'), MB_ICONWARNING or MB_YESNO) <> ID_YES then 917 | exit; 918 | 919 | DismUninstall(PackageNames); 920 | Reload; 921 | end; 922 | 923 | procedure TMainForm.pmCopyUninstallationCommandsClick(Sender: TObject); 924 | var PackageNames: TStringArray; 925 | AText, APackageName: string; 926 | begin 927 | PackageNames := GetSelectedPackageNames(); 928 | if Length(PackageNames) <= 0 then exit; 929 | 930 | AText := 'dism.exe /Online /Remove-Package'; 931 | for APackageName in PackageNames do 932 | AText := AText + ' /PackageName='+APackageName; 933 | 934 | Clipboard.SetTextBuf(PChar(AText)); 935 | end; 936 | 937 | procedure TMainForm.Saveselectedpackagelist1Click(Sender: TObject); 938 | var PackageNames: TStringArray; 939 | begin 940 | PackageNames := GetSelectedPackageNames(); 941 | if Length(PackageNames) <= 0 then exit; 942 | 943 | SavePackageList(PackageNames); 944 | end; 945 | 946 | procedure TMainForm.pmTakeRegistryOwnershipClick(Sender: TObject); 947 | begin 948 | JobProcessorForm.Caption := 'Taking ownership...'; 949 | JobProcessorForm.Show(); 950 | JobProcessorForm.Process(TTakeOwnershipJob.Create()) 951 | end; 952 | 953 | procedure TMainForm.pmDecoupleAllPackagesClick(Sender: TObject); 954 | begin 955 | JobProcessorForm.Caption := 'Decoupling...'; 956 | JobProcessorForm.Show(); 957 | JobProcessorForm.Process(TDecouplePackagesJob.Create(nil)) 958 | end; 959 | 960 | procedure TMainForm.pmDecouplePackagesClick(Sender: TObject); 961 | var packages: TStringArray; 962 | begin 963 | packages := GetSelectedPackageNames(); 964 | if Length(packages) <= 0 then exit; //because that would mean "Decouple all" 965 | JobProcessorForm.Caption := 'Decoupling...'; 966 | JobProcessorForm.Show(); 967 | JobProcessorForm.Process(TDecouplePackagesJob.Create(packages)) 968 | end; 969 | 970 | procedure TMainForm.pmMakeVisibleClick(Sender: TObject); 971 | begin 972 | SetCbsVisibility(GetSelectedPackages(), 1); 973 | end; 974 | 975 | procedure TMainForm.pmMakeInvisibleClick(Sender: TObject); 976 | begin 977 | SetCbsVisibility(GetSelectedPackages(), 2); 978 | end; 979 | 980 | procedure TMainForm.pmRestoreDefaultVisibilityClick(Sender: TObject); 981 | begin 982 | SetCbsVisibility(GetSelectedPackages(), -1); 983 | end; 984 | 985 | procedure TMainForm.pmMakeAllVisibileClick(Sender: TObject); 986 | begin 987 | SetCbsVisibility(GetAllPackages(), 1); 988 | end; 989 | 990 | procedure TMainForm.pmMakeAllInvisibleClick(Sender: TObject); 991 | begin 992 | SetCbsVisibility(GetAllPackages(), 2); 993 | end; 994 | 995 | procedure TMainForm.pmRestoreDefaltVisibilityAllClick(Sender: TObject); 996 | begin 997 | SetCbsVisibility(GetAllPackages(), -1); 998 | end; 999 | 1000 | 1001 | procedure TMainForm.edtFilterChange(Sender: TObject); 1002 | begin 1003 | UpdateNodeVisibility; 1004 | end; 1005 | 1006 | procedure TMainForm.edtFilterKeyDown(Sender: TObject; var Key: Word; 1007 | Shift: TShiftState); 1008 | begin 1009 | if Key = VK_ESCAPE then 1010 | TEdit(Sender).Text := ''; 1011 | end; 1012 | 1013 | procedure TMainForm.vtPackagesFocusChanged(Sender: TBaseVirtualTree; 1014 | Node: PVirtualNode; Column: TColumnIndex); 1015 | begin 1016 | if Assigned(pcPageInfo.ActivePage.OnEnter) then 1017 | pcPageInfo.ActivePage.OnEnter(pcPageInfo.ActivePage); 1018 | end; 1019 | 1020 | procedure TMainForm.tsInfoEnter(Sender: TObject); 1021 | var xml: IXmlDocument; 1022 | NodeData: PNdPackageData; 1023 | assembly, package, node: IXmlNode; 1024 | assemblyName: string; 1025 | copyright: string; 1026 | i: integer; 1027 | begin 1028 | lblDescription.Caption := ''; 1029 | lbUpdates.Items.Clear; 1030 | 1031 | NodeData := vtPackages.GetNodeData(vtPackages.FocusedNode); 1032 | if (NodeData = nil) or (NodeData.Package = nil) then 1033 | exit; 1034 | 1035 | xml := TXmlDocument.Create(GetWindowsDir()+'\servicing\Packages\'+NodeData.Package.Name+'.mum'); 1036 | try 1037 | assembly := xml.ChildNodes['assembly']; 1038 | if assembly = nil then exit; 1039 | package := assembly.ChildNodes['package']; 1040 | 1041 | assemblyName := ''; 1042 | if assembly.HasAttribute('name') then 1043 | assemblyName := assemblyName + assembly.Attributes['name']+#13; 1044 | if assembly.HasAttribute('description') then 1045 | assemblyName := assemblyName + assembly.Attributes['description']+#13; 1046 | if (assemblyName='') and (package <> nil) then begin 1047 | if package.HasAttribute('name') then 1048 | assemblyName := assemblyName + package.Attributes['name']+#13; 1049 | if package.HasAttribute('description') then 1050 | assemblyName := assemblyName + package.Attributes['description']+#13; 1051 | end; 1052 | //If nothing else, use registry package name 1053 | if assemblyName='' then 1054 | if (package <> nil) and (package.HasAttribute('identifier')) then 1055 | lblDescription.Caption := package.Attributes['identifier'] 1056 | else 1057 | lblDescription.Caption := NodeData.Package.Name; 1058 | 1059 | copyright := ''; 1060 | if assembly.HasAttribute('copyright') then 1061 | copyright := copyright + assembly.Attributes['copyright']; 1062 | if (copyright = '') and (package <> nil) then begin 1063 | if package.HasAttribute('copyright') then 1064 | copyright := copyright + package.Attributes['copyright']; 1065 | end; 1066 | 1067 | lblDescription.Caption := assemblyName; 1068 | if copyright <> '' then 1069 | lblDescription.Caption := lblDescription.Caption + #13 + copyright; 1070 | 1071 | if package <> nil then 1072 | for i := 0 to package.ChildNodes.Count-1 do begin 1073 | node := package.ChildNodes[i]; 1074 | if node.NodeName='update' then begin 1075 | assemblyName := ''; 1076 | if node.HasAttribute('displayName') then 1077 | assemblyName := assemblyName + node.Attributes['displayName'] + ' '; 1078 | if node.HasAttribute('description') then 1079 | assemblyName := assemblyName + node.Attributes['description'] + ' '; 1080 | if assemblyName = '' then 1081 | assemblyName := node.Attributes['name']; 1082 | lbUpdates.Items.Add(assemblyName); 1083 | end; 1084 | end; 1085 | 1086 | finally 1087 | xml := nil; 1088 | end; 1089 | end; 1090 | 1091 | 1092 | function textAttribute(const ANode: IXmlNode; const AAttribName: string): string; 1093 | begin 1094 | if ANode.HasAttribute(AAttribName) then 1095 | Result := ANode.attributes[AAttribName] 1096 | else 1097 | Result := ''; 1098 | end; 1099 | 1100 | //Parses a given assemblyIdentity node, extracting all the fields that identify an assembly 1101 | function XmlReadAssemblyIdentityData(const ANode: IXmlNode): TAssemblyIdentity; 1102 | begin 1103 | Result.name := textAttribute(ANode, 'name'); 1104 | Result.type_ := textAttribute(ANode, 'type'); 1105 | Result.language := textAttribute(ANode, 'language'); 1106 | Result.buildType := textAttribute(ANode, 'buildType'); 1107 | Result.processorArchitecture := textAttribute(ANode, 'processorArchitecture'); 1108 | Result.version := textAttribute(ANode, 'version'); 1109 | Result.publicKeyToken := textAttribute(ANode, 'publicKeyToken'); 1110 | Result.versionScope := textAttribute(ANode, 'versionScope'); 1111 | end; 1112 | 1113 | 1114 | type 1115 | TXmlNodeList = array of IXmlNode; 1116 | 1117 | function ListPackageAssemblies(xml: IXmlDocument): TXmlNodeList; overload; 1118 | var assembly, package, update, component, node: IXmlNode; 1119 | i, j: integer; 1120 | begin 1121 | SetLength(Result, 0); 1122 | 1123 | assembly := xml.ChildNodes['assembly']; 1124 | if assembly = nil then exit; 1125 | package := assembly.ChildNodes['package']; 1126 | if package = nil then exit; 1127 | 1128 | for i := 0 to package.ChildNodes.Count-1 do begin 1129 | update := package.ChildNodes[i]; 1130 | if update.NodeName <> 'update' then continue; 1131 | 1132 | for j := 0 to update.ChildNodes.Count-1 do begin 1133 | component := update.ChildNodes[j]; 1134 | if component.NodeName <> 'component' then continue; 1135 | 1136 | node := component.ChildNodes.FindNode('assemblyIdentity'); 1137 | if node = nil then continue; //that component wasn't assembly. huh. 1138 | 1139 | SetLength(Result, Length(Result)+1); 1140 | Result[Length(Result)-1] := node; 1141 | end; 1142 | end; 1143 | end; 1144 | 1145 | 1146 | procedure Log(const msg: string); 1147 | begin 1148 | MessageBox(0, PChar(msg), PChar('Log'), 0); 1149 | end; 1150 | 1151 | procedure TMainForm.tsResourcesEnter(Sender: TObject); 1152 | var xml: IXmlDocument; 1153 | NodeData: PNdPackageData; 1154 | node: IXmlNode; 1155 | assemblyData: TAssemblyIdentity; 1156 | assemblyId: TAssemblyId; 1157 | begin 1158 | FResources.Assemblies.Clear; 1159 | NodeData := vtPackages.GetNodeData(vtPackages.FocusedNode); 1160 | if (NodeData = nil) or (NodeData.Package = nil) then 1161 | exit; 1162 | 1163 | xml := TXmlDocument.Create(GetWindowsDir()+'\servicing\Packages\'+NodeData.Package.Name+'.mum'); 1164 | try 1165 | for node in ListPackageAssemblies(xml) do begin 1166 | assemblyData := XmlReadAssemblyIdentityData(node); 1167 | assemblyId := FDb.Assemblies.NeedAssembly(assemblyData); 1168 | FResources.Assemblies.Add(assemblyId); 1169 | end; 1170 | finally 1171 | xml := nil; 1172 | end; 1173 | FResources.Reload; 1174 | end; 1175 | 1176 | 1177 | procedure TMainForm.Exit1Click(Sender: TObject); 1178 | begin 1179 | Close; 1180 | end; 1181 | 1182 | procedure TMainForm.pmOpenCBSRegistryClick(Sender: TObject); 1183 | begin 1184 | RegeditOpenAndNavigate('HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\' 1185 | +'CurrentVersion\Component Based Servicing'); 1186 | end; 1187 | 1188 | procedure TMainForm.Diskcleanup1Click(Sender: TObject); 1189 | begin 1190 | StartProcess(GetSystemDir()+'\cleanmgr.exe', 'cleanmgr.exe'); 1191 | end; 1192 | 1193 | procedure TMainForm.Optionalfeatures1Click(Sender: TObject); 1194 | begin 1195 | StartProcess(GetSystemDir()+'\OptionalFeatures.exe', 'OptionalFeatures.exe'); 1196 | end; 1197 | 1198 | procedure TMainForm.DismCleanup1Click(Sender: TObject); 1199 | begin 1200 | StartProcess(GetSystemDir()+'\dism.exe', 1201 | PChar('dism.exe /Online /Cleanup-Image /StartComponentCleanup')); 1202 | end; 1203 | 1204 | procedure TMainForm.pmUninstallByListClick(Sender: TObject); 1205 | var lines: TStringList; 1206 | line: string; 1207 | i, i_pos: integer; 1208 | packages: TPackageArray; 1209 | packageNames: TStringArray; 1210 | begin 1211 | if not UninstallListOpenDialog.Execute then 1212 | exit; 1213 | 1214 | SetLength(packages, 0); 1215 | 1216 | lines := TStringList.Create; 1217 | try 1218 | lines.LoadFromFile(UninstallListOpenDialog.FileName); 1219 | 1220 | for i := 0 to lines.Count-1 do begin 1221 | line := Trim(lines[i]); 1222 | if line = '' then continue; 1223 | if line.StartsWith('//') then continue; 1224 | 1225 | // #-style comments are also supported at the end of the line 1226 | i_pos := pos('#', line); 1227 | if i_pos > 0 then begin 1228 | line := Trim(copy(line, 1, i_pos-1)); 1229 | if line = '' then continue; 1230 | end; 1231 | 1232 | FPackages.SelectMatching(line, packages); 1233 | end; 1234 | finally 1235 | FreeAndNil(lines); 1236 | end; 1237 | 1238 | packageNames := PackagesToPackageNames(packages); 1239 | 1240 | if Length(packageNames) <= 0 then begin 1241 | MessageBox(Self.Handle, PChar('Nothing to remove.'), PChar('Uninstall by list'), MB_ICONINFORMATION + MB_OK); 1242 | exit; 1243 | end else 1244 | if MessageBox(Self.Handle, PChar(IntToStr(Length(packageNames))+' packages is going to be removed. Do you really want to do this?'), 1245 | PChar('Confirm removal'), MB_ICONQUESTION + MB_YESNO) <> ID_YES then 1246 | exit; 1247 | 1248 | DismUninstall(packageNames); 1249 | Reload; 1250 | end; 1251 | 1252 | procedure TMainForm.Rebuildassemblydatabase1Click(Sender: TObject); 1253 | begin 1254 | RebuildAssemblyDatabase(FDb, AppFolder+'\assembly.db'); 1255 | end; 1256 | 1257 | end. 1258 | --------------------------------------------------------------------------------