{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is JclSysInfo.pas.                                                             }
{                                                                                                  }
{ The Initial Developer of the Original Code is documented in the accompanying                     }
{ help file JCL.chm. Portions created by these individuals are Copyright (C) of these individuals. }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ This unit contains routines and classes to retrieve various pieces of system information.        }
{ Examples are the location of standard folders, settings of environment variables, processor      }
{ details and the Windows version.                                                                 }
{                                                                                                  }
{ Unit owner: Eric S. Fisher                                                                       }
{ Last modified: October 13, 2002                                                                  }
{                                                                                                  }
{**************************************************************************************************}

unit JclSysInfo;

{$I jcl.inc}

interface

uses
  Windows, ActiveX, Classes, ShlObj,
  JclResources;

//--------------------------------------------------------------------------------------------------
// Environment Variables
//--------------------------------------------------------------------------------------------------

type
  TEnvironmentOption = (eoLocalMachine, eoCurrentUser, eoAdditional);

  TEnvironmentOptions = set of TEnvironmentOption;

function DelEnvironmentVar(const Name: string): Boolean;
function ExpandEnvironmentVar(var Value: string): Boolean;
function GetEnvironmentVar(const Name: string; var Value: string; Expand: Boolean): Boolean;
function GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean;
function SetEnvironmentVar(const Name, Value: string): Boolean;
function CreateEnvironmentBlock(const Options: TEnvironmentOptions; const AdditionalVars: TStrings): PChar;

//--------------------------------------------------------------------------------------------------
// Common Folder Locations
//--------------------------------------------------------------------------------------------------

function GetCommonFilesFolder: string;
function GetCurrentFolder: string;
function GetProgramFilesFolder: string;
function GetWindowsFolder: string;
function GetWindowsSystemFolder: string;
function GetWindowsTempFolder: string;

function GetDesktopFolder: string;
function GetProgramsFolder: string;
function GetPersonalFolder: string;
function GetFavoritesFolder: string;
function GetStartupFolder: string;
function GetRecentFolder: string;
function GetSendToFolder: string;
function GetStartmenuFolder: string;
function GetDesktopDirectoryFolder: string;
function GetNethoodFolder: string;
function GetFontsFolder: string;
function GetCommonStartmenuFolder: string;
function GetCommonProgramsFolder: string;
function GetCommonStartupFolder: string;
function GetCommonDesktopdirectoryFolder: string;
function GetCommonAppdataFolder: string;
function GetAppdataFolder: string;
function GetPrinthoodFolder: string;
function GetCommonFavoritesFolder: string;
function GetTemplatesFolder: string;
function GetInternetCacheFolder: string;
function GetCookiesFolder: string;
function GetHistoryFolder: string;

//--------------------------------------------------------------------------------------------------
// Advanced Power Management (APM)
//--------------------------------------------------------------------------------------------------

type
  TAPMLineStatus = (alsOffline, alsOnline, alsUnknown);
  TAPMBatteryFlag = (abfHigh, abfLow, abfCritical, abfCharging, abfNoBattery, abfUnknown);

function GetAPMLineStatus: TAPMLineStatus;
function GetAPMBatteryFlag: TAPMBatteryFlag;
function GetAPMBatteryLifePercent: Integer;
function GetAPMBatteryLifeTime: DWORD;
function GetAPMBatteryFullLifeTime: DWORD;

//--------------------------------------------------------------------------------------------------
// Identification
//--------------------------------------------------------------------------------------------------

function GetVolumeName(const Drive: string): string;
function GetVolumeSerialNumber(const Drive: string): string;
function GetVolumeFileSystem(const Drive: string): string;
function GetIPAddress(const HostName: string): string;
function GetLocalComputerName: string;
function GetLocalUserName: string;
function GetUserDomainName(const CurUser: string): string;
function GetDomainName: string;
function GetRegisteredCompany: string;
function GetRegisteredOwner: string;

function GetBIOSName: string;
function GetBIOSCopyright: string;
function GetBIOSExtendedInfo: string;
function GetBIOSDate: TDateTime;

//--------------------------------------------------------------------------------------------------
// Processes, Tasks and Modules
//--------------------------------------------------------------------------------------------------

type
  TJclTerminateAppResult = (taError, taClean, taKill);

function RunningProcessesList(const List: TStrings; FullPath: Boolean = True): Boolean;
function LoadedModulesList(const List: TStrings; ProcessID: DWORD; HandlesOnly: Boolean = False): Boolean;
function GetTasksList(const List: TStrings): Boolean;

function ModuleFromAddr(const Addr: Pointer): HMODULE;
function IsSystemModule(const Module: HMODULE): Boolean;

function IsMainAppWindow(Wnd: HWND): Boolean;
function IsWindowResponding(Wnd: HWND; Timeout: Integer): Boolean;

function GetWindowIcon(Wnd: HWND; LargeIcon: Boolean): HICON;
function GetWindowCaption(Wnd: HWND): string;

function TerminateTask(Wnd: HWND; Timeout: Integer): TJclTerminateAppResult;
function TerminateApp(ProcessID: DWORD; Timeout: Integer): TJclTerminateAppResult;

function GetPidFromProcessName(const ProcessName: string): DWORD;
function GetProcessNameFromWnd(Wnd: HWND): string;
function GetProcessNameFromPid(PID: DWORD): string;
function GetMainAppWndFromPid(PID: DWORD): HWND;

function GetShellProcessName: string;
function GetShellProcessHandle: THandle;

//--------------------------------------------------------------------------------------------------
// Version Information
//--------------------------------------------------------------------------------------------------

// TODOC Added wvWinNT351, wvWinNT35, IsWinNT351 and changed wvWinNT3 to wvWinNT31

type
  TWindowsVersion = (wvUnknown, wvWin95, wvWin95OSR2, wvWin98, wvWin98SE,
                     wvWinME, wvWinNT31, wvWinNT35, wvWinNT351, wvWinNT4, wvWin2000, wvWinXP);
  TNtProductType = (ptUnknown, ptWorkStation, ptServer, ptAdvancedServer,
                    ptPersonal, ptProfessional, ptDatacenterServer);
                    
{ TODOC

  Added to TNtProductType (by Jean-Fabien Connault):

  ptPersonal          Windows XP Personal
  ptProfessional      Windows 2000/XP Proffesional
  ptDatacenterServer  Windows 2000 DataCenter server
}

var
  { in case of additions, don't forget to update initialization section! }

  IsWin95: Boolean = False;
  IsWin95OSR2: Boolean = False;
  IsWin98: Boolean = False;
  IsWin98SE: Boolean = False;
  IsWinME: Boolean = False;
  IsWinNT: Boolean = False;
  IsWinNT3: Boolean = False;
  IsWinNT31: Boolean = False;
  IsWinNT35: Boolean = False;
  IsWinNT351: Boolean = False;
  IsWinNT4: Boolean = False;
  IsWin2K: Boolean = False;
  IsWinXP: Boolean = False;

function GetWindowsVersion: TWindowsVersion;
function NtProductType: TNtProductType;

// TODOC

function GetWindowsVersionString: string;
{
ShortDescr: Returns the windows version as a string.
Descr: GetWindowsVersion returns the operating system as a string. For example, 'Windows 2000'.
Result: The windows version as a string or an empty string if the OS is not recognized.
Author: Jean-Fabien Connault
}

function NtProductTypeString: string;
{
ShortDescr: Returns the Windows NT product type as a string.
Descr: NtProductTypeString returns the NT product type as a string. For example 'Workstation'.
Result: The NT product type as a string or an empty string if the product type is not recognized.
Author: Jean-Fabien Connault
}
function GetWindowsServicePackVersion: Integer;
{
ShortDescr: Returns the installed service pack
Descr: Returns the major version number of the latest installed Windows Service Pack.
Result: The major version number of the latest installed Service Pack. In case of failure, or it
        no Service Pack is installed, the function returns 0.
Author: Jean-Fabien Connault
}

function GetWindowsServicePackVersionString: string;
{
ShortDescr: Returns the installed service pack as a string
Descr: Returns the major version number of the latest installed Windows Service Pack.
Result: The major version number of the latest installed Service Pack. In case of failure, or if
        no Service Pack is installed, the function returns an empty string.
Author: Jean-Fabien Connault
}

//--------------------------------------------------------------------------------------------------
// Hardware
//--------------------------------------------------------------------------------------------------

function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer;

function ReadTimeStampCounter: Int64;

type
  TIntelSpecific = record
    L2Cache: Cardinal;
    CacheDescriptors: array [0..15] of Byte;
    BrandID : Byte;
  end;

  TCyrixSpecific = record
    L1CacheInfo: array [0..3] of Byte;
    TLBInfo: array [0..3] of Byte;
  end;

  TAMDSpecific = record
    DataTLB: array [0..1] of Byte;
    InstructionTLB: array [0..1] of Byte;
    L1DataCache: array [0..3] of Byte;
    L1ICache: array [0..3] of Byte;
  end;

  TCacheInfo = record
    D: Byte;
    I: string;
  end;

  TFreqInfo = record
    RawFreq: Cardinal;
    NormFreq: Cardinal;
    InCycles: Cardinal;
    ExTicks: Cardinal;
  end;

  TCpuInfo = record
    HasInstruction: Boolean;
    MMX: Boolean;
    IsFDIVOK: Boolean;
    HasCacheInfo: Boolean;
    HasExtendedInfo: Boolean;
    CpuType: Byte;
    PType: Byte;
    Family: Byte;
    Model: Byte;
    Stepping: Byte;
    Features: Cardinal;
    FrequencyInfo: TFreqInfo;
    VendorIDString: array [0..11] of Char;
    Manufacturer: array [0..9] of Char;
    CpuName: array [0..47] of Char;
    IntelSpecific: TIntelSpecific;
    CyrixSpecific: TCyrixSpecific;
    AMDSpecific: TAMDSpecific;
  end;

const
  CPU_TYPE_INTEL  = 1;
  CPU_TYPE_CYRIX  = 2;
  CPU_TYPE_AMD    = 3;
  CPU_TYPE_CRUSOE = 4;

// Constants to be used with Feature Flag set of a CPU
// eg. IF (Features and FPU_FLAG = FPU_FLAG) THEN CPU has Floating-Point unit on
// chip. However, Intel claims that in future models, a zero in the feature
// flags will mean that the chip has that feature, however, the following flags
// will work for any production 80x86 chip or clone.
// eg. IF (Features and FPU_FLAG = 0) then CPU has Floating-Point unit on chip.

const

{ Standard (Intel) Feature Flags }

  FPU_FLAG   = $00000001; // Floating-Point unit on chip
  VME_FLAG   = $00000002; // Virtual Mode Extention
  DE_FLAG    = $00000004; // Debugging Extention
  PSE_FLAG   = $00000008; // Page Size Extention
  TSC_FLAG   = $00000010; // Time Stamp Counter
  MSR_FLAG   = $00000020; // Model Specific Registers
  PAE_FLAG   = $00000040; // Physical Address Extention
  MCE_FLAG   = $00000080; // Machine Check Exception
  CX8_FLAG   = $00000100; // CMPXCHG8 Instruction
  APIC_FLAG  = $00000200; // Software-accessible local APIC on Chip
  BIT_10     = $00000400; // Reserved, do not count on value
  SEP_FLAG   = $00000800; // Fast System Call
  MTRR_FLAG  = $00001000; // Memory Type Range Registers
  PGE_FLAG   = $00002000; // Page Global Enable
  MCA_FLAG   = $00004000; // Machine Check Architecture
  CMOV_FLAG  = $00008000; // Conditional Move Instruction
  PAT_FLAG   = $00010000; // Page Attribute Table
  PSE36_FLAG = $00020000; // 36-bit Page Size Extention
  BIT_18     = $00040000; // Reserved, do not count on value
  BIT_19     = $00080000; // Reserved, do not count on value
  BIT_20     = $00100000; // Reserved, do not count on value
  BIT_21     = $00200000; // Reserved, do not count on value
  BIT_22     = $00400000; // Reserved, do not count on value
  MMX_FLAG   = $00800000; // MMX technology
  FXSR_FLAG  = $01000000; // Fast Floating Point Save and Restore
  BIT_25     = $02000000; // Reserved, do not count on value
  BIT_26     = $04000000; // Reserved, do not count on value
  BIT_27     = $08000000; // Reserved, do not count on value
  BIT_28     = $10000000; // Reserved, do not count on value
  BIT_29     = $20000000; // Reserved, do not count on value
  BIT_30     = $40000000; // Reserved, do not count on value
  BIT_31     = DWORD($80000000); // Reserved, do not count on value

{ AMD Standard Feature Flags }

  AMD_FPU_FLAG   = $00000001; // Floating-Point unit on chip
  AMD_VME_FLAG   = $00000002; // Virtual Mode Extention
  AMD_DE_FLAG    = $00000004; // Debugging Extention
  AMD_PSE_FLAG   = $00000008; // Page Size Extention
  AMD_TSC_FLAG   = $00000010; // Time Stamp Counter
  AMD_MSR_FLAG   = $00000020; // Model Specific Registers
  AMD_BIT_6      = $00000040; // Reserved, do not count on value
  AMD_MCE_FLAG   = $00000080; // Machine Check Exception
  AMD_CX8_FLAG   = $00000100; // CMPXCHG8 Instruction
  AMD_APIC_FLAG  = $00000200; // Software-accessible local APIC on Chip
  AMD_BIT_10     = $00000400; // Reserved, do not count on value
  AMD_BIT_11     = $00000800; // Reserved, do not count on value
  AMD_MTRR_FLAG  = $00001000; // Memory Type Range Registers
  AMD_PGE_FLAG   = $00002000; // Page Global Enable
  AMD_BIT_14     = $00004000; // Reserved, do not count on value
  AMD_CMOV_FLAG  = $00008000; // Conditional Move Instruction
  AMD_BIT_16     = $00010000; // Reserved, do not count on value
  AMD_BIT_17     = $00020000; // Reserved, do not count on value
  AMD_BIT_18     = $00040000; // Reserved, do not count on value
  AMD_BIT_19     = $00080000; // Reserved, do not count on value
  AMD_BIT_20     = $00100000; // Reserved, do not count on value
  AMD_BIT_21     = $00200000; // Reserved, do not count on value
  AMD_BIT_22     = $00400000; // Reserved, do not count on value
  AMD_MMX_FLAG   = $00800000; // MMX technology
  AMD_BIT_24     = $01000000; // Reserved, do not count on value
  AMD_BIT_25     = $02000000; // Reserved, do not count on value
  AMD_BIT_26     = $04000000; // Reserved, do not count on value
  AMD_BIT_27     = $08000000; // Reserved, do not count on value
  AMD_BIT_28     = $10000000; // Reserved, do not count on value
  AMD_BIT_29     = $20000000; // Reserved, do not count on value
  AMD_BIT_30     = $40000000; // Reserved, do not count on value
  AMD_BIT_31     = DWORD($80000000); // Reserved, do not count on value

{ AMD Enhanced Feature Flags }

  EAMD_FPU_FLAG   = $00000001; // Floating-Point unit on chip
  EAMD_VME_FLAG   = $00000002; // Virtual Mode Extention
  EAMD_DE_FLAG    = $00000004; // Debugging Extention
  EAMD_PSE_FLAG   = $00000008; // Page Size Extention
  EAMD_TSC_FLAG   = $00000010; // Time Stamp Counter
  EAMD_MSR_FLAG   = $00000020; // Model Specific Registers
  EAMD_BIT_6      = $00000040; // Reserved, do not count on value
  EAMD_MCE_FLAG   = $00000080; // Machine Check Exception
  EAMD_CX8_FLAG   = $00000100; // CMPXCHG8 Instruction
  EAMD_BIT_9      = $00000200; // Reserved, do not count on value
  EAMD_BIT_10     = $00000400; // Reserved, do not count on value
  EAMD_SEP_FLAG   = $00000800; // Fast System Call
  EAMD_BIT_12     = $00001000; // Reserved, do not count on value
  EAMD_PGE_FLAG   = $00002000; // Page Global Enable
  EAMD_BIT_14     = $00004000; // Reserved, do not count on value
  EAMD_ICMOV_FLAG = $00008000; // Integer Conditional Move Instruction
  EAMD_FCMOV_FLAG = $00010000; // Floating Point Conditional Move Instruction
  EAMD_BIT_17     = $00020000; // Reserved, do not count on value
  EAMD_BIT_18     = $00040000; // Reserved, do not count on value
  EAMD_BIT_19     = $00080000; // Reserved, do not count on value
  EAMD_BIT_20     = $00100000; // Reserved, do not count on value
  EAMD_BIT_21     = $00200000; // Reserved, do not count on value
  EAMD_BIT_22     = $00400000; // Reserved, do not count on value
  EAMD_MMX_FLAG   = $00800000; // MMX technology
  EAMD_BIT_24     = $01000000; // Reserved, do not count on value
  EAMD_BIT_25     = $02000000; // Reserved, do not count on value
  EAMD_BIT_26     = $04000000; // Reserved, do not count on value
  EAMD_BIT_27     = $08000000; // Reserved, do not count on value
  EAMD_BIT_28     = $10000000; // Reserved, do not count on value
  EAMD_BIT_29     = $20000000; // Reserved, do not count on value
  EAMD_BIT_30     = $40000000; // Reserved, do not count on value
  EAMD_3DNOW_FLAG = DWORD($80000000); // AMD 3DNOW! Technology

{ Cyrix Standard Feature Flags }

  CYRIX_FPU_FLAG   = $00000001; // Floating-Point unit on chip
  CYRIX_VME_FLAG   = $00000002; // Virtual Mode Extention
  CYRIX_DE_FLAG    = $00000004; // Debugging Extention
  CYRIX_PSE_FLAG   = $00000008; // Page Size Extention
  CYRIX_TSC_FLAG   = $00000010; // Time Stamp Counter
  CYRIX_MSR_FLAG   = $00000020; // Model Specific Registers
  CYRIX_PAE_FLAG   = $00000040; // Physical Address Extention
  CYRIX_MCE_FLAG   = $00000080; // Machine Check Exception
  CYRIX_CX8_FLAG   = $00000100; // CMPXCHG8 Instruction
  CYRIX_APIC_FLAG  = $00000200; // Software-accessible local APIC on Chip
  CYRIX_BIT_10     = $00000400; // Reserved, do not count on value
  CYRIX_BIT_11     = $00000800; // Reserved, do not count on value
  CYRIX_MTRR_FLAG  = $00001000; // Memory Type Range Registers
  CYRIX_PGE_FLAG   = $00002000; // Page Global Enable
  CYRIX_MCA_FLAG   = $00004000; // Machine Check Architecture
  CYRIX_CMOV_FLAG  = $00008000; // Conditional Move Instruction
  CYRIX_BIT_16     = $00010000; // Reserved, do not count on value
  CYRIX_BIT_17     = $00020000; // Reserved, do not count on value
  CYRIX_BIT_18     = $00040000; // Reserved, do not count on value
  CYRIX_BIT_19     = $00080000; // Reserved, do not count on value
  CYRIX_BIT_20     = $00100000; // Reserved, do not count on value
  CYRIX_BIT_21     = $00200000; // Reserved, do not count on value
  CYRIX_BIT_22     = $00400000; // Reserved, do not count on value
  CYRIX_MMX_FLAG   = $00800000; // MMX technology
  CYRIX_BIT_24     = $01000000; // Reserved, do not count on value
  CYRIX_BIT_25     = $02000000; // Reserved, do not count on value
  CYRIX_BIT_26     = $04000000; // Reserved, do not count on value
  CYRIX_BIT_27     = $08000000; // Reserved, do not count on value
  CYRIX_BIT_28     = $10000000; // Reserved, do not count on value
  CYRIX_BIT_29     = $20000000; // Reserved, do not count on value
  CYRIX_BIT_30     = $40000000; // Reserved, do not count on value
  CYRIX_BIT_31     = DWORD($80000000); // Reserved, do not count on value

{ Cyrix Enhanced Feature Flags }

  ECYRIX_FPU_FLAG   = $00000001; // Floating-Point unit on chip
  ECYRIX_VME_FLAG   = $00000002; // Virtual Mode Extention
  ECYRIX_DE_FLAG    = $00000004; // Debugging Extention
  ECYRIX_PSE_FLAG   = $00000008; // Page Size Extention
  ECYRIX_TSC_FLAG   = $00000010; // Time Stamp Counter
  ECYRIX_MSR_FLAG   = $00000020; // Model Specific Registers
  ECYRIX_PAE_FLAG   = $00000040; // Physical Address Extention
  ECYRIX_MCE_FLAG   = $00000080; // Machine Check Exception
  ECYRIX_CX8_FLAG   = $00000100; // CMPXCHG8 Instruction
  ECYRIX_APIC_FLAG  = $00000200; // Software-accessible local APIC on Chip
  ECYRIX_SEP_FLAG   = $00000400; // Fast System Call
  ECYRIX_BIT_11     = $00000800; // Reserved, do not count on value
  ECYRIX_MTRR_FLAG  = $00001000; // Memory Type Range Registers
  ECYRIX_PGE_FLAG   = $00002000; // Page Global Enable
  ECYRIX_MCA_FLAG   = $00004000; // Machine Check Architecture
  ECYRIX_ICMOV_FLAG = $00008000; // Integer Conditional Move Instruction
  ECYRIX_FCMOV_FLAG = $00010000; // Floating Point Conditional Move Instruction
  ECYRIX_BIT_17     = $00020000; // Reserved, do not count on value
  ECYRIX_BIT_18     = $00040000; // Reserved, do not count on value
  ECYRIX_BIT_19     = $00080000; // Reserved, do not count on value
  ECYRIX_BIT_20     = $00100000; // Reserved, do not count on value
  ECYRIX_BIT_21     = $00200000; // Reserved, do not count on value
  ECYRIX_BIT_22     = $00400000; // Reserved, do not count on value
  ECYRIX_MMX_FLAG   = $00800000; // MMX technology
  ECYRIX_EMMX_FLAG  = $01000000; // Extended MMX Technology
  ECYRIX_BIT_25     = $02000000; // Reserved, do not count on value
  ECYRIX_BIT_26     = $04000000; // Reserved, do not count on value
  ECYRIX_BIT_27     = $08000000; // Reserved, do not count on value
  ECYRIX_BIT_28     = $10000000; // Reserved, do not count on value
  ECYRIX_BIT_29     = $20000000; // Reserved, do not count on value
  ECYRIX_BIT_30     = $40000000; // Reserved, do not count on value
  ECYRIX_BIT_31     = DWORD($80000000); // Reserved, do not count on value

const
  IntelCacheDescription: array [0..13] of TCacheInfo = (
    (D: $01; I: RsIntelCacheDescr01),
    (D: $02; I: RsIntelCacheDescr02),
    (D: $03; I: RsIntelCacheDescr03),
    (D: $04; I: RsIntelCacheDescr04),
    (D: $06; I: RsIntelCacheDescr06),
    (D: $08; I: RsIntelCacheDescr08),
    (D: $0A; I: RsIntelCacheDescr0A),
    (D: $0C; I: RsIntelCacheDescr0C),
    (D: $40; I: RsIntelCacheDescr40),
    (D: $41; I: RsIntelCacheDescr41),
    (D: $42; I: RsIntelCacheDescr42),
    (D: $43; I: RsIntelCacheDescr43),
    (D: $44; I: RsIntelCacheDescr44),
    (D: $45; I: RsIntelCacheDescr45));

procedure GetCpuInfo(var CpuInfo: TCpuInfo);

function GetIntelCacheDescription(const D: Byte): string;
function RoundFrequency(const Frequency: Integer): Integer;
function GetCPUSpeed(var CpuSpeed: TFreqInfo): Boolean;
function CPUID: TCpuInfo;
function TestFDIVInstruction: Boolean;

//--------------------------------------------------------------------------------------------------
// Memory Information
//--------------------------------------------------------------------------------------------------

function GetMaxAppAddress: Integer;
function GetMinAppAddress: Integer;
function GetMemoryLoad: Byte;
function GetSwapFileSize: Integer;
function GetSwapFileUsage: Integer;
function GetTotalPhysicalMemory: Integer;
function GetFreePhysicalMemory: Integer;
function GetTotalPageFileMemory: Integer;
function GetFreePageFileMemory: Integer;
function GetTotalVirtualMemory: Integer;
function GetFreeVirtualMemory: Integer;

//--------------------------------------------------------------------------------------------------
// Alloc granularity
//--------------------------------------------------------------------------------------------------

procedure RoundToAllocGranularity64(var Value: Int64; Up: Boolean);
procedure RoundToAllocGranularityPtr(var Value: Pointer; Up: Boolean);

//--------------------------------------------------------------------------------------------------
// Keyboard Information
//--------------------------------------------------------------------------------------------------

function GetKeyState(const VirtualKey: Cardinal): Boolean;
function GetNumLockKeyState: Boolean;
function GetScrollLockKeyState: Boolean;
function GetCapsLockKeyState: Boolean;

//--------------------------------------------------------------------------------------------------
// Windows 95/98/Me system resources information
//--------------------------------------------------------------------------------------------------

type
  TFreeSysResKind = (rtSystem, rtGdi, rtUser);
  TFreeSystemResources = record
    SystemRes, GdiRes, UserRes: Integer;
  end;

function IsSystemResourcesMeterPresent: Boolean;

function GetFreeSystemResources(const ResourceType: TFreeSysResKind): Integer; overload;
function GetFreeSystemResources: TFreeSystemResources; overload;

//--------------------------------------------------------------------------------------------------
// Public global variables
//--------------------------------------------------------------------------------------------------

var
  ProcessorCount: Cardinal = 0;
  AllocGranularity: Cardinal = 0;
  PageSize: Cardinal = 0;

implementation

uses
  Messages, SysUtils, TLHelp32, PsApi, Winsock, Snmp,
  {$IFNDEF DELPHI5_UP}
  JclSysUtils,
  {$ENDIF DELPHI5_UP}
  JclBase, JclFileUtils, JclIniFiles, JclRegistry, JclShell, JclStrings, JclWin32;

//==================================================================================================
// Environment
//==================================================================================================

function DelEnvironmentVar(const Name: string): Boolean;
begin
  Result := SetEnvironmentVariable(PChar(Name), nil);
end;

//--------------------------------------------------------------------------------------------------

function ExpandEnvironmentVar(var Value: string): Boolean;
var
  R: Integer;
  Expanded: string;
begin
  SetLength(Expanded, 1);
  R := ExpandEnvironmentStrings(PChar(Value), PChar(Expanded), 0);
  SetLength(Expanded, R);
  Result := ExpandEnvironmentStrings(PChar(Value), PChar(Expanded), R) <> 0;
  if Result then
  begin
    StrResetLength(Expanded);
    Value := Expanded;
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetEnvironmentVar(const Name: string; var Value: string; Expand: Boolean): Boolean;
var
  R: DWORD;
begin
  R := GetEnvironmentVariable(PChar(Name), nil, 0);
  SetLength(Value, R);
  R := GetEnvironmentVariable(PChar(Name), PChar(Value), R);
  Result := R <> 0;
  if not Result then
    Value := ''
  else
  begin
    SetLength(Value, R);
    if Expand then
      ExpandEnvironmentVar(Value);
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean;
var
  Raw: PChar;
  Expanded: string;
  I: Integer;
begin
  Vars.Clear;
  Raw := GetEnvironmentStrings;
  try
    MultiSzToStrings(Vars, Raw);
    Result := True;
  finally
    FreeEnvironmentStrings(Raw);
  end;
  if Expand then
  begin
    for I := 0 to Vars.Count - 1 do
    begin
      Expanded := Vars[I];
      if ExpandEnvironmentVar(Expanded) then
        Vars[I] := Expanded;
    end;
  end;
end;

//--------------------------------------------------------------------------------------------------

function SetEnvironmentVar(const Name, Value: string): Boolean;
begin
  Result := SetEnvironmentVariable(PChar(Name), PChar(Value));
end;

//--------------------------------------------------------------------------------------------------

function CreateEnvironmentBlock(const Options: TEnvironmentOptions; const AdditionalVars: TStrings): PChar;
const
  RegLocalEnvironment = 'SYSTEM\CurrentControlSet\Control\Session Manager\Environment';
  RegUserEnvironment = '\Environment\';
var
  KeyNames, TempList: TStrings;
  Temp, Name, Value: string;
  I: Integer;
begin
  TempList := TStringList.Create;
  try
    // add additional environment variables
    if eoAdditional in Options then
      for I := 0 to AdditionalVars.Count - 1 do
      begin
        Temp := AdditionalVars[I];
        ExpandEnvironmentVar(Temp);
        TempList.Add(Temp);
      end;
    // get environment strings from local machine
    if eoLocalMachine in Options then
    begin
      KeyNames := TStringList.Create;
      try
        if RegGetValueNames(HKEY_LOCAL_MACHINE, RegLocalEnvironment, KeyNames) then
        begin
          for I := 0 to KeyNames.Count - 1 do
          begin
            Name := KeyNames[I];
            Value := RegReadString(HKEY_LOCAL_MACHINE, RegLocalEnvironment, Name);
            ExpandEnvironmentVar(Value);
            TempList.Add(Name + '=' + Value);
          end;
        end;
      finally
        FreeAndNil(KeyNames);
      end;
    end;
    // get environment strings from current user
    if eoCurrentUser in Options then
    begin
      KeyNames := TStringLIst.Create;
      try
        if RegGetValueNames(HKEY_CURRENT_USER, RegUserEnvironment, KeyNames) then
        begin
          for I := 0 to KeyNames.Count - 1 do
          begin
            Name := KeyNames[I];
            Value := RegReadString(HKEY_CURRENT_USER, RegUserEnvironment, Name);
            ExpandEnvironmentVar(Value);
            TempList.Add(Name + '=' + Value);
          end;
        end;
      finally
        KeyNames.Free;
      end;
    end;
    // transform stringlist into multi-PChar
    StringsToMultiSz(Result, TempList);
  finally
    FreeAndNil(TempList);
  end;
end;

//==================================================================================================
// Common Folders
//==================================================================================================

// Utility function which returns the Windows independent CurrentVersion key
// inside HKEY_LOCAL_MACHINE

const
  HKLM_CURRENT_VERSION_WINDOWS = 'Software\Microsoft\Windows\CurrentVersion';
  HKLM_CURRENT_VERSION_NT      = 'Software\Microsoft\Windows NT\CurrentVersion';

function REG_CURRENT_VERSION: string;
begin
  if IsWinNT then
    Result := HKLM_CURRENT_VERSION_NT
  else
    Result := HKLM_CURRENT_VERSION_WINDOWS;
end;

//--------------------------------------------------------------------------------------------------

function GetCommonFilesFolder: string;
begin
  Result := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS,
    'CommonFilesDir', '');
end;

//--------------------------------------------------------------------------------------------------

function GetCurrentFolder: string;
var
  Required: Cardinal;
begin
  Result := '';
  Required := GetCurrentDirectory(0, nil);
  if Required <> 0 then
  begin
    SetLength(Result, Required);
    GetCurrentDirectory(Required, PChar(Result));
    StrResetLength(Result);
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetProgramFilesFolder: string;
begin
  Result := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS, 'ProgramFilesDir', '');
end;

//--------------------------------------------------------------------------------------------------

function GetWindowsFolder: string;
var
  Required: Cardinal;
begin
  Result := '';
  Required := GetWindowsDirectory(nil, 0);
  if Required <> 0 then
  begin
    SetLength(Result, Required);
    GetWindowsDirectory(PChar(Result), Required);
    StrResetLength(Result);
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetWindowsSystemFolder: string;
var
  Required: Cardinal;
begin
  Result := '';
  Required := GetSystemDirectory(nil, 0);
  if Required <> 0 then
  begin
    SetLength(Result, Required);
    GetSystemDirectory(PChar(Result), Required);
    StrResetLength(Result);
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetWindowsTempFolder: string;
var
  Required: Cardinal;
begin
  Result := '';
  Required := GetTempPath(0, nil);
  if Required <> 0 then
  begin
    SetLength(Result, Required);
    GetTempPath(Required, PChar(Result));
    StrResetLength(Result);
    Result := PathRemoveSeparator(Result);
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetDesktopFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_DESKTOP);
end;

//--------------------------------------------------------------------------------------------------

function GetProgramsFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_PROGRAMS);
end;

//--------------------------------------------------------------------------------------------------

function GetPersonalFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_PERSONAL);
end;

//--------------------------------------------------------------------------------------------------

function GetFavoritesFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_FAVORITES);
end;

//--------------------------------------------------------------------------------------------------

function GetStartupFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_STARTUP);
end;

//--------------------------------------------------------------------------------------------------

function GetRecentFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_RECENT);
end;

//--------------------------------------------------------------------------------------------------

function GetSendToFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_SENDTO);
end;

//--------------------------------------------------------------------------------------------------

function GetStartmenuFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_STARTMENU);
end;

//--------------------------------------------------------------------------------------------------

function GetDesktopDirectoryFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_DESKTOPDIRECTORY);
end;

//--------------------------------------------------------------------------------------------------

function GetNethoodFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_NETHOOD);
end;

//--------------------------------------------------------------------------------------------------

function GetFontsFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_FONTS);
end;

//--------------------------------------------------------------------------------------------------

function GetCommonStartmenuFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_COMMON_STARTMENU);
end;

//--------------------------------------------------------------------------------------------------

function GetCommonProgramsFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_COMMON_PROGRAMS);
end;

//--------------------------------------------------------------------------------------------------

function GetCommonStartupFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_COMMON_STARTUP);
end;

//--------------------------------------------------------------------------------------------------

function GetCommonDesktopdirectoryFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_COMMON_DESKTOPDIRECTORY);
end;

//--------------------------------------------------------------------------------------------------

// TODOC
// From: Jean-Fabien Connault
// Descr: Application data for all users. A typical path is C:\Documents and Settings\All Users\Application Data.
// Note: requires shell v 5.00 up

function GetCommonAppdataFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_COMMON_APPDATA);
end;

//--------------------------------------------------------------------------------------------------

function GetAppdataFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_APPDATA);
end;

//--------------------------------------------------------------------------------------------------

function GetPrinthoodFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_PRINTHOOD);
end;

//--------------------------------------------------------------------------------------------------

function GetCommonFavoritesFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_COMMON_FAVORITES);
end;

//--------------------------------------------------------------------------------------------------

function GetTemplatesFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_TEMPLATES);
end;

//--------------------------------------------------------------------------------------------------

function GetInternetCacheFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_INTERNET_CACHE);
end;

//--------------------------------------------------------------------------------------------------

function GetCookiesFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_COOKIES);
end;

//--------------------------------------------------------------------------------------------------

function GetHistoryFolder: string;
begin
  Result := GetSpecialFolderLocation(CSIDL_HISTORY);
end;

// the following special folders are pure virtual and cannot be
// mapped to a directory path:
// CSIDL_INTERNET
// CSIDL_CONTROLS
// CSIDL_PRINTERS
// CSIDL_BITBUCKET
// CSIDL_DRIVES
// CSIDL_NETWORK
// CSIDL_ALTSTARTUP
// CSIDL_COMMON_ALTSTARTUP

//==================================================================================================
// Identification
//==================================================================================================

type
  TVolumeInfoKind = (vikName, vikSerial, vikFileSystem);

function GetVolumeInfoHelper(const Drive: string; InfoKind: TVolumeInfoKind): string;
var
  VolumeSerialNumber: DWORD;
  MaximumComponentLength: DWORD;
  Flags: DWORD;
  Name: array [0..MAX_PATH] of Char;
  FileSystem: array [0..15] of Char;
  ErrorMode: Cardinal;
  DriveStr: string;
begin
  // TODO Perform better checking of Drive param or document that no checking is
  // performed. RM Suggested:
  // DriveStr := Drive;
  // if (Length(Drive) < 2) or (Drive[2] <> ':') then
  //   DriveStr := GetCurrentFolder;
  // DriveStr  := DriveStr[1] + ':\';
  Result := '';
  DriveStr := Drive + ':\';
  ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    if GetVolumeInformation(PChar(DriveStr), Name, SizeOf(Name), @VolumeSerialNumber,
      MaximumComponentLength, Flags, FileSystem, SizeOf(FileSystem)) then
    case InfoKind of
      vikName:
        Result := StrPas(Name);
      vikSerial:
        begin
          Result := IntToHex(HiWord(VolumeSerialNumber), 4) + '-' +
          IntToHex(LoWord(VolumeSerialNumber), 4);
        end;
      vikFileSystem:
        Result := StrPas(FileSystem);
    end;
  finally
    SetErrorMode(ErrorMode);
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetVolumeName(const Drive: string): string;
begin
  Result := GetVolumeInfoHelper(Drive, vikName);
end;

//--------------------------------------------------------------------------------------------------

function GetVolumeSerialNumber(const Drive: string): string;
begin
  Result := GetVolumeInfoHelper(Drive, vikSerial);
end;

//--------------------------------------------------------------------------------------------------

function GetVolumeFileSystem(const Drive: string): string;
begin
  Result := GetVolumeInfoHelper(Drive, vikFileSystem);
end;

//--------------------------------------------------------------------------------------------------

function GetIPAddress(const HostName: string): string;
var
  R: Integer;
  WSAData: TWSAData;
  HostEnt: PHostEnt;
  Host: string;
  SockAddr: TSockAddrIn;
begin
  Result := '';
  R := WSAStartup(MakeWord(1, 1), WSAData);
  if R = 0 then
  try
    Host := HostName;
    if Host = '' then
    begin
      SetLength(Host, MAX_PATH);
      GetHostName(PChar(Host), MAX_PATH);
    end;
    HostEnt := GetHostByName(PChar(Host));
    if HostEnt <> nil then
    begin
      SockAddr.sin_addr.S_addr := Longint(PLongint(HostEnt^.h_addr_list^)^);
      Result := inet_ntoa(SockAddr.sin_addr);
    end;
  finally
    WSACleanup;
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetLocalComputerName: string;
var
  Count: DWORD;
begin
  Count := MAX_COMPUTERNAME_LENGTH + 1;
  // set buffer size to MAX_COMPUTERNAME_LENGTH + 2 characters for safety
  SetLength(Result, Count);
  if GetComputerName(PChar(Result), Count) then
    StrResetLength(Result)
  else
    Result := '';
end;

//--------------------------------------------------------------------------------------------------

function GetLocalUserName: string;
var
  Count: DWORD;
begin
  Count := 256 + 1; // UNLEN + 1
  // set buffer size to 256 + 2 characters
  SetLength(Result, Count);
  if GetUserName(PChar(Result), Count) then
    StrResetLength(Result)
  else
    Result := '';  
end;

//--------------------------------------------------------------------------------------------------

function GetRegisteredCompany: string;
begin
  Result := RegReadStringDef(HKEY_LOCAL_MACHINE, REG_CURRENT_VERSION, 'RegisteredOrganization', '');
end;

//--------------------------------------------------------------------------------------------------

function GetRegisteredOwner: string;
begin
  Result := RegReadStringDef(HKEY_LOCAL_MACHINE, REG_CURRENT_VERSION, 'RegisteredOwner', '');
end;

//--------------------------------------------------------------------------------------------------

function GetUserDomainName(const CurUser: string): string;
var
  Count1, Count2: DWORD;
  Sd: PSecurityDescriptor;
  Snu: SID_Name_Use;
begin
  Count1 := 0;
  Count2 := 0;
  Sd := nil;
  Snu := SIDTypeUser;
  LookUpAccountName(nil, PChar(CurUser), Sd, Count1, PChar(Result), Count2, Snu);
  // set buffer size to Count2 + 2 characters for safety
  SetLength(Result, Count2 + 1);
  Sd := AllocMem(Count1);
  try
    if LookUpAccountName(nil, PChar(CurUser), Sd, Count1, PChar(Result), Count2, Snu) then
      StrResetLength(Result)
    else
      Result := EmptyStr;
  finally
    FreeMem(Sd);
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetDomainName: string;
begin
  Result := GetUserDomainName(GetLocalUserName);
end;

//--------------------------------------------------------------------------------------------------

function GetBIOSName: string;
const
  Win9xBIOSInfoKey = 'Enum\Root\*PNP0C01\0000';
// Reference: How to Obtain BIOS Information from the Registry
// http://support.microsoft.com/default.aspx?scid=kb;en-us;q195268
begin
  if IsWinNT then
    Result := ''
  else
    Result := RegReadStringDef(HKEY_LOCAL_MACHINE, Win9xBIOSInfoKey, 'BIOSName', '');
end;

//--------------------------------------------------------------------------------------------------

function GetBIOSCopyright: string;
const
  ADR_BIOSCOPYRIGHT = $FE091;
begin
  Result := '';
  if not IsWinNT and not IsBadReadPtr(Pointer(ADR_BIOSCOPYRIGHT), 2) then
  try
    Result := PChar(ADR_BIOSCOPYRIGHT);
  except
    Result := '';
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetBIOSExtendedInfo: string;
const
  ADR_BIOSEXTENDEDINFO = $FEC71;
begin
  Result := '';
  if not IsWinNT and not IsBadReadPtr(Pointer(ADR_BIOSEXTENDEDINFO), 2) then
  try
    Result := PChar(ADR_BIOSEXTENDEDINFO);
  except
    Result := '';
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetBIOSDate: TDateTime;
const
  REGSTR_PATH_SYSTEM = '\HARDWARE\DESCRIPTION\System';
  REGSTR_SYSTEMBIOSDATE = 'SystemBiosDate';
var
  RegStr, RegFormat: string;
  RegSeparator: Char;
begin
  Result := 0;
  RegStr := RegReadString(HKEY_LOCAL_MACHINE, REGSTR_PATH_SYSTEM, REGSTR_SYSTEMBIOSDATE);
  RegFormat := ShortDateFormat;
  RegSeparator := DateSeparator;
  try
    DateSeparator := '/';
    try
      ShortDateFormat := 'm/d/y';
      Result := StrToDate(RegStr);
    except
      try
        ShortDateFormat := 'y/m/d';
        Result := StrToDate(RegStr);
      except
      end;
    end;
  finally
    ShortDateFormat := RegFormat;
    DateSeparator := RegSeparator;
  end;
end;

//==================================================================================================
// Processes, Tasks and Modules
//==================================================================================================

function RunningProcessesList(const List: TStrings; FullPath: Boolean): Boolean;

  function ProcessFileName(PID: DWORD): string;
  var
    Handle: THandle;
  begin
    Result := '';
    Handle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, PID);
    if Handle <> 0 then
    try
      SetLength(Result, MAX_PATH);
      if FullPath then
      begin
        if GetModuleFileNameEx(Handle, 0, PChar(Result), MAX_PATH) > 0 then
          StrResetLength(Result)
        else
          Result := '';
      end
      else
      begin
        if GetModuleBaseNameA(Handle, 0, PChar(Result), MAX_PATH) > 0 then
          StrResetLength(Result)
        else
          Result := '';
      end;
    finally
      CloseHandle(Handle);
    end;
  end;

  function BuildListTH: Boolean;
  var
    SnapProcHandle: THandle;
    ProcEntry: TProcessEntry32;
    NextProc: Boolean;
    FileName: string;
  begin
    SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
    Result := (SnapProcHandle <> INVALID_HANDLE_VALUE);
    if Result then
    try
      ProcEntry.dwSize := SizeOf(ProcEntry);
      NextProc := Process32First(SnapProcHandle, ProcEntry);
      while NextProc do
      begin
        if ProcEntry.th32ProcessID = 0 then
        begin
          // PID 0 is always the "System Idle Process" but this name cannot be
          // retrieved from the system and has to be fabricated.
          FileName := RsSystemIdleProcess;
        end
        else
        begin
          if IsWin2k or IsWinXP then
          begin
            FileName := ProcessFileName(ProcEntry.th32ProcessID);
            if FileName = '' then
              FileName := ProcEntry.szExeFile;
          end
          else
          begin
            FileName := ProcEntry.szExeFile;
            if not FullPath then
              FileName := ExtractFileName(FileName);
          end;
        end;
        List.AddObject(FileName, Pointer(ProcEntry.th32ProcessID));
        NextProc := Process32Next(SnapProcHandle, ProcEntry);
      end;
    finally
      CloseHandle(SnapProcHandle);
    end;
  end;

  function BuildListPS: Boolean;
  var
    PIDs: array [0..1024] of DWORD;
    Needed: DWORD;
    I: Integer;
    FileName: string;
  begin
    Result := EnumProcesses(@PIDs, SizeOf(PIDs), Needed);
    if Result then
    begin
      for I := 0 to (Needed div SizeOf(DWORD)) - 1 do
      begin
        case PIDs[I] of
          0:
            // PID 0 is always the "System Idle Process" but this name cannot be
            // retrieved from the system and has to be fabricated.
            FileName := RsSystemIdleProcess;
          2:
            // On NT 4 PID 2 is the "System Process" but this name cannot be
            // retrieved from the system and has to be fabricated.
            if IsWinNT4 then
              FileName := RsSystemProcess
            else
              FileName := ProcessFileName(PIDs[I]);
          8:
            // On Win2K PID 8 is the "System Process" but this name cannot be
            // retrieved from the system and has to be fabricated.
            if IsWin2k or IsWinXP then
              FileName := RsSystemProcess
            else
              FileName := ProcessFileName(PIDs[I]);
        else
          FileName := ProcessFileName(PIDs[I]);
        end;
        if FileName <> '' then
          List.AddObject(FileName, Pointer(PIDs[I]));
      end;
    end;
  end;

begin
  if GetWindowsVersion in [wvWinNT31, wvWinNT35, wvWinNT351, wvWinNT4] then
    Result := BuildListPS
  else
    Result := BuildListTH;
end;

//--------------------------------------------------------------------------------------------------

function LoadedModulesList(const List: TStrings; ProcessID: DWORD; HandlesOnly: Boolean): Boolean;

  procedure AddToList(ProcessHandle: THandle; Module: HMODULE);
  var
    FileName: array [0..MAX_PATH] of Char;
    ModuleInfo: TModuleInfo;
  begin
    if GetModuleInformation(ProcessHandle, Module, @ModuleInfo, SizeOf(ModuleInfo)) then
    begin
      if HandlesOnly then
        List.AddObject('', Pointer(ModuleInfo.lpBaseOfDll))
      else
      if GetModuleFileNameEx(ProcessHandle, Module, Filename, SizeOf(Filename)) > 0 then
        List.AddObject(FileName, Pointer(ModuleInfo.lpBaseOfDll));
    end;
  end;

  function EnumModulesVQ(ProcessHandle: THandle): Boolean;
  var
    MemInfo: TMemoryBasicInformation;
    Base: PChar;
    LastAllocBase: Pointer;
    Res: DWORD;
  begin
    Base := nil;
    LastAllocBase := nil;
    FillChar(MemInfo, SizeOf(MemInfo), #0);
    Res := VirtualQueryEx(ProcessHandle, Base, MemInfo, SizeOf(MemInfo));
    Result := (Res = SizeOf(MemInfo));
    while Res = SizeOf(MemInfo) do
    begin
      if MemInfo.AllocationBase <> LastAllocBase then
      begin
        if MemInfo.Type_9 = MEM_IMAGE then
          AddToList(ProcessHandle, HMODULE(MemInfo.AllocationBase));
        LastAllocBase := MemInfo.AllocationBase;
      end;
      Inc(Base, MemInfo.RegionSize);
      Res := VirtualQueryEx(ProcessHandle, Base, MemInfo, SizeOf(MemInfo));
    end;
  end;

  function EnumModulesPS: Boolean;
  var
    ProcessHandle: THandle;
    Needed: DWORD;
    Modules: array of THandle;
    I, Cnt: Integer;
  begin
    Result := False;
    ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);
    if ProcessHandle <> 0 then
    try
      Result := EnumProcessModules(ProcessHandle, nil, 0, Needed);
      if Result then
      begin
        Cnt := Needed div SizeOf(HMODULE);
        SetLength(Modules, Cnt);
        if EnumProcessModules(ProcessHandle, @Modules[0], Needed, Needed) then
          for I := 0 to Cnt - 1 do
            AddToList(ProcessHandle, Modules[I]);
      end
      else
        Result := EnumModulesVQ(ProcessHandle);
    finally
      CloseHandle(ProcessHandle);
    end;
  end;

  function EnumModulesTH: Boolean;
  var
    SnapProcHandle: THandle;
    Module: TModuleEntry32;
    Next: Boolean;
  begin
    SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcessID);
    Result := (SnapProcHandle <> INVALID_HANDLE_VALUE);
    if Result then
    try
      FillChar(Module, SizeOf(Module), #0);
      Module.dwSize := SizeOf(Module);
      Next := Module32First(SnapProcHandle, Module);
      while Next do
      begin
        if HandlesOnly then
          List.AddObject('', Pointer(Module.hModule))
        else
          List.AddObject(Module.szExePath, Pointer(Module.hModule));
        Next := Module32Next(SnapProcHandle, Module);
      end;
    finally
      CloseHandle(SnapProcHandle);
    end;
  end;

begin
  if IsWinNT then
    Result := EnumModulesPS
  else
    Result := EnumModulesTH;
end;

//--------------------------------------------------------------------------------------------------

function GetTasksList(const List: TStrings): Boolean;

  function EnumWindowsProc(Wnd: HWND; List: TStrings): Boolean; stdcall;
  var
    Caption: array [0..1024] of Char;
  begin
    if IsMainAppWindow(Wnd) and (GetWindowText(Wnd, Caption, SizeOf(Caption)) > 0) then
      List.AddObject(Caption, Pointer(Wnd));
    Result := True;
  end;

begin
  Result := EnumWindows(@EnumWindowsProc, Integer(List));
end;

//--------------------------------------------------------------------------------------------------

function ModuleFromAddr(const Addr: Pointer): HMODULE;
var
  MI: TMemoryBasicInformation;
begin
  VirtualQuery(Addr, MI, SizeOf(MI));
  if MI.State <> MEM_COMMIT then
    Result := 0
  else
    Result := HMODULE(MI.AllocationBase);
end;

//--------------------------------------------------------------------------------------------------

function IsSystemModule(const Module: HMODULE): Boolean;
var
  CurModule: PLibModule;
begin
  Result := False;
  if Module <> 0 then
  begin
    CurModule := LibModuleList;
    while CurModule <> nil do
    begin
      if CurModule.Instance = Module then
      begin
        Result := True;
        Break;
      end;
      CurModule := CurModule.Next;
    end;
  end;
end;

//--------------------------------------------------------------------------------------------------

// Refernce: http://msdn.microsoft.com/library/periodic/period97/win321197.htm
function IsMainAppWindow(Wnd: HWND): Boolean;
var
  ParentWnd: HWND;
  ExStyle: DWORD;
begin
  if IsWindowVisible(Wnd) then
  begin
    ParentWnd := GetWindowLong(Wnd, GWL_HWNDPARENT);
    ExStyle := GetWindowLong(Wnd, GWL_EXSTYLE);
    Result := ((ParentWnd = 0) or (ParentWnd = GetDesktopWindow)) and
      ((ExStyle and WS_EX_TOOLWINDOW = 0) or (ExStyle and WS_EX_APPWINDOW <> 0));
  end
  else
    Result := False;
end;

//--------------------------------------------------------------------------------------------------

function IsWindowResponding(Wnd: HWND; Timeout: Integer): Boolean;
var
  Res: DWORD;
begin
  Result := SendMessageTimeout(Wnd, WM_NULL, 0, 0, SMTO_ABORTIFHUNG, Timeout, Res) <> 0;
end;

//--------------------------------------------------------------------------------------------------

function GetWindowIcon(Wnd: HWND; LargeIcon: Boolean): HICON;
var
  Width, Height: Integer;
  TempIcon: HICON;
  IconType: DWORD;
begin
  if LargeIcon then
  begin
    Width := GetSystemMetrics(SM_CXICON);
    Height := GetSystemMetrics(SM_CYICON);
    IconType := ICON_BIG;
    TempIcon := GetClassLong(Wnd, GCL_HICON);
  end
  else
  begin
    Width := GetSystemMetrics(SM_CXSMICON);
    Height := GetSystemMetrics(SM_CYSMICON);
    IconType := ICON_SMALL;
    TempIcon := GetClassLong(Wnd, GCL_HICONSM);
  end;
  if TempIcon = 0 then
    TempIcon := SendMessage(Wnd, WM_GETICON, IconType, 0);
  if (TempIcon = 0) and not LargeIcon then
    TempIcon := SendMessage(Wnd, WM_GETICON, ICON_BIG, 0);
  Result := CopyImage(TempIcon, IMAGE_ICON, Width, Height, 0);
end;

//--------------------------------------------------------------------------------------------------

function GetWindowCaption(Wnd: HWND): string;
const
  BufferAllocStep = 256;
var
  Buffer: PChar;
  Size, TextLen: Integer;
begin
  Result := '';
  Buffer := nil;
  try
    Size := GetWindowTextLength(Wnd) + 2 - BufferAllocStep;
    repeat
      Inc(Size, BufferAllocStep);
      ReallocMem(Buffer, Size);
      TextLen := GetWindowText(Wnd, Buffer, Size);
    until TextLen < Size - 1;
    if TextLen > 0 then
      Result := Buffer;
  finally
    FreeMem(Buffer);
  end;
end;

//--------------------------------------------------------------------------------------------------

// Q178893

function TerminateApp(ProcessID: DWORD; Timeout: Integer): TJclTerminateAppResult;
var
  ProcessHandle: THandle;

  function EnumWindowsProc(Wnd: HWND; ProcessID: DWORD): Boolean; stdcall;
  var
    PID: DWORD;
  begin
    GetWindowThreadProcessId(Wnd, @PID);
    if ProcessID = PID then
      PostMessage(Wnd, WM_CLOSE, 0, 0);
    Result := True;
  end;

begin
  Result := taError;
  if ProcessID <> GetCurrentProcessId then
  begin
    ProcessHandle := OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False, ProcessID);
    try
      if ProcessHandle <> 0 then
      begin
        EnumWindows(@EnumWindowsProc, LPARAM(ProcessID));
        if WaitForSingleObject(ProcessHandle, Timeout) = WAIT_OBJECT_0 then
          Result := taClean
        else
        if TerminateProcess(ProcessHandle, 0) then
          Result := taKill;
      end;
    finally
      CloseHandle(ProcessHandle);
    end;
  end;
end;

//--------------------------------------------------------------------------------------------------

function TerminateTask(Wnd: HWND; Timeout: Integer): TJclTerminateAppResult;
var
  PID: DWORD;
begin
  if GetWindowThreadProcessId(Wnd, @PID) <> 0 then
    Result := TerminateApp(PID, Timeout)
  else
    Result := taError;  
end;

//--------------------------------------------------------------------------------------------------

function GetProcessNameFromWnd(Wnd: HWND): string;
var
  List: TStringList;
  PID: DWORD;
  I: Integer;
begin
  Result := '';
  if IsWindow(Wnd) then
  begin
    PID := INVALID_HANDLE_VALUE;
    GetWindowThreadProcessId(Wnd, @PID);
    List := TStringList.Create;
    try
      if RunningProcessesList(List, True) then
      begin
        I := List.IndexOfObject(Pointer(PID));
        if I > -1 then
          Result := List[I];
      end;
    finally
      List.Free;
    end;
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetPidFromProcessName(const ProcessName: string): DWORD;
var
  List: TStringList;
  I: Integer;
  HasFullPath: Boolean;
begin
  Result := INVALID_HANDLE_VALUE;
  List := TStringList.Create;
  try
    HasFullPath := ExtractFilePath(ProcessName) <> '';
    if RunningProcessesList(List, HasFullPath) then
    begin
      I := List.IndexOf(ProcessName);
      if I > -1 then
        Result := DWORD(List.Objects[I]);
    end;
  finally
    List.Free;
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetProcessNameFromPid(PID: DWORD): string;
var
  List: TStringList;
  I: Integer;
begin
  // Note: there are other ways to retrieve the name of the process given it's
  // PID but this implementation seems to work best without making assumptions
  // although it may not be the most efficient implementation.
  Result := '';
  List := TStringList.Create;
  try
    if RunningProcessesList(List, True) then
    begin
      I := List.IndexOfObject(Pointer(PID));
      if I > -1 then
        Result := List[I];
    end;
  finally
    List.Free;
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetMainAppWndFromPid(PID: DWORD): HWND;
type
  PSearch = ^TSearch;
  TSearch = record
    PID: DWORD;
    Wnd: HWND;
  end;
var
  SearchRec: TSearch;

  function EnumWindowsProc(Wnd: HWND; Res: PSearch): Boolean; stdcall;
  var
    WindowPid: DWORD;
  begin
    WindowPid := 0;
    GetWindowThreadProcessId(Wnd, @WindowPid);
    if (WindowPid = Res^.PID) and IsMainAppWindow(Wnd) then
    begin
      Res^.Wnd := Wnd;
      Result := False;
    end
    else
      Result := True;
  end;

begin
  SearchRec.PID := PID;
  SearchRec.Wnd := 0;
  EnumWindows(@EnumWindowsProc, Integer(@SearchRec));
  Result := SearchRec.Wnd;
end;

//--------------------------------------------------------------------------------------------------

function GetShellProcessName: string;
const
  cShellKey = 'Software\Microsoft\Windows NT\CurrentVersion\WinLogon';
  cShellValue = 'Shell';
  cShellDefault = 'explorer.exe';
  cShellSystemIniFileName = 'system.ini';
  cShellBootSection = 'boot';
begin
  if IsWinNT then
    Result := RegReadStringDef(HKEY_LOCAL_MACHINE, cShellKey, cShellValue, '')
  else
    Result := IniReadString(PathAddSeparator(GetWindowsFolder) + cShellSystemIniFileName, cShellBootSection, cShellValue);
  if Result = '' then
    Result := cShellDefault;
end;

//--------------------------------------------------------------------------------------------------

function GetShellProcessHandle: THandle;
var
  Pid: Longword;
begin
  Pid := GetPidFromProcessName(GetShellProcessName);
  Result := OpenProcess(PROCESS_ALL_ACCESS, False, Pid);
  if Result = 0 then
    RaiseLastOSError;
end;

//==================================================================================================
// Version Information
//==================================================================================================

{ Q159/238

  Windows 95 retail, OEM    4.00.950                      7/11/95
  Windows 95 retail SP1     4.00.950A                     7/11/95-12/31/95
  OEM Service Release 2     4.00.1111* (4.00.950B)        8/24/96
  OEM Service Release 2.1   4.03.1212-1214* (4.00.950B)   8/24/96-8/27/97
  OEM Service Release 2.5   4.03.1214* (4.00.950C)        8/24/96-11/18/97
  Windows 98 retail, OEM    4.10.1998                     5/11/98
  Windows 98 Second Edition 4.10.2222A                    4/23/99
  Windows Millennium        4.90.3000

  TODO: Distinquish between all these different releases?
}

var
  KernelVersionHi: DWORD;

function GetWindowsVersion: TWindowsVersion;
begin
  Result := wvUnknown;
  case Win32Platform of
    VER_PLATFORM_WIN32_WINDOWS:
      case Win32MinorVersion of
        0..9:
          if Trim(Win32CSDVersion) = 'B' then
            Result := wvWin95OSR2
          else
            Result := wvWin95;
        10..89:
          // On Windows ME Win32MinorVersion can be 10 (indicating Windows 98
          // under certain circumstances (image name is setup.exe). Checking
          // the kernel version is one way of working around that.
          if KernelVersionHi = $0004005A then // 4.90.x.x
            Result := wvWinME
          else
          if Trim(Win32CSDVersion) = 'A' then
            Result := wvWin98SE
          else
            Result := wvWin98;
        90:
          Result := wvWinME;
      end;
    VER_PLATFORM_WIN32_NT:
      case Win32MajorVersion of
        3:
          case Win32MinorVersion of
            1:
              Result := wvWinNT31;
            5:
              Result := wvWinNT35;
            51:
              Result := wvWinNT351;
          end;
        4:
          Result := wvWinNT4;
        5:
          case Win32MinorVersion of
            0:
              Result := wvWin2000;
            1:
              Result := wvWinXP;
          end;
      end;
  end;
end;

//--------------------------------------------------------------------------------------------------

function NtProductType: TNtProductType;
const
  ProductType = 'System\CurrentControlSet\Control\ProductOptions';
var
  Product: string;
  VersionInfo: TOSVersionInfoEx;
begin
  Result := ptUnknown;
  FillChar(VersionInfo, SizeOf(VersionInfo), 0);
  VersionInfo.dwOSVersionInfoSize := SizeOf(VersionInfo);

  // Favor documented API over registry
  if IsWinNT4 and (GetWindowsServicePackVersion >= 6) then
  begin
    if JclWin32.GetVersionEx(@VersionInfo) then
    begin
      if (VersionInfo.wProductType = VER_NT_WORKSTATION) then
        Result := ptWorkstation
      else
        Result := ptServer;
    end;
  end
  else
  if IsWin2K then
  begin
    if JclWin32.GetVersionEx(@VersionInfo) then
    begin
      if (VersionInfo.wProductType = VER_NT_SERVER) then
      begin
        { Changes by Scott Price on 11-Jan-2002 }
        if (VersionInfo.wSuiteMask and VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER then
          Result := ptDatacenterServer
        { Changes by Scott Price on 11-Jan-2002 }
        else
        if (VersionInfo.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then
          Result := ptAdvancedServer
        else
          result := ptServer;
      end
      else
      if (VersionInfo.wProductType = VER_NT_WORKSTATION) then
        Result := ptProfessional;
    end;
  end
  else
  if IsWinXP then
  begin
    if JclWin32.GetVersionEx(@VersionInfo) then
    begin
      if (VersionInfo.wProductType = VER_NT_WORKSTATION) then
      begin
        { Changes by Scott Price on 10-Jan-2002 }
        if (VersionInfo.wSuiteMask and VER_SUITE_PERSONAL) = VER_SUITE_PERSONAL then
          Result := ptPersonal
        else
          Result := ptProfessional;
      end;
    end;
  end;

  if Result = ptUnknown then
  begin
    // Non Windows 2000/XP system or the above method failed, try registry
    { Changes by Scott Price on 11-Jan-2002 }
    Product := RegReadStringDef(HKEY_LOCAL_MACHINE, ProductType, 'ProductType', '');
    if CompareText(Product, 'WINNT') = 0 then
      Result :=  ptWorkStation
    else
    if CompareText(Product, 'SERVERNT') = 0 then
      Result := {ptServer} ptAdvancedServer
    else
    if CompareText(Product, 'LANMANNT') = 0 then
      Result := {ptAdvancedServer} ptServer
    else
      Result := ptUnknown;
  end;

end;

//--------------------------------------------------------------------------------------------------

function GetWindowsVersionString: string;
begin
  case GetWindowsVersion of
    wvWin95: Result := RsOSVersionWin95;
    wvWin95OSR2: Result := RsOSVersionWin95OSR2;
    wvWin98: Result := RsOSVersionWin98;
    wvWin98SE: Result := RsOSVersionWin98SE;
    wvWinME: Result := RsOSVersionWinME;
    wvWinNT31, wvWinNT35, wvWinNT351: Result := Format(RsOSVersionWinNT3, [Win32MinorVersion]);
    wvWinNT4: Result := Format(RsOSVersionWinNT4, [Win32MinorVersion]);
    wvWin2000: Result := RsOSVersionWin2000;
    wvWinXP: Result := RsOSVersionWinXP;
  else
    Result := '';
  end;
end;

//--------------------------------------------------------------------------------------------------

function NtProductTypeString: string;
begin
  case NtProductType of
    ptWorkStation: Result := RsProductTypeWorkStation;
    ptServer: Result := RsProductTypeServer;
    ptAdvancedServer: Result := RsProductTypeAdvancedServer;
    ptPersonal: Result := RsProductTypePersonal;
    ptProfessional: Result := RsProductTypeProfessional;
    ptDatacenterServer: Result := RsProductTypeDatacenterServer;
  else
    Result := '';
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetWindowsServicePackVersion: Integer;
const
  RegWindowsControl = '\SYSTEM\CurrentControlSet\Control\Windows\';
var
  SP: Integer;
  VersionInfo: TOSVersionInfoEx;
begin
  Result := 0;
  if IsWin2K or IsWinXP then
  begin
    FillChar(VersionInfo, SizeOf(VersionInfo), 0);
    VersionInfo.dwOSVersionInfoSize := SizeOf(VersionInfo);
    if JclWin32.GetVersionEx(@VersionInfo) then Result := VersionInfo.wServicePackMajor;
  end
  else
  begin
    SP := RegReadIntegerDef(HKEY_LOCAL_MACHINE, RegWindowsControl, 'CSDVersion', 0);
    Result := StrToInt(IntToHex(SP, 4)) div 100;
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetWindowsServicePackVersionString: string;
var
  SP: Integer;
begin
  SP := GetWindowsServicePackVersion;
  if SP > 0 then
    Result := 'SP' + IntToStr(SP)
  else
    Result := '';
end;

//==================================================================================================
// Hardware
//==================================================================================================

// Helper function for GetMacAddress()
// Converts the adapter_address array to a string

function AdapterToString(Adapter: PByteArray): string;
begin
  Result := Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x', [
    Integer(Adapter[0]), Integer(Adapter[1]),
    Integer(Adapter[2]), Integer(Adapter[3]),
    Integer(Adapter[4]), Integer(Adapter[5])]);
end;

//--------------------------------------------------------------------------------------------------

function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer;

  procedure GetMacAddressesNetBios;
  var
    NCB: TNCB;
    Enum: TLanaEnum;
    I, L, NameLen: Integer;
    Adapter: ASTAT;
    MachineName: string;
  begin
    MachineName := UpperCase(Machine);
    if MachineName = '' then
      MachineName := '*';
    NameLen := Length(MachineName);
    L := NCBNAMSZ - NameLen;
    if L > 0 then
    begin
      SetLength(MachineName, NCBNAMSZ);
      FillChar(MachineName[NameLen + 1], L, ' ');
    end;
    FillChar(NCB, SizeOf(NCB), #0);
    NCB.ncb_command := NCBENUM;
    NCB.ncb_buffer := Pointer(@Enum);
    NCB.ncb_length := SizeOf(Enum);
    if NetBios(@NCB) = NRC_GOODRET then
    begin
      Result := Enum.Length;
      for I := 0 to Ord(Enum.Length) - 1 do
      begin
        FillChar(NCB, SizeOf(NCB), #0);
        NCB.ncb_command := NCBRESET;
        NCB.ncb_lana_num := Enum.lana[I];
        if NetBios(@NCB) = NRC_GOODRET then
        begin
          FillChar(NCB, SizeOf(NCB), #0);
          NCB.ncb_command := NCBASTAT;
          NCB.ncb_lana_num := Enum.lana[I];
          Move(MachineName[1], NCB.ncb_callname, SizeOf(NCB.ncb_callname));
          NCB.ncb_buffer := PChar(@Adapter);
          NCB.ncb_length := SizeOf(Adapter);
          if NetBios(@NCB) = NRC_GOODRET then
            Addresses.Add(AdapterToString(@Adapter.adapt));
        end;
      end;
    end;
  end;

  procedure GetMacAddressesSnmp;
  const
    InetMib1 = 'inetmib1.dll';
    DunAdapterAddress: array[0..4] of Byte = ($44, $45, $53, $54, $00);
    NullAdapterAddress: array[0..5] of Byte = ($00, $00, $00, $00, $00, $00);
    OID_ipMACEntAddr: array[0..9] of UINT = (1, 3, 6, 1, 2, 1, 2, 2, 1, 6);
    OID_ifEntryType: array [0..9] of UINT = (1, 3, 6, 1, 2, 1, 2, 2, 1, 3);
    OID_ifEntryNum: array [0..7] of UINT = (1, 3, 6, 1, 2, 1, 2, 1);
  var
    PollForTrapEvent: THandle;
    SupportedView: PAsnObjectIdentifier;
    MIB_ifMACEntAddr: TAsnObjectIdentifier;
    MIB_ifEntryType: TAsnObjectIdentifier;
    MIB_ifEntryNum: TAsnObjectIdentifier;
    varBindList: TSnmpVarBindList;
    varBind: array[0..1] of TSnmpVarBind;
    ErrorStatus, ErrorIndex: TAsnInteger32;
    Dtmp: Integer;
    Ret: Boolean;
    MAC: PByteArray;
  begin
    if LoadSnmp then
    try
      if LoadSnmpExtension(InetMib1) then
      try
        MIB_ifMACEntAddr.idLength := Length(OID_ipMACEntAddr);
        MIB_ifMACEntAddr.ids := @OID_ipMACEntAddr;
        MIB_ifEntryType.idLength := Length(OID_ifEntryType);
        MIB_ifEntryType.ids := @OID_ifEntryType;
        MIB_ifEntryNum.idLength := Length(OID_ifEntryNum);
        MIB_ifEntryNum.ids := @OID_ifEntryNum;
        if SnmpExtensionInit(GetTickCount, PollForTrapEvent, SupportedView) then
        begin
          varBindList.list := @varBind[0];
          varBind[0].name := DEFINE_NULLOID;
          varBind[1].name := DEFINE_NULLOID;
          varBindList.len := 1;      
          SnmpUtilOidCpy(@varBind[0].name, @MIB_ifEntryNum);
          Ret := SnmpExtensionQuery(SNMP_PDU_GETNEXT, varBindList, ErrorStatus, ErrorIndex);
          if Ret then
          begin
            Result := varBind[0].value.number;
            varBindList.len := 2;
            SnmpUtilOidCpy(@varBind[0].name, @MIB_ifEntryType);
            SnmpUtilOidCpy(@varBind[1].name, @MIB_ifMACEntAddr);
            while Ret do
            begin
              Ret := SnmpExtensionQuery(SNMP_PDU_GETNEXT, varBindList, ErrorStatus, ErrorIndex);
              if Ret then
              begin
                Ret := SnmpUtilOidNCmp(@varBind[0].name, @MIB_ifEntryType, MIB_ifEntryType.idLength) = SNMP_ERRORSTATUS_NOERROR;
                if Ret then
                begin
                  Dtmp := varBind[0].value.number;
                  if Dtmp = 6 then
                  begin
                    Ret := SnmpUtilOidNCmp(@varBind[1].name, @MIB_ifMACEntAddr, MIB_ifMACEntAddr.idLength) = SNMP_ERRORSTATUS_NOERROR;
                    if Ret and (varBind[1].value.address.stream <> nil) then
                    begin
                      MAC := PByteArray(varBind[1].value.address.stream);
                      if not CompareMem(MAC, @NullAdapterAddress, SizeOf(NullAdapterAddress)) then
                        Addresses.Add(AdapterToString(MAC));
                    end;
                  end;
                end;
              end;
            end;
          end;
          SnmpUtilVarBindFree(@varBind[0]);
          SnmpUtilVarBindFree(@varBind[1]);
        end;
      finally
        UnloadSnmpExtension;
      end;
    finally
      UnloadSnmp;
    end;
  end;

begin
  Result := -1;
  Addresses.Clear;
  GetMacAddressesNetBios;
  if (Result = -1) and (Machine = '') then
    GetMacAddressesSnmp;
end;

//--------------------------------------------------------------------------------------------------

function ReadTimeStampCounter: Int64; assembler;
asm
        DW      $310F
end;

//--------------------------------------------------------------------------------------------------

function GetIntelCacheDescription(const D: Byte): string;
var
  I: Integer;
begin
  Result := '';
  if D <> 0 then
  begin
    for I := Low(IntelCacheDescription) to High(IntelCacheDescription) do
    begin
      if IntelCacheDescription[I].D = D then
      begin
        Result := IntelCacheDescription[I].I;
        Break;
      end;
    end;
  end;
end;

//--------------------------------------------------------------------------------------------------

procedure GetCpuInfo(var CpuInfo: TCpuInfo);
begin
  CpuInfo := CPUID;
  CpuInfo.IsFDIVOK := TestFDIVInstruction;
  if CpuInfo.HasInstruction then
  begin
    if (CpuInfo.Features and TSC_FLAG) = TSC_FLAG then
      GetCpuSpeed(CpuInfo.FrequencyInfo);
    CpuInfo.MMX := (CpuInfo.Features and MMX_FLAG) = MMX_FLAG;
  end;
end;

//--------------------------------------------------------------------------------------------------

function RoundFrequency(const Frequency: Integer): Integer;
const
  NF: array [0..8] of Integer = (0, 20, 33, 50, 60, 66, 80, 90, 100);
var
  Freq, RF: Integer;
  I: Byte;
  Hi, Lo: Byte;
begin
  RF := 0;
  Freq := Frequency mod 100;
  for I := 0 to 8 do
  begin
    if Freq < NF[I] then
    begin
      Hi := I;
      Lo := I - 1;
      if (NF[Hi] - Freq) > (Freq - NF[Lo]) then
        RF := NF[Lo] - Freq
      else
        RF := NF[Hi] - Freq;
      Break;
    end;
  end;
  Result := Frequency + RF;
end;

//--------------------------------------------------------------------------------------------------

function GetCPUSpeed(var CpuSpeed: TFreqInfo): Boolean;
var
  T0, T1: TULargeInteger;
  CountFreq: TULargeInteger;
  Freq, Freq2, Freq3, Total: Integer;
  TotalCycles, Cycles: Int64;
  Stamp0, Stamp1: Int64;
  TotalTicks, Ticks: Cardinal;
  Tries, Priority: Integer;
  Thread: THandle;
begin
  Stamp0 := 0;
  Stamp1 := 0;
  Freq  := 0;
  Freq2 := 0;
  Freq3 := 0;
  Tries := 0;
  TotalCycles := 0;
  TotalTicks := 0;
  Total := 0;

  Thread := GetCurrentThread();
  Result := QueryPerformanceFrequency(Int64(CountFreq));
  if Result then
  begin
    while ((Tries < 3 ) or ((Tries < 20) and ((Abs(3 * Freq - Total) > 3) or
      (Abs(3 * Freq2 - Total) > 3) or (Abs(3 * Freq3 - Total) > 3)))) do
    begin
      Inc(Tries);
      Freq3 := Freq2;
      Freq2 := Freq;
      QueryPerformanceCounter(Int64(T0));
      T1.LowPart := T0.LowPart;
      T1.HighPart := T0.HighPart;

      Priority := GetThreadPriority(Thread);
      if Priority <> THREAD_PRIORITY_ERROR_RETURN then
        SetThreadPriority(Thread, THREAD_PRIORITY_TIME_CRITICAL);
      try
        while (T1.LowPart - T0.LowPart) < 50 do
        begin
          QueryPerformanceCounter(Int64(T1));
          Stamp0 := ReadTimeStampCounter;
        end;
        T0.LowPart := T1.LowPart;
        T0.HighPart := T1.HighPart;

        while (T1.LowPart - T0.LowPart) < 1000 do
        begin
          QueryPerformanceCounter(Int64(T1));
          Stamp1 := ReadTimeStampCounter;
        end;
      finally
        if Priority <> THREAD_PRIORITY_ERROR_RETURN then
          SetThreadPriority(Thread, Priority);
      end;

      Cycles := Stamp1 - Stamp0;
      Ticks := T1.LowPart - T0.LowPart;
      Ticks := Ticks * 100000;

      //xarka
      if CountFreq.LowPart=0 then
      begin
       result:=false; exit;
      end;
      //
      Ticks := Round(Ticks / (CountFreq.LowPart / 10));
      TotalTicks := TotalTicks + Ticks;
      TotalCycles := TotalCycles + Cycles;

      //xarka
      if Ticks=0 then
      begin
       result:=false; exit;
      end;
      //

      Freq := Round(Cycles / Ticks);
      Total := Freq + Freq2 + Freq3;
    end;
    Freq3 := Round((TotalCycles * 10) / TotalTicks);
    Freq2 := Round((TotalCycles * 100) / TotalTicks);

    if Freq2 - (Freq3 * 10) >= 6 then
      Inc(Freq3);

    CpuSpeed.RawFreq := Round(TotalCycles / TotalTicks);
    CpuSpeed.NormFreq := CpuSpeed.RawFreq;

    Freq := CpuSpeed.RawFreq * 10;
    if (Freq3 - Freq) >= 6 then
      Inc(CpuSpeed.NormFreq);

    CpuSpeed.ExTicks := TotalTicks;
    CpuSpeed.InCycles := TotalCycles;

    CpuSpeed.NormFreq := RoundFrequency(CpuSpeed.NormFreq);
    Result := True;
  end;
end;

//--------------------------------------------------------------------------------------------------

// Helper function for CPUID. Initializes Intel specific fields.

procedure IntelSpecific(var CpuInfo: TCpuInfo);
var
  I: Integer;
begin
  with CpuInfo do
  begin
    Manufacturer := 'Intel';
    CpuType := CPU_TYPE_INTEL;
    if HasCacheInfo then
      with CPUInfo.IntelSpecific do
      begin
        L2Cache := 0;
        for I := 1 to 15 do
          case CacheDescriptors[I] of
            $40:
              L2Cache := 0;
            $41:
              L2Cache := 128;
            $42:
              L2Cache := 256;
            $43:
              L2Cache := 512;
            $44:
              L2Cache := 1024;
            $45:
              L2Cache := 2048;
          end;
      end;
    if not HasExtendedInfo then
    begin
      case Family of
        4:
          case Model of
            1:
              CpuName := 'Intel 486DX Processor';
            2:
              CpuName := 'Intel 486SX Processor';
            3:
              CpuName := 'Intel DX2 Processor';
            4:
              CpuName := 'Intel 486 Processor';
            5:
              CpuName := 'Intel SX2 Processor';
            7:
              CpuName := 'Write-Back Enhanced Intel DX2 Processor';
            8:
              CpuName := 'Intel DX4 Processor';
          else
            CpuName := 'Intel 486 Processor';
          end;
        5:
          CpuName := 'Pentium';
        6:
          case Model of
            1:
              CpuName := 'Pentium Pro';
            3:
              CpuName := 'Pentium II';
            5:
              case IntelSpecific.L2Cache of
                0:
                  CpuName := 'Celeron';
                1024:
                  CpuName := 'Pentium II Xeon';
                2048:
                  CpuName := 'Pentium II Xeon';
              else
                CpuName := 'Pentium II';
              end;
            6:
              case IntelSpecific.L2Cache of
                0:
                  CpuName := 'Celeron';
                128:
                  CpuName := 'Celeron';
              else
                CpuName := 'Pentium II';
              end;
            7:
              case IntelSpecific.L2Cache of
                1024:
                  CpuName := 'Pentium III Xeon';
                2048:
                  CpuName := 'Pentium III Xeon';
              else
                CpuName := 'Pentium III';
              end;
            8:
              case IntelSpecific.BrandID of
                1: CpuName := 'Celeron';
                2: CpuName := 'Pentium III';
                3: CpuName := 'Pentium III Xeon';
                4: CpuName := 'Pentium III';
              else
                CpuName := 'Pentium III';
              end;
            10:
              CpuName := 'Pentium III Xeon';
            11:
              CpuName := 'Pentium III';
          else
            StrPCopy(CpuName, Format('P6 (Model %d)', [Model]));
          end;
        15:
          case IntelSpecific.BrandID of
            1:
              CpuName := 'Celeron';
            8:
              CpuName := 'Pentium 4';
            14:
              CpuName := 'Xeon';
          else
            CpuName := 'Pentium 4';
          end;
      else
        StrPCopy(CpuName, Format('P%d', [Family]));
      end;
    end;
  end;
end;

//--------------------------------------------------------------------------------------------------

// Helper function for CPUID. Initializes Cyrix specific fields.

procedure CyrixSpecific(var CpuInfo: TCpuInfo);
begin
  with CpuInfo do
  begin
    Manufacturer := 'Cyrix';
    CpuType := CPU_TYPE_CYRIX;
    if not HasExtendedInfo then
    begin
      case Family of
        4:
          CpuName := 'Cyrix MediaGX';
        5:
          case Model of
            2:
              CpuName := 'Cyrix 6x86';
            4:
              CpuName := 'Cyrix GXm';
          end;
        6:
          CpuName := '6x86MX';
      else
        StrPCopy(CpuName, Format('%dx86', [Family]));
      end;
    end;
  end;
end;

//--------------------------------------------------------------------------------------------------

// Helper function for CPUID. Initializes AMD specific fields.

procedure AMDSpecific(var CpuInfo: TCpuInfo);
begin
  with CpuInfo do
  begin
    Manufacturer := 'AMD';
    CpuType := CPU_TYPE_AMD;
    if not HasExtendedInfo then
    begin
      case Family of
        4:
          CpuName := 'Am486(R) or Am5x86';
        5:
          case Model of
            0:
              CpuName := 'AMD-K5 (Model 0)';
            1:
              CpuName := 'AMD-K5 (Model 1)';
            2:
              CpuName := 'AMD-K5 (Model 2)';
            3:
              CpuName := 'AMD-K5 (Model 3)';
            6:
              CpuName := 'AMD-K6(R)';
            7:
              CpuName := 'AMD-K6';
            8:
              CpuName := 'AMD-K6(R) -2';
            9:
              CpuName := 'AMD-K6(R) -3';
          else
            CpuName := 'Unknown AMD Model';
          end;
      else
        CpuName := 'Unknown AMD Chip';
      end;
    end;
  end;
end;

//--------------------------------------------------------------------------------------------------

procedure TransmetaSpecific(var CpuInfo: TCpuInfo);
begin
  with CpuInfo do
  begin
    Manufacturer := 'Transmeta';
    CpuType := CPU_TYPE_CRUSOE;
    CpuName := 'Crusoe';
  end;
end;
  
//--------------------------------------------------------------------------------------------------

function CPUID: TCpuInfo;
var
  CPUInfo: TCpuInfo;
  HiVal: Cardinal;
  TimesToExecute, CurrentLoop: Byte;
begin
  asm
        MOV     [CPUInfo.HasInstruction], 0
        MOV     [CPUInfo.HasExtendedInfo], 0
        MOV     [CPUInfo.HasCacheInfo], 0
        MOV     [CPUInfo.PType], 0
        MOV     [CPUInfo.Model], 0
        MOV     [CPUInfo.Stepping], 0
        MOV     [CPUInfo.Features], 0
        MOV     [CPUInfo.FrequencyInfo.RawFreq], 0
        MOV     [CPUInfo.FrequencyInfo.NormFreq], 0
        MOV     [CPUInfo.FrequencyInfo.InCycles], 0
        MOV     [CPUInfo.FrequencyInfo.ExTicks], 0
        MOV     [CPUInfo.IntelSpecific.BrandID],0

        PUSH    EAX
        PUSH    EBP
        PUSH    EBX
        PUSH    ECX
        PUSH    EDI
        PUSH    EDX
        PUSH    ESI

  @@Check80486:
        MOV     [CPUInfo.Family], 4
        PUSHFD
        POP     EAX
        MOV     ECX, EAX
        XOR     EAX, 200000H
        PUSH    EAX
        POPFD
        PUSHFD
        POP     EAX
        XOR     EAX, ECX
        JE      @@DoneCpuType

  @@HasCPUIDInstruction:
        MOV     [CPUInfo.HasInstruction], 1
        MOV     EAX, 0
        DB      0FH
        DB      0A2H

        MOV     HiVal, EAX
        MOV     DWORD PTR [CPUInfo.VendorIDString], EBX
        MOV     DWORD PTR [CPUInfo.VendorIDString + 4], EDX
        MOV     DWORD PTR [CPUInfo.VendorIDString + 8], ECX

  @@CheckIntel:
        CMP     DWORD PTR [CPUInfo.VendorIDString], 'uneG'
        JNE     @@CheckAMD
        CMP     DWORD PTR [CPUInfo.VendorIDString + 4], 'Ieni'
        JNE     @@CheckAMD
        CMP     DWORD PTR [CPUInfo.VendorIDString + 8], 'letn'
        JNE     @@CheckAMD
        MOV     [CPUInfo.CpuType], CPU_TYPE_INTEL
        JMP     @@StandardFunctions

  @@CheckAMD:
        CMP     DWORD PTR [CPUInfo.VendorIDString], 'htuA'
        JNE     @@CheckCitrix
        CMP     DWORD PTR [CPUInfo.VendorIDString + 4], 'itne'
        JNE     @@CheckCitrix
        CMP     DWORD PTR [CPUInfo.VendorIDString + 8], 'DMAc'
        JNE     @@CheckCitrix
        MOV     [CPUInfo.CpuType], CPU_TYPE_AMD
        JMP     @@CheckAMDExtended

  @@CheckCitrix:
        CMP     DWORD PTR [CPUInfo.VendorIDString], 'iryC'
        JNE     @@StandardFunctions
        CMP     DWORD PTR [CPUInfo.VendorIDString + 4], 'snIx'
        JNE     @@StandardFunctions
        CMP     DWORD PTR [CPUInfo.VendorIDString + 8], 'daet'
        JNE     @@StandardFunctions
        MOV     [CPUInfo.CpuType], CPU_TYPE_CYRIX
        JMP     @@CheckCitrixExtended

  @@CheckAMDExtended:
        MOV     EAX, 80000000h
        DB      0Fh
        DB      0A2h
        CMP     EAX, 0
        JE      @@StandardFunctions
        JMP     @@AMDOnly

  @@CheckCitrixExtended:
        MOV     EAX, 80000000h
        DB      0Fh
        DB      0A2h
        CMP     EAX, 0
        JE      @@StandardFunctions
        JMP     @@CitrixOnly

  @@StandardFunctions:
        CMP     HiVal, 1
        JL      @@DoneCPUType
        MOV     EAX, 1
        DB      0FH
        DB      0A2H
        MOV     [CPUInfo.Features], EDX
        MOV     [CPUInfo.IntelSpecific.BrandID], BL 
        MOV     ECX, EAX
        AND     EAX, 3000H
        SHR     EAX, 12
        MOV     [CPUInfo.PType], AL
        MOV     EAX, ECX
        AND     EAX, 0F00H
        SHR     EAX, 8
        MOV     [CPUInfo.Family], AL
        MOV     EAX, ECX
        AND     EAX, 00F0H
        SHR     EAX, 4
        MOV     [CPUInfo.MODEL], AL
        MOV     EAX, ECX
        AND     EAX, 000FH
        MOV     [CPUInfo.Stepping], AL
        CMP     DWORD PTR [CPUInfo.VendorIDString], 'uneG'
        JNE     @@DoneCPUType
        CMP     DWORD PTR [CPUInfo.VendorIDString + 4], 'Ieni'
        JNE     @@DoneCPUType
        CMP     DWORD PTR [CPUInfo.VendorIDString + 8], 'letn'
        JNE     @@DoneCPUType

  @@IntelStandard:
        CMP     HiVal, 2
        JL      @@DoneCPUType
        MOV     CurrentLoop, 0
        MOV     [CPUInfo.HasCacheInfo], 1
        PUSH    ECX

  @@RepeatCacheQuery:
        POP     ECX
        MOV     EAX, 2
        DB      0FH
        DB      0A2H
        INC     CurrentLoop
        CMP     CurrentLoop, 1
        JNE     @@DoneCacheQuery
        MOV     TimesToExecute, AL
        CMP     AL, 0
        JE      @@DoneCPUType

  @@DoneCacheQuery:
        PUSH    ECX
        MOV     CL, CurrentLoop
        SUB     CL, TimesToExecute
        JNZ     @@RepeatCacheQuery
        POP     ECX
        MOV     DWORD PTR [CPUInfo.IntelSpecific.CacheDescriptors], EAX
        MOV     DWORD PTR [CPUInfo.IntelSpecific.CacheDescriptors + 4], EBX
        MOV     DWORD PTR [CPUInfo.IntelSpecific.CacheDescriptors + 8], ECX
        MOV     DWORD PTR [CPUInfo.IntelSpecific.CacheDescriptors + 12], EDX
        JMP     @@DoneCPUType

  @@AMDOnly:
        MOV     HiVal, EAX
        MOV     EAX, 80000001h
        CMP     HiVal, EAX
        JL      @@DoneCPUType
        MOV     [CPUInfo.HasExtendedInfo], 1
        DB      0Fh
        DB      0A2h
        MOV     ECX, EAX
        AND     EAX, 0F000H
        SHR     EAX, 12
        MOV     [CPUInfo.PType], AL
        MOV     EAX, ECX
        AND     EAX, 0F00H
        SHR     EAX, 8
        MOV     [CPUInfo.Family], AL
        MOV     EAX, ECX
        AND     EAX, 00F0H
        SHR     EAX, 4
        MOV     [CPUInfo.MODEL], AL
        MOV     EAX, ECX
        AND     EAX, 000FH
        MOV     [CPUInfo.Stepping], AL
        MOV     [CPUInfo.Features], EDX

        MOV     EAX, 80000002h
        CMP     HiVal, EAX
        JL      @@DoneCPUType
        DB      0Fh
        DB      0A2h
        MOV     DWORD PTR [CPUInfo.CpuName], EAX
        MOV     DWORD PTR [CPUInfo.CpuName + 4], EBX
        MOV     DWORD PTR [CPUInfo.CpuName + 8], ECX
        MOV     DWORD PTR [CPUInfo.CpuName + 12], EDX

        MOV     EAX, 80000003h
        CMP     HiVal, EAX
        JL      @@DoneCPUType
        DB      0Fh
        DB      0A2h
        MOV     DWORD PTR [CPUInfo.CpuName + 16], EAX
        MOV     DWORD PTR [CPUInfo.CpuName + 20], EBX
        MOV     DWORD PTR [CPUInfo.CpuName + 24], ECX
        MOV     DWORD PTR [CPUInfo.CpuName + 28], EDX

        MOV     EAX, 80000004h
        CMP     HiVal, EAX
        JL      @@DoneCPUType
        DB      0Fh
        DB      0A2h
        MOV     DWORD PTR [CPUInfo.CpuName + 32], EAX
        MOV     DWORD PTR [CPUInfo.CpuName + 36], EBX
        MOV     DWORD PTR [CPUInfo.CpuName + 40], ECX
        MOV     DWORD PTR [CPUInfo.CpuName + 44], EDX

        MOV     EAX, 80000005h
        CMP     HiVal, EAX
        JL      @@DoneCPUType
        MOV     [CPUInfo.HasCacheInfo], 1
        DB      0Fh
        DB      0A2h
        MOV     WORD PTR [CPUInfo.AMDSpecific.InstructionTLB], BX
        SHR     EBX, 16
        MOV     WORD PTR [CPUInfo.AMDSpecific.DataTLB], BX
        MOV     DWORD PTR [CPUInfo.AMDSpecific.L1DataCache], ECX
        MOV     DWORD PTR [CPUInfo.AMDSpecific.L1ICache], EDX
        JMP     @@DoneCPUType

  @@CitrixOnly:
        MOV     HiVal, EAX
        MOV     EAX, 80000001h
        CMP     HiVal, EAX
        JL      @@DoneCPUType
        MOV     [CPUInfo.HasExtendedInfo], 1
        DB      0Fh
        DB      0A2h
        MOV     ECX, EAX
        AND     EAX, 0F000H
        SHR     EAX, 12
        MOV     [CPUInfo.PType], AL
        MOV     EAX, ECX
        AND     EAX, 0F00H
        SHR     EAX, 8
        MOV     [CPUInfo.Family], AL
        MOV     EAX, ECX
        AND     EAX, 00F0H
        SHR     EAX, 4
        MOV     [CPUInfo.MODEL], AL
        MOV     EAX, ECX
        AND     EAX, 000FH
        MOV     [CPUInfo.Stepping], AL
        MOV     [CPUInfo.Features], EDX

        MOV     EAX, 80000002h
        CMP     HiVal, EAX
        JL      @@DoneCPUType
        DB      0Fh
        DB      0A2h
        MOV     DWORD PTR [CPUInfo.CpuName], EAX
        MOV     DWORD PTR [CPUInfo.CpuName + 4], EBX
        MOV     DWORD PTR [CPUInfo.CpuName + 8], ECX
        MOV     DWORD PTR [CPUInfo.CpuName + 12], EDX

        MOV     EAX, 80000003h
        CMP     HiVal, EAX
        JL      @@DoneCPUType
        DB      0Fh
        DB      0A2h
        MOV     DWORD PTR [CPUInfo.CpuName + 16], EAX
        MOV     DWORD PTR [CPUInfo.CpuName + 20], EBX
        MOV     DWORD PTR [CPUInfo.CpuName + 24], ECX
        MOV     DWORD PTR [CPUInfo.CpuName + 28], EDX

        MOV     EAX, 80000004h
        CMP     HiVal, EAX
        JL      @@DoneCPUType
        DB      0Fh
        DB      0A2h
        MOV     DWORD PTR [CPUInfo.CpuName + 32], EAX
        MOV     DWORD PTR [CPUInfo.CpuName + 36], EBX
        MOV     DWORD PTR [CPUInfo.CpuName + 40], ECX
        MOV     DWORD PTR [CPUInfo.CpuName + 44], EDX

        MOV     EAX, 80000005h
        CMP     HiVal, EAX
        JL      @@DoneCPUType
        MOV     [CPUInfo.HasCacheInfo], 1
        DB      0Fh
        DB      0A2h
        MOV     DWORD PTR [CPUInfo.CyrixSpecific.TLBInfo], EBX
        MOV     DWORD PTR [CPUInfo.CyrixSpecific.L1CacheInfo], ECX

  @@DoneCpuType:
        POP     ESI
        POP     EDX
        POP     EDI
        POP     ECX
        POP     EBX
        POP     EBP
        POP     EAX
  end;

  if CPUInfo.VendorIDString = 'GenuineIntel' then
    IntelSpecific(CpuInfo)
  else
  if CPUInfo.VendorIDString = 'CyrixInstead' then
    CyrixSpecific(CpuInfo)
  else
  if CPUInfo.VendorIDString = 'AuthenticAMD' then
    AMDSpecific(CpuInfo)
  else
  if CPUInfo.VendorIDString = 'GenuineTMx86' then
    TransmetaSpecific(CpuInfo)
  else
  begin
    CpuInfo.Manufacturer := 'Unknown';
    CpuInfo.CpuName := 'Unknown';
  end;


  Result := CPUInfo;
end;

//--------------------------------------------------------------------------------------------------

function TestFDIVInstruction: Boolean;
var
  TopNum: Double;
  BottomNum: Double;
  One: Double;
  ISOK: Boolean;
begin
  // The following code was found in Borlands fdiv.asm file in the
  // Delphi 3\Source\RTL\SYS directory, (I made some minor modifications)
  // therefore I cannot take credit for it.
  TopNum := 2658955;
  BottomNum := PI;
  One := 1;
  asm
        PUSH    EAX
        FLD     [TopNum]
        FDIV    [BottomNum]
        FMUL    [BottomNum]
        FSUBR   [TopNum]
        FCOMP   [One]
        FSTSW   AX
        SHR     EAX, 8
        AND     EAX, 01H
        MOV     ISOK, AL
        POP     EAX
  end;
  Result := ISOK;
end;

//==================================================================================================
// Alloc granularity
//==================================================================================================

procedure RoundToAllocGranularity64(var Value: Int64; Up: Boolean);
begin
  if (Value mod AllocGranularity) <> 0 then
    if Up then
      Value := ((Value div AllocGranularity) + 1) * AllocGranularity
    else
      Value := (Value div AllocGranularity) * AllocGranularity;
end;

//--------------------------------------------------------------------------------------------------

procedure RoundToAllocGranularityPtr(var Value: Pointer; Up: Boolean);
begin
  if (Cardinal(Value) mod AllocGranularity) <> 0 then
    if Up then
      Value := Pointer(((Cardinal(Value) div AllocGranularity) + 1) * AllocGranularity)
    else
      Value := Pointer((Cardinal(Value) div AllocGranularity) * AllocGranularity);
end;

//==================================================================================================
// Advanced Power Management (APM)
//==================================================================================================

function GetAPMLineStatus: TAPMLineStatus;
var
  SystemPowerstatus: TSystemPowerStatus;
begin
  Result := alsUnknown;
  if not GetSystemPowerStatus(SystemPowerStatus) then
    RaiseLastOSError
  else
  begin
    case SystemPowerStatus.ACLineStatus  of
      0:
        Result := alsOffline;
      1:
        Result := alsOnline;
      255:
        Result := alsUnknown;
    end;
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetAPMBatteryFlag: TAPMBatteryFlag;
var
  SystemPowerstatus: TSystemPowerStatus;
begin
  Result := abfUnknown;
  if not GetSystemPowerStatus(SystemPowerStatus) then
    RaiseLastOSError
  else
  begin
    case SystemPowerStatus.BatteryFlag of
      1:
       Result := abfHigh;
      2:
        Result := abfLow;
      4:
        Result := abfCritical;
      8:
        Result := abfCharging;
      128:
        Result := abfNoBattery;
      255:
        Result := abfUnknown;
    end;
  end;
end;

//--------------------------------------------------------------------------------------------------

function GetAPMBatteryLifePercent: Integer;
var
  SystemPowerstatus: TSystemPowerStatus;
begin
  Result := 0;
  if not GetSystemPowerStatus(SystemPowerStatus) then
    RaiseLastOSError
  else
    Result := SystemPowerStatus.BatteryLifePercent;
end;

//--------------------------------------------------------------------------------------------------

function GetAPMBatteryLifeTime: DWORD;
var
  SystemPowerstatus: TSystemPowerStatus;
begin
  Result := 0;
  if not GetSystemPowerStatus(SystemPowerStatus) then
    RaiseLastOSError
  else
    Result := SystemPowerStatus.BatteryLifeTime;
end;

//--------------------------------------------------------------------------------------------------

function GetAPMBatteryFullLifeTime: DWORD;
var
  SystemPowerstatus: TSystemPowerStatus;
begin
  Result := 0;
  if not GetSystemPowerStatus(SystemPowerStatus) then
    RaiseLastOSError
  else
    Result := SystemPowerStatus.BatteryFullLifeTime;
end;

//==================================================================================================
// Memory Information
//==================================================================================================

function GetMaxAppAddress: Integer;
var
  SystemInfo: TSystemInfo;
begin
  FillChar(SystemInfo, SizeOf(SystemInfo), #0);
  GetSystemInfo(SystemInfo);
  Result := Integer(SystemInfo.lpMaximumApplicationAddress);
end;

//--------------------------------------------------------------------------------------------------

function GetMinAppAddress: Integer;
var
  SystemInfo: TSystemInfo;
begin
  FillChar(SystemInfo, SizeOf(SystemInfo), #0);
  GetSystemInfo(SystemInfo);
  Result := Integer(SystemInfo.lpMinimumApplicationAddress);
end;

//--------------------------------------------------------------------------------------------------

function GetMemoryLoad: Byte;
var
  MemoryStatus: TMemoryStatus;
begin
  FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
  MemoryStatus.dwLength := SizeOf(MemoryStatus);
  GlobalMemoryStatus(MemoryStatus);
  Result := MemoryStatus.dwMemoryLoad;
end;

//--------------------------------------------------------------------------------------------------

function GetSwapFileSize: Integer;
var
  MemoryStatus: TMemoryStatus;
begin
  FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
  MemoryStatus.dwLength := SizeOf(MemoryStatus);
  GlobalMemoryStatus(MemoryStatus);
  with MemoryStatus do
    Result := Trunc(dwTotalPageFile - dwAvailPageFile);
end;

//--------------------------------------------------------------------------------------------------

function GetSwapFileUsage: Integer;
var
  MemoryStatus: TMemoryStatus;
begin
  FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
  MemoryStatus.dwLength := SizeOf(MemoryStatus);
  GlobalMemoryStatus(MemoryStatus);
  with MemoryStatus do
    if dwTotalPageFile > 0 then
      Result := 100 - Trunc(dwAvailPageFile / dwTotalPageFile * 100)
    else
      Result := 0;  
end;

//--------------------------------------------------------------------------------------------------

function GetTotalPhysicalMemory: Integer;
var
  MemoryStatus: TMemoryStatus;
begin
  FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
  MemoryStatus.dwLength := SizeOf(MemoryStatus);
  GlobalMemoryStatus(MemoryStatus);
  Result := MemoryStatus.dwTotalPhys;
end;

//--------------------------------------------------------------------------------------------------

function GetFreePhysicalMemory: Integer;
var
  MemoryStatus: TMemoryStatus;
begin
  FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
  MemoryStatus.dwLength := SizeOf(MemoryStatus);
  GlobalMemoryStatus(MemoryStatus);
  Result := MemoryStatus.dwAvailPhys;
end;

//--------------------------------------------------------------------------------------------------

function GetTotalPageFileMemory: Integer;
var
  MemoryStatus: TMemoryStatus;
begin
  FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
  MemoryStatus.dwLength := SizeOf(MemoryStatus);
  GlobalMemoryStatus(MemoryStatus);
  Result := MemoryStatus.dwTotalPageFile;
end;

//--------------------------------------------------------------------------------------------------

function GetFreePageFileMemory: Integer;
var
  MemoryStatus: TMemoryStatus;
begin
  FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
  MemoryStatus.dwLength := SizeOf(MemoryStatus);
  GlobalMemoryStatus(MemoryStatus);
  Result := MemoryStatus.dwAvailPageFile;
end;

//--------------------------------------------------------------------------------------------------

function GetTotalVirtualMemory: Integer;
var
  MemoryStatus: TMemoryStatus;
begin
  FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
  MemoryStatus.dwLength := SizeOf(MemoryStatus);
  GlobalMemoryStatus(MemoryStatus);
  Result := MemoryStatus.dwTotalVirtual;
end;

//--------------------------------------------------------------------------------------------------

function GetFreeVirtualMemory: Integer;
var
  MemoryStatus: TMemoryStatus;
begin
  FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
  MemoryStatus.dwLength := SizeOf(MemoryStatus);
  GlobalMemoryStatus(MemoryStatus);
  Result := MemoryStatus.dwAvailVirtual;
end;

//==================================================================================================
// Keyboard Information
//==================================================================================================

function GetKeybStateHelper(VirtualKey: Cardinal; Mask: Byte): Boolean;
var
  Keys: TKeyboardState;
begin
  Result := GetKeyBoardState(Keys) and (Keys[VirtualKey] and Mask <> 0);
end;

//--------------------------------------------------------------------------------------------------

function GetKeyState(const VirtualKey: Cardinal): Boolean;
begin
  Result := GetKeybStateHelper(VirtualKey, $80);
end;

//--------------------------------------------------------------------------------------------------

function GetNumLockKeyState: Boolean;
begin
  Result := GetKeybStateHelper(VK_NUMLOCK, $01);
end;

//--------------------------------------------------------------------------------------------------

function GetScrollLockKeyState: Boolean;
begin
  Result := GetKeybStateHelper(VK_SCROLL, $01);
end;

//--------------------------------------------------------------------------------------------------

function GetCapsLockKeyState: Boolean;
begin
  Result := GetKeybStateHelper(VK_CAPITAL, $01);
end;

//==================================================================================================
// Windows 95/98/Me system resources information
//==================================================================================================

var
  ResmeterLibHandle: THandle;
  MyGetFreeSystemResources: function (ResType: UINT): UINT; stdcall;

//--------------------------------------------------------------------------------------------------

procedure UnloadSystemResourcesMeterLib;
begin
  if ResmeterLibHandle <> 0 then
  begin
    FreeLibrary(ResmeterLibHandle);
    ResmeterLibHandle := 0;
    @MyGetFreeSystemResources := nil;
  end;
end;

//--------------------------------------------------------------------------------------------------

function IsSystemResourcesMeterPresent: Boolean;

  procedure LoadResmeter;
  var
    OldErrorMode: UINT;
  begin
    OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
    try
      ResmeterLibHandle := LoadLibrary('rsrc32.dll');
    finally
      SetErrorMode(OldErrorMode);
    end;
    if ResmeterLibHandle <> 0 then
    begin
      @MyGetFreeSystemResources := GetProcAddress(ResmeterLibHandle, '_MyGetFreeSystemResources32@4');
      if not Assigned(MyGetFreeSystemResources) then
        UnloadSystemResourcesMeterLib;
    end;    
  end;

begin
  if not IsWinNT and (ResmeterLibHandle = 0) then
    LoadResmeter;
  Result := (ResmeterLibHandle <> 0);
end;

//--------------------------------------------------------------------------------------------------

function GetFreeSystemResources(const ResourceType: TFreeSysResKind): Integer;
const
  ParamValues: array [TFreeSysResKind] of UINT = (0, 1, 2);
begin
  if IsSystemResourcesMeterPresent then
    Result := MyGetFreeSystemResources(ParamValues[ResourceType])
  else
    Result := -1;
end;

//--------------------------------------------------------------------------------------------------

function GetFreeSystemResources: TFreeSystemResources;
begin
  with Result do
  begin
    SystemRes := GetFreeSystemResources(rtSystem);
    GdiRes := GetFreeSystemResources(rtGdi);
    UserRes := GetFreeSystemResources(rtUser);
  end;
end;

//==================================================================================================
// Initialization
//==================================================================================================

procedure InitSysInfo;
var
  SystemInfo: TSystemInfo;
  Kernel32FileName: string;
  VerFixedFileInfo: TVSFixedFileInfo;
begin

  { processor information related initialization }

  FillChar(SystemInfo, SizeOf(SystemInfo), #0);
  GetSystemInfo(SystemInfo);
  ProcessorCount := SystemInfo.dwNumberOfProcessors;
  AllocGranularity := SystemInfo.dwAllocationGranularity;
  PageSize := SystemInfo.dwPageSize;

  { Windows version information }

  IsWinNT := Win32Platform = VER_PLATFORM_WIN32_NT;

  Kernel32FileName := GetModulePath(GetModuleHandle(kernel32));
  if (not IsWinNT) and VersionFixedFileInfo(Kernel32FileName, VerFixedFileInfo) then
    KernelVersionHi := VerFixedFileInfo.dwProductVersionMS
  else
    KernelVersionHi := 0;

  case GetWindowsVersion of
    wvUnknown: ;
    wvWin95:
      IsWin95 := True;
    wvWin95OSR2:
      IsWin95OSR2 := True;
    wvWin98:
      IsWin98 := True;
    wvWin98SE:
      IsWin98SE := True;
    wvWinME:
      IsWinME := True;
    wvWinNT31:
      begin
        IsWinNT3 := True;
        IsWinNT31 := True;
      end;
    wvWinNT35:
      begin
        IsWinNT3 := True;
        IsWinNT35 := True;
      end;
    wvWinNT351:
      begin
        IsWinNT3 := True;
        IsWinNT351 := True;
      end;
    wvWinNT4:
      IsWinNT4 := True;
    wvWin2000:
      IsWin2K := True;
    wvWinXP:
      IsWinXP := True;
  end;
end;

//==================================================================================================
// Finalization
//==================================================================================================

procedure FinalizeSysInfo;
begin
  UnloadSystemResourcesMeterLib;
end;

//--------------------------------------------------------------------------------------------------

initialization
  InitSysInfo;

finalization
  FinalizeSysInfo;

end.
