Unit Utils;

{
  Tento soubor obsahuje funkce a procedury plnici
  rozlicne ukoly. Vzhledem k rozmanitosti a
  velikosti techto uloh nelze tyto rutiny dale
  rozdelit do vice souboru.
}

Interface

Uses
  Windows, Classes;

Type
  // Reprezentuje typ aktualne beziciho OS
  // ostNone - neznamy/neinicializovano
  // ost32bit - 32bitovy (x86)
  // ost64bit - 64bitovy, AMD64/x64
  TOperatingSystemType = (ostNone, ost32bit, ost64bit);

  // Pomocne definice seznamu ruznych hodnot
  TNameList = Array Of WideString;
  TPointerList = Array Of Pointer;
  TIntegerList = Array Of Cardinal;

Type
  // Tento zaznam se pouziva pri ziskavani seznamu
  // beziich procesu. Obsahuje informace o jednom
  // procesu
  TProcessInfoRecord = Record
    // Jmeno souboru procesu (bez cesty)
    Name : WideString;
    // Jedinecny identifikator
    PID : DWORD;
    // Zakladni priorita
    Priority : DWORD;
    // Aktualni pocet vlaken
    NumberOfThreads : DWORD;
    end;
  PProcessInfoRecord = ^TProcessInfoRecord;


Procedure Error(Msg:WideString);
Procedure Warning(Msg:WideString);
Procedure Information(Msg:WideString);
Function GetProcessName(ProcessId:DWORD):WideString;
Function GetOSType:TOperatingSystemType;
Function GetPointerLength:Integer;
Function GetThreadProcessId(TID:DWORD):DWORD;
Function GetProcessIdFromName(Name:WideString):DWORD;
Procedure GetOSVersion(Var Major:DWORD; Var Minor:DWORD; Var Build:DWORD);
Function EventTypeToStr(EventType:DWORD):WideString;
Function GetProcessList(List:TList):Boolean;

Function GetDriverList(Var Names:TNameList; Var Addresses:TPointerList; Var Sizes:TIntegerList):Boolean;
Function GetAddressOwner(Addresses:TPointerList; Sizes:TIntegerList; Address:Pointer):Integer;
Function AddressToModuleName(Address:Pointer; Names:TNameList; Addresses:TPointerList; Sizes:TIntegerList):WideString;

Function GetWinDir:WideString;
Function GetSysDir:WideString;

Function MemAlloc(Size:Integer):Pointer;
Procedure MemFree(Address:Pointer);

Function LastErrorStr:WideString;

Implementation

Uses
  TlHelp32, SysUtils, Native;

Var
  // Uchovava typ operacniho systemu
  OSType : TOperatingSystemType;
  // Delka adresy v bajtech (zavisi na typu OS)
  PointerLength : Integer;

  // Cisla verzi a sestaveni
  OSMajorVersion : DWORD;
  OSMinorVersion : DWORD;
  OSBuildNumber : DWORD;



Function GetThreadProcessId(TID:DWORD):DWORD;
{
  Zjisti, kteremu procesu vlakno se zadanym cislem TID
  patri. K zjisteni pouzije knihovnu Tool Help Library.
}
Var
  hSnap : THandle;
  TE : THREADENTRY32;
begin
Result := $FFFFFFFF;
hSnap := CreateToolHelp32Snapshot(TH32CS_SNAPTHREAD,0);
If hSnap > 0 Then
  begin
  TE.dwSize := SizeOf(TE);
  if Thread32First(hSnap,TE) Then
    begin
    Repeat
    If TE.th32ThreadID = TID Then
      begin
      Result := TE.th32OwnerProcessID;
      Break;
      end;
    Until Not Thread32Next(hSnap,TE);
    end;

  CloseHandle(hSnap);
  end;
end;

Function GetProcessIdFromName(Name:WideString):DWORD;
{
  Prohleda seznam prave bezicich procesu a vrati
  PID prvniho takoveho, jehoz jmeno souboru odpovida
  jmenu zadanemu parametrem Name.
}
Var
  hSnap : THandle;
  ProcEntry32 : PROCESSENTRY32W;
  ProcessName : WideString;
begin
Result := $FFFFFFFF;
hSnap := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
If hSnap > 0 Then
  begin
  Name := WideUpperCase(Name);
  ProcEntry32.dwSize := SizeOf(ProcEntry32);
  if Process32FirstW(hSnap, ProcEntry32) then
    begin
    Repeat
    ProcessName := WideUpperCase(ProcEntry32.szExeFile);
    if Name = ProcessName then
      begin
      Result := ProcEntry32.th32ProcessID;
      Break;
      end;
    Until Not Process32NextW(hSnap, ProcEntry32);
    end;

  CloseHandle(hSnap);
  end;
end;



Function GetPointerLength:Integer;
{
  Vrati delku adres v bajtech na aktualne bezicim
  operacnim systemu. Jedna se o delku nativnich
  adres. WOW64 neni uvazovano.
}
begin
Result := PointerLength;
end;

Function GetOSType:TOperatingSystemType;
{
  Vrati typ operacniho systemu (32bit, 64bit).
}
begin
Result := OSType;
end;

Procedure Error(Msg:WideString);
{
  Zobrazi chybovou hlasku pomoci dialogu.
}
begin
MessageBoxW(0, PWideChar(Msg), 'Error', MB_OK Or MB_ICONERROR);
end;

Procedure Warning(Msg:WideString);
{
  Zobrazi varovani pomoci dialogu.
}
begin
MessageBoxW(0, PWideChar(Msg), 'Warning', MB_OK Or MB_ICONWARNING);
end;

Procedure Information(Msg:WideString);
{
  Zobrazi informacni text pomoci dialogu.
}
begin
MessageBoxW(0, PWideChar(Msg), 'Information', MB_OK Or MB_ICONINFORMATION);
end;

Function GetProcessName(ProcessId:DWORD):WideString;
{
  Vrati jmeno procesu se zadanym PID. Ke sve praci
  vyuziva sluzeb knihovny Tool Help Library.
}
Var
  PE : ProcessEntry32;
  hSnap : THandle;
begin
Result := '<unknown>';
If ProcessId > 0 Then
  begin
  hSnap := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  If hSnap > 0 Then
    begin
    PE.dwSize := SizeOf(PE);
    If Process32First(hSnap, PE) Then
      begin
      Repeat
      If PE.th32ProcessID = ProcessId Then
        begin
        Result := PE.szExeFile;
        Break;
        end;

      Until Not Process32Next(hSnap, PE);
      end;

    CloseHandle(hSnap);
    end;
  end;
end;

Procedure GetOSVersion(Var Major:DWORD; Var Minor:DWORD; Var Build:DWORD);
{
  Naplni parametry majoritnim cislem verze,
  minoritnim cislem verze a cislem sestaveni.
}
begin
Major := OSMajorVersion;
Minor := OSMinorVersion;
Build := OSBuildNumber;
end;

Function UtilsInit:Boolean;
{
  Provede inicializaci promennych v tomto souboru.
  Jedna se o zjisteni cisel verzi a sestaveni
  aktualne beziciho OS, zjisteni platformy a
  nativni delky adresy. Pokud tato rutina selze,
   program by mel byt okamzite ukoncen.
}
Const
  PROCESSOR_ARCHITECTURE_AMD64 = 9;

Var
  SysInfo : SYSTEM_INFO;
  VersionInfo : OSVERSIONINFOW;
begin
ZeroMemory(@VersionInfo, SizeOf(VersionInfo));
VersionInfo.dwOSVersionInfoSize := SizeOf(VersionInfo);
Result := GetVersionExW(VersionInfo);
If (Result) And (VersionInfo.dwMajorVersion >= 5) Then
  begin
  OSMajorVersion := VersionInfo.dwMajorVersion;
  OSMinorVersion := VersionInfo.dwMinorVersion;
  OSBuildNumber := VersionInfo.dwBuildNumber;
  OSType := ostNone;
  GetNativeSystemInfo(SysInfo);
  If SysInfo.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64 Then
    begin
    OSType := ost64bit;
    PointerLength := 8;
    end
  Else begin
    OSType := ost32bit;
    PointerLength := 4;
    end;
  end
Else begin
  If Result Then
    begin
    Result := False;
    Error(Format('Tato verze operacniho systomu (%u.%u.%u) neni podporovana', [VersionInfo.dwMajorVersion, VersionInfo.dwMinorVersion, VersionInfo.dwBuildNumber]))
    end
  Else Error(Format('GetVersionExW selhalo. Chyba %s', [SysErrorMessage(GetLastError)]));  end;
end;

Function EventTypeToStr(EventType:DWORD):WideString;
{
  Prevadi ciselny typ udalosti na retezec. Pro
  0 - notifikacni udalost
  1 - synchronizacni udalost
  * - neplatny typ udalosti
}
begin
Result := '<neznamy>';
Case EventType Of
  0 : Result := 'Notifikacni';
  1 : Result := 'Synchronizacni'
  end;
end;




Function TranslatePath(Path:WideString) : WideString;
{
  Prelozi cestu do srozumitelnejsi podoby. Rutina nahradi nazvy nekterych
  znamych symbolickych odkazu jejich cilovymi cestami.
}
begin
If Copy(Path, 1, Length('\??\')) = '\??\' Then
  Delete(Path, 1, Length('\??\'));

If Copy(Path, 1, Length('\SystemRoot')) = '\SystemRoot' Then
  begin
  Delete(Path, 1, Length('\SystemRoot'));
  Path := GetWinDir + Path;
  end
Else If Copy(Path, 1, Length('\WINDOWS')) = '\WINDOWS' Then
  begin
  Delete(Path, 1, Length('\WINDOWS'));
  Path := GetWinDir + Path;
  end
Else If Copy(Path, 1, Length('\WINNT')) = '\WINNT' Then
  begin
  Delete(Path, 1, Length('\WINNT'));
  Path := GetWinDir + Path;
  end;

Result := WideLowerCase(Path);
end;

Function LastErrorStr:WideString;
{
  Vrati retezec obsahujici text posledni chybove zpravy
}
begin
Result := SysErrorMessage(GetLastError);
end;


Function GetDriverList(Var Names:TNameList; Var Addresses:TPointerList; Var Sizes:TIntegerList):Boolean;
{
  Zjisti seznam aktualne bezicich ovladacu. O kazdem z nich zjisti virtualni
  adresu, velikost a jmeno
}
Var
 smi : PSYSTEM_MODULE_INFORMATION;
 sm : SYSTEM_MODULE;
 Status : NTSTATUS;
 Size : Cardinal;
 Returned : Cardinal;
 I : Integer;
begin
Names := Nil;
Addresses := Nil;
Sizes := Nil;
Size := 32768;
Status := STATUS_INFO_LENGTH_MISMATCH;
Result := False;
smi := Nil;
While Status = STATUS_INFO_LENGTH_MISMATCH Do
  begin
  If Assigned(smi) Then
    MemFree(smi);

  Size := Size * 2;
  smi := MemAlloc(Size);
  if Assigned(smi) Then
    Status := NtQuerySystemInformation(SystemModuleInformation, smi, Size, Returned)
  Else Status := STATUS_NO_MEMORY;
  end;

Result := Status = STATUS_SUCCESS;
If Result Then
  begin
  SetLength(Names, smi.ModuleCount);
  SetLength(Addresses, smi.ModuleCount);
  SetLength(Sizes, smi.ModuleCount);
  For I := 0 To smi.ModuleCount - 1 Do
    begin
    sm := smi.Module[I];
    Addresses[I] := sm.ImageBaseAddress;
    Sizes[I] := sm.ImageSize;
    Names[I] := TranslatePath(Copy(WideString(PAnsiChar(@sm.Name)), 1, Length(WideString(PAnsiChar(@sm.Name)))));
    end;
  end;

if Assigned(smi) Then
  MemFree(smi);
end;


Function GetAddressOwner(Addresses:TPointerList; Sizes:TIntegerList; Address:Pointer):Integer;
{
  Zjisti index modulu, kteremu patri dana adresa
}
Var
  I : Integer;
begin
Result := -1;
For I := 0 To High(Addresses) Do
  begin
  If (Cardinal(Addresses[I]) <= Cardinal(Address)) And
     (Cardinal(Addresses[I]) + Sizes[I] >= Cardinal(Address)) Then
    begin
    Result := I;
    Break;
    end;
  end;
end;



Function AddressToModuleName(Address:Pointer; Names:TNameList; Addresses:TPointerList; Sizes:TIntegerList):WideString;
{
  Prevede adresu na nazev modulu, kteremu patri.
}
Var
  idx : Integer;
begin
if Assigned(Address) Then
  begin
  If Assigned(Names) Then
    begin
    idx := GetAddressOwner(Addresses, Sizes, Address);
    if idx <> -1 then
      Result := Format('%p (%s)', [Address, Names[idx]])
    Else Result := Format('%p (nepatri zadnemu modulu)', [Address]);
    end Else Result := Format('%p (chyba)', [Address]);
  end Else Result := Format('%p', [Address]);
end;



Function GetWinDir:WideString;
{
  Vrati absolutni nazev korenoveho adresare instalace Windows
  (obvykle X:\Windows)
}
Var
  Buffer : PWideChar;
  Size : Cardinal;
begin
Result := '';
Size := MAX_PATH * SizeOf(WideChar);
Buffer := MemAlloc(Size);
if Assigned(Buffer) Then
  begin
  ZeroMemory(Buffer, Size);
  Size := GetWindowsDirectoryW(Buffer, Size);
  If Size > 0 Then
    Result := Copy(WideString(Buffer), 1, Length(WideString(Buffer)));

  MemFree(Buffer);
  Result := WideLowerCase(Result);
  end;
end;



Function GetSysDir:WideString;
{
  Vrati absolutni nazev systemoveho adresare (obvykle X:\Windows\system32)
}
Var
  Buffer : PWideChar;
  Size : Cardinal;
begin
Result := '';
Size := MAX_PATH * SizeOf(WideChar);
Buffer := MemAlloc(Size);
If Assigned(Buffer) Then
  begin
  ZeroMemory(Buffer, Size);
  Size := GetSystemDirectoryW(Buffer, Size);
  If Size > 0 Then
    Result := Copy(WideString(Buffer), 1, Length(WideString(Buffer)));

  MemFree(Buffer);
  Result := WideLowerCase(Result);
  end;
end;


Function MemAlloc(Size:Integer):Pointer;
{
  Pokusi se alokovat blok pameti o velikosti Size z haldy procesu.
}
begin
Result := HeapAlloc(GetProcessHeap, 0, Size);
If Assigned(Result) Then
  ZeroMemory(Result, Size);
end;


Procedure MemFree(Address:Pointer);
{
  Uvolni blok pameti zacinajici na adrese Address. Rutina jej vrati
  halde procesu.
}
begin
HeapFree(GetProcessHeap, 0, Address);
end;

Function GetProcessList(List:TList):Boolean;
{
  Zjisti seznam bezicich procesu prostrednictvim
  Tool Help Library a zapise informace o nich do
  kontejneru TList zadaneho v parametru.
}
Var
  hSnap : THandle;
  PE : ProcessEntry32W;
  InfoRecord : PProcessInfoRecord;
begin
hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
Result := hSnap > 0;
If hSnap > 0 Then
  begin
  PE.dwSize := SIzeOf(PE);
  Result := Process32First(hSnap, PE);
  If Result Then
    begin
    Repeat
    InfoRecord := MemAlloc(SizeOf(TProcessInfoRecord));
    Result := Assigned(InfoRecord);
    If Not Result Then
      Break;

    ZeroMemory(InfoRecord, SizeOf(TProcessInfoRecord));
    InfoRecord.Name := '';
    InfoRecord.Name := Copy(PE.szExeFile, 1, Length(PE.szExeFile));
    InfoRecord.PID := PE.th32ProcessID;
    InfoRecord.Priority := PE.pcPriClassBase;
    Inforecord.NumberOfThreads := PE.cntThreads;
    List.Add(InfoRecord);
    Until Not Process32Next(hSnap, PE);
    end;

  CloseHandle(hSnap);
  end;
end;


Initialization
If Not UtilsInit Then
  ExitProcess(1);
End.

