Sordie.co.uk

libsassy/libSassy.System.pas

Raw

{(
 )) libSassy.System
((    System information
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2016
 ))
((  This work is made available under the terms of the Creative Commons
 )) Attribution-NonCommercial-ShareAlike 3.0 Unported license
((  http://creativecommons.org/licenses/by-nc-sa/3.0/
 )}

unit libSassy.System;

interface

uses
  Winapi.Windows,
  Winapi.Messages,

  libSassy.Strings;

{$REGION 'Registry'}
function ReadRegPtr (Root: HKEY; Path, Key: String;                     Ptr: Pointer; var Size: Cardinal; const Wow64: Boolean = False): Cardinal;
function WriteRegPtr(Root: HKEY; Path, Key: String; DataType: Cardinal; Ptr: Pointer;     Size: Cardinal; const Wow64: Boolean = False): Boolean;

function ReadReg(Root: HKEY; Path, Key: String; const Default: String   = ''): String;   overload;
function ReadReg(Root: HKEY; Path, Key: String; const Default: Cardinal = 0):  Cardinal; overload;

function WriteReg(Root: HKEY; Path, Key: String; Value: String):   Boolean; overload;
function WriteReg(Root: HKEY; Path, Key: String; Value: Cardinal): Boolean; overload;

function DeleteReg(Root: HKEY; Path, Key: String): Boolean;
{$ENDREGION}

{$REGION 'Environment'}
function  ReadEnv (Name: String; const Default: String = ''): String;
procedure WriteEnv(Name: String; const Value:   String = ''; const Save: Boolean = False);

function ExpandEnv(Str: String): String;

const
  EnvPath = 'SYSTEM\CurrentControlSet\Control\Session Manager\Environment';
{$ENDREGION}

{$REGION 'Identification'}
function ComputerName: String;
function UserName:     String;
function MachineGUID:  String;
function HDDID:        String;
{$ENDREGION}

implementation

{$REGION 'Registry'}
function ReadRegPtr;
var
  h: HKEY;
  f: Cardinal;
begin
  f := KEY_READ;
  if Wow64 then f := f or $100;

  if RegOpenKeyEx(Root, PChar(Path), 0, f, h) <> ERROR_SUCCESS then Exit(REG_NONE);

  try
    if RegQueryValueEx(h, PChar(Key), nil, @Result, Ptr, @Size) <> ERROR_SUCCESS then
      Result := REG_NONE;
  finally
    RegCloseKey(h);
  end;
end;

function WriteRegPtr;
var
  h: HKEY;
  f: Cardinal;
begin
  f := KEY_WRITE;
  if Wow64 then f := f or $100;

  if RegCreateKeyEx(Root, PChar(Path), 0, nil, REG_OPTION_NON_VOLATILE, f, nil, h, nil) <> ERROR_SUCCESS then Exit(False);

  try
    Result := RegSetValueEx(h, PChar(Key), 0, DataType, Ptr, Size) = ERROR_SUCCESS;
  finally
    RegCloseKey(h);
  end;
end;

function ReadReg(Root: HKEY; Path, Key: String; const Default: String = ''): String;
var
  Size: Cardinal;
  Kind: Cardinal;
begin
  SetLength(Result, 1024);
  Size := Result.Length;

  Kind := ReadRegPtr(Root, Path, Key, @Result[1], Size, False);

  if Kind = REG_NONE then
    Kind := ReadRegPtr(Root, Path, Key, @Result[1], Size, True);

  case Kind of
    REG_SZ: Result.Length := Size - 1;

     REG_EXPAND_SZ:
     begin
      Result.Length := Size - 1;
      Result := ExpandEnv(Result);
     end;
  else
    Result := Default;
  end;
end;

function ReadReg(Root: HKEY; Path, Key: String; const Default: Cardinal = 0): Cardinal;
var
  Size: Cardinal;
  Kind: Cardinal;
begin
  Size := SizeOf(Result);

  Kind := ReadRegPtr(Root, Path, Key, @Result, Size, False);

  if Kind = REG_NONE then
    Kind := ReadRegPtr(Root, Path, Key, @Result, Size, True);

  if Kind <> REG_DWORD then
    Result := Default;
end;

function WriteReg(Root: HKEY; Path, Key: String; Value: String): Boolean;
begin
  Result := WriteRegPtr(Root, Path, Key, REG_SZ, Value.Ptr, Value.Length);
end;

function WriteReg(Root: HKEY; Path, Key: String; Value: Cardinal): Boolean;
begin
  Result := WriteRegPtr(Root, Path, Key, REG_DWORD, @Value, SizeOf(Value));
end;

function DeleteReg;
var
  h: HKEY;
begin
  if Key.Empty then Exit(RegDeleteKey(Root, PChar(Path)) = ERROR_SUCCESS);

  Result := RegOpenKeyEx(Root, PChar(Path), 0, KEY_READ, h) = ERROR_SUCCESS;
  if not Result then Exit;

  try
    Result := RegDeleteValue(h, PChar(Key)) = ERROR_SUCCESS;
  finally
    RegCloseKey(h);
  end;
end;
{$ENDREGION}

{$REGION 'Environment'}
function ReadEnv;
begin
  Result.Length := 1024;
  Result.Length := GetEnvironmentVariable(Name.Ptr, Result.Ptr, Result.Length);

  if Result.Empty then
    Result := ReadReg(HKEY_LOCAL_MACHINE, EnvPath, Name, Default);
end;

procedure WriteEnv;
begin
  if Save then
  begin
    if Value.Empty then
      DeleteReg(HKEY_LOCAL_MACHINE, EnvPath, Name)
    else
      WriteReg(HKEY_LOCAL_MACHINE, EnvPath, Name, Value);

    SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0, SMTO_NORMAL, 1000, nil);
  end;

  SetEnvironmentVariable(Name.Ptr, Value.Ptr);
end;

function ExpandEnv;
var
  NamBuf: String;
  VarBuf: String;
  EnvBuf: PChar;
  i:      Integer;
begin
  Result := Str;

  EnvBuf := GetEnvironmentStrings;

  try
    i := 0;

    repeat
      VarBuf := '';

      while EnvBuf[i] <> #0 do
      begin
        VarBuf := VarBuf + EnvBuf[i];
        inc(i);
      end;

      inc(i);

      NamBuf := VarBuf.Split('=');
      Result := Result.Replace('%' + NamBuf + '%', VarBuf);
    until EnvBuf[i] = #0;
  finally
    FreeEnvironmentStrings(EnvBuf);
  end;
end;
{$ENDREGION}

{$REGION 'Identification'}
function ComputerName;
var
  i: Cardinal;
begin
  i := 256; Result.Length := i;
  GetComputerName(Result.Ptr, i);
  Result.Length := i;

  if Result.Empty then
    Result := ReadEnv('COMPUTERNAME');
end;

function UserName;
var
  i: Cardinal;
begin
  i := 256; Result.Length := i;
  GetUserName(Result.Ptr, i);
  Result.Length := i - 1;

  if Result.Empty then
    Result := ReadEnv('USERNAME');
end;

function MachineGUID;
begin
  Result := ReadReg(HKEY_LOCAL_MACHINE, 'SOFTWARE\Microsoft\Cryptography', 'MachineGuid', '');
end;

type
  TStoragePropertyQuery = packed record
    PropertyID: Cardinal;
    QueryType:  Cardinal;
    Parameters: array[0..3] of Byte;
  end;

  TStorageDescriptor = packed record
    Version:        Cardinal;
    Size:           Cardinal;
    DeviceType:     Byte;
    DeviceTypeMod:  Byte;
    Removable:      Boolean;
    Queueing:       Boolean;
    VendorIDOfs:    Cardinal;
    ProductIDOfs:   Cardinal;
    ProductRevOfs:  Cardinal;
    SerialNoOfs:    Cardinal;
    StorageBusType: Cardinal;
    PropLength:     Cardinal;
    PropRaw:        array[0..511] of Byte;
  end;

function HDDID;
var
  HDD:    THandle;
  Query:  TStoragePropertyQuery;
  Header: TStorageDescriptor;
  Ret:    Cardinal;
begin
  Result := '0';

  HDD := CreateFile('\\.\PhysicalDrive0', 0, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
  if HDD = INVALID_HANDLE_VALUE then Exit;

  try
    FillChar(Query,  SizeOf(Query),  0);
    FillChar(Header, SizeOf(Header), 0);

    if not DeviceIOControl(HDD, IOCTL_STORAGE_QUERY_PROPERTY, @Query, SizeOf(Query), @Header, SizeOf(Header), Ret, nil) then Exit;

    if Header.SerialNoOfs > 0 then
      Result := String(PAnsiChar(Cardinal(@Header) + Header.SerialNoOfs));
  finally
    CloseHandle(HDD);
  end;
end;
{$ENDREGION}

end.