Archivado/Componentes.Terceros.jcl
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
17dcd15e37
Componentes.Terceros.jcl/official/1.96/source/common/JclSysInfo.pas

5436 lines
180 KiB
ObjectPascal
Raw Blame History

{**************************************************************************************************}
{ }
{ 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 Marcel van Brakel. }
{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. }
{ }
{ Contributors: }
{ Alexander Radchenko }
{ André Snepvangers (asnepvangers) }
{ Azret Botash }
{ Bryan Coutch }
{ Carl Clark }
{ Eric S. Fisher }
{ Florent Ouchet (outchy) }
{ James Azarja }
{ Jean-Fabien Connault }
{ John C Molyneux }
{ Marcel van Brakel }
{ Matthias Thoma (mthoma) }
{ Mike Lischke }
{ Nick Hodges }
{ Olivier Sannier (obones) }
{ Peter Friese }
{ Peter Thörnquist (peter3) }
{ Petr Vones (pvones) }
{ Rik Barker }
{ Robert Marquardt (marquardt) }
{ Robert Rossmair (rrossmair) }
{ Scott Price }
{ Tom Hahn (tomhahn) }
{ Wim de Cleen }
{ }
{**************************************************************************************************}
{ }
{ 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. }
{ }
{**************************************************************************************************}
// Last modified: $Date: 2005/12/12 21:54:09 $
// For history see end of file
// Windows NT 4 and earlier do not support GetSystemPowerStatus (while introduced
// in NT4 - it is a stub there - implemented in Windows 2000 and later.
unit JclSysInfo;
{$I jcl.inc}
interface
uses
{$IFDEF HAS_UNIT_TYPES}
Types,
{$ENDIF HAS_UNIT_TYPES}
{$IFDEF HAS_UNIT_LIBC}
Libc,
{$ENDIF HAS_UNIT_LIBC}
{$IFDEF CLR}
System.IO, System.Configuration, System.Diagnostics, System.Collections,
System.Net, System.ComponentModel,
{$ELSE ~CLR}
{$IFDEF MSWINDOWS}
Windows,
{$IFNDEF FPC}
ShlObj,
{$ENDIF ~FPC}
{$ENDIF MSWINDOWS}
{$ENDIF ~CLR}
Classes,
JclResources;
// Environment Variables
{$IFDEF MSWINDOWS}
type
TEnvironmentOption = (eoLocalMachine, eoCurrentUser, eoAdditional);
TEnvironmentOptions = set of TEnvironmentOption;
{$ENDIF MSWINDOWS}
{$IFDEF CLR}
type
DWORD = LongWord;
{$ENDIF CLR}
function DelEnvironmentVar(const Name: string): Boolean;
function ExpandEnvironmentVar(var Value: string): Boolean;
function GetEnvironmentVar(const Name: string; var Value: string): Boolean; overload;
function GetEnvironmentVar(const Name: string; var Value: string; Expand: Boolean): Boolean; overload;
function GetEnvironmentVars(const Vars: TStrings): Boolean; overload;
function GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean; overload;
function SetEnvironmentVar(const Name, Value: string): Boolean;
{$IFNDEF CLR}
{$IFDEF MSWINDOWS}
function CreateEnvironmentBlock(const Options: TEnvironmentOptions; const AdditionalVars: TStrings): PChar;
procedure DestroyEnvironmentBlock(var Env: PChar);
procedure SetGlobalEnvironmentVariable(VariableName, VariableContent: string);
{$ENDIF MSWINDOWS}
{$ENDIF ~CLR}
// Common Folder Locations
{$IFNDEF CLR}
{$IFDEF MSWINDOWS}
function GetCommonFilesFolder: string;
{$ENDIF MSWINDOWS}
{$ENDIF ~CLR}
function GetCurrentFolder: string;
{$IFDEF MSWINDOWS}
function GetProgramFilesFolder: string;
{$IFNDEF CLR}
function GetWindowsFolder: string;
{$ENDIF ~CLR}
function GetWindowsSystemFolder: string;
function GetWindowsTempFolder: string;
function GetDesktopFolder: string;
function GetProgramsFolder: string;
{$ENDIF MSWINDOWS}
function GetPersonalFolder: string;
{$IFDEF MSWINDOWS}
function GetFavoritesFolder: string;
function GetStartupFolder: string;
function GetRecentFolder: string;
function GetSendToFolder: string;
function GetStartmenuFolder: string;
function GetDesktopDirectoryFolder: string;
{$IFNDEF CLR}
function GetNethoodFolder: string;
function GetFontsFolder: string;
function GetCommonStartmenuFolder: string;
function GetCommonStartupFolder: string;
function GetPrinthoodFolder: string;
function GetProfileFolder: string;
{$ENDIF ~CLR}
function GetCommonProgramsFolder: string;
function GetCommonDesktopdirectoryFolder: string;
function GetCommonAppdataFolder: string;
function GetAppdataFolder: string;
function GetCommonFavoritesFolder: string;
function GetTemplatesFolder: string;
function GetInternetCacheFolder: string;
function GetCookiesFolder: string;
function GetHistoryFolder: string;
{$IFNDEF CLR}
// Advanced Power Management (APM)
type
TAPMLineStatus = (alsOffline, alsOnline, alsUnknown);
TAPMBatteryFlag = (abfHigh, abfLow, abfCritical, abfCharging, abfNoBattery, abfUnknown);
TAPMBatteryFlags = set of TAPMBatteryFlag;
function GetAPMLineStatus: TAPMLineStatus;
function GetAPMBatteryFlag: TAPMBatteryFlag;
function GetAPMBatteryFlags: TAPMBatteryFlags;
function GetAPMBatteryLifePercent: Integer;
function GetAPMBatteryLifeTime: DWORD;
function GetAPMBatteryFullLifeTime: DWORD;
// Identification
type
TFileSystemFlag =
(
fsCaseSensitive, // The file system supports case-sensitive file names.
fsCasePreservedNames, // The file system preserves the case of file names when it places a name on disk.
fsSupportsUnicodeOnDisk, // The file system supports Unicode in file names as they appear on disk.
fsPersistentACLs, // The file system preserves and enforces ACLs. For example, NTFS preserves and enforces ACLs, and FAT does not.
fsSupportsFileCompression, // The file system supports file-based compression.
fsSupportsVolumeQuotas, // The file system supports disk quotas.
fsSupportsSparseFiles, // The file system supports sparse files.
fsSupportsReparsePoints, // The file system supports reparse points.
fsSupportsRemoteStorage, // ?
fsVolumeIsCompressed, // The specified volume is a compressed volume; for example, a DoubleSpace volume.
fsSupportsObjectIds, // The file system supports object identifiers.
fsSupportsEncryption, // The file system supports the Encrypted File System (EFS).
fsSupportsNamedStreams, // The file system supports named streams.
fsVolumeIsReadOnly // The specified volume is read-only.
// Windows 2000/NT and Windows Me/98/95: This value is not supported.
);
TFileSystemFlags = set of TFileSystemFlag;
function GetVolumeName(const Drive: string): string;
function GetVolumeSerialNumber(const Drive: string): string;
function GetVolumeFileSystem(const Drive: string): string;
function GetVolumeFileSystemFlags(const Volume: string): TFileSystemFlags;
{$ENDIF ~CLR}
{$ENDIF MSWINDOWS}
function GetIPAddress(const HostName: string): string;
{$IFDEF UNIX}
procedure GetIpAddresses(Results: TStrings);
{$ENDIF UNIX}
function GetLocalComputerName: string;
{$IFNDEF CLR}
function GetLocalUserName: string;
{$IFDEF MSWINDOWS}
function GetUserDomainName(const CurUser: string): string;
{$ENDIF MSWINDOWS}
function GetDomainName: string;
{$IFDEF MSWINDOWS}
function GetRegisteredCompany: string;
function GetRegisteredOwner: string;
function GetBIOSName: string;
function GetBIOSCopyright: string;
function GetBIOSExtendedInfo: string;
function GetBIOSDate: TDateTime;
{$ENDIF MSWINDOWS}
// Processes, Tasks and Modules
type
TJclTerminateAppResult = (taError, taClean, taKill);
{$ENDIF ~CLR}
function RunningProcessesList(const List: TStrings; FullPath: Boolean = True): Boolean;
{$IFDEF MSWINDOWS}
{$IFNDEF CLR}
function LoadedModulesList(const List: TStrings; ProcessID: DWORD; HandlesOnly: Boolean = False): Boolean;
function GetTasksList(const List: TStrings): Boolean;
function ModuleFromAddr(const Addr: Pointer): HMODULE;
{$IFNDEF FPC}
function IsSystemModule(const Module: HMODULE): Boolean;
{$ENDIF ~FPC}
function IsMainAppWindow(Wnd: THandle): Boolean;
function IsWindowResponding(Wnd: THandle; Timeout: Integer): Boolean;
function GetWindowIcon(Wnd: THandle; LargeIcon: Boolean): HICON;
function GetWindowCaption(Wnd: THandle): string;
function TerminateTask(Wnd: THandle; Timeout: Integer): TJclTerminateAppResult;
function TerminateApp(ProcessID: DWORD; Timeout: Integer): TJclTerminateAppResult;
{$ENDIF ~CLR}
{$ENDIF MSWINDOWS}
{$IFNDEF CLR}
{$IFDEF MSWINDOWS}
{.$IFNDEF FPC}
function GetPidFromProcessName(const ProcessName: string): DWORD;
function GetProcessNameFromWnd(Wnd: THandle): string;
function GetProcessNameFromPid(PID: DWORD): string;
function GetMainAppWndFromPid(PID: DWORD): THandle;
{.$ENDIF ~FPC}
function GetShellProcessName: string;
{.$IFNDEF FPC}
function GetShellProcessHandle: THandle;
{.$ENDIF ~FPC}
// Version Information
type
TWindowsVersion =
(wvUnknown, wvWin95, wvWin95OSR2, wvWin98, wvWin98SE, wvWinME,
wvWinNT31, wvWinNT35, wvWinNT351, wvWinNT4, wvWin2000, wvWinXP,
wvWin2003, wvWinXP64, wvWin2003R2, wvWinVista, wvWinLonghorn);
TNtProductType =
(ptUnknown, ptWorkStation, ptServer, ptAdvancedServer,
ptPersonal, ptProfessional, ptDatacenterServer, ptEnterprise, ptWebEdition);
TProcessorArchitecture =
(paUnknown, // unknown processor
pax8632, // x86 32 bit processors (some P4, Celeron, Athlon and older)
pax8664, // x86 64 bit processors (latest P4, Celeron and Athlon64)
paIA64); // Itanium processors
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;
IsWin2003: Boolean = False;
IsWinXP64: Boolean = False;
IsWin2003R2: Boolean = False;
IsWinVista: Boolean = False;
IsWinLonghorn: Boolean = False;
const
PROCESSOR_ARCHITECTURE_INTEL = 0;
{$EXTERNALSYM PROCESSOR_ARCHITECTURE_INTEL}
PROCESSOR_ARCHITECTURE_AMD64 = 9;
{$EXTERNALSYM PROCESSOR_ARCHITECTURE_AMD64}
PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 = 10;
{$EXTERNALSYM PROCESSOR_ARCHITECTURE_IA32_ON_WIN64}
PROCESSOR_ARCHITECTURE_IA64 = 6;
{$EXTERNALSYM PROCESSOR_ARCHITECTURE_IA64}
function GetWindowsVersion: TWindowsVersion;
function NtProductType: TNtProductType;
function GetWindowsVersionString: string;
function NtProductTypeString: string;
function GetWindowsServicePackVersion: Integer;
function GetWindowsServicePackVersionString: string;
function GetOpenGLVersion(const Win: THandle; out Version, Vendor: AnsiString): Boolean;
function GetNativeSystemInfo(var SystemInfo: TSystemInfo): Boolean;
function GetProcessorArchitecture: TProcessorArchitecture;
function IsWindows64: Boolean;
{$ENDIF MSWINDOWS}
function GetOSVersionString: string;
// Hardware
{$IFDEF MSWINDOWS}
function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer;
{$ENDIF MSWINDOWS}
function ReadTimeStampCounter: Int64;
type
TTLBInformation = (tiEntries, tiAssociativity);
TCacheInformation = (ciLineSize {in Bytes}, ciLinesPerTag, ciAssociativity, ciSize);
TIntelSpecific = record
L2Cache: Cardinal;
CacheDescriptors: array [0..15] of Byte;
BrandID: Byte;
ExFeatures: Cardinal;
Ex64Features: Cardinal;
end;
TCyrixSpecific = record
L1CacheInfo: array [0..3] of Byte;
TLBInfo: array [0..3] of Byte;
end;
TAMDSpecific = record
ExFeatures: Cardinal;
MByteDataTLB: array [TTLBInformation] of Byte;
MByteInstructionTLB: array [TTLBInformation] of Byte;
KByteDataTLB: array [TTLBInformation] of Byte;
KByteInstructionTLB: array [TTLBInformation] of Byte;
L1DataCache: array [TCacheInformation] of Byte;
L1InstructionCache: array [TCacheInformation] of Byte;
L2MByteDataTLB: array [TTLBInformation] of Byte; // L2 TLB for 2-MByte and 4-MByte pages
L2MByteInstructionTLB: array [TTLBInformation] of Byte; // L2 TLB for 2-MByte and 4-MByte pages
L2KByteDataTLB: array [TTLBInformation] of Byte; // L2 TLB for 4-KByte pages
L2KByteInstructionTLB: array [TTLBInformation] of Byte; // L2 TLB for 4-KByte pages
L2Cache: Cardinal;
AdvancedPowerManagement: Cardinal;
PhysicalAddressSize: Byte;
VirtualAddressSize: Byte;
end;
TVIASpecific = record
ExFeatures: Cardinal;
DataTLB: array [TTLBInformation] of Byte;
InstructionTLB: array [TTLBInformation] of Byte;
L1DataCache: array [TCacheInformation] of Byte;
L1InstructionCache: array [TCacheInformation] of Byte;
L2DataCache: Cardinal;
end;
TTransmetaSpecific = record
ExFeatures: Cardinal;
DataTLB: array [TTLBInformation] of Byte;
CodeTLB: array [TTLBInformation] of Byte;
L1DataCache: array [TCacheInformation] of Byte;
L1CodeCache: array [TCacheInformation] of Byte;
L2Cache: Cardinal;
RevisionABCD: Cardinal;
RevisionXXXX: Cardinal;
Frequency: Cardinal;
CodeMorphingABCD: Cardinal;
CodeMorphingXXXX: Cardinal;
TransmetaFeatures: Cardinal;
TransmetaInformations: array [0..64] of Char;
CurrentVoltage: Cardinal;
CurrentFrequency: Cardinal;
CurrentPerformance: Cardinal;
end;
TCacheFamily = (
cfInstructionTLB, cfDataTLB,
cfL1InstructionCache, cfL1DataCache,
cfL2Cache, cfL3Cache, cfTrace, cfOther);
TCacheInfo = record
D: Byte;
Family: TCacheFamily;
Size: Cardinal;
WaysOfAssoc: Byte;
LineSize: Byte; // for Normal Cache
LinePerSector: Byte; // for L3 Normal Cache
Entries: Cardinal; // for TLB
I: string;
end;
TFreqInfo = record
RawFreq: Cardinal;
NormFreq: Cardinal;
InCycles: Cardinal;
ExTicks: Cardinal;
end;
const
CPU_TYPE_INTEL = 1;
CPU_TYPE_CYRIX = 2;
CPU_TYPE_AMD = 3;
CPU_TYPE_TRANSMETA = 4;
CPU_TYPE_VIA = 5;
type
TCpuInfo = record
HasInstruction: Boolean;
MMX: Boolean;
ExMMX: Boolean;
_3DNow: Boolean;
Ex3DNow: Boolean;
SSE: Byte; // SSE version 0 = no SSE, 1 = SSE, 2 = SSE2, 3 = SSE3
IsFDIVOK: Boolean;
Is64Bits: Boolean;
HasCacheInfo: Boolean;
HasExtendedInfo: Boolean;
PType: Byte;
Family: Byte;
ExtendedFamily: Byte;
Model: Byte;
ExtendedModel: 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;
L1DataCacheSize: Cardinal; // in kByte
L1DataCacheLineSize: Byte; // in Byte
L1DataCacheAssociativity: Byte;
L1InstructionCacheSize: Cardinal; // in kByte
L1InstructionCacheLineSize: Byte; // in Byte
L1InstructionCacheAssociativity: Byte;
L2CacheSize: Cardinal; // in kByte
L2CacheLineSize: Byte; // in Byte
L2CacheAssociativity: Byte;
L3CacheSize: Cardinal; // in kByte
L3CacheLineSize: Byte; // in Byte
L3CacheAssociativity: Byte;
L3LinesPerSector: Byte;
// todo: TLB
case CpuType: Byte of
CPU_TYPE_INTEL: (IntelSpecific: TIntelSpecific;);
CPU_TYPE_CYRIX: (CyrixSpecific: TCyrixSpecific;);
CPU_TYPE_AMD: (AMDSpecific: TAMDSpecific;);
CPU_TYPE_TRANSMETA: (TransmetaSpecific: TTransmetaSpecific;);
CPU_TYPE_VIA: (ViaSpecific: TViaSpecific;);
end;
const
VendorIDIntel: array [0..11] of Char = 'GenuineIntel';
VendorIDCyrix: array [0..11] of Char = 'CyrixInstead';
VendorIDAMD: array [0..11] of Char = 'AuthenticAMD';
VendorIDTransmeta: array [0..11] of Char = 'GenuineTMx86';
VendorIDVIA: array [0..11] of Char = 'CentaurHauls';
// 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
{ 32 bits in a DWord Value }
BIT_0 = $00000001;
BIT_1 = $00000002;
BIT_2 = $00000004;
BIT_3 = $00000008;
BIT_4 = $00000010;
BIT_5 = $00000020;
BIT_6 = $00000040;
BIT_7 = $00000080;
BIT_8 = $00000100;
BIT_9 = $00000200;
BIT_10 = $00000400;
BIT_11 = $00000800;
BIT_12 = $00001000;
BIT_13 = $00002000;
BIT_14 = $00004000;
BIT_15 = $00008000;
BIT_16 = $00010000;
BIT_17 = $00020000;
BIT_18 = $00040000;
BIT_19 = $00080000;
BIT_20 = $00100000;
BIT_21 = $00200000;
BIT_22 = $00400000;
BIT_23 = $00800000;
BIT_24 = $01000000;
BIT_25 = $02000000;
BIT_26 = $04000000;
BIT_27 = $08000000;
BIT_28 = $10000000;
BIT_29 = $20000000;
BIT_30 = $40000000;
BIT_31 = DWORD($80000000);
{ Standard Feature Flags }
FPU_FLAG = BIT_0; // Floating-Point unit on chip
VME_FLAG = BIT_1; // Virtual Mode Extention
DE_FLAG = BIT_2; // Debugging Extention
PSE_FLAG = BIT_3; // Page Size Extention
TSC_FLAG = BIT_4; // Time Stamp Counter
MSR_FLAG = BIT_5; // Model Specific Registers
PAE_FLAG = BIT_6; // Physical Address Extention
MCE_FLAG = BIT_7; // Machine Check Exception
CX8_FLAG = BIT_8; // CMPXCHG8 Instruction
APIC_FLAG = BIT_9; // Software-accessible local APIC on Chip
BIT_10_FLAG = BIT_10; // Reserved, do not count on value
SEP_FLAG = BIT_11; // Fast System Call
MTRR_FLAG = BIT_12; // Memory Type Range Registers
PGE_FLAG = BIT_13; // Page Global Enable
MCA_FLAG = BIT_14; // Machine Check Architecture
CMOV_FLAG = BIT_15; // Conditional Move Instruction
PAT_FLAG = BIT_16; // Page Attribute Table
PSE36_FLAG = BIT_17; // 36-bit Page Size Extention
PSN_FLAG = BIT_18; // Processor serial number is present and enabled
CLFLSH_FLAG = BIT_19; // CLFLUSH intruction
BIT_20_FLAG = BIT_20; // Reserved, do not count on value
DS_FLAG = BIT_21; // Debug store
ACPI_FLAG = BIT_22; // Thermal monitor and clock control
MMX_FLAG = BIT_23; // MMX technology
FXSR_FLAG = BIT_24; // Fast Floating Point Save and Restore
SSE_FLAG = BIT_25; // Streaming SIMD Extensions
SSE2_FLAG = BIT_26; // Streaming SIMD Extensions 2
SS_FLAG = BIT_27; // Self snoop
HTT_FLAG = BIT_28; // Hyper-threading technology
TM_FLAG = BIT_29; // Thermal monitor
BIT_30_FLAG = BIT_30; // Reserved, do not count on value
PBE_FLAG = BIT_31; // Pending Break Enable
{ Standard Intel Feature Flags }
INTEL_FPU = BIT_0; // Floating-Point unit on chip
INTEL_VME = BIT_1; // Virtual Mode Extention
INTEL_DE = BIT_2; // Debugging Extention
INTEL_PSE = BIT_3; // Page Size Extention
INTEL_TSC = BIT_4; // Time Stamp Counter
INTEL_MSR = BIT_5; // Model Specific Registers
INTEL_PAE = BIT_6; // Physical Address Extention
INTEL_MCE = BIT_7; // Machine Check Exception
INTEL_CX8 = BIT_8; // CMPXCHG8 Instruction
INTEL_APIC = BIT_9; // Software-accessible local APIC on Chip
INTEL_BIT_10 = BIT_10; // Reserved, do not count on value
INTEL_SEP = BIT_11; // Fast System Call
INTEL_MTRR = BIT_12; // Memory Type Range Registers
INTEL_PGE = BIT_13; // Page Global Enable
INTEL_MCA = BIT_14; // Machine Check Architecture
INTEL_CMOV = BIT_15; // Conditional Move Instruction
INTEL_PAT = BIT_16; // Page Attribute Table
INTEL_PSE36 = BIT_17; // 36-bit Page Size Extention
INTEL_PSN = BIT_18; // Processor serial number is present and enabled
INTEL_CLFLSH = BIT_19; // CLFLUSH intruction
INTEL_BIT_20 = BIT_20; // Reserved, do not count on value
INTEL_DS = BIT_21; // Debug store
INTEL_ACPI = BIT_22; // Thermal monitor and clock control
INTEL_MMX = BIT_23; // MMX technology
INTEL_FXSR = BIT_24; // Fast Floating Point Save and Restore
INTEL_SSE = BIT_25; // Streaming SIMD Extensions
INTEL_SSE2 = BIT_26; // Streaming SIMD Extensions 2
INTEL_SS = BIT_27; // Self snoop
INTEL_HTT = BIT_28; // Hyper-threading technology
INTEL_TM = BIT_29; // Thermal monitor
INTEL_BIT_30 = BIT_30; // Reserved, do not count on value
INTEL_PBE = BIT_31; // Pending Break Enable
{ Extended Intel Feature Flags }
EINTEL_SSE3 = BIT_0; // Streaming SIMD Extensions 3
EINTEL_BIT_1 = BIT_1; // Reserved, do not count on value
EINTEL_BIT_2 = BIT_2; // Reserved, do not count on value
EINTEL_MONITOR = BIT_3; // Monitor/MWAIT
EINTEL_DSCPL = BIT_4; // CPL Qualified debug Store
EINTEL_BIT_5 = BIT_5; // Reserved, do not count on value
EINTEL_BIT_6 = BIT_6; // Reserved, do not count on value
EINTEL_EST = BIT_7; // Enhanced Intel Speedstep technology
EINTEL_TM2 = BIT_8; // Thermal monitor 2
EINTEL_BIT_9 = BIT_9; // Reserved, do not count on value
EINTEL_CNXTID = BIT_10; // L1 Context ID
EINTEL_BIT_11 = BIT_11; // Reserved, do not count on value
EINTEL_BIT_12 = BIT_12; // Reserved, do not count on value
EINTEL_BIT_13 = BIT_13; // Reserved, do not count on value
EINTEL_XTPR = BIT_14; // Send Task Priority messages
EINTEL_BIT_15 = BIT_15; // Reserved, do not count on value
EINTEL_BIT_16 = BIT_16; // Reserved, do not count on value
EINTEL_BIT_17 = BIT_17; // Reserved, do not count on value
EINTEL_BIT_18 = BIT_18; // Reserved, do not count on value
EINTEL_BIT_19 = BIT_19; // Reserved, do not count on value
EINTEL_BIT_20 = BIT_20; // Reserved, do not count on value
EINTEL_BIT_21 = BIT_21; // Reserved, do not count on value
EINTEL_BIT_22 = BIT_22; // Reserved, do not count on value
EINTEL_BIT_23 = BIT_23; // Reserved, do not count on value
EINTEL_BIT_24 = BIT_24; // Reserved, do not count on value
EINTEL_BIT_25 = BIT_25; // Reserved, do not count on value
EINTEL_BIT_26 = BIT_26; // Reserved, do not count on value
EINTEL_BIT_27 = BIT_27; // Reserved, do not count on value
EINTEL_BIT_28 = BIT_28; // Reserved, do not count on value
EINTEL_BIT_29 = BIT_29; // Reserved, do not count on value
EINTEL_BIT_30 = BIT_30; // Reserved, do not count on value
EINTEL_BIT_31 = BIT_31; // Reserved, do not count on value
{ Extended Intel 64 Bits Feature Flags }
EINTEL64_BIT_0 = BIT_0; // Reserved, do not count on value
EINTEL64_BIT_1 = BIT_1; // Reserved, do not count on value
EINTEL64_BIT_2 = BIT_2; // Reserved, do not count on value
EINTEL64_BIT_3 = BIT_3; // Reserved, do not count on value
EINTEL64_BIT_4 = BIT_4; // Reserved, do not count on value
EINTEL64_BIT_5 = BIT_5; // Reserved, do not count on value
EINTEL64_BIT_6 = BIT_6; // Reserved, do not count on value
EINTEL64_BIT_7 = BIT_7; // Reserved, do not count on value
EINTEL64_BIT_8 = BIT_8; // Reserved, do not count on value
EINTEL64_BIT_9 = BIT_9; // Reserved, do not count on value
EINTEL64_BIT_10 = BIT_10; // Reserved, do not count on value
EINTEL64_SYS = BIT_11; // 64 Bit - SYSCALL SYSRET
EINTEL64_BIT_12 = BIT_12; // Reserved, do not count on value
EINTEL64_BIT_13 = BIT_13; // Reserved, do not count on value
EINTEL64_BIT_14 = BIT_14; // Reserved, do not count on value
EINTEL64_BIT_15 = BIT_15; // Reserved, do not count on value
EINTEL64_BIT_16 = BIT_16; // Reserved, do not count on value
EINTEL64_BIT_17 = BIT_17; // Reserved, do not count on value
EINTEL64_BIT_18 = BIT_18; // Reserved, do not count on value
EINTEL64_BIT_19 = BIT_19; // Reserved, do not count on value
EINTEL64_BIT_20 = BIT_20; // Reserved, do not count on value
EINTEL64_BIT_21 = BIT_21; // Reserved, do not count on value
EINTEL64_BIT_22 = BIT_22; // Reserved, do not count on value
EINTEL64_BIT_23 = BIT_23; // Reserved, do not count on value
EINTEL64_BIT_24 = BIT_24; // Reserved, do not count on value
EINTEL64_BIT_25 = BIT_25; // Reserved, do not count on value
EINTEL64_BIT_26 = BIT_26; // Reserved, do not count on value
EINTEL64_BIT_27 = BIT_27; // Reserved, do not count on value
EINTEL64_BIT_28 = BIT_28; // Reserved, do not count on value
EINTEL64_EM64T = BIT_29; // Intel® Extended Memory 64 Technology
EINTEL64_BIT_30 = BIT_30; // Reserved, do not count on value
EINTEL64_BIT_31 = BIT_31; // Reserved, do not count on value
{ AMD Standard Feature Flags }
AMD_FPU = BIT_0; // Floating-Point unit on chip
AMD_VME = BIT_1; // Virtual Mode Extention
AMD_DE = BIT_2; // Debugging Extention
AMD_PSE = BIT_3; // Page Size Extention
AMD_TSC = BIT_4; // Time Stamp Counter
AMD_MSR = BIT_5; // Model Specific Registers
AMD_PAE = BIT_6; // Physical address Extensions
AMD_MCE = BIT_7; // Machine Check Exception
AMD_CX8 = BIT_8; // CMPXCHG8 Instruction
AMD_APIC = BIT_9; // Software-accessible local APIC on Chip
AMD_BIT_10 = BIT_10; // Reserved, do not count on value
AMD_SEP_BIT = BIT_11; // SYSENTER and SYSEXIT instructions
AMD_MTRR = BIT_12; // Memory Type Range Registers
AMD_PGE = BIT_13; // Page Global Enable
AMD_MCA = BIT_14; // Machine Check Architecture
AMD_CMOV = BIT_15; // Conditional Move Instruction
AMD_PAT = BIT_16; // Page Attribute Table
AMD_PSE2 = BIT_17; // Page Size Extensions
AMD_BIT_18 = BIT_18; // Reserved, do not count on value
AMD_CLFLSH = BIT_19; // CLFLUSH instruction
AMD_BIT_20 = BIT_20; // Reserved, do not count on value
AMD_BIT_21 = BIT_21; // Reserved, do not count on value
AMD_BIT_22 = BIT_22; // Reserved, do not count on value
AMD_MMX = BIT_23; // MMX technology
AMD_FX = BIT_24; // FXSAVE and FXSTORE instructions
AMD_SSE = BIT_25; // SSE Extensions
AMD_SSE2 = BIT_26; // SSE2 Extensions
AMD_BIT_27 = BIT_27; // Reserved, do not count on value
AMD_BIT_28 = BIT_28; // Reserved, do not count on value
AMD_BIT_29 = BIT_29; // Reserved, do not count on value
AMD_BIT_30 = BIT_30; // Reserved, do not count on value
AMD_BIT_31 = BIT_31; // Reserved, do not count on value
{ AMD Enhanced Feature Flags }
EAMD_FPU = BIT_0; // Floating-Point unit on chip
EAMD_VME = BIT_1; // Virtual Mode Extention
EAMD_DE = BIT_2; // Debugging Extention
EAMD_PSE = BIT_3; // Page Size Extention
EAMD_TSC = BIT_4; // Time Stamp Counter
EAMD_MSR = BIT_5; // Model Specific Registers
EAMD_PAE = BIT_6; // Physical-address extensions
EAMD_MCE = BIT_7; // Machine Check Exception
EAMD_CX8 = BIT_8; // CMPXCHG8 Instruction
EAMD_APIC = BIT_9; // Advanced Programmable Interrupt Controler
EAMD_BIT_10 = BIT_10; // Reserved, do not count on value
EAMD_SEP = BIT_11; // Fast System Call
EAMD_MTRR = BIT_12; // Memory-Type Range Registers
EAMD_PGE = BIT_13; // Page Global Enable
EAMD_MCA = BIT_14; // Machine Check Architecture
EAMD_CMOV = BIT_15; // Conditional Move Intructions
EAMD_PAT = BIT_16; // Page Attributes Table
EAMD_PSE2 = BIT_17; // Page Size Extensions
EAMD_BIT_18 = BIT_18; // Reserved, do not count on value
EAMD_BIT_19 = BIT_19; // Reserved, do not count on value
EAMD_NEPP = BIT_20; // No-Execute Page Protection
EAMD_BIT_21 = BIT_21; // Reserved, do not count on value
EAMD_EXMMX = BIT_22; // AMD Extensions to MMX technology
EAMD_MMX = BIT_23; // MMX technology
EAMD_FX = BIT_24; // FXSAVE and FXSTORE instructions
EAMD_FFX = BIT_25; // Fast FXSAVE and FXSTORE instructions
EAMD_BIT_26 = BIT_26; // Reserved, do not count on value
EAMD_BIT_27 = BIT_27; // Reserved, do not count on value
EAMD_BIT_28 = BIT_28; // Reserved, do not count on value
EAMD_LONG = BIT_29; // Long Mode (64-bit Core)
EAMD_EX3DNOW = BIT_30; // AMD Extensions to 3DNow! intructions
EAMD_3DNOW = BIT_31; // AMD 3DNOW! Technology
{ AMD Power Management Features Flags }
PAMD_TEMPSENSOR = $00000001; // Temperature Sensor
PAMD_FREQUENCYID = $00000002; // Frequency ID Control
PAMD_VOLTAGEID = $00000004; // Voltage ID Control
PAMD_THERMALTRIP = $00000008; // Thermal Trip
PAMD_THERMALMONITOR = $00000010; // Thermal Monitoring
PAMD_SOFTTHERMCONTROL = $00000020; // Software Thermal Control
{ AMD TLB and L1 Associativity constants }
AMD_ASSOC_RESERVED = 0;
AMD_ASSOC_DIRECT = 1;
// 2 to 254 = direct value to the associativity
AMD_ASSOC_FULLY = 255;
{ AMD L2 Cache Associativity constants }
AMD_L2_ASSOC_DISABLED = 0;
AMD_L2_ASSOC_DIRECT = 1;
AMD_L2_ASSOC_2WAY = 2;
AMD_L2_ASSOC_4WAY = 4;
AMD_L2_ASSOC_8WAY = 6;
AMD_L2_ASSOC_16WAY = 8;
AMD_L2_ASSOC_FULLY = 15;
{ VIA Standard Feature Flags }
VIA_FPU = BIT_0; // FPU present
VIA_VME = BIT_1; // Virtual Mode Extension
VIA_DE = BIT_2; // Debugging extensions
VIA_PSE = BIT_3; // Page Size Extensions (4MB)
VIA_TSC = BIT_4; // Time Stamp Counter
VIA_MSR = BIT_5; // Model Specific Registers
VIA_PAE = BIT_6; // Physical Address Extension
VIA_MCE = BIT_7; // Machine Check Exception
VIA_CX8 = BIT_8; // CMPXCHG8B instruction
VIA_APIC = BIT_9; // APIC supported
VIA_BIT_10 = BIT_10; // Reserved, do not count on value
VIA_SEP = BIT_11; // Fast System Call
VIA_MTRR = BIT_12; // Memory Range Registers
VIA_PTE = BIT_13; // PTE Global Bit
VIA_MCA = BIT_14; // Machine Check Architecture
VIA_CMOVE = BIT_15; // Conditional Move
VIA_PAT = BIT_16; // Page Attribute Table
VIA_PSE2 = BIT_17; // 36-bit Page Size Extension
VIA_SNUM = BIT_18; // Processor serial number
VIA_BIT_19 = BIT_19; // Reserved, do not count on value
VIA_BIT_20 = BIT_20; // Reserved, do not count on value
VIA_BIT_21 = BIT_21; // Reserved, do not count on value
VIA_BIT_22 = BIT_22; // Reserved, do not count on value
VIA_MMX = BIT_23; // MMX
VIA_FX = BIT_24; // FXSAVE and FXSTORE instructions
VIA_SSE = BIT_25; // Streaming SIMD Extension
VIA_BIT_26 = BIT_26; // Reserved, do not count on value
VIA_BIT_27 = BIT_27; // Reserved, do not count on value
VIA_BIT_28 = BIT_28; // Reserved, do not count on value
VIA_BIT_29 = BIT_29; // Reserved, do not count on value
VIA_BIT_30 = BIT_30; // Reserved, do not count on value
VIA_3DNOW = BIT_31; // 3DNow! Technology
{ VIA Extended Feature Flags }
EVIA_AIS = BIT_0; // Alternate Instruction Set
EVIA_AISE = BIT_1; // Alternate Instruction Set Enabled
EVIA_NO_RNG = BIT_2; // NO Random Number Generator
EVIA_RNGE = BIT_3; // Random Number Generator Enabled
EVIA_MSR = BIT_4; // Longhaul MSR 0x110A available
EVIA_FEMMS = BIT_5; // FEMMS instruction Present
EVIA_NO_ACE = BIT_6; // Advanced Cryptography Engine NOT Present
EVIA_ACEE = BIT_7; // ACE Enabled
EVIA_BIT_8 = BIT_8; // Reserved, do not count on value
EVIA_BIT_9 = BIT_9; // Reserved, do not count on value
EVIA_BIT_10 = BIT_10; // Reserved, do not count on value
EVIA_BIT_11 = BIT_11; // Reserved, do not count on value
EVIA_BIT_12 = BIT_12; // Reserved, do not count on value
EVIA_BIT_13 = BIT_13; // Reserved, do not count on value
EVIA_BIT_14 = BIT_14; // Reserved, do not count on value
EVIA_BIT_15 = BIT_15; // Reserved, do not count on value
EVIA_BIT_16 = BIT_16; // Reserved, do not count on value
EVIA_BIT_17 = BIT_17; // Reserved, do not count on value
EVIA_BIT_18 = BIT_18; // Reserved, do not count on value
EVIA_BIT_19 = BIT_19; // Reserved, do not count on value
EVIA_BIT_20 = BIT_20; // Reserved, do not count on value
EVIA_BIT_21 = BIT_21; // Reserved, do not count on value
EVIA_BIT_22 = BIT_22; // Reserved, do not count on value
EVIA_BIT_23 = BIT_23; // Reserved, do not count on value
EVIA_BIT_24 = BIT_24; // Reserved, do not count on value
EVIA_BIT_25 = BIT_25; // Reserved, do not count on value
EVIA_BIT_26 = BIT_26; // Reserved, do not count on value
EVIA_BIT_27 = BIT_27; // Reserved, do not count on value
EVIA_BIT_28 = BIT_28; // Reserved, do not count on value
EVIA_BIT_29 = BIT_29; // Reserved, do not count on value
EVIA_BIT_30 = BIT_30; // Reserved, do not count on value
EVIA_BIT_31 = BIT_31; // Reserved, do not count on value
{ Cyrix Standard Feature Flags }
CYRIX_FPU = BIT_0; // Floating-Point unit on chip
CYRIX_VME = BIT_1; // Virtual Mode Extention
CYRIX_DE = BIT_2; // Debugging Extention
CYRIX_PSE = BIT_3; // Page Size Extention
CYRIX_TSC = BIT_4; // Time Stamp Counter
CYRIX_MSR = BIT_5; // Model Specific Registers
CYRIX_PAE = BIT_6; // Physical Address Extention
CYRIX_MCE = BIT_7; // Machine Check Exception
CYRIX_CX8 = BIT_8; // CMPXCHG8 Instruction
CYRIX_APIC = BIT_9; // Software-accessible local APIC on Chip
CYRIX_BIT_10 = BIT_10; // Reserved, do not count on value
CYRIX_BIT_11 = BIT_11; // Reserved, do not count on value
CYRIX_MTRR = BIT_12; // Memory Type Range Registers
CYRIX_PGE = BIT_13; // Page Global Enable
CYRIX_MCA = BIT_14; // Machine Check Architecture
CYRIX_CMOV = BIT_15; // Conditional Move Instruction
CYRIX_BIT_16 = BIT_16; // Reserved, do not count on value
CYRIX_BIT_17 = BIT_17; // Reserved, do not count on value
CYRIX_BIT_18 = BIT_18; // Reserved, do not count on value
CYRIX_BIT_19 = BIT_19; // Reserved, do not count on value
CYRIX_BIT_20 = BIT_20; // Reserved, do not count on value
CYRIX_BIT_21 = BIT_21; // Reserved, do not count on value
CYRIX_BIT_22 = BIT_22; // Reserved, do not count on value
CYRIX_MMX = BIT_23; // MMX technology
CYRIX_BIT_24 = BIT_24; // Reserved, do not count on value
CYRIX_BIT_25 = BIT_25; // Reserved, do not count on value
CYRIX_BIT_26 = BIT_26; // Reserved, do not count on value
CYRIX_BIT_27 = BIT_27; // Reserved, do not count on value
CYRIX_BIT_28 = BIT_28; // Reserved, do not count on value
CYRIX_BIT_29 = BIT_29; // Reserved, do not count on value
CYRIX_BIT_30 = BIT_30; // Reserved, do not count on value
CYRIX_BIT_31 = BIT_31; // Reserved, do not count on value
{ Cyrix Enhanced Feature Flags }
ECYRIX_FPU = BIT_0; // Floating-Point unit on chip
ECYRIX_VME = BIT_1; // Virtual Mode Extention
ECYRIX_DE = BIT_2; // Debugging Extention
ECYRIX_PSE = BIT_3; // Page Size Extention
ECYRIX_TSC = BIT_4; // Time Stamp Counter
ECYRIX_MSR = BIT_5; // Model Specific Registers
ECYRIX_PAE = BIT_6; // Physical Address Extention
ECYRIX_MCE = BIT_7; // Machine Check Exception
ECYRIX_CX8 = BIT_8; // CMPXCHG8 Instruction
ECYRIX_APIC = BIT_9; // Software-accessible local APIC on Chip
ECYRIX_SEP = BIT_10; // Fast System Call
ECYRIX_BIT_11 = BIT_11; // Reserved, do not count on value
ECYRIX_MTRR = BIT_12; // Memory Type Range Registers
ECYRIX_PGE = BIT_13; // Page Global Enable
ECYRIX_MCA = BIT_14; // Machine Check Architecture
ECYRIX_ICMOV = BIT_15; // Integer Conditional Move Instruction
ECYRIX_FCMOV = BIT_16; // Floating Point Conditional Move Instruction
ECYRIX_BIT_17 = BIT_17; // Reserved, do not count on value
ECYRIX_BIT_18 = BIT_18; // Reserved, do not count on value
ECYRIX_BIT_19 = BIT_19; // Reserved, do not count on value
ECYRIX_BIT_20 = BIT_20; // Reserved, do not count on value
ECYRIX_BIT_21 = BIT_21; // Reserved, do not count on value
ECYRIX_BIT_22 = BIT_22; // Reserved, do not count on value
ECYRIX_MMX = BIT_23; // MMX technology
ECYRIX_EMMX = BIT_24; // Extended MMX Technology
ECYRIX_BIT_25 = BIT_25; // Reserved, do not count on value
ECYRIX_BIT_26 = BIT_26; // Reserved, do not count on value
ECYRIX_BIT_27 = BIT_27; // Reserved, do not count on value
ECYRIX_BIT_28 = BIT_28; // Reserved, do not count on value
ECYRIX_BIT_29 = BIT_29; // Reserved, do not count on value
ECYRIX_BIT_30 = BIT_30; // Reserved, do not count on value
ECYRIX_BIT_31 = BIT_31; // Reserved, do not count on value
{ Transmeta Features }
TRANSMETA_FPU = BIT_0; // Floating-Point unit on chip
TRANSMETA_VME = BIT_1; // Virtual Mode Extention
TRANSMETA_DE = BIT_2; // Debugging Extention
TRANSMETA_PSE = BIT_3; // Page Size Extention
TRANSMETA_TSC = BIT_4; // Time Stamp Counter
TRANSMETA_MSR = BIT_5; // Model Specific Registers
TRANSMETA_BIT_6 = BIT_6; // Reserved, do not count on value
TRANSMETA_BIT_7 = BIT_7; // Reserved, do not count on value
TRANSMETA_CX8 = BIT_8; // CMPXCHG8 Instruction
TRANSMETA_BIT_9 = BIT_9; // Reserved, do not count on value
TRANSMETA_BIT_10 = BIT_10; // Reserved, do not count on value
TRANSMETA_SEP = BIT_11; // Fast system Call Extensions
TRANSMETA_BIT_12 = BIT_12; // Reserved, do not count on value
TRANSMETA_BIT_13 = BIT_13; // Reserved, do not count on value
TRANSMETA_BIT_14 = BIT_14; // Reserved, do not count on value
TRANSMETA_CMOV = BIT_15; // Conditional Move Instruction
TRANSMETA_BIT_16 = BIT_16; // Reserved, do not count on value
TRANSMETA_BIT_17 = BIT_17; // Reserved, do not count on value
TRANSMETA_PSN = BIT_18; // Processor Serial Number
TRANSMETA_BIT_19 = BIT_19; // Reserved, do not count on value
TRANSMETA_BIT_20 = BIT_20; // Reserved, do not count on value
TRANSMETA_BIT_21 = BIT_21; // Reserved, do not count on value
TRANSMETA_BIT_22 = BIT_22; // Reserved, do not count on value
TRANSMETA_MMX = BIT_23; // MMX technology
TRANSMETA_BIT_24 = BIT_24; // Reserved, do not count on value
TRANSMETA_BIT_25 = BIT_25; // Reserved, do not count on value
TRANSMETA_BIT_26 = BIT_26; // Reserved, do not count on value
TRANSMETA_BIT_27 = BIT_27; // Reserved, do not count on value
TRANSMETA_BIT_28 = BIT_28; // Reserved, do not count on value
TRANSMETA_BIT_29 = BIT_29; // Reserved, do not count on value
TRANSMETA_BIT_30 = BIT_30; // Reserved, do not count on value
TRANSMETA_BIT_31 = BIT_31; // Reserved, do not count on value
{ Extended Transmeta Features }
ETRANSMETA_FPU = BIT_0; // Floating-Point unit on chip
ETRANSMETA_VME = BIT_1; // Virtual Mode Extention
ETRANSMETA_DE = BIT_2; // Debugging Extention
ETRANSMETA_PSE = BIT_3; // Page Size Extention
ETRANSMETA_TSC = BIT_4; // Time Stamp Counter
ETRANSMETA_MSR = BIT_5; // Model Specific Registers
ETRANSMETA_BIT_6 = BIT_6; // Reserved, do not count on value
ETRANSMETA_BIT_7 = BIT_7; // Reserved, do not count on value
ETRANSMETA_CX8 = BIT_8; // CMPXCHG8 Instruction
ETRANSMETA_BIT_9 = BIT_9; // Reserved, do not count on value
ETRANSMETA_BIT_10 = BIT_10; // Reserved, do not count on value
ETRANSMETA_BIT_11 = BIT_11; // Reserved, do not count on value
ETRANSMETA_BIT_12 = BIT_12; // Reserved, do not count on value
ETRANSMETA_BIT_13 = BIT_13; // Reserved, do not count on value
ETRANSMETA_BIT_14 = BIT_14; // Reserved, do not count on value
ETRANSMETA_CMOV = BIT_15; // Conditional Move Instruction
ETRANSMETA_FCMOV = BIT_16; // Float Conditional Move Instruction
ETRANSMETA_BIT_17 = BIT_17; // Reserved, do not count on value
ETRANSMETA_BIT_18 = BIT_18; // Reserved, do not count on value
ETRANSMETA_BIT_19 = BIT_19; // Reserved, do not count on value
ETRANSMETA_BIT_20 = BIT_20; // Reserved, do not count on value
ETRANSMETA_BIT_21 = BIT_21; // Reserved, do not count on value
ETRANSMETA_BIT_22 = BIT_22; // Reserved, do not count on value
ETRANSMETA_MMX = BIT_23; // MMX technology
ETRANSMETA_BIT_24 = BIT_24; // Reserved, do not count on value
ETRANSMETA_BIT_25 = BIT_25; // Reserved, do not count on value
ETRANSMETA_BIT_26 = BIT_26; // Reserved, do not count on value
ETRANSMETA_BIT_27 = BIT_27; // Reserved, do not count on value
ETRANSMETA_BIT_28 = BIT_28; // Reserved, do not count on value
ETRANSMETA_BIT_29 = BIT_29; // Reserved, do not count on value
ETRANSMETA_BIT_30 = BIT_30; // Reserved, do not count on value
ETRANSMETA_BIT_31 = BIT_31; // Reserved, do not count on value
{ Transmeta Specific Features }
STRANSMETA_RECOVERY = BIT_0; // Recovery Mode
STRANSMETA_LONGRUN = BIT_1; // Long Run
STRANSMETA_BIT_2 = BIT_2; // Debugging Extention
STRANSMETA_LRTI = BIT_3; // Long Run Table Interface
STRANSMETA_BIT_4 = BIT_4; // Reserved, do not count on value
STRANSMETA_BIT_5 = BIT_5; // Reserved, do not count on value
STRANSMETA_BIT_6 = BIT_6; // Reserved, do not count on value
STRANSMETA_PTTI1 = BIT_7; // Persistent Translation Technology 1.x
STRANSMETA_PTTI2 = BIT_8; // Persistent Translation Technology 2.0
STRANSMETA_BIT_9 = BIT_9; // Reserved, do not count on value
STRANSMETA_BIT_10 = BIT_10; // Reserved, do not count on value
STRANSMETA_BIT_11 = BIT_11; // Reserved, do not count on value
STRANSMETA_BIT_12 = BIT_12; // Reserved, do not count on value
STRANSMETA_BIT_13 = BIT_13; // Reserved, do not count on value
STRANSMETA_BIT_14 = BIT_14; // Reserved, do not count on value
STRANSMETA_BIT_15 = BIT_15; // Reserved, do not count on value
STRANSMETA_BIT_16 = BIT_16; // Reserved, do not count on value
STRANSMETA_BIT_17 = BIT_17; // Reserved, do not count on value
STRANSMETA_BIT_18 = BIT_18; // Reserved, do not count on value
STRANSMETA_BIT_19 = BIT_19; // Reserved, do not count on value
STRANSMETA_BIT_20 = BIT_20; // Reserved, do not count on value
STRANSMETA_BIT_21 = BIT_21; // Reserved, do not count on value
STRANSMETA_BIT_22 = BIT_22; // Reserved, do not count on value
STRANSMETA_BIT_23 = BIT_23; // Reserved, do not count on value
STRANSMETA_BIT_24 = BIT_24; // Reserved, do not count on value
STRANSMETA_BIT_25 = BIT_25; // Reserved, do not count on value
STRANSMETA_BIT_26 = BIT_26; // Reserved, do not count on value
STRANSMETA_BIT_27 = BIT_27; // Reserved, do not count on value
STRANSMETA_BIT_28 = BIT_28; // Reserved, do not count on value
STRANSMETA_BIT_29 = BIT_29; // Reserved, do not count on value
STRANSMETA_BIT_30 = BIT_30; // Reserved, do not count on value
STRANSMETA_BIT_31 = BIT_31; // Reserved, do not count on value
{ Constants of bits of the MXCSR register - Intel and AMD processors that support SSE instructions}
MXCSR_IE = BIT_0; // Invalid Operation flag
MXCSR_DE = BIT_1; // Denormal flag
MXCSR_ZE = BIT_2; // Divide by Zero flag
MXCSR_OE = BIT_3; // Overflow flag
MXCSR_UE = BIT_4; // Underflow flag
MXCSR_PE = BIT_5; // Precision flag
MXCSR_DAZ = BIT_6; // Denormal are Zero flag
MXCSR_IM = BIT_7; // Invalid Operation mask
MXCSR_DM = BIT_8; // Denormal mask
MXCSR_ZM = BIT_9; // Divide by Zero mask
MXCSR_OM = BIT_10; // Overflow mask
MXCSR_UM = BIT_11; // Underflow mask
MXCSR_PM = BIT_12; // Precision mask
MXCSR_RC1 = BIT_13; // Rounding control, bit 1
MXCSR_RC2 = BIT_14; // Rounding control, bit 2
MXCSR_RC = MXCSR_RC1 or MXCSR_RC2; // Rounding control
MXCSR_FZ = BIT_15; // Flush to Zero
const
IntelCacheDescription: array [0..50] of TCacheInfo = (
(D: $00; Family: cfOther; I: RsIntelCacheDescr00),
(D: $01; Family: cfInstructionTLB; Size: 4; WaysOfAssoc: 4; Entries: 32; I: RsIntelCacheDescr01), // Instruction TLB: 4 KByte Pages, 4-way set associative, 32 entries
(D: $02; Family: cfInstructionTLB; Size: 4096; WaysOfAssoc: 4; Entries: 2; I: RsIntelCacheDescr02), // Instruction TLB: 4 MByte Pages, 4-way set associative, 2 entries
(D: $03; Family: cfDataTLB; Size: 4; WaysOfAssoc: 4; Entries: 64; I: RsIntelCacheDescr03), // Data TLB: 4KByte Pages, 4-way set associative, 64 entries
(D: $04; Family: cfDataTLB; Size: 4096; WaysOfAssoc: 4; Entries: 8; I: RsIntelCacheDescr04), // Data TLB: 4MByte Pages, 4-way set associative, 8 entries
(D: $06; Family: cfL1InstructionCache; Size: 8; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr06), // 1st-level instruction cache: 8 KBytes, 4-way set associative, 32 byte line size
(D: $08; Family: cfL1InstructionCache; Size: 16; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr08), // 1st-level instruction cache: 16 KBytes, 4-way set associative, 32 byte line size
(D: $0A; Family: cfL1DataCache; Size: 8; WaysOfAssoc: 2; LineSize: 32; I: RsIntelCacheDescr0A), // 1st-level data cache: 8 KBytes, 2-way set associative, 32 byte line size
(D: $0C; Family: cfL1DataCache; Size: 16; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr0C), // 1st-level data cache: 16 KBytes, 4-way set associative, 32 byte line size
(D: $22; Family: cfL3Cache; Size: 512; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 2; I: RsIntelCacheDescr22), // 3rd-level cache: 512 KBytes, 4-way set associative, 64 byte line size, 2 lines per sector
(D: $23; Family: cfL3Cache; Size: 1024; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; I: RsIntelCacheDescr23), // 3rd-level cache: 1 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector
(D: $25; Family: cfL3Cache; Size: 2048; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; I: RsIntelCacheDescr25), // 3rd-level cache: 2 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector
(D: $29; Family: cfL3Cache; Size: 4096; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; I: RsIntelCacheDescr29), // 3rd-level cache: 4M Bytes, 8-way set associative, 64 byte line size, 2 lines per sector
(D: $2C; Family: cfL1DataCache; Size: 32; WaysOfAssoc: 8; LineSize: 64; I: RsIntelCacheDescr2C), // 1st-level data cache: 32K Bytes, 8-way set associative, 64 byte line size
(D: $30; Family: cfL1InstructionCache; Size: 32; WaysOfAssoc: 8; LineSize: 64; I: RsIntelCacheDescr30), // 1st-level instruction cache: 32K Bytes, 8-way set associative, 64 byte line size
(D: $40; Family: cfOther; I: RsIntelCacheDescr40), // No 2nd-level cache or, if processor contains a valid 2nd-level cache, no 3rd-level cache
(D: $41; Family: cfL2Cache; Size: 128; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr41), // 2nd-level cache: 128 KBytes, 4-way set associative, 32 byte line size
(D: $42; Family: cfL2Cache; Size: 256; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr42), // 2nd-level cache: 256 KBytes, 4-way set associative, 32 byte line size
(D: $43; Family: cfL2Cache; Size: 512; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr43), // 2nd-level cache: 512 KBytes, 4-way set associative, 32 byte line size
(D: $44; Family: cfL2Cache; Size: 1024; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr44), // 2nd-level cache: 1 MByte, 4-way set associative, 32 byte line size
(D: $45; Family: cfL2Cache; Size: 2048; WaysOfAssoc: 4; LineSize: 32; I: RsIntelCacheDescr45), // 2nd-level cache: 2 MByte, 4-way set associative, 32 byte line size
(D: $50; Family: cfInstructionTLB; Size: 4096; Entries: 64; I: RsIntelCacheDescr50), // Instruction TLB: 4 KByte and 2-MByte or 4-MByte pages, 64 entries
(D: $51; Family: cfInstructionTLB; Size: 4096; Entries: 128; I: RsIntelCacheDescr51), // Instruction TLB: 4 KByte and 2-MByte or 4-MByte pages, 128 entries
(D: $52; Family: cfInstructionTLB; Size: 4096; Entries: 256; I: RsIntelCacheDescr52), // Instruction TLB: 4 KByte and 2-MByte or 4-MByte pages, 256 entries
(D: $5B; Family: cfDataTLB; Size: 4096; Entries: 64; I: RsIntelCacheDescr5B), // Data TLB: 4 KByte and 4 MByte pages, 64 entries
(D: $5C; Family: cfDataTLB; Size: 4096; Entries: 128; I: RsIntelCacheDescr5C), // Data TLB: 4 KByte and 4 MByte pages,128 entries
(D: $5D; Family: cfDataTLB; Size: 4096; Entries: 256; I: RsIntelCacheDescr5D), // Data TLB: 4 KByte and 4 MByte pages,256 entries
(D: $60; Family: cfL1DataCache; Size: 16; WaysOfAssoc: 8; LineSize: 64; I: RsIntelCacheDescr60), // 1st-level data cache: 16 KByte, 8-way set associative, 64 byte line size
(D: $66; Family: cfL1DataCache; Size: 8; WaysOfAssoc: 4; LineSize: 64; I: RsIntelCacheDescr66), // 1st-level data cache: 8 KByte, 4-way set associative, 64 byte line size
(D: $67; Family: cfL1DataCache; Size: 16; WaysOfAssoc: 4; LineSize: 64; I: RsIntelCacheDescr67), // 1st-level data cache: 16 KByte, 4-way set associative, 64 byte line size
(D: $68; Family: cfL1DataCache; Size: 32; WaysOfAssoc: 4; LineSize: 64; I: RsIntelCacheDescr68), // 1st-level data cache: 32 KByte, 4-way set associative, 64 byte line size
(D: $70; Family: cfTrace; Size: 12; WaysOfAssoc: 8; I: RsIntelCacheDescr70), // Trace cache: 12 K-µop, 8-way set associative
(D: $71; Family: cfTrace; Size: 16; WaysOfAssoc: 8; I: RsIntelCacheDescr71), // Trace cache: 16 K-µop, 8-way set associative
(D: $72; Family: cfTrace; Size: 32; WaysOfAssoc: 8; I: RsIntelCacheDescr72), // Trace cache: 32 K-µop, 8-way set associative
(D: $78; Family: cfL2Cache; Size: 1024; WaysOfAssoc: 4; LineSize: 64; I: RsIntelCacheDescr78), // 2nd-level cache: 1 MByte, 4-way set associative, 64byte line size
(D: $79; Family: cfL2Cache; Size: 128; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; I: RsIntelCacheDescr79), // 2nd-level cache: 128 KByte, 8-way set associative, 64 byte line size, 2 lines per sector
(D: $7A; Family: cfL2Cache; Size: 256; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; I: RsIntelCacheDescr7A), // 2nd-level cache: 256 KByte, 8-way set associative, 64 byte line size, 2 lines per sector
(D: $7B; Family: cfL2Cache; Size: 512; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; I: RsIntelCacheDescr7B), // 2nd-level cache: 512 KByte, 8-way set associative, 64 byte line size, 2 lines per sector
(D: $7C; Family: cfL2Cache; Size: 1024; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; I: RsIntelCacheDescr7C), // 2nd-level cache: 1 MByte, 8-way set associative, 64 byte line size, 2 lines per sector
(D: $7D; Family: cfL2Cache; Size: 2048; WaysOfAssoc: 8; LineSize: 64; I: RsIntelCacheDescr7D), // 2nd-level cache: 2 MByte, 8-way set associative, 64byte line size
(D: $7F; Family: cfL2Cache; Size: 512; WaysOfAssoc: 2; LineSize: 64; I: RsIntelCacheDescr7F), // 2nd-level cache: 512 KByte, 2-way set associative, 64-byte line size
(D: $82; Family: cfL2Cache; Size: 256; WaysOfAssoc: 8; LineSize: 32; I: RsIntelCacheDescr82), // 2nd-level cache: 256 KByte, 8-way set associative, 32 byte line size
(D: $83; Family: cfL2Cache; Size: 512; WaysOfAssoc: 8; LineSize: 32; I: RsIntelCacheDescr83), // 2nd-level cache: 512 KByte, 8-way set associative, 32 byte line size
(D: $84; Family: cfL2Cache; Size: 1024; WaysOfAssoc: 8; LineSize: 32; I: RsIntelCacheDescr84), // 2nd-level cache: 1 MByte, 8-way set associative, 32 byte line size
(D: $85; Family: cfL2Cache; Size: 2048; WaysOfAssoc: 8; LineSize: 32; I: RsIntelCacheDescr85), // 2nd-level cache: 2 MByte, 8-way set associative, 32 byte line size
(D: $86; Family: cfL2Cache; Size: 512; WaysOfAssoc: 4; LineSize: 64; I: RsIntelCacheDescr86), // 2nd-level cache: 512 KByte, 4-way set associative, 64 byte line size
(D: $87; Family: cfL2Cache; Size: 1024; WaysOfAssoc: 8; LineSize: 64; I: RsIntelCacheDescr87), // 2nd-level cache: 1 MByte, 8-way set associative, 64 byte line size
(D: $B0; Family: cfInstructionTLB; Size: 4; WaysOfAssoc: 4; Entries: 128; I: RsIntelCacheDescrB0), // Instruction TLB: 4 KByte Pages, 4-way set associative, 128 entries
(D: $B3; Family: cfDataTLB; Size: 4; WaysOfAssoc: 4; Entries: 128; I: RsIntelCacheDescrB3), // Data TLB: 4 KByte Pages, 4-way set associative, 128 entries
(D: $F0; Family: cfOther; I: RsIntelCacheDescrF0), // 64-Byte Prefetching
(D: $F1; Family: cfOther; I: RsIntelCacheDescrF1) // 128-Byte Prefetching
);
procedure GetCpuInfo(var CpuInfo: TCpuInfo);
function GetIntelCacheDescription(const D: Byte): string;
function RoundFrequency(const Frequency: Integer): Integer;
{$IFDEF MSWINDOWS}
function GetCPUSpeed(var CpuSpeed: TFreqInfo): Boolean;
{$ENDIF MSWINDOWS}
function CPUID: TCpuInfo;
function TestFDIVInstruction: Boolean;
// Memory Information
{$IFDEF MSWINDOWS}
function GetMaxAppAddress: Cardinal;
function GetMinAppAddress: Cardinal;
{$ENDIF MSWINDOWS}
function GetMemoryLoad: Byte;
function GetSwapFileSize: Cardinal;
function GetSwapFileUsage: Byte;
function GetTotalPhysicalMemory: Cardinal;
function GetFreePhysicalMemory: Cardinal;
{$IFDEF MSWINDOWS}
function GetTotalPageFileMemory: Cardinal;
function GetFreePageFileMemory: Cardinal;
function GetTotalVirtualMemory: Cardinal;
function GetFreeVirtualMemory: Cardinal;
{$ENDIF MSWINDOWS}
// Alloc granularity
procedure RoundToAllocGranularity64(var Value: Int64; Up: Boolean);
procedure RoundToAllocGranularityPtr(var Value: Pointer; Up: Boolean);
{$IFDEF MSWINDOWS}
// 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: Integer;
GdiRes: Integer;
UserRes: Integer;
end;
function IsSystemResourcesMeterPresent: Boolean;
function GetFreeSystemResources(const ResourceType: TFreeSysResKind): Integer; overload;
function GetFreeSystemResources: TFreeSystemResources; overload;
{$ENDIF MSWINDOWS}
// Public global variables
var
ProcessorCount: Cardinal = 0;
AllocGranularity: Cardinal = 0;
PageSize: Cardinal = 0;
{$ENDIF ~CLR}
implementation
uses
SysUtils,
{$IFNDEF CLR}
{$IFDEF MSWINDOWS}
Messages, Winsock, Snmp,
{$IFDEF FPC}
ActiveX, JwaTlHelp32, JwaPsApi,
{$ELSE ~FPC}
TLHelp32, PsApi,
JclShell,
{$ENDIF ~FPC}
JclRegistry, JclWin32,
{$ENDIF MSWINDOWS}
Jcl8087, JclIniFiles,
{$ENDIF ~CLR}
JclBase, JclFileUtils, JclStrings;
{$IFDEF FPC}
{$I JclSysInfo.fpc}
{$ENDIF FPC}
//=== Environment ============================================================
function DelEnvironmentVar(const Name: string): Boolean;
begin
{$IFDEF CLR}
System.Environment.GetEnvironmentVariables.Remove(Name);
Result := True;
{$ELSE ~CLR}
{$IFDEF UNIX}
UnSetEnv(PChar(Name));
Result := True;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
Result := SetEnvironmentVariable(PChar(Name), nil);
{$ENDIF MSWINDOWS}
{$ENDIF ~CLR}
end;
function ExpandEnvironmentVar(var Value: string): Boolean;
{$IFDEF CLR}
begin
Value := System.Environment.ExpandEnvironmentVariables(Value);
Result := True;
end;
{$ELSE ~CLR}
{$IFDEF UNIX}
begin
Result := True;
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
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;
{$ENDIF MSWINDOWS}
{$ENDIF ~CLR}
{$IFDEF UNIX}
function GetEnvironmentVar(const Name: string; var Value: string): Boolean;
begin
Value := getenv(PChar(Name));
Result := Value <> '';
end;
function GetEnvironmentVar(const Name: string; var Value: string; Expand: Boolean): Boolean;
begin
Result := GetEnvironmentVar(Name, Value); // Expand is there just for x-platform compatibility
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
function GetEnvironmentVar(const Name: string; var Value: string): Boolean;
begin
{$IFDEF CLR}
Value := System.Environment.GetEnvironmentVariable(Name);
Result := TObject(Value) <> nil;
{$ELSE ~CLR}
Result := GetEnvironmentVar(Name, Value, True);
{$ENDIF ~CLR}
end;
function GetEnvironmentVar(const Name: string; var Value: string; Expand: Boolean): Boolean;
{$IFDEF CLR}
begin
Result := GetEnvironmentVar(Name, Value);
if Expand then
ExpandEnvironmentVar(Value);
end;
{$ELSE ~CLR}
var
R: DWORD;
begin
R := Windows.GetEnvironmentVariable(PChar(Name), nil, 0);
SetLength(Value, R);
R := Windows.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;
{$ENDIF ~CLR}
{$ENDIF MSWINDOWS}
{$IFDEF KYLIX}
function GetEnvironmentVars(const Vars: TStrings): Boolean;
var
P: PPChar;
begin
Vars.BeginUpdate;
try
Vars.Clear;
P := System.envp;
Result := P <> nil;
while (P <> nil) and (P^ <> nil) do
begin
Vars.Add(P^);
Inc(P);
end;
finally
Vars.EndUpdate;
end;
end;
{$ENDIF KYLIX}
{$IFDEF UNIX}
function GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean;
begin
Result := GetEnvironmentVars(Vars); // Expand is there just for x-platform compatibility
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
function GetEnvironmentVars(const Vars: TStrings): Boolean;
begin
Result := GetEnvironmentVars(Vars, True);
end;
function GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean;
{$IFDEF CLR}
var
Dic: IDictionaryEnumerator;
begin
Vars.BeginUpdate;
try
Vars.Clear;
for Dic in System.Environment.GetEnvironmentVariables do
Vars.Add(string(Dic.Key) + '=' + string(Dic.Value));
finally
Vars.EndUpdate;
end;
Result := True;
end;
{$ELSE ~CLR}
var
Raw: PChar;
Expanded: string;
I: Integer;
begin
Vars.BeginUpdate;
try
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;
finally
Vars.EndUpdate;
end;
end;
{$ENDIF ~CLR}
{$ENDIF MSWINDOWS}
function SetEnvironmentVar(const Name, Value: string): Boolean;
begin
{$IFDEF CLR}
if System.Environment.GetEnvironmentVariables.Contains(Name) then
System.Environment.GetEnvironmentVariables.Item[Name] := Value
else
System.Environment.GetEnvironmentVariables.Add(Name, Value);
Result := True;
{$ELSE ~CLR}
{$IFDEF UNIX}
SetEnv(PChar(Name), PChar(Value), 1);
Result := True;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
Result := SetEnvironmentVariable(PChar(Name), PChar(Value));
{$ENDIF MSWINDOWS}
{$ENDIF ~CLR}
end;
{$IFNDEF CLR}
{$IFDEF MSWINDOWS}
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;
// frees an environment block allocated by CreateEnvironmentBlock and
// sets Env to nil
procedure DestroyEnvironmentBlock(var Env: PChar);
begin
FreeMultiSz(Env);
end;
procedure SetGlobalEnvironmentVariable(VariableName, VariableContent: string);
const
cEnvironment = 'Environment';
begin
if VariableName = '' then
Exit;
if VariableContent = '' then
begin
RegDeleteEntry(HKEY_CURRENT_USER, cEnvironment, VariableName);
SetEnvironmentVariable(PChar(VariableName), nil);
end
else
begin
RegWriteAnsiString(HKEY_CURRENT_USER, cEnvironment, VariableName, VariableContent);
SetEnvironmentVariable(PChar(VariableName), PChar(VariableContent));
end;
SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, LPARAM(PChar(cEnvironment)));
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;
{ TODO : Check for documented solution }
function GetCommonFilesFolder: string;
begin
Result := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS,
'CommonFilesDir', '');
end;
{$ENDIF MSWINDOWS}
{$ENDIF ~CLR}
function GetCurrentFolder: string;
{$IFDEF CLR}
begin
Result := System.Environment.CurrentDirectory;
end;
{$ELSE ~CLR}
{$IFDEF UNIX}
const
InitialSize = 64;
var
Size: Integer;
begin
Size := InitialSize;
while True do
begin
SetLength(Result, Size);
if getcwd(PChar(Result), Size) <> nil then
begin
StrResetLength(Result);
Exit;
end;
if GetLastError <> ERANGE then
RaiseLastOSError;
Size := Size * 2;
end;
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
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;
{$ENDIF MSWINDOWS}
{$ENDIF ~CLR}
{$IFDEF MSWINDOWS}
{ TODO : Check for documented solution }
function GetProgramFilesFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.ProgramFiles);
{$ELSE ~CLR}
Result := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS, 'ProgramFilesDir', '');
{$ENDIF ~CLR}
end;
{$IFNDEF CLR}
{ TODO : Check for documented solution }
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;
{$ENDIF ~CLR}
{ TODO : Check for documented solution }
function GetWindowsSystemFolder: string;
{$IFDEF CLR}
begin
Result := System.Environment.SystemDirectory;
end;
{$ELSE ~CLR}
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;
{$ENDIF ~CLR}
function GetWindowsTempFolder: string;
{$IFDEF CLR}
begin
Result := Path.GetTempPath;
end;
{$ELSE ~CLR}
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;
{$ENDIF ~CLR}
function GetDesktopFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.Desktop);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_DESKTOP);
{$ENDIF ~CLR}
end;
{ TODO : Check GetProgramsFolder = GetProgramFilesFolder }
function GetProgramsFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.Programs);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_PROGRAMS);
{$ENDIF ~CLR}
end;
{$ENDIF MSWINDOWS}
function GetPersonalFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.Personal);
{$ELSE ~CLR}
{$IFDEF UNIX}
Result := GetEnvironmentVariable('HOME');
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
Result := GetSpecialFolderLocation(CSIDL_PERSONAL);
{$ENDIF MSWINDOWS}
{$ENDIF ~CLR}
end;
{$IFDEF MSWINDOWS}
function GetFavoritesFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.Favorites);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_FAVORITES);
{$ENDIF ~CLR}
end;
function GetStartupFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.Startup);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_STARTUP);
{$ENDIF ~CLR}
end;
function GetRecentFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.Recent);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_RECENT);
{$ENDIF ~CLR}
end;
function GetSendToFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.SendTo);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_SENDTO);
{$ENDIF ~CLR}
end;
function GetStartmenuFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.StartMenu);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_STARTMENU);
{$ENDIF ~CLR}
end;
function GetDesktopDirectoryFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.DesktopDirectory);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_DESKTOPDIRECTORY);
{$ENDIF ~CLR}
end;
{$IFNDEF CLR}
function GetNethoodFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_NETHOOD);
end;
{$ENDIF ~CLR}
{$IFNDEF CLR}
function GetFontsFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_FONTS);
end;
function GetCommonStartmenuFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_COMMON_STARTMENU);
end;
{$ENDIF ~CLR}
function GetCommonProgramsFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.CommonProgramFiles);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_COMMON_PROGRAMS);
{$ENDIF ~CLR}
end;
{$IFNDEF CLR}
function GetCommonStartupFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_COMMON_STARTUP);
end;
{$ENDIF ~CLR}
function GetCommonDesktopdirectoryFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.DesktopDirectory);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_COMMON_DESKTOPDIRECTORY);
{$ENDIF ~CLR}
end;
function GetCommonAppdataFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.CommonApplicationData);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_COMMON_APPDATA);
{$ENDIF ~CLR}
end;
function GetAppdataFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_APPDATA);
{$ENDIF ~CLR}
end;
{$IFNDEF CLR}
function GetPrinthoodFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_PRINTHOOD);
end;
{$ENDIF ~CLR}
function GetCommonFavoritesFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.Favorites);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_COMMON_FAVORITES);
{$ENDIF ~CLR}
end;
function GetTemplatesFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.Templates);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_TEMPLATES);
{$ENDIF ~CLR}
end;
function GetInternetCacheFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.InternetCache);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_INTERNET_CACHE);
{$ENDIF ~CLR}
end;
function GetCookiesFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.Cookies);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_COOKIES);
{$ENDIF ~CLR}
end;
function GetHistoryFolder: string;
begin
{$IFDEF CLR}
Result := System.Environment.GetFolderPath(Environment.SpecialFolder.History);
{$ELSE ~CLR}
Result := GetSpecialFolderLocation(CSIDL_HISTORY);
{$ENDIF ~CLR}
end;
{$IFNDEF CLR}
function GetProfileFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_PROFILE);
end;
{$ENDIF ~CLR}
// 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
{$IFNDEF CLR}
// 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 : Change to RootPath }
{ 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;
{ TODO -cHelp : Donator (incl. TFileSystemFlag[s]): Robert Rossmair }
function GetVolumeFileSystemFlags(const Volume: string): TFileSystemFlags;
var
MaximumComponentLength, Flags: Cardinal;
Flag: TFileSystemFlag;
begin
if not GetVolumeInformation(PChar(PathAddSeparator(Volume)), nil, 0, nil,
MaximumComponentLength, Flags, nil, 0) then
RaiseLastOSError;
Result := [];
for Flag := Low(TFileSystemFlag) to High(TFileSystemFlag) do
if (Flags and Ord(Flag)) <> 0 then
Include(Result, Flag);
end;
{$ENDIF ~CLR}
{$ENDIF MSWINDOWS}
{ TODO -cDoc: Contributor: twm }
function GetIPAddress(const HostName: string): string;
{$IFDEF CLR}
var
Host: IPHostEntry;
begin
Host := System.Net.Dns.Resolve(HostName);
if (Host <> nil) and (Length(Host.AddressList) > 0) then
Result := Host.AddressList[0].ToString()
else
Result := '';
end;
{$ELSE ~CLR}
var
{$IFDEF MSWINDOWS}
R: Integer;
WSAData: TWSAData;
{$ENDIF MSWINDOWS}
HostEnt: PHostEnt;
Host: string;
SockAddr: TSockAddrIn;
begin
Result := '';
{$IFDEF MSWINDOWS}
R := WSAStartup(MakeWord(1, 1), WSAData);
if R = 0 then
try
{$ENDIF MSWINDOWS}
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;
{$IFDEF MSWINDOWS}
finally
WSACleanup;
end;
{$ENDIF MSWINDOWS}
end;
{$ENDIF ~CLR}
{$IFDEF UNIX}
{ TODO -cDoc: Donator: twm, Contributor rrossmair }
// Returns all IP addresses of the local machine in the form
// <interface>=<IP-Address> (which allows for access to the interface names
// by means of Results.Names and the addresses through Results.Values)
//
// Example:
//
// lo=127.0.0.1
// eth0=10.10.10.1
// ppp0=217.82.187.130
//
// note that this will append to Results!
//
procedure GetIpAddresses(Results: TStrings);
var
Sock: Integer;
IfReq: TIfReq;
SockAddrPtr: PSockAddrIn;
ListSave, IfList: PIfNameIndex;
begin
//need a socket for ioctl()
Sock := socket(AF_INET, SOCK_STREAM, 0);
if Sock < 0 then
RaiseLastOSError;
try
//returns pointer to dynamically allocated list of structs
ListSave := if_nameindex();
try
IfList := ListSave;
//walk thru the array returned and query for each
//interface's address
while IfList^.if_index <> 0 do
begin
//copy in the interface name to look up address of
strncpy(IfReq.ifrn_name, IfList^.if_name, IFNAMSIZ);
//get the address for this interface
if ioctl(Sock, SIOCGIFADDR, @IfReq) <> 0 then
RaiseLastOSError;
//print out the address
SockAddrPtr := PSockAddrIn(@IfReq.ifru_addr);
Results.Add(Format('%s=%s', [IfReq.ifrn_name, inet_ntoa(SockAddrPtr^.sin_addr)]));
Inc(IfList);
end;
finally
//free the dynamic memory kernel allocated for us
if_freenameindex(ListSave);
end;
finally
Libc.__close(Sock)
end;
end;
{$ENDIF UNIX}
function GetLocalComputerName: string;
{$IFDEF CLR}
begin
Result := System.Environment.MachineName;
end;
{$ELSE ~CLR}
// (rom) UNIX or LINUX?
{$IFDEF LINUX}
var
MachineInfo: utsname;
begin
uname(MachineInfo);
Result := MachineInfo.nodename;
end;
{$ENDIF LINUX}
{$IFDEF MSWINDOWS}
var
Count: DWORD;
begin
Count := MAX_COMPUTERNAME_LENGTH + 1;
// set buffer size to MAX_COMPUTERNAME_LENGTH + 2 characters for safety
{ TODO : Win2k solution }
SetLength(Result, Count);
if GetComputerName(PChar(Result), Count) then
StrResetLength(Result)
else
Result := '';
end;
{$ENDIF MSWINDOWS}
{$ENDIF ~CLR}
{$IFNDEF CLR}
function GetLocalUserName: string;
{$IFDEF UNIX}
begin
Result := GetEnv('USER');
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
var
Count: DWORD;
begin
Count := 256 + 1; // UNLEN + 1
// set buffer size to 256 + 2 characters
{ TODO : Win2k solution }
SetLength(Result, Count);
if GetUserName(PChar(Result), Count) then
StrResetLength(Result)
else
Result := '';
end;
{$ENDIF MSWINDOWS}
{$IFDEF MSWINDOWS}
function GetRegisteredCompany: string;
begin
{ TODO : check for MSDN documentation }
Result := RegReadStringDef(HKEY_LOCAL_MACHINE, REG_CURRENT_VERSION, 'RegisteredOrganization', '');
end;
function GetRegisteredOwner: string;
begin
{ TODO : check for MSDN documentation }
Result := RegReadStringDef(HKEY_LOCAL_MACHINE, REG_CURRENT_VERSION, 'RegisteredOwner', '');
end;
{ TODO: Check supported platforms, maybe complete rewrite }
function GetUserDomainName(const CurUser: string): string;
var
Count1, Count2: DWORD;
Sd: PSID; // PSecurityDescriptor; // FPC requires PSID
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;
{$ENDIF MSWINDOWS}
function GetDomainName: string;
{$IFDEF UNIX}
var
MachineInfo: utsname;
begin
uname(MachineInfo);
Result := MachineInfo.domainname;
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
begin
Result := GetUserDomainName(GetLocalUserName);
end;
{$ENDIF MSWINDOWS}
{$IFDEF MSWINDOWS}
// Reference: How to Obtain BIOS Information from the Registry
// http://support.microsoft.com/default.aspx?scid=kb;en-us;q195268
function GetBIOSName: string;
const
Win9xBIOSInfoKey = 'Enum\Root\*PNP0C01\0000';
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;
// Reference: How to Obtain BIOS Information from the Registry
// http://support.microsoft.com/default.aspx?scid=kb;en-us;q195268
{ TODO : the date string can be e.g. 00/00/00 }
function GetBIOSDate: TDateTime;
const
WinNT_REG_PATH = 'HARDWARE\DESCRIPTION\System';
WinNT_REG_KEY = 'SystemBiosDate';
Win9x_REG_PATH = 'Enum\Root\*PNP0C01\0000';
Win9x_REG_KEY = 'BiosDate';
var
RegStr: string;
{$IFDEF RTL150_UP}
FormatSettings: TFormatSettings;
{$ELSE RTL150_UP}
RegFormat: string;
RegSeparator: Char;
{$ENDIF RTL150_UP}
begin
if IsWinNT then
RegStr := RegReadString(HKEY_LOCAL_MACHINE, WinNT_REG_PATH, WinNT_REG_KEY)
else
RegStr := RegReadString(HKEY_LOCAL_MACHINE, Win9x_REG_PATH, Win9x_REG_KEY);
{$IFDEF RTL150_UP}
FillChar(FormatSettings, SizeOf(FormatSettings), 0);
FormatSettings.DateSeparator := '/';
FormatSettings.ShortDateFormat := 'm/d/y';
if not TryStrToDate(RegStr, Result, FormatSettings) then
begin
FormatSettings.ShortDateFormat := 'y/m/d';
if not TryStrToDate(RegStr, Result, FormatSettings) then
Result := 0;
end;
{$ELSE RTL150_UP}
Result := 0;
{ TODO : change to a threadsafe solution }
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;
{$ENDIF RTL150_UP}
end;
{$ENDIF MSWINDOWS}
//=== Processes, Tasks and Modules ===========================================
{$IFDEF UNIX}
const
CommLen = 16; // synchronize with size of comm in struct task_struct in
// /usr/include/linux/sched.h
SProcDirectory = '/proc';
function RunningProcessesList(const List: TStrings; FullPath: Boolean): Boolean;
var
ProcDir: PDirectoryStream;
PtrDirEnt: PDirEnt;
Scratch: TDirEnt;
ProcID: __pid_t;
E: Integer;
FileName: string;
F: PIOFile;
begin
Result := False;
ProcDir := opendir(SProcDirectory);
if ProcDir <> nil then
begin
PtrDirEnt := nil;
if readdir_r(ProcDir, @Scratch, PtrDirEnt) <> 0 then
Exit;
List.BeginUpdate;
try
while PtrDirEnt <> nil do
begin
Val(PtrDirEnt^.d_name, ProcID, E);
if E = 0 then // name was process id
begin
FileName := '';
if FullPath then
FileName := SymbolicLinkTarget(Format('/proc/%s/exe', [PtrDirEnt^.d_name]));
if FileName = '' then // usually due to insufficient access rights
begin
// read stat
FileName := Format('/proc/%s/stat', [PtrDirEnt^.d_name]);
F := fopen(PChar(FileName), 'r');
if F = nil then
raise EJclError.CreateResFmt(@RsInvalidProcessID, [ProcID]);
try
SetLength(FileName, CommLen);
if fscanf(F, PChar(Format('%%*d (%%%d[^)])', [CommLen])), PChar(FileName)) <> 1 then
RaiseLastOSError;
StrResetLength(FileName);
finally
fclose(F);
end;
end;
List.AddObject(FileName, Pointer(ProcID));
end;
if readdir_r(ProcDir, @Scratch, PtrDirEnt) <> 0 then
Break;
end;
finally
List.EndUpdate;
end;
end;
end;
{$ENDIF UNIX}
{$ENDIF ~CLR}
{$IFDEF MSWINDOWS}
function RunningProcessesList(const List: TStrings; FullPath: Boolean): Boolean;
{$IFDEF CLR}
var
Processes: array of Process;
I: Integer;
HasModules: Boolean;
begin
Result := True;
Processes := Process.GetProcesses;
for I := 0 to High(Processes) do
begin
try
HasModules := Processes[I].Modules.Count > 0;
except
on Win32Exception do
HasModules := False;
end;
if not HasModules then
List.Add(Processes[I].ProcessName)
else
if FullPath then
List.Add(Processes[I].MainModule.FileName)
else
List.Add(Processes[I].MainModule.ModuleName);
end;
end;
{$ELSE ~CLR}
// This function always returns an empty string on Win9x
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;
{ TODO: Check return value of CreateToolhelp32Snapshot on Windows NT (0?) }
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 or IsWin2003 or IsWin2003R2 or IsWinXP64
or IsWinVista or IsWinLonghorn 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
{ TODO : safer solution? }
List.BeginUpdate;
try
if GetWindowsVersion in [wvWinNT31, wvWinNT35, wvWinNT351, wvWinNT4] then
Result := BuildListPS
else
Result := BuildListTH;
finally
List.EndUpdate;
end;
end;
{$ENDIF ~CLR}
{$IFNDEF CLR}
{ TODO Windows 9x ? }
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
{$IFDEF FPC}
if GetModuleInformation(ProcessHandle, Module, ModuleInfo, SizeOf(ModuleInfo)) then
{$ELSE ~FPC}
if GetModuleInformation(ProcessHandle, Module, @ModuleInfo, SizeOf(ModuleInfo)) then
{$ENDIF ~FPC}
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
{$IFDEF FPC}
if MemInfo._Type = MEM_IMAGE then
{$ELSE ~FPC}
if MemInfo.Type_9 = MEM_IMAGE then
{$ENDIF ~FPC}
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;
{ TODO: Check return value of CreateToolhelp32Snapshot on Windows NT (0?) }
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
List.BeginUpdate;
try
if IsWinNT then
Result := EnumModulesPS
else
Result := EnumModulesTH;
finally
List.EndUpdate;
end;
end;
function GetTasksList(const List: TStrings): Boolean;
function EnumWindowsProc(Wnd: THandle; 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
List.BeginUpdate;
try
Result := EnumWindows(@EnumWindowsProc, Integer(List));
finally
List.EndUpdate;
end;
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;
{$IFNDEF FPC}
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;
{$ENDIF ~FPC}
// Reference: http://msdn.microsoft.com/library/periodic/period97/win321197.htm
{ TODO : wrong link }
function IsMainAppWindow(Wnd: THandle): Boolean;
var
ParentWnd: THandle;
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: THandle; Timeout: Integer): Boolean;
var
Res: DWORD;
begin
Result := SendMessageTimeout(Wnd, WM_NULL, 0, 0, SMTO_ABORTIFHUNG, Timeout, Res) <> 0;
end;
function GetWindowIcon(Wnd: THandle; 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: THandle): string;
const
BufferAllocStep = 256;
var
Buffer: PChar;
Size, TextLen: Integer;
begin
{ TODO : use string }
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
// http://support.microsoft.com/default.aspx?scid=kb;en-us;178893
function TerminateApp(ProcessID: DWORD; Timeout: Integer): TJclTerminateAppResult;
var
ProcessHandle: THandle;
function EnumWindowsProc(Wnd: THandle; 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);
if ProcessHandle <> 0 then
try
EnumWindows(@EnumWindowsProc, LPARAM(ProcessID));
if WaitForSingleObject(ProcessHandle, Timeout) = WAIT_OBJECT_0 then
Result := taClean
else
if TerminateProcess(ProcessHandle, 0) then
Result := taKill;
finally
CloseHandle(ProcessHandle);
end;
end;
end;
function TerminateTask(Wnd: THandle; Timeout: Integer): TJclTerminateAppResult;
var
PID: DWORD;
begin
if GetWindowThreadProcessId(Wnd, @PID) <> 0 then
Result := TerminateApp(PID, Timeout)
else
Result := taError;
end;
function GetProcessNameFromWnd(Wnd: THandle): 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): THandle;
type
PSearch = ^TSearch;
TSearch = record
PID: DWORD;
Wnd: THandle;
end;
var
SearchRec: TSearch;
function EnumWindowsProc(Wnd: THandle; 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;
var
TrimmedWin32CSDVersion: string;
SystemInfo: TSystemInfo;
OSVersionInfoEx: TOSVersionInfoEx;
const
SM_SERVERR2 = 89;
begin
Result := wvUnknown;
TrimmedWin32CSDVersion := Trim(Win32CSDVersion);
case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS:
case Win32MinorVersion of
0..9:
if (TrimmedWin32CSDVersion = 'B') or (TrimmedWin32CSDVersion = 'C') 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 TrimmedWin32CSDVersion = '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;
2:
begin
OSVersionInfoEx.dwOSVersionInfoSize := SizeOf(OSVersionInfoEx);
GetNativeSystemInfo(SystemInfo);
if GetSystemMetrics(SM_SERVERR2) <> 0 then
Result := wvWin2003R2
else if (SystemInfo.wProcessorArchitecture <> PROCESSOR_ARCHITECTURE_INTEL)
and GetVersionEx(OSVersionInfoEx) and (OSVersionInfoEx.wProductType = VER_NT_WORKSTATION) then
Result := wvWinXP64
else
Result := wvWin2003;
end;
end;
6:
if Win32MinorVersion = 0 then
begin
OSVersionInfoEx.dwOSVersionInfoSize := SizeOf(OSVersionInfoEx);
if GetVersionEx(OSVersionInfoEx) and (OSVersionInfoEx.wProductType = VER_NT_WORKSTATION) then
Result := wvWinVista
else
Result := wvWinLonghorn;
end;
end;
end;
end;
function NtProductType: TNtProductType;
const
ProductType = 'SYSTEM\CurrentControlSet\Control\ProductOptions';
var
Product: string;
OSVersionInfo: TOSVersionInfoEx;
SystemInfo: TSystemInfo;
begin
Result := ptUnknown;
FillChar(OSVersionInfo, SizeOf(OSVersionInfo), 0);
FillChar(SystemInfo, SizeOf(SystemInfo), 0);
OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
GetNativeSystemInfo(SystemInfo);
// Favor documented API over registry
if IsWinNT4 and (GetWindowsServicePackVersion >= 6) then
begin
if GetVersionEx(OSVersionInfo) then
begin
if (OSVersionInfo.wProductType = VER_NT_WORKSTATION) then
Result := ptWorkstation
else if (OSVersionInfo.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then
Result := ptEnterprise
else
Result := ptServer;
end;
end
else
if IsWin2K then
begin
if GetVersionEx(OSVersionInfo) then
begin
if OSVersionInfo.wProductType in [VER_NT_SERVER,VER_NT_DOMAIN_CONTROLLER] then
begin
if (OSVersionInfo.wSuiteMask and VER_SUITE_DATACENTER) <> 0 then
Result := ptDatacenterServer
else if (OSVersionInfo.wSuiteMask and VER_SUITE_ENTERPRISE) <> 0 then
Result := ptAdvancedServer
else
Result := ptServer;
end
else
Result := ptProfessional;
end;
end
else
if IsWinXP64 or IsWin2003 or IsWin2003R2 then // all (5.2)
begin
if GetVersionEx(OSVersionInfo) then
begin
if OSVersionInfo.wProductType in [VER_NT_SERVER,VER_NT_DOMAIN_CONTROLLER] then
begin
if (OSVersionInfo.wSuiteMask and VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER then
Result := ptDatacenterServer
else
if (OSVersionInfo.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then
Result := ptEnterprise
else if (OSVersionInfo.wSuiteMask = VER_SUITE_BLADE) then
Result := ptWebEdition
else
Result := ptServer;
end
else
if (OSVersionInfo.wProductType = VER_NT_WORKSTATION) then
Result := ptProfessional;
end;
end
else
if IsWinXP or IsWinVista or IsWinLonghorn then // workstation
begin
if GetVersionEx(OSVersionInfo) then
begin
if OSVersionInfo.wProductType = VER_NT_WORKSTATION then
begin
if (OSVersionInfo.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
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;
wvWin2003:
Result := RsOSVersionWin2003;
wvWin2003R2:
Result := RsOSVersionWin2003R2;
wvWinXP64:
Result := RsOSVersionWinXP64;
wvWinLonghorn:
Result := RsOSVersionWinLonghorn;
wvWinVista:
Result := RsOSVersionWinVista;
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;
ptEnterprise:
Result := RsProductTypeEnterprise;
ptWebEdition:
Result := RsProductTypeWebEdition;
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 or IsWin2003 or IsWinXP64 or IsWin2003R2 or IsWinVista
or IsWinLonghorn then
begin
FillChar(VersionInfo, SizeOf(VersionInfo), 0);
VersionInfo.dwOSVersionInfoSize := SizeOf(VersionInfo);
if 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 := Format(RsSPInfo, [SP])
else
Result := '';
end;
// Imports copied from OpenGL unit. Direct using of OpenGL unit might cause unexpected problems due
// setting 8087CW in the intialization section
function glGetString(name: Cardinal): PChar; stdcall; external opengl32;
function glGetError: Cardinal; stdcall; external opengl32;
function gluErrorString(errCode: Cardinal): PChar; stdcall; external 'glu32.dll';
function GetOpenGLVersion(const Win: THandle; out Version, Vendor: AnsiString): Boolean;
const
GL_NO_ERROR = 0;
GL_VENDOR = $1F00;
GL_VERSION = $1F02;
var
pfd: TPixelFormatDescriptor;
iFormatIndex: Integer;
hGLContext: HGLRC;
hGLDC: HDC;
pcTemp: PChar;
glErr: Cardinal;
bError: Boolean;
sOpenGLVersion, sOpenGLVendor: string;
Save8087CW: Word;
procedure FunctionFailedError(Name: string);
begin
raise EJclError.CreateResFmt(@RsEOpenGLInfo, [Name]);
end;
begin
{ To call for the version information string we must first have an active
context established for use. We can, of course, close this after use }
Save8087CW := Get8087ControlWord;
try
Set8087CW($133F);
hGLContext := 0;
Result := False;
bError := False;
if Win = 0 then
begin
Result := False;
Vendor := RsOpenGLInfoError;
Version := RsOpenGLInfoError;
Exit;
end;
FillChar(pfd, SizeOf(pfd), 0);
with pfd do
begin
nSize := SizeOf(pfd);
nVersion := 1; { The Current Version of the descriptor is 1 }
dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL;
iPixelType := PFD_TYPE_RGBA;
cColorBits := 24; { support 24-bit colour }
cDepthBits := 32; { Depth of the z-buffer }
iLayerType := PFD_MAIN_PLANE;
end;
hGLDC := GetDC(Win);
try
iFormatIndex := ChoosePixelFormat(hGLDC, @pfd);
if iFormatIndex = 0 then
FunctionFailedError('ChoosePixelFormat');
if not SetPixelFormat(hGLDC, iFormatIndex, @pfd) then
FunctionFailedError('SetPixelFormat');
hGLContext := wglCreateContext(hGLDC);
if hGLContext = 0 then
FunctionFailedError('wglCreateContext');
if not wglMakeCurrent(hGLDC, hGLContext) then
FunctionFailedError('wglMakeCurrent');
{ TODO : Review the following. Not sure I am 100% happy with this code
in its current structure. }
pcTemp := glGetString(GL_VERSION);
if pcTemp <> nil then
begin
{ TODO : Store this information in a Global Variable, and return that??
This would save this work being performed again with later calls }
sOpenGLVersion := StrPas(pcTemp);
end
else
begin
bError := True;
glErr := glGetError;
if glErr <> GL_NO_ERROR then
begin
sOpenGLVersion := gluErrorString(glErr);
sOpenGLVendor := '';
end;
end;
pcTemp := glGetString(GL_VENDOR);
if pcTemp <> nil then
begin
{ TODO : Store this information in a Global Variable, and return that??
This would save this work being performed again with later calls }
sOpenGLVendor := StrPas(pcTemp);
end
else
begin
bError := True;
glErr := glGetError;
if glErr <> GL_NO_ERROR then
begin
sOpenGLVendor := gluErrorString(glErr);
Exit;
end;
end;
Result := (not bError);
Version := sOpenGLVersion;
Vendor := sOpenGLVendor;
finally
{ Close all resources }
wglMakeCurrent(hGLDC, 0);
if hGLContext <> 0 then
wglDeleteContext(hGLContext);
end;
finally
Set8087CW(Save8087CW);
end;
end;
function GetNativeSystemInfo(var SystemInfo: TSystemInfo): Boolean;
type
TGetNativeSystemInfo = procedure (var SystemInfo: TSystemInfo) stdcall;
var
LibraryHandle: HMODULE;
_GetNativeSystemInfo: TGetNativeSystemInfo;
begin
Result := False;
LibraryHandle := LoadLibrary('kernel32.dll');
if LibraryHandle <> 0 then
begin
try
_GetNativeSystemInfo := GetProcAddress(LibraryHandle,'GetNativeSystemInfo');
if Assigned(_GetNativeSystemInfo) then
begin
_GetNativeSystemInfo(SystemInfo);
Result := True;
end
else
GetSystemInfo(SystemInfo);
finally
FreeLibrary(LibraryHandle);
end;
end
else
GetSystemInfo(SystemInfo);
end;
function GetProcessorArchitecture: TProcessorArchitecture;
var
ASystemInfo: TSystemInfo;
begin
GetNativeSystemInfo(ASystemInfo);
case ASystemInfo.wProcessorArchitecture of
PROCESSOR_ARCHITECTURE_INTEL:
Result := pax8632;
PROCESSOR_ARCHITECTURE_IA64:
Result := paIA64;
PROCESSOR_ARCHITECTURE_AMD64:
Result := pax8664;
else
Result := paUnknown;
end;
end;
function IsWindows64: Boolean;
var
ASystemInfo: TSystemInfo;
begin
GetNativeSystemInfo(ASystemInfo);
Result := ASystemInfo.wProcessorArchitecture in [PROCESSOR_ARCHITECTURE_IA64,PROCESSOR_ARCHITECTURE_AMD64];
end;
{$ENDIF ~CLR}
{$ENDIF MSWINDOWS}
{$IFNDEF CLR}
function GetOSVersionString: string;
{$IFDEF UNIX}
var
MachineInfo: utsname;
begin
uname(MachineInfo);
Result := Format('%s %s', [MachineInfo.sysname, MachineInfo.release]);
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
begin
Result := Format('%s %s', [GetWindowsVersionString, GetWindowsServicePackVersionString]);
end;
{$ENDIF MSWINDOWS}
//=== Hardware ===============================================================
// Helper function for GetMacAddress()
// Converts the adapter_address array to a string
function AdapterToString(Adapter: PJclByteArray): 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;
{ TODO: RTLD version of NetBios }
{$IFDEF MSWINDOWS}
type
TNetBios = function(P: PNCB): Byte; stdcall;
var
NetBiosLib: HINST = 0;
_NetBios: TNetBios;
{$IFDEF FPC}
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);
{$ENDIF FPC}
function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer;
procedure ExitNetbios;
begin
if NetBiosLib <> 0 then
begin
FreeLibrary(NetBiosLib);
NetBiosLib := 0;
end;
end;
function InitNetbios: Boolean;
begin
Result := True;
if NetBiosLib = 0 then
begin
NetBiosLib := LoadLibrary(PChar('netapi32.dll'));
Result := NetBiosLib <> 0;
if Result then
begin
@_NetBios := GetProcAddress(NetBiosLib, PChar('Netbios'));
Result := @_NetBios <> nil;
if not Result then
ExitNetbios;
end;
end;
end;
function NetBios(P: PNCB): Byte;
begin
if InitNetbios then
Result := _NetBios(P)
else
Result := 1; // anything other than NRC_GOODRET will do
end;
procedure GetMacAddressesNetBios;
// Platform SDK
// http://msdn.microsoft.com/library/default.asp?url=/library/en-us/netbios/netbios_1l82.asp
// Microsoft Knowledge Base Article - 118623
// HOWTO: Get the MAC Address for an Ethernet Adapter
// http://support.microsoft.com/default.aspx?scid=kb;en-us;118623
type
AStat = packed record
adapt: TAdapterStatus;
NameBuff: array [0..29] of TNameBuffer;
end;
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);
{$IFNDEF FPC // can't resolve address of const }
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);
{$ENDIF ~FPC}
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: PJclByteArray;
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 := PJclByteArray(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.BeginUpdate;
try
Addresses.Clear;
GetMacAddressesNetBios;
if (Result <= 0) and (Machine = '') then
GetMacAddressesSnmp;
finally
Addresses.EndUpdate;
end;
end;
{$ENDIF MSWINDOWS}
function ReadTimeStampCounter: Int64; assembler;
asm
DW $310F
end;
function GetIntelCacheDescription(const D: Byte): string;
var
I: Integer;
begin
Result := '';
if D <> 0 then
for I := Low(IntelCacheDescription) to High(IntelCacheDescription) do
if IntelCacheDescription[I].D = D then
begin
Result := IntelCacheDescription[I].I;
Break;
end;
// (outchy) added a return value for unknow D value
if Result = '' then
Result := Format(RsIntelUnknownCache,[D]);
end;
procedure GetCpuInfo(var CpuInfo: TCpuInfo);
begin
CpuInfo := CPUID;
CpuInfo.IsFDIVOK := TestFDIVInstruction;
if CpuInfo.HasInstruction then
begin
{$IFDEF MSWINDOWS}
if (CpuInfo.Features and TSC_FLAG) = TSC_FLAG then
GetCpuSpeed(CpuInfo.FrequencyInfo);
{$ENDIF MSWINDOWS}
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;
{$IFDEF UNIX}
begin
{ TODO : GetCPUSpeed: Solution for Linux }
Result := False;
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
var
T0, T1: Int64;
CountFreq: Int64;
Freq, Freq2, Freq3, Total: Int64;
TotalCycles, Cycles: Int64;
Stamp0, Stamp1: Int64;
TotalTicks, Ticks: Double;
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(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(T0);
T1 := T0;
Priority := GetThreadPriority(Thread);
if Priority <> THREAD_PRIORITY_ERROR_RETURN then
SetThreadPriority(Thread, THREAD_PRIORITY_TIME_CRITICAL);
try
while T1 - T0 < 50 do
begin
QueryPerformanceCounter(T1);
Stamp0 := ReadTimeStampCounter;
end;
T0 := T1;
while T1 - T0 < 1000 do
begin
QueryPerformanceCounter(T1);
Stamp1 := ReadTimeStampCounter;
end;
finally
if Priority <> THREAD_PRIORITY_ERROR_RETURN then
SetThreadPriority(Thread, Priority);
end;
Cycles := Stamp1 - Stamp0;
Ticks := T1 - T0;
Ticks := Ticks * 100000;
// avoid division by zero
if CountFreq = 0 then
Ticks := High(Int64)
else
Ticks := Ticks / (CountFreq / 10);
TotalTicks := TotalTicks + Ticks;
TotalCycles := TotalCycles + Cycles;
// avoid division by zero
if Ticks = 0 then
Freq := High(Freq)
else
Freq := Round(Cycles / Ticks);
Total := Freq + Freq2 + Freq3;
end;
// avoid division by zero
if TotalTicks = 0 then
begin
Freq3 := High(Freq3);
Freq2 := High(Freq2);
CpuSpeed.RawFreq := High(CpuSpeed.RawFreq);
end
else
begin
Freq3 := Round((TotalCycles * 10) / TotalTicks); // freq. in multiples of 10^5 Hz
Freq2 := Round((TotalCycles * 100) / TotalTicks); // freq. in multiples of 10^4 Hz
CpuSpeed.RawFreq := Round(TotalCycles / TotalTicks);
end;
CpuSpeed.NormFreq := CpuSpeed.RawFreq;
if Freq2 - (Freq3 * 10) >= 6 then
Inc(Freq3);
Freq := CpuSpeed.RawFreq * 10;
if (Freq3 - Freq) >= 6 then
Inc(CpuSpeed.NormFreq);
CpuSpeed.ExTicks := Round(TotalTicks);
CpuSpeed.InCycles := TotalCycles;
CpuSpeed.NormFreq := RoundFrequency(CpuSpeed.NormFreq);
Result := True;
end;
end;
{$ENDIF MSWINDOWS}
// Helper function for CPUID. Initializes Intel specific fields.
procedure IntelSpecific(var CpuInfo: TCpuInfo);
var
I, J: Integer;
begin
with CpuInfo do
begin
Manufacturer := 'Intel';
if HasCacheInfo then
begin
if (IntelSpecific.L2Cache <> 0) then
begin
L2CacheSize := IntelSpecific.L2Cache shr 16;
L2CacheLineSize := IntelSpecific.L2Cache and $FF;
L2CacheAssociativity := (IntelSpecific.L2Cache shr 12) and $F;
end;
for I := Low(IntelSpecific.CacheDescriptors) to High(IntelSpecific.CacheDescriptors) do
if IntelSpecific.CacheDescriptors[I]<>0 then
for J := Low(IntelCacheDescription) to High(IntelCacheDescription) do
if IntelCacheDescription[J].D = IntelSpecific.CacheDescriptors[I] then
with IntelCacheDescription[J] do
case Family of
//cfInstructionTLB :
//cfDataTLB :
cfL1InstructionCache :
begin
Inc(L1InstructionCacheSize,Size);
L1InstructionCacheLineSize := LineSize;
L1InstructionCacheAssociativity := WaysOfAssoc;
end;
cfL1DataCache :
begin
Inc(L1DataCacheSize,Size);
L1DataCacheLineSize := LineSize;
L1DataCacheAssociativity := WaysOfAssoc;
end;
cfL2Cache :
if (IntelSpecific.L2Cache = 0) then
begin
Inc(L2CacheSize,Size);
L2CacheLineSize := LineSize;
L2CacheAssociativity := WaysOfAssoc;
end;
cfL3Cache :
begin
Inc(L3CacheSize,Size);
L3CacheLineSize := LineSize;
L3CacheAssociativity := WaysOfAssoc;
L3LinesPerSector := LinePerSector;
end;
//cfTrace : // no numeric informations
//cfOther :
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 L2CacheSize of
0:
CpuName := 'Celeron';
1024:
CpuName := 'Pentium II Xeon';
2048:
CpuName := 'Pentium II Xeon';
else
CpuName := 'Pentium II';
end;
6:
case L2CacheSize of
0:
CpuName := 'Celeron';
128:
CpuName := 'Celeron';
else
CpuName := 'Pentium II';
end;
7:
case L2CacheSize 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;
MMX := (Features and MMX_FLAG) <> 0;
if (Features and SSE_FLAG) <> 0 then
if (Features and SSE2_FLAG) <> 0 then
if (IntelSpecific.ExFeatures and EINTEL_SSE3) <> 0 then
SSE := 3
else
SSE := 2
else
SSE := 1
else
SSE := 0;
Is64Bits := HasExtendedInfo and ((IntelSpecific.Ex64Features and EINTEL64_EM64T)<>0);
end;
end;
// Helper function for CPUID. Initializes Cyrix specific fields.
procedure CyrixSpecific(var CpuInfo: TCpuInfo);
begin
with CpuInfo do
begin
Manufacturer := '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.
resourcestring
RsUnknownAMDModel = 'Unknown AMD (Model %d)';
procedure AMDSpecific(var CpuInfo: TCpuInfo);
begin
with CpuInfo do
begin
Manufacturer := '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® (Model 6)';
7:
CpuName := 'AMD-K6® (Model 7)';
8:
CpuName := 'AMD-K6®-2 (Model 8)';
9:
CpuName := 'AMD-K6®-III (Model 9)';
else
StrFmt(CpuName,PChar(RsUnknownAMDModel),[Model]);
end;
6:
case Model of
1:
CpuName := 'AMD Athlon™ (Model 1)';
2:
CpuName := 'AMD Athlon™ (Model 2)';
3:
CpuName := 'AMD Duron™ (Model 3)';
4:
CpuName := 'AMD Athlon™ (Model 4)';
6:
CpuName := 'AMD Athlon™ XP (Model 6)';
7:
CpuName := 'AMD Duron™ (Model 7)';
8:
CpuName := 'AMD Athlon™ XP (Model 8)';
10:
CpuName := 'AMD Athlon™ XP (Model 10)';
else
StrFmt(CpuName,PChar(RsUnknownAMDModel),[Model]);
end;
8:
else
CpuName := 'Unknown AMD Chip';
end;
end;
if (HasCacheInfo) then
begin
L1DataCacheSize := AMDSpecific.L1DataCache[ciSize];
L1DataCacheLineSize := AMDSpecific.L1DataCache[ciLineSize];
L1DataCacheAssociativity := AMDSpecific.L1DataCache[ciAssociativity];
L1InstructionCacheSize := AMDSpecific.L1InstructionCache[ciSize];
L1InstructionCacheLineSize := AMDSpecific.L1InstructionCache[ciLineSize];
L1InstructionCacheAssociativity := AMDSpecific.L1InstructionCache[ciAssociativity];
L2CacheLineSize := AMDSpecific.L2Cache and $FF;
L2CacheAssociativity := (AMDSpecific.L2Cache shr 12) and $F;
L2CacheSize := AMDSpecific.L2Cache shr 16;
end;
MMX := (Features and AMD_MMX) <> 0;
ExMMX := HasExtendedInfo and ((AMDSpecific.ExFeatures and EAMD_EXMMX) <> 0);
_3DNow := HasExtendedInfo and ((AMDSpecific.ExFeatures and EAMD_3DNOW) <> 0);
Ex3DNow := HasExtendedInfo and ((AMDSpecific.ExFeatures and EAMD_EX3DNOW) <> 0);
if (Features and AMD_SSE) <> 0 then
if (Features and AMD_SSE2) <> 0 then
SSE := 2
else
SSE := 1
else
SSE := 0;
Is64Bits := HasExtendedInfo and ((AMDSpecific.ExFeatures and EAMD_LONG) <> 0);
end;
end;
// Helper function for CPUID. Initializes Transmeta specific fields.
procedure TransmetaSpecific(var CpuInfo: TCpuInfo);
begin
with CpuInfo do
begin
Manufacturer := 'Transmeta';
if not HasExtendedInfo then
CpuName := 'Crusoe';
if HasCacheInfo then
begin
L1DataCacheSize := TransmetaSpecific.L1DataCache[ciSize];
L1DataCacheLineSize := TransmetaSpecific.L1DataCache[ciLineSize];
L1DataCacheAssociativity := TransmetaSpecific.L1DataCache[ciAssociativity];
L1InstructionCacheSize := TransmetaSpecific.L1CodeCache[ciSize];
L1InstructionCacheLineSize := TransmetaSpecific.L1CodeCache[ciLineSize];
L1InstructionCacheAssociativity := TransmetaSpecific.L1CodeCache[ciAssociativity];
L2CacheLineSize := TransmetaSpecific.L2Cache and $FF;
L2CacheAssociativity := (TransmetaSpecific.L2Cache shr 12) and $F;
L2CacheSize := TransmetaSpecific.L2Cache shr 16;
end;
MMX := (Features and TRANSMETA_MMX) <> 0;
end;
end;
// Helper function for CPUID. Initializes Via specific fields.
procedure ViaSpecific(var CpuInfo: TCpuInfo);
begin
with CpuInfo do
begin
Manufacturer := 'Via';
if not HasExtendedInfo then
CpuName := 'C3';
if HasCacheInfo then
begin
L1DataCacheSize := VIASpecific.L1DataCache[ciSize];
L1DataCacheLineSize := VIASpecific.L1DataCache[ciLineSize];
L1DataCacheAssociativity := VIASpecific.L1DataCache[ciAssociativity];
L1InstructionCacheSize := VIASpecific.L1InstructionCache[ciSize];
L1InstructionCacheLineSize := VIASpecific.L1InstructionCache[ciLineSize];
L1InstructionCacheAssociativity := VIASpecific.L1InstructionCache[ciAssociativity];
L2CacheLineSize := VIASpecific.L2DataCache and $FF;
L2CacheAssociativity := (VIASpecific.L2DataCache shr 12) and $F;
L2CacheSize := VIASpecific.L2DataCache shr 16;
end;
MMX := (Features and VIA_MMX) <> 0;
if (Features and VIA_SSE) <> 0
then SSE := 1
else SSE := 0;
_3DNow := (Features and VIA_3DNOW) <> 0;
end;
end;
function CPUID: TCpuInfo;
var
CPUInfo: TCpuInfo;
HiVal: Cardinal;
ExHiVal: Cardinal;
TimesToExecute, CurrentLoop: Byte;
begin
FillChar(CPUInfo, sizeof(CPUInfo), 0);
asm
PUSH EAX
PUSH EBP
PUSH EBX
PUSH ECX
PUSH EDI
PUSH EDX
PUSH ESI
{$IFDEF PIC} // position independent code for linux
MOV ESI, EBX // get the GOT placed in ebx
{$ELSE} // PIC
XOR ESI, ESI
{$ENDIF} // PIC
@@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 [ESI].VendorIDIntel, EBX //'uneG'
JNE @@CheckAMD
CMP DWORD PTR [ESI+4].VendorIDIntel, EDX //'Ieni'
JNE @@CheckAMD
CMP DWORD PTR [ESI+8].VendorIDIntel, ECX //'letn'
JNE @@CheckAMD
MOV [CPUInfo.CpuType], CPU_TYPE_INTEL
JMP @@CheckIntelExtended
@@CheckAMD:
CMP DWORD PTR [ESI].VendorIDAMD, EBX //'htuA'
JNE @@CheckCyrix
CMP DWORD PTR [ESI+4].VendorIDAMD, EDX //'itne'
JNE @@CheckCyrix
CMP DWORD PTR [ESI+8].VendorIDAMD, ECX //'DMAc'
JNE @@CheckCyrix
MOV [CPUInfo.CpuType], CPU_TYPE_AMD
JMP @@CheckAMDExtended
@@CheckCyrix:
CMP DWORD PTR [ESI].VendorIDCyrix, EBX //'iryC'
JNE @@CheckVIA
CMP DWORD PTR [ESI+4].VendorIDCyrix, EDX //'snIx'
JNE @@CheckVIA
CMP DWORD PTR [ESI+8].VendorIDCyrix, ECX //'daet'
JNE @@CheckVIA
MOV [CPUInfo.CpuType], CPU_TYPE_CYRIX
JMP @@CheckCyrixExtended
@@CheckVIA:
CMP DWORD PTR [ESI].VendorIDVIA, EBX //'tneC'
JNE @@CheckTransmeta
CMP DWORD PTR [ESI+4].VendorIDVIA, EDX //'Hrua'
JNE @@CheckTransmeta
CMP DWORD PTR [ESI+8].VendorIDVIA, ECX //'slua'
JNE @@CheckTransmeta
MOV [CPUInfo.CpuType], CPU_TYPE_VIA
JMP @@CheckVIAExtended
@@CheckTransmeta:
CMP DWORD PTR [ESI].VendorIDTransmeta, EBX //'uneG'
JNE @@StandardFunctions
CMP DWORD PTR [ESI+4].VendorIDTransmeta, EDX //'Teni'
JNE @@StandardFunctions
CMP DWORD PTR [ESI+8].VendorIDTransmeta, ECX //'68xM'
JNE @@StandardFunctions
MOV [CPUInfo.CpuType], CPU_TYPE_TRANSMETA
JMP @@CheckTransmetaExtended
@@CheckIntelExtended:
MOV EAX, 80000000h
DB 0Fh
DB 0A2h
TEST EAX, 80000000h
JZ @@StandardFunctions
JMP @@IntelOnly
@@CheckAMDExtended:
MOV EAX, 1
CMP HiVal, 1
JL @@StandardFunctions
DB 0Fh
DB 0A2h
MOV [CpuInfo.Features], EDX
MOV EAX, 80000000h
DB 0Fh
DB 0A2h
CMP EAX, 0
JE @@StandardFunctions
JMP @@AMDOnly
@@CheckCyrixExtended:
MOV EAX, 80000000h
DB 0Fh
DB 0A2h
CMP EAX, 0
JE @@StandardFunctions
JMP @@CyrixOnly
@@CheckVIAExtended:
MOV EAX, 80000000h
DB 0Fh
DB 0A2h
CMP EAX, 0
JE @@StandardFunctions
JMP @@VIAOnly
@@CheckTransmetaExtended:
JMP @@TransmetaOnly
@@StandardFunctions:
CMP HiVal, 1
JL @@DoneCPUType
MOV EAX, 1
DB 0FH
DB 0A2H
MOV [CPUInfo.Features], EDX
MOV [CPUInfo.IntelSpecific.BrandID], BL
MOV EBX, EAX
AND EAX, 3000H
SHR EAX, 12
MOV [CPUInfo.PType], AL
MOV EAX, EBX
AND EAX, 0F00H
SHR EAX, 8
MOV [CPUInfo.Family], AL
MOV EAX, EBX
AND EAX, 00F0H
SHR EAX, 4
MOV [CPUInfo.MODEL], AL
MOV EAX, EBX
AND EAX, 000FH
MOV [CPUInfo.Stepping], AL
CMP [CpuInfo.CpuType], CPU_TYPE_INTEL
JNE @@DoneCPUType
MOV [CPUInfo.IntelSpecific.ExFeatures], ECX // (outchy) added extended features for intel processors
@@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
@@IntelOnly:
MOV ExHiVal, EAX
MOV EAX, 80000001h
CMP ExHiVal, EAX
JL @@StandardFunctions
MOV [CPUInfo.HasExtendedInfo], 1
DB 0Fh
DB 0A2h
MOV [CPUInfo.IntelSpecific.Ex64Features], EDX
MOV EAX, 80000002h
CMP ExHiVal, EAX
JL @@StandardFunctions
MOV [CPUInfo.HasExtendedInfo], 1
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 ExHiVal, EAX
JL @@StandardFunctions
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 ExHiVal, EAX
JL @@StandardFunctions
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, 80000006h
CMP ExHiVal, EAX
JL @@StandardFunctions
DB 0Fh
DB 0A2h
MOV [CPUInfo.IntelSpecific.L2Cache], EDX
JMP @@StandardFunctions
@@AMDOnly:
MOV ExHiVal, EAX
MOV EAX, 80000001h
CMP ExHiVal, EAX
JL @@DoneCPUType
MOV [CPUInfo.HasExtendedInfo], 1
DB 0Fh
DB 0A2h
MOV ECX, EAX
//AND EAX, 0F000H
//SHR EAX, 12
//MOV [CPUInfo.PType], AL // (outchy) AMD processors don't support ProcessorType
//MOV EAX, ECX
AND EAX, 00000F00h
SHR EAX, 8
MOV [CPUInfo.Family], AL
MOV EAX, ECX
AND EAX, 0FF00000h
SHR EAX, 20
MOV [CpuInfo.ExtendedFamily], AL
MOV EAX, ECX
AND EAX, 000000F0h
SHR EAX, 4
MOV [CPUInfo.Model], AL
MOV EAX, ECX
AND EAX, 000F0000h
SHR EAX, 16
MOV [CpuInfo.ExtendedModel], AL
MOV EAX, ECX
AND EAX, 000FH
MOV [CPUInfo.Stepping], AL
MOV [CPUInfo.AMDSpecific.ExFeatures], EDX
MOV EAX, 80000002h
CMP ExHiVal, 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 ExHiVal, 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 ExHiVal, 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 ExHiVal, EAX
JL @@DoneCPUType
MOV [CPUInfo.HasCacheInfo], 1
DB 0Fh
DB 0A2h
MOV [CPUInfo.AMDSpecific.MByteInstructionTLB], AX
SHR EAX, 16
MOV [CPUInfo.AMDSpecific.MByteDataTLB], AX
MOV [CPUInfo.AMDSpecific.KByteInstructionTLB], BX
SHR EBX, 16
MOV [CPUInfo.AMDSpecific.KByteDataTLB], BX
MOV [CPUInfo.AMDSpecific.L1DataCache], ECX
MOV [CPUInfo.AMDSpecific.L1InstructionCache], EDX
MOV EAX, 80000006h
CMP ExHiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV [CpuInfo.AMDSpecific.L2MByteInstructionTLB], AX
SHR EAX, 16
MOV [CpuInfo.AMDSpecific.L2MByteDataTLB], AX
MOV [CpuInfo.AMDSpecific.L2KByteInstructionTLB], BX
SHR EBX, 16
MOV [CpuInfo.AMDSpecific.L2KByteDataTLB], BX
MOV [CpuInfo.AMDSpecific.L2Cache], ECX
MOV EAX, 80000007h
CMP ExHiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV [CpuInfo.AMDSpecific.AdvancedPowerManagement], EDX
MOV EAX, 80000008h
CMP ExHiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV [CPUInfo.AMDSpecific.PhysicalAddressSize], AL
MOV [CPUInfo.AMDSpecific.VirtualAddressSize], AH
JMP @@DoneCPUType
@@CyrixOnly:
MOV ExHiVal, EAX
MOV EAX, 80000001h
CMP ExHiVal, 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 ExHiVal, 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 ExHiVal, 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 ExHiVal, 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 ExHiVal, EAX
JL @@DoneCPUType
MOV [CPUInfo.HasCacheInfo], 1
DB 0Fh
DB 0A2h
MOV [CPUInfo.CyrixSpecific.TLBInfo], EBX
MOV [CPUInfo.CyrixSpecific.L1CacheInfo], ECX
JMP @@DoneCPUType
@@VIAOnly:
MOV ExHiVal, EAX
MOV EAX, 80000001h
CMP ExHiVal, EAX
JL @@VIAExtended
MOV [CPUInfo.HasExtendedInfo], 1
DB 0Fh
DB 0A2h
MOV [CpuInfo.Features], EDX
MOV ECX, EAX
AND EAX, 000Fh
MOV [CpuInfo.Stepping], AL
MOV EAX, ECX
AND EAX, 00F0h
MOV [CpuInfo.Model], AL
MOV EAX, ECX
AND EAX, 0F00h
MOV [CpuInfo.Family], AL
MOV EAX, ECX
AND EAX, 3000h
MOV [CpuInfo.Stepping], AL
MOV EAX, 80000002h
CMP ExHiVal, EAX
JL @@VIAExtended
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 ExHiVal, EAX
JL @@VIAExtended
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 ExHiVal, EAX
JL @@VIAExtended
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 ExHiVal, EAX
JL @@VIAExtended
DB 0Fh
DB 0A2h
MOV [CPUInfo.VIASpecific.InstructionTLB], BX
SHR EBX, 16
MOV [CPUInfo.VIASpecific.DataTLB], BX
MOV [CPUInfo.VIASpecific.L1DataCache], ECX
MOV [CPUInfo.VIASpecific.L1InstructionCache], EDX
MOV [CPUInfo.HasCacheInfo], 1
MOV EAX, 80000006h
CMP ExHiVal, EAX
JL @@VIAExtended
DB 0Fh
DB 0A2h
MOV [CPUInfo.VIASpecific.L2DataCache], ECX
@@VIAExtended:
MOV EAX, 0C0000000h
DB 0Fh
DB 0A2h
CMP EAX, 0
JE @@DoneCpuType
MOV ExHiVal, EAX
MOV EAX, 0C0000001h
CMP ExHiVal, EAX
JL @@DoneCpuType
DB 0Fh
DB 0A2h
MOV [CPUInfo.VIASpecific.ExFeatures], EDX
JMP @@DoneCpuType
@@TransmetaOnly:
MOV EAX, 1
CMP HiVal, EAX
JL @@TransmetaExtended1
DB 0Fh
DB 0A2h
MOV [CpuInfo.Features], EDX
MOV EBX, EAX
AND EAX, 3000H
SHR EAX, 12
MOV [CPUInfo.PType], AL
MOV EAX, EBX
AND EAX, 0F00H
SHR EAX, 8
MOV [CPUInfo.Family], AL
MOV EAX, EBX
AND EAX, 00F0H
SHR EAX, 4
MOV [CPUInfo.MODEL], AL
MOV EAX, EBX
AND EAX, 000FH
MOV [CPUInfo.Stepping], AL
// no information when eax is 2
// eax is 3 means Serial Number, not detected there
@@TransmetaExtended1:
MOV EAX, 80000000h
DB 0Fh
DB 0A2h
CMP EAX, 0
JE @@TransmetaExtended2
MOV ExHiVal, EAX
MOV [CPUInfo.HasExtendedInfo], 1
MOV DWORD PTR [CPUInfo.CpuName], EBX // small CPU description, overriden if ExHiVal >=80000004
MOV DWORD PTR [CPUInfo.CpuName + 4], EDX
MOV DWORD PTR [CPUInfo.CpuName + 8], ECX
MOV EAX, 80000001h
CMP ExHiVal, EAX
JL @@TransmetaExtended2
DB 0Fh
DB 0A2h
MOV [CPUInfo.TransmetaSpecific.ExFeatures], EDX
MOV EAX, 80000002h
CMP ExHiVal, EAX
JL @@TransmetaExtended2
DB 0Fh
DB 0A2h
MOV DWORD PTR [CPUInfo.CpuName], EAX // large CPU description
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 ExHiVal, EAX
JL @@TransmetaExtended2
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 ExHiVal, EAX
JL @@TransmetaExtended2
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 ExHiVal, EAX
JL @@TransmetaExtended2
DB 0Fh
DB 0A2h
MOV [CPUInfo.HasCacheInfo], 1
MOV [CPUInfo.TransmetaSpecific.CodeTLB], BX
SHR EBX, 16
MOV [CPUInfo.TransmetaSpecific.DataTLB], BX
MOV [CPUInfo.TransmetaSpecific.L1DataCache], ECX
MOV [CPUInfo.TransmetaSpecific.L1CodeCache], EDX
MOV EAX, 80000006h
CMP ExHiVal, EAX
JL @@TransmetaExtended2
DB 0Fh
DB 0A2h
MOV [CPUInfo.TransmetaSpecific.L2Cache], ECX
@@TransmetaExtended2:
MOV EAX, 80860000h
DB 0Fh
DB 0A2h
CMP EAX, 0
JE @@DoneCPUType
MOV ExHiVal, EAX
MOV EAX, 80860001h
CMP ExHiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV [CPUInfo.TransmetaSpecific.RevisionABCD], EBX
MOV [CPUInfo.TransmetaSpecific.RevisionXXXX], ECX
MOV [CPUInfo.TransmetaSpecific.TransmetaFeatures], EDX
MOV EAX, 80860002h
CMP ExHiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV [CPUInfo.TransmetaSpecific.CodeMorphingABCD], EBX
MOV [CPUInfo.TransmetaSpecific.CodeMorphingXXXX], ECX
MOV EAX, 80860003h
CMP ExHiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations], EAX
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 4], EBX
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 8], ECX
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 12], EDX
MOV EAX, 80860004h
CMP ExHiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 16], EAX
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 20], EBX
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 24], ECX
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 28], EDX
MOV EAX, 80860005h
CMP ExHiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 32], EAX
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 36], EBX
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 40], ECX
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 44], EDX
MOV EAX, 80860006h
CMP ExHiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 48], EAX
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 52], EBX
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 56], ECX
MOV DWORD PTR [CPUInfo.TransmetaSpecific.TransmetaInformations + 60], EDX
MOV EAX, 80860007h
CMP ExHiVal, EAX
JL @@DoneCPUType
MOV EBX, [CPUInfo.TransmetaSpecific.TransmetaFeatures]
TEST EBX, STRANSMETA_LONGRUN
JZ @@DoneCPUType
DB 0Fh
DB 0A2h
MOV [CPUInfo.TransmetaSpecific.CurrentFrequency], EAX
MOV [CPUInfo.TransmetaSpecific.CurrentVoltage], EBX
MOV [CPUInfo.TransmetaSpecific.CurrentPerformance], ECX
@@DoneCpuType:
POP ESI
POP EDX
POP EDI
POP ECX
POP EBX
POP EBP
POP EAX
end;
case CPUInfo.CpuType of
CPU_TYPE_INTEL : IntelSpecific(CpuInfo);
CPU_TYPE_CYRIX : CyrixSpecific(CpuInfo);
CPU_TYPE_AMD : AMDSpecific(CpuInfo);
CPU_TYPE_TRANSMETA : TransmetaSpecific(CpuInfo);
CPU_TYPE_VIA : ViaSpecific(CpuInfo);
else begin
CpuInfo.Manufacturer := 'Unknown';
CpuInfo.CpuName := 'Unknown';
end;
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) ========================================
{$IFDEF MSWINDOWS}
function GetAPMLineStatus: TAPMLineStatus;
var
SystemPowerStatus: TSystemPowerStatus;
begin
Result := alsUnknown;
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 5) then // Windows NT doesn't support GetSystemPowerStatus
Exit; // so we return 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 (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 5) then // Windows NT doesn't support GetSystemPowerStatus
Exit; // so we return 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 GetAPMBatteryFlags: TAPMBatteryFlags;
var
SystemPowerStatus: TSystemPowerStatus;
begin
Result := [];
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 5) then // Windows NT doesn't support GetSystemPowerStatus
begin
Result := [abfUnknown];
Exit; // so we return [abfUnknown]
end;
if not GetSystemPowerStatus(SystemPowerStatus) then
RaiseLastOSError
else
begin
if (SystemPowerStatus.BatteryFlag and 1) <> 0 then
Result := Result + [abfHigh];
if (SystemPowerStatus.BatteryFlag and 2) <> 0 then
Result := Result + [abfLow];
if (SystemPowerStatus.BatteryFlag and 4) <> 0 then
Result := Result + [abfCritical];
if (SystemPowerStatus.BatteryFlag and 8) <> 0 then
Result := Result + [abfCharging];
if (SystemPowerStatus.BatteryFlag and 128) <> 0 then
Result := Result + [abfNoBattery];
if SystemPowerStatus.BatteryFlag = 255 then
Result := Result + [abfUnknown];
end;
end;
function GetAPMBatteryLifePercent: Integer;
var
SystemPowerStatus: TSystemPowerStatus;
begin
Result := 0;
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 5) then // Windows NT doesn't support GetSystemPowerStatus
Exit;
if not GetSystemPowerStatus(SystemPowerStatus) then
RaiseLastOSError
else
Result := SystemPowerStatus.BatteryLifePercent;
end;
function GetAPMBatteryLifeTime: DWORD;
var
SystemPowerStatus: TSystemPowerStatus;
begin
Result := 0;
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 5) then // Windows NT doesn't support GetSystemPowerStatus
Exit;
if not GetSystemPowerStatus(SystemPowerStatus) then
RaiseLastOSError
else
Result := SystemPowerStatus.BatteryLifeTime;
end;
function GetAPMBatteryFullLifeTime: DWORD;
var
SystemPowerStatus: TSystemPowerStatus;
begin
Result := 0;
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 5) then // Windows NT doesn't support GetSystemPowerStatus
Exit;
if not GetSystemPowerStatus(SystemPowerStatus) then
RaiseLastOSError
else
Result := SystemPowerStatus.BatteryFullLifeTime;
end;
//=== Memory Information =====================================================
function GetMaxAppAddress: Cardinal;
var
SystemInfo: TSystemInfo;
begin
FillChar(SystemInfo, SizeOf(SystemInfo), #0);
GetSystemInfo(SystemInfo);
Result := Integer(SystemInfo.lpMaximumApplicationAddress);
end;
function GetMinAppAddress: Cardinal;
var
SystemInfo: TSystemInfo;
begin
FillChar(SystemInfo, SizeOf(SystemInfo), #0);
GetSystemInfo(SystemInfo);
Result := Integer(SystemInfo.lpMinimumApplicationAddress);
end;
{$ENDIF MSWINDOWS}
function GetMemoryLoad: Byte;
{$IFDEF UNIX}
var
SystemInf: TSysInfo ;
begin
SysInfo(SystemInf);
with SystemInf do
Result := 100 - Round(100 * freeram / totalram);
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwMemoryLoad;
end;
{$ENDIF MSWINDOWS}
function GetSwapFileSize: Cardinal;
{$IFDEF UNIX}
var
SystemInf: TSysInfo;
begin
SysInfo(SystemInf);
Result := SystemInf.totalswap;
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
with MemoryStatus do
Result := dwTotalPageFile - dwAvailPageFile;
end;
{$ENDIF MSWINDOWS}
function GetSwapFileUsage: Byte;
{$IFDEF UNIX}
var
SystemInf: TSysInfo;
begin
SysInfo(SystemInf);
with SystemInf do
Result := 100 - Trunc(100 * FreeSwap / TotalSwap);
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
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;
{$ENDIF MSWINDOWS}
function GetTotalPhysicalMemory: Cardinal;
{$IFDEF UNIX}
var
SystemInf: TSysInfo;
begin
SysInfo(SystemInf);
Result := SystemInf.totalram;
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwTotalPhys;
end;
{$ENDIF MSWINDOWS}
function GetFreePhysicalMemory: Cardinal;
{$IFDEF UNIX}
var
SystemInf: TSysInfo;
begin
SysInfo(SystemInf);
Result := SystemInf.freeram;
end;
{$ENDIF UNIX}
{$IFDEF MSWINDOWS}
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwAvailPhys;
end;
function GetTotalPageFileMemory: Cardinal;
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwTotalPageFile;
end;
function GetFreePageFileMemory: Cardinal;
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwAvailPageFile;
end;
function GetTotalVirtualMemory: Cardinal;
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwTotalVirtual;
end;
function GetFreeVirtualMemory: Cardinal;
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 ==========================
{ TODO -oPJH : compare to Win9xFreeSysResources }
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/Finalization ============================================
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;
IsWinNT35 := True;
IsWinNT351 := True;
end;
wvWinNT4:
IsWinNT4 := True;
wvWin2000:
IsWin2K := True;
wvWinXP:
IsWinXP := True;
wvWin2003:
IsWin2003 := True;
wvWinXP64:
IsWinXP64 := True;
wvWin2003R2:
IsWin2003R2 := True;
wvWinVista:
IsWinVista := True;
wvWinLonghorn:
IsWinLonghorn := True;
end;
end;
procedure FinalizeSysInfo;
begin
UnloadSystemResourcesMeterLib;
end;
initialization
InitSysInfo;
finalization
FinalizeSysInfo;
{$ENDIF MSWINDOWS}
{$ENDIF ~CLR}
// History:
// $Log: JclSysInfo.pas,v $
// Revision 1.56 2005/12/12 21:54:09 outchy
// HWND changed to THandle (linking problems with BCB).
//
// Revision 1.55 2005/11/22 08:37:59 obones
// Added missing EXTERNALSYM declarations
//
// Revision 1.54 2005/11/21 11:50:22 outchy
// Detection of Windows Vista/Longhorn/2003 R2/XP 64.
// From: http://msdn.microsoft.com/library/default.asp?url=/library/en-us/sysinfo/base/getting_the_system_version.asp
//
// Revision 1.53 2005/10/30 01:51:27 rrossmair
// - introduce KEEP_DEPRECATED as alias for ~DROP_OBSOLETE_CODE
// - some style cleaning
//
// Revision 1.52 2005/09/28 23:27:50 outchy
// Added constant of bits of the MXCSR register.
//
// Revision 1.51 2005/08/09 10:30:22 ahuser
// JCL.NET changes
//
// Revision 1.50 2005/08/09 07:39:28 marquardt
// forgot to compile last (bad) changes
//
// Revision 1.49 2005/08/09 07:35:42 marquardt
// minor style fix
//
// Revision 1.48 2005/08/08 07:02:56 marquardt
// minor style fix
//
// Revision 1.47 2005/08/07 13:09:55 outchy
// Changed PByteArray to PJclByteArray to avoid RangeCheck exceptions.
//
// Revision 1.46 2005/07/03 19:29:27 ahuser
// Fixed another CLR IFDEFs bug
//
// Revision 1.45 2005/07/02 18:40:19 ahuser
// Fixed IFDEFs
//
// Revision 1.44 2005/05/23 19:19:17 outchy
// IT2974: Memory sizes should be cardinal values (not Integer values).
//
// Revision 1.43 2005/05/05 20:08:45 ahuser
// JCL.NET support
//
// Revision 1.42 2005/04/07 00:41:35 rrossmair
// - changed for FPC 1.9.8
//
// Revision 1.41 2005/03/12 01:32:50 outchy
// Update of the CPUID function. New processors detection, constants reworked and specifications upgraded.
//
// Revision 1.40 2005/03/08 08:33:17 marquardt
// overhaul of exceptions and resourcestrings, minor style cleaning
//
// Revision 1.39 2005/03/03 15:35:59 rikbarker
// Windows 2003 Fix for NTProductType and GetWindowsServicePackVersion
//
// Revision 1.38 2005/02/24 16:34:40 marquardt
// remove divider lines, add section lines (unfinished)
//
// Revision 1.37 2005/02/24 07:36:24 marquardt
// resolved the compiler warnings, style cleanup, removed code from JclContainerIntf.pas
//
// Revision 1.36 2005/02/20 04:37:09 rrossmair
// - added GetIPAddress() and GetIPAddresses() for Unix
//
// Revision 1.35 2004/12/19 20:16:31 rrossmair
// - added TCpuInfo improvements by Florent Ouchet
//
// Revision 1.34 2004/12/07 02:40:07 rrossmair
// - added GetVolumeFileSystemFlags function
//
// Revision 1.33 2004/10/21 08:40:10 marquardt
// style cleaning
//
// Revision 1.32 2004/10/17 23:48:22 mthoma
// Removed contributions... Reintroduced orignal GetOpenGLVersion.
//
// Revision 1.31 2004/10/17 20:25:21 mthoma
// style cleaning, adjusting contributors
//
// Revision 1.30 2004/10/10 12:52:12 marquardt
// DestroyEnvironmentBlock introduced
//
// Revision 1.29 2004/08/04 09:05:51 marquardt
// forgot to export SetGlobalEnvironmentVariable
//
// Revision 1.28 2004/08/04 06:11:49 marquardt
// added SetGlobalEnvironmentVariable
//
// Revision 1.27 2004/08/03 07:22:37 marquardt
// resourcestring cleanup
//
// Revision 1.26 2004/07/31 06:21:01 marquardt
// fixing TStringLists, adding BeginUpdate/EndUpdate, finalization improved
//
// Revision 1.25 2004/07/28 18:00:51 marquardt
// various style cleanings, some minor fixes
//
// Revision 1.24 2004/07/16 04:11:46 rrossmair
// fixed RunningProcessesList for Win2003
//
// Revision 1.23 2004/06/16 07:30:28 marquardt
// added tilde to all IFNDEF ENDIFs, inherited qualified
//
// Revision 1.22 2004/06/14 13:05:18 marquardt
// style cleaning ENDIF, Tabs
//
// Revision 1.21 2004/06/14 06:24:52 marquardt
// style cleaning IFDEF
//
// Revision 1.20 2004/06/02 03:23:46 rrossmair
// cosmetic changes in several units (code formatting, help TODOs processed etc.)
//
// Revision 1.19 2004/05/08 08:44:17 rrossmair
// introduced & applied symbol HAS_UNIT_LIBC
//
// Revision 1.18 2004/05/05 07:12:03 rrossmair
// changes for FPC compatibility
//
// Revision 1.17 2004/05/05 00:15:12 mthoma
// Updated headers: Added donors as contributors, adjusted the initial authors, added cvs names when they were not obvious. Changed $data to $date where necessary,
//
// Windows NT 4 and earlier do not support GetSystemPowerStatus. Modified the APM function accordingly.
//
// Revision 1.16 2004/04/19 06:14:43 rrossmair
// Help TODOs done
//
// Revision 1.15 2004/04/18 19:57:29
// - rename one of the GetOpenGLVersion to GetOpenGLVersionBitmapRendering
// - delete pre-loading of Glu32Handle
// - move the OpenGl32Handle call to directly before ChoosePixelFormat
//
// Revision 1.14 2004/04/18 05:14:11 rrossmair
// fixed GetOpenGLVersion (draw to bitmap overload); removed VCL dependency ("uses Graphics")
//
// Revision 1.13 2004/04/18 00:43:19
// modify und bugfix GetOpenGLVersion, add second function for bitmap rendering
//
// Revision 1.12 2004/04/09 15:05:09 mthoma
// Added new function GetAPMBatteryFlags.
//
// Revision 1.11 2004/04/07 13:55:09 peter3
// - var params cannot be passed by adress
//
// Revision 1.10 2004/04/07 07:33:39 marquardt
// fixes for GetVersionEx
//
// Revision 1.9 2004/04/06 04:53:18
// adapt compiler conditions, add log entry
//
end.
Reference in New Issue View Git Blame Copy Permalink