unit ELPlugin_AddHardwareListZippedFile;

{$I ELDefines.inc}

interface

function GetHardwareList: String;

procedure UnregisterHandler;

implementation

uses
  Windows,
  SysUtils,
  Classes,
  DateUtils,
  ETypes,
  EConsts,
  ELowLevel,
  EBase,
  EConfig,
  ESysInfo,
  EException,
  EEncoding,
  EEvents,
  EDLLs,
  ExceptionLog7,
  ECompatibility;

const
  PluginID    = '365EE619-4025-488A-B651-0C4BD7043377';
  RegistryKey = EPluginsEurekaLogRegistryKey + '\' + PluginID;

type
  TDeviceInfo = packed record
                  cbSize: DWORD;
                  ClassGuid: TGuid;
                  DevInst: DWORD;
                  Reserved: Pointer;
                end;

 TSetupDiGetClassDevsWFunc = function(ClassGuid, Enum: Pointer; ParentWnd: HWND; Flags: DWORD): THandle; stdcall;
 TSetupDiDestroyDeviceInfoListFunc = function(Handle: THandle): BOOL; stdcall;
 TSetupDiEnumDeviceInfoFunc = function(Handle: THandle; Index: DWORD; DevInfo: Pointer): BOOL; stdcall;
 TSetupDiGetDeviceRegistryPropertyWFunc = function(Handle: THandle; DevInfo: Pointer; InfoType: DWORD; out DataType: DWORD; Buf: Pointer; BufSize: DWORD; var reqSize: DWORD): BOOL; stdcall;

var
  Lib: HMODULE;
  SetupDiGetClassDevsW: TSetupDiGetClassDevsWFunc;
  SetupDiDestroyDeviceInfoList: TSetupDiDestroyDeviceInfoListFunc;
  SetupDiEnumDeviceInfo: TSetupDiEnumDeviceInfoFunc;
  SetupDiGetDeviceRegistryPropertyW: TSetupDiGetDeviceRegistryPropertyWFunc;

function GetHardwareList: String;
type
  TDriver = record
              Name: String;
              Driver: String;
            end;
  TDrivers = array of TDriver;
  THardwareEntry = record
                     Name: String;
                     Description: String;
                     Drivers: TDrivers;
                   end;
  THardwareList = array of THardwareEntry;

var
  Hardware: THardwareList;

  procedure AddDevice(const AClassName, AClassDescription, ADeviceName, ADriverPath: String);
  var
    HInd, DInd, I, C: integer;
  begin
    HInd := -1;
    for I := 0 to High(Hardware) do
    begin
      C := CompareText(Hardware[I].Name, AClassName);
      if C >= 0 then
      begin
        HInd := I;
        Break;
      end;
    end;

    if HInd = -1 then
    begin
      HInd := Length(Hardware);
      SetLength(Hardware, HInd + 1);
    end
    else
    begin
      if Hardware[HInd].Name <> AClassName then
      begin
        I := Length(Hardware);
        SetLength(Hardware, I + 1);
        Move(Hardware[HInd], Hardware[HInd + 1], (I - HInd) * SizeOf(Hardware[HInd]));
        ZeroMemory(@Hardware[HInd], SizeOf(Hardware[HInd]));
      end;
    end;

    Hardware[HInd].Name := AClassName;
    Hardware[HInd].Description := AClassDescription;
    DInd := -1;
    for I := 0 to High(Hardware[HInd].Drivers) do
    begin
      C := CompareText(Hardware[HInd].Drivers[I].Name, ADeviceName);
      if C >= 0 then
      begin
        DInd := I;
        Break;
      end;
    end;
    I := Length(Hardware[HInd].Drivers);
    SetLength(Hardware[HInd].Drivers, I + 1);
    if DInd <> -1 then
    begin
      Move(Hardware[HInd].Drivers[DInd], Hardware[HInd].Drivers[DInd + 1], (I - DInd) * SizeOf(Hardware[HInd].Drivers[DInd]));
      ZeroMemory(@Hardware[HInd].Drivers[DInd], sizeOf(Hardware[HInd].Drivers[DInd]));
    end
    else
      DInd := I;
    Hardware[HInd].Drivers[DInd].Name := ADeviceName;
    Hardware[HInd].Drivers[DInd].Driver := ADriverPath;
  end;

  procedure BuildHardwareList;

    function GetDeviceInfo(const Handle: THandle; const DI: TDeviceInfo; const AInfoType: DWORD): String;
    var
      Size: DWORD;
      DataType: DWORD;
      Data: PWideChar;
    begin
      Result := '';

      Size := 0;
      SetupDiGetDeviceRegistryPropertyW(Handle, @DI, AInfoType, DataType, nil, 0, Size);
      if Size <> 0 then
      begin
        Size := Size * SizeOf(WideChar);
        Data := Pointer(LocalAlloc(LPTR, Size));
        if SetupDiGetDeviceRegistryPropertyW(Handle, @DI, AInfoType, DataType, Data, Size, Size) then
          Result := Data;
        LocalFree(HLOCAL(Data));
      end;
    end;

  const
    DIGCF_PRESENT      = 2;
    DIGCF_ALLCLASSES   = 4;

    SPDRP_DEVICEDESC = $00000000;
    SPDRP_HARDWAREID = $00000001;
    SPDRP_COMPATIBLEIDS = $00000002;
    SPDRP_UNUSED0 = $00000003;
    SPDRP_SERVICE = $00000004;
    SPDRP_UNUSED1 = $00000005;
    SPDRP_UNUSED2 = $00000006;
    SPDRP_CLASS = $00000007;
    SPDRP_CLASSGUID = $00000008;
    SPDRP_DRIVER = $00000009;
    SPDRP_CONFIGFLAGS = $0000000A;
    SPDRP_MFG = $0000000B;
    SPDRP_FRIENDLYNAME = $0000000C;
    SPDRP_LOCATION_INFORMATION = $0000000D;
    SPDRP_PHYSICAL_DEVICE_OBJECT_NAME = $0000000E;
    SPDRP_CAPABILITIES = $0000000F;
    SPDRP_UI_NUMBER = $00000010;
    SPDRP_UPPERFILTERS = $00000011;
    SPDRP_LOWERFILTERS = $00000012;
    SPDRP_BUSTYPEGUID = $00000013;
    SPDRP_LEGACYBUSTYPE = $00000014;
    SPDRP_BUSNUMBER = $00000015;
    SPDRP_ENUMERATOR_NAME = $00000016;
    SPDRP_SECURITY = $00000017;
    SPDRP_SECURITY_SDS = $00000018;
    SPDRP_DEVTYPE = $00000019;
    SPDRP_EXCLUSIVE = $0000001A;
    SPDRP_CHARACTERISTICS = $0000001B;
    SPDRP_ADDRESS = $0000001C;
    SPDRP_UI_NUMBER_DESC_FORMAT = $0000001D;
    SPDRP_DEVICE_POWER_DATA = $0000001E;
    SPDRP_REMOVAL_POLICY = $0000001F;
    SPDRP_REMOVAL_POLICY_HW_DEFAULT = $00000020;
    SPDRP_REMOVAL_POLICY_OVERRIDE = $00000021;
    SPDRP_INSTALL_STATE = $00000022;
    SPDRP_LOCATION_PATHS = $00000023;

  var
    Handle: THandle;
    DI: TDeviceInfo;
    DInd: Integer;
    ClassName: String;
    ClassGUID: String;
    ClassDescription: String;
    HardwareID: String;
    FileName: String;
    Description: String;
    OverrideStr: String;
  begin
    if Lib = 0 then
      Exit;

    Handle := SetupDiGetClassDevsW(nil, nil, 0, DIGCF_PRESENT or DIGCF_ALLCLASSES);
    if Handle = INVALID_HANDLE_VALUE then
      Exit;

    try
      FillChar(DI, SizeOf(DI), 0);
      DI.cbSize := SizeOf(DI);

      DInd := 0;
      while SetupDiEnumDeviceInfo(Handle, DInd, @DI) do
      begin
        ClassName := GetDeviceInfo(Handle, DI, SPDRP_CLASS);
        ClassGUID := GetDeviceInfo(Handle, DI, SPDRP_CLASSGUID);
        HardwareID := GetDeviceInfo(Handle, DI, SPDRP_HARDWAREID);
        ClassDescription := RegKeyRead(HKEY_LOCAL_MACHINE, '\System\CurrentControlSet\Control\Class\' + ClassGUID, 'ClassDesc');
        if (ClassDescription <> '') and (ClassName <> '') then
          ClassDescription := Format('%s [%s]', [ClassDescription, ClassName]);
        if (ClassName <> 'LegacyDriver') and (ClassName <> 'Unknown') and (ClassName <> 'Volume') and (Pos('sw\', HardwareID) = 0) then
        begin
          OverrideStr := RegKeyRead(HKEY_LOCAL_MACHINE, '\System\CurrentControlSet\Control\Class\' + ClassGUID, '');
          if OverrideStr <> '' then
            ClassName := OverrideStr;
          if ClassName <> '' then
          begin
            Description := GetDeviceInfo(Handle, DI, SPDRP_FRIENDLYNAME);
            if Description = '' then
              Description := GetDeviceInfo(Handle, DI, SPDRP_DEVICEDESC);
            FileName := GetDeviceInfo(Handle, DI, SPDRP_DRIVER);
            if FileName <> '' then
              FileName := '\System\CurrentControlSet\Control\Class\' + FileName;
            AddDevice(ClassGUID, ClassDescription, Description, FileName);
          end;
        end;
        Inc(DInd);
      end;

    finally
      SetupDiDestroyDeviceInfoList(Handle);
    end;
  end;

  function GetCPUName: String;
  begin
    Result := RegKeyRead(HKEY_LOCAL_MACHINE, '\Hardware\Description\System\CentralProcessor\0', 'ProcessorNameString');
    Result := Trim(StringReplace(Result, '  ', ' ', [rfReplaceAll]));
  end;

  function GetCPUCount: Integer;
  var
    X: Integer;
  begin
    Result := 16;
    for X := 1 to 15 do
      if RegKeyRead(HKEY_LOCAL_MACHINE, '\Hardware\Description\System\CentralProcessor\' + IntToStr(X), 'ProcessorNameString') = '' then
      begin
        Result := X;
        Break;
      end;
  end;

  function GetHardwareListStr: String;
  var
    HIndexes: array of Integer;

    procedure SortHardware(L, R: Integer);

      function Compare(I, J: Integer): Integer;
      var
        S1, S2: String;
      begin
        if Hardware[I].Description = '' then
          S1 := Hardware[I].Name
        else
          S1 := Hardware[I].Description;
        if Hardware[J].Description = '' then
          S2 := Hardware[J].Name
        else
          S2 := Hardware[J].Description;
        Result := CompareStr(S1, S2);
      end;

    var
      I, J: Integer;
      P, T: Integer;
    begin
      repeat
        I := L;
        J := R;
        P := HIndexes[(L + R) shr 1];
        repeat
          while Compare(HIndexes[I], P) < 0 do
            Inc(I);
          while Compare(HIndexes[J], P) > 0 do
            Dec(J);
          if I <= J then
          begin
            if I <> J then
            begin
              T := HIndexes[I];
              HIndexes[I] := HIndexes[J];
              HIndexes[J] := T;
            end;
            Inc(I);
            Dec(J);
          end;
        until I > J;
        if L < J then
          SortHardware(L, J);
        L := I;
      until I >= R;
    end;

  var
    HUInd, HInd, DInd: Integer;
    X: Integer;
    DName: String;
    DVersion: String;
  begin
    Result := '';

    SetLength(HIndexes, Length(Hardware));
    for X := 0 to High(HIndexes) do
      HIndexes[X] := X;
    if High(HIndexes) <> 0 then
      SortHardware(0, High(HIndexes));

    for HUInd := 0 to High(Hardware) do
    begin
      HInd := HIndexes[HUInd];
      if Hardware[HInd].Description <> '' then
        Result := Result + sLineBreak + Format('+ %s', [Hardware[HInd].Description])
      else
        Result := Result + sLineBreak + Format('+ %s', [Hardware[HInd].Name]);

      for DInd := 0 to High(Hardware[HInd].Drivers) do
      begin
        Result := Result + sLineBreak + '  - ' + Hardware[HInd].Drivers[DInd].Name;

        if Hardware[HInd].Drivers[DInd].Driver <> '' then
        begin
          DName := Trim(RegKeyRead(HKEY_LOCAL_MACHINE, Hardware[HInd].Drivers[DInd].Driver, 'ProviderName'));
          if DName <> '' then
          begin
            DVersion := Trim(RegKeyRead(HKEY_LOCAL_MACHINE, Hardware[HInd].Drivers[DInd].Driver, 'DriverVersion'));
            if DVersion = '' then
              DVersion := Trim(RegKeyRead(HKEY_LOCAL_MACHINE, Hardware[HInd].Drivers[DInd].Driver, 'DriverDate'));
            if DVersion <> '' then
              DName := Format('%s, %s', [DName, DVersion]);
            Result := Format('%s  [%s]', [Result, DName]);
          end;
        end;
      end;
    end;
    Result := Trim(Result);
  end;

var
  SetThreadUILanguage: function(LCID: Cardinal): Cardinal; stdcall;
  SavedLocale, SavedUI: Cardinal;
begin
  if CheckWin32Version(6, 0) then
    SetThreadUILanguage := GetProcAddress(LibKernel32, 'SetThreadUILanguage')
  else
    SetThreadUILanguage := nil;

  SavedLocale := GetThreadLocale;
  SetThreadLocale(MAKELCID(MAKELANGID(LANG_ENGLISH, SUBLANG_DEFAULT), SORT_DEFAULT));
  if Assigned(SetThreadUILanguage) then
    SavedUI := SetThreadUILanguage(MAKELANGID(LANG_ENGLISH, SUBLANG_DEFAULT))
  else
    SavedUI := SavedLocale;

  try
    BuildHardwareList;
    Result := Trim(Format('CPU: %s (%d processors)' + sLineBreak + sLineBreak + '%s', [GetCPUName, GetCPUCount, GetHardwareListStr]));
  finally
    SetThreadLocale(SavedLocale);
    if Assigned(SetThreadUILanguage) then
      SetThreadUILanguage(SavedUI);
  end;
end;

var
  CachedHWList: String;
  CachedHWListFile: String;

procedure _AddHardwareListFileHandler(const ACustom: Pointer; AExceptionInfo: TEurekaExceptionInfo; const ATempFolder: String; AAttachedFiles: TStrings; var ACallNextHandler: Boolean);
var
  FileName, Content: String;
begin
  Content := CachedHWList;
  if Content = '' then
    Content := GetHardwareList;

  FileName := ATempFolder + 'Hardware.txt';
  TextToFile(FileName, Content, TEncoding.UTF8);
  AAttachedFiles.Add(FileName);
end;

function CacheHWInfo(Parameter: Pointer): Integer;
begin
  try
    CachedHWList := GetHardwareList;
  except
    on E: Exception do
      CachedHWList := E.Message;
  end;
  try
    if (CachedHWList <> '') and (CachedHWListFile <> '') then
    begin
      ForceDirectories(ExtractFilePath(CachedHWListFile));
      TextToFile(CachedHWListFile, CachedHWList, TEncoding.UTF8);
      RegKeyWrite(HKEY_CURRENT_USER, RegistryKey, 'LastBoot', FloatToStr(Extended(GetSystemStartTime)));
    end;
  except
    // ignore caching errors
  end;
  Result := 0;
end;

procedure Init;
var
  TID: Cardinal;
  LastBoot: TDateTime;
begin
  Lib := LibSetupAPI;
  if Lib <> 0 then
  begin
    SetupDiGetClassDevsW := GetProcAddress(Lib, 'SetupDiGetClassDevsW');
    SetupDiDestroyDeviceInfoList := GetProcAddress(Lib, 'SetupDiDestroyDeviceInfoList');
    SetupDiEnumDeviceInfo := GetProcAddress(Lib, 'SetupDiEnumDeviceInfo');
    SetupDiGetDeviceRegistryPropertyW := GetProcAddress(Lib, 'SetupDiGetDeviceRegistryPropertyW');
    if (not Assigned(SetupDiGetClassDevsW)) or
       (not Assigned(SetupDiDestroyDeviceInfoList)) or
       (not Assigned(SetupDiEnumDeviceInfo)) or
       (not Assigned(SetupDiGetDeviceRegistryPropertyW)) then
      Lib := 0;
  end;

  LastBoot := TDateTime(StrToFloatDef(RegKeyRead(HKEY_CURRENT_USER, RegistryKey, 'LastBoot'), 0));
  CachedHWListFile := GetFolderEurekaLogAppData + 'Plugins' + PathDelim + PluginID + PathDelim + 'CachedHWList.txt';
  if (SecondsBetween(LastBoot, GetSystemStartTime) < 30) and
     FileExists(CachedHWListFile) then
    CachedHWList := FileToText(CachedHWListFile);

  if (Lib <> 0) or (CachedHWList <> '') then
    RegisterEventZippedFilesRequest(nil, _AddHardwareListFileHandler);
  if (Lib <> 0) and (CachedHWList = '') then
    BeginThreadEx(nil, 0, CacheHWInfo, nil, 0, TID, 'ELHardwareList Cache Thread');
end;

procedure UnregisterHandler;
begin
  UnregisterEventZippedFilesRequest(nil, _AddHardwareListFileHandler);
end;

initialization
  SafeExec(Init, 'ELPlugin_AddHardwareListZippedFile.Init');
end.