Case DriveType Of
0: Result := '?';
1: Result := 'Path does not exists';
Drive_Removable: Result := 'Removable';
Drive_Fixed : Result := 'Fixed';
Drive_Remote : Result := 'Remote';
Drive_CDROM : Result := 'CD-ROM';
Drive_RamDisk : Result := 'RAMDisk'
else
Result := 'Unknown';
end;
end;
function GettingHWProfileName: String;
var
pInfo: TagHW_PROFILE_INFOA;
begin
GetCurrentHwProfile(pInfo);
Result := pInfo.szHwProfileName;
end;
procedure TDiadnostic.FormCreate(Sender: TObject);
var OsVerInfo:Tosversioninfo;
winver,build:string;
Disks:byte;
buffer:array[0..255]of char;
wd:string;
sp:array[0..max_path-1]of char;
s:string;
memorystatus:tmemorystatus;
dwLength:DWORD; // sizeof(MEMORYSTATUS)
dwMemoryLoad:DWORD; // percent of memory in use
dwTotalPhys:DWORD ; // bytes of physical memory
dwAvailPhys:DWORD ; // free physical memory bytes
dwTotalPageFile:DWORD ; // bytes of paging file
dwAvailPageFile:DWORD ;// free bytes of paging file
dwTotalVirtual:DWORD ;// user bytes of address space
dwAvailVirtual:DWORD ; // free user bytes
ktype:integer;
R:Tregistry;
R2:Tregistry;
disk1:integer;
msgtext:string;
const monitorregdir:string='\system\currentcontrolset\ENUM\Display\Default_Monitor';
videordir:string='\System\currentcontrolset\services\class\display\0000';
processordir:string='Hardware\Description\System\Centralprocessor\0';
begin
button2.click;
Label50.Caption:=GettingHWProfileName;
listbox1.items:=screen.fonts;
numofbuttons.caption:=inttostr(getsystemmetrics(sm_cmousebuttons));
if getsystemmetrics(sm_mousepresent)<>0then ismouse.caption:='Есть'else
ismouse.caption:='Нет';
for disk1:=0 to diskname.items.count-1 do
begin
disk.lines.add(diskname.items[disk1]+' '+CheckDriveType(diskname.items[disk1][1]));
end;
{monitor&video}
///////
R:=tregistry.create;
R.RootKey:=HKEY_LOCAL_MACHINE;
R.OpenKey(monitorregdir,false);
monitortype.caption:=R.ReadString('DeviceDesc');
monitormanufacturer.caption:=R.ReadString('Mfg');
monitorid.caption:=r.readstring('HardwareID');
R.OpenKey(videordir,false);
//drvdesc.caption:=r.ReadString('DriverDesc');
driverdate.caption:=r.readstring('DriverDate');
drvprovider.caption:=r.readstring('ProviderName');
driverver.caption:=r.readstring('ver');
r.closekey;
r.closekey;
getinfovideo;
//////
{Version BIOS}
GetRegInfoWinNT;
{advanced processor info}
R2:=Tregistry.create;
R2.RootKey:=HKEY_LOCAL_MACHINE;
r2.OpenKey(processordir,false);
processorname.caption:=r2.readstring('Identifier');
vident.caption:=r2.readstring('VendorIdentifier');
if not (r2.readstring('MMXIdentifier')='')then
mmx1.caption:=r2.readstring('MMXIdentifier')
else
mmx1.caption:='нет';
Label48.Caption:=inttostr(Trunc(GetCPUSpeed))+' MHz';
{}
{memory}
memorystatus.dwlength:=sizeof(memorystatus);
globalmemorystatus(memorystatus);
physmemory.caption:=floattostr(memorystatus.dwtotalphys div 1024 div 1024)+' Мега '+'('+
floattostr(memorystatus.dwtotalphys / 1024 / 1024)+')';
avail.caption:=floattostr(memorystatus.dwavailphys / 1024 / 1024)+' Мег';
maxpf.caption:=floattostr(memorystatus.dwtotalpagefile / 1024 / 1024);
pffree.caption:=floattostr(memorystatus.dwavailpagefile / 1024 / 1024);
{}
{Windows info}
winid.caption:=getwinid;
winkey.caption:=getwinkey;
ver1.Caption:=getwinname;
username.caption:=getusernme;
//plusver.caption:=getplusvernum;
company.caption:=getorgname;
resolution.caption:=getscreenresolution;
{printer}
try
getprofilestring('windows','device',',,,',buffer,256);
s:=strpas(buffer);
defprn.Lines.add(' Принтер: '+copy(s,1,pos(',',s)-1));
delete(s,1,pos(',',s)-1);
defprn.lines.add(' Порт: '+copy(s,1,pos(',',s)-1));
delete(s,1,pos(',',s)-1);
defprn.lines.add(' Драйвер и порт:'+ s);
except
showmessage('Printer not found');
end;
{keyboard}
ktype:=GetKeyboardType(0);
case ktype of
1:keytype.caption:='IBM PC/XT или совместимая (83-клавииши)';
2:keytype.caption:='Olivetti "ICO" (102-клавиши)';
3:keytype.caption:='IBM PC/AT (84-клавиши) и другие';
4:keytype.caption:='IBM-расширенная (101/102-клавиши)';
5:keytype.caption:='Nokia 1050 and similar keyboards';
6:keytype.caption:='Nokia 9140 and similar keyboards';
7:keytype.caption:='Japanese keyboard';
end;
numoffunckey.Caption:=inttostr(getkeyboardtype(2));
{
typ.hide;
label14.hide;
{windir}
getwindowsdirectory(sp,max_path);
wd:=strpas(sp);
{windir.caption:=wd;
progrfiles.caption:=getprogramfilesdir;
label13.hide;
label12.hide;
{Windows version}
OSVerInfo.dwOsversioninfosize:=sizeof(osverinfo);
getversionex(osverinfo);
case osverinfo.dwplatformid of
ver_platform_win32s:os.caption:='Windows 3.x';
ver_platform_win32_windows:os.Caption:='Windows 95 (98)';
ver_platform_win32_nt:os.caption:='Windows NT';
end;
with osverinfo do
begin
winver:=format('%d.%d',[dwmajorversion, dwminorversion]);
build:=format('%d', [LoWord(dwbuildnumber)]);
osver.caption:=winver;
osver.caption:=osver.caption+' (сборка: '+build+')';
end;
{boot}
{oottype.caption:=getboottype;
{printer}
{Prntrs.items:=Printer.Printers;}
prn.items:=Printer.Printers;
try
fnt.items:=printer.fonts;
except
end;
prn.ItemIndex:=0;
edit2.text:=inttostr(printer.pageheight);
edit1.text:=inttostr(printer.pagewidth);
GetPrName(Processor1);
GetPrName(pt);
resolution.Caption :=inttostr(Screen.Width)+'на'+inttostr(Screen.Height);
timer1.Enabled:=true;
end;
function OpenCD(Drive : Char) : Boolean;
Var
Res : MciError;
OpenParm: TMCI_Open_Parms;
Flags : DWord;
S : String;
DeviceID : Word;
begin
Result := False;
S := Drive + ':';
Flags := mci_Open_Type or mci_Open_Element;
With OpenParm do begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
{Эта строчка необходима для правильной работы функции IntellectCD}
Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
IF Res <> 0 Then Exit;
DeviceID := OpenParm.wDeviceID;
try
Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
IF Res = 0 Then Exit;
Result := True;
finally
mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
end;
end;
function CloseCD(Drive : Char) : Boolean;
Var
Res : MciError;
OpenParm: TMCI_Open_Parms;
Flags : DWord;
S : String;
DeviceID : Word;
begin
Result := False;
S := Drive + ':';
Flags := mci_Open_Type or mci_Open_Element;
With OpenParm do begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
IF Res <> 0 Then Exit;
DeviceID := OpenParm.wDeviceID;
try
Res := mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
IF Res = 0 Then
Result := True;
finally
mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
end;
end;
procedure Delay(msecs : Longint);
var
FirstTick : Longint;
begin
FirstTick := GetTickCount;
repeat
Application.ProcessMessages;
until GetTickCount - FirstTick >= msecs;
end;
procedure TDiadnostic.Button1Click(Sender: TObject);
var disk1:integer;
begin
for disk1:=0 to diskname.items.count-1 do
begin
if CheckDriveType(diskname.items[disk1][1])='CD-ROM'
then
begin
opencd(diskname.items[disk1][1]);
delay(5000);
closecd(diskname.items[disk1][1]);
end;
end;
end;
procedure TDiadnostic.SpeedButton1Click(Sender: TObject);
begin
form1.show;
end;
procedure TDiadnostic.SpeedButton2Click(Sender: TObject);
begin
//ShellExecute(handle,nil,'mem.exe',nil,nil,sw_restore);
MessageDlg('Тестирующая программа загружена в оперативную память',mtInformation,[mbok],0);
end;
end.
//модуль тестирования процессора
unit ProcessorClockCounter;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TClockPriority=(cpIdle, cpNormal, cpHigh, cpRealTime, cpProcessDefined);
TPrecizeProc = procedure(Sender: TObject) of Object;
TProcessorClockCounter = class(TComponent)
private
FCache:array[0..(1 shl 19) - 1] of byte; // 512 Kb NOP instructions is enough to clear cache
FStarted:DWORD;
FClockPriority:TClockPriority;
FProcessHandle:HWND;
FCurrentProcessPriority: Integer;
FDesiredProcessPriority: Integer;
FThreadHandle:HWND;
FCurrentThreadPriority: Integer;
FDesiredThreadPriority: Integer;
FCalibration:int64; //used to
FPrecizeCalibration:int64;
FStartValue:int64;
FStopValue:int64;
FDeltaValue:int64;
FPrecizeProc:TPrecizeProc;
FCounterSupported:boolean;
procedure PrecizeStart;
procedure PrecizeStartInCache;
procedure GetProcInf;
procedure SetClockPriority(Value: TClockPriority);
procedure ProcedureWithoutInstruction; //description is in code
function GetClock:Int64; register;
function GetStarted:Boolean;
protected
procedure AdjustPriority; virtual; // internal used in constructor to setup parameters when class is created in RunTime
function CheckCounterSupported:boolean;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Calibrate;
procedure Start;
procedure Stop;
procedure EraseCache;
procedure TestPrecizeProc; virtual;
procedure TestPrecizeProcInCache; virtual;
property Counter:int64 read FDeltaValue; // contain the measured test clock pulses (StopValue - StartValue - Calibration)
property StartValue:int64 read FStartValue; // Value on the begining
property StopValue:int64 read FStopValue; // Value on test finished
property Started:Boolean read GetStarted;
property CurrentClock:int64 read GetClock; // for longer tests this could be use to get current counter
published
property ClockPriority:TClockPriority read FClockPriority write SetClockPriority default cpNormal;
property Calibration:int64 read FCalibration; // this is used to nullify self code execution timing
property OnPrecizeProc:TPrecizeProc read FPrecizeProc write FPrecizeProc; // user can define it for testing part of code inside it
property CounterSupported:boolean read FCounterSupported;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('ASM Utils', [TProcessorClockCounter]);
end;
constructor TProcessorClockCounter.Create(AOwner: TComponent);
var n:integer;
begin
inherited create(AOwner);
FCounterSupported:=CheckCounterSupported;
for n:=0 to High(FCache)-1 do FCache[n]:=$90; // fill with NOP instructions
FCache[High(FCache)]:=$C3; // the last is the RET instruction
FClockPriority:=cpNormal;
FStarted:=0;
FDesiredProcessPriority:=NORMAL_PRIORITY_CLASS;
FDesiredThreadPriority :=THREAD_PRIORITY_NORMAL;
AdjustPriority;
Calibrate;
FStartValue:=0;
FStopValue:=0;
FDeltaValue:=0;
end;
destructor TProcessorClockCounter.Destroy;
begin
inherited destroy;
end;
procedure TProcessorClockCounter.GetProcInf;
begin
FProcessHandle:=GetCurrentProcess;
FCurrentProcessPriority:=GetPriorityClass(FProcessHandle);
FThreadHandle:=GetCurrentThread;
FCurrentThreadPriority:=GetThreadPriority(FThreadHandle);
end;
procedure TProcessorClockCounter.AdjustPriority;
begin
GetProcInf;
case FDesiredProcessPriority of
IDLE_PRIORITY_CLASS: FClockPriority:=cpIdle;
NORMAL_PRIORITY_CLASS: FClockPriority:=cpNormal;
HIGH_PRIORITY_CLASS: FClockPriority:=cpHigh;
REALTIME_PRIORITY_CLASS: FClockPriority:=cpRealTime;
end;
end;
procedure TProcessorClockCounter.SetClockPriority(Value: TClockPriority);
begin
if Value<>FClockPriority then
begin
FClockPriority:=Value;
case FClockPriority of
cpIdle: begin
FDesiredProcessPriority:=IDLE_PRIORITY_CLASS;
FDesiredThreadPriority :=THREAD_PRIORITY_IDLE;
end;
cpNormal: begin
FDesiredProcessPriority:=NORMAL_PRIORITY_CLASS;
FDesiredThreadPriority :=THREAD_PRIORITY_NORMAL;
end;
cpHigh: begin
FDesiredProcessPriority:=HIGH_PRIORITY_CLASS;
FDesiredThreadPriority :=THREAD_PRIORITY_HIGHEST;
end;
cpRealTime:begin
FDesiredProcessPriority:=REALTIME_PRIORITY_CLASS;
FDesiredThreadPriority :=THREAD_PRIORITY_TIME_CRITICAL;
end;
cpProcessDefined:
begin
FDesiredProcessPriority:=FCurrentProcessPriority;
FDesiredThreadPriority :=FCurrentThreadPriority;
end;
end;
Calibrate;
end;
end;
procedure TProcessorClockCounter.TestPrecizeProc;
// This procedure is intended for testing small block of
// code when it must be put in the processor cache
begin
FDeltaValue:=0;
if FCounterSupported and assigned(FPrecizeProc) then
begin
PrecizeStart; // start test
end;
end;
procedure TProcessorClockCounter.TestPrecizeProcInCache;
// This procedure is intended for testing small block of
// code when it is already in the processor cache
begin
FDeltaValue:=0;
if FCounterSupported and assigned(FPrecizeProc) then
begin
EraseCache;
PrecizeStartInCache; // first test will fill processor cache
PrecizeStartInCache; // second test
// generate calibration value for
// code already put in the cache
end;
end;
procedure TProcessorClockCounter.ProcedureWithoutInstruction;
// this is used for calibration! DO NOT CHANGE
asm
ret
end;
procedure TProcessorClockCounter.EraseCache; register;
asm
push ebx
lea ebx,[eax + FCache]
call ebx // force call to code in array :)
pop ebx // this will fill level2 cache with NOPs (For motherboards with 1 Mb level 2 cache,
ret // size of array should be increased to 1 Mb)
// next instructions are never executed but need for proper align of 16 byte.
// Some processors has different execution times when code is not 16 byte aligned
// Actually, (on some processors), internal mechanism of level 1 cache (cache built
// in processor) filling is designed to catch memory block faster, when
// it is 16 byte aligned !!!
nop
nop
nop
nop
nop
nop
end;
function TProcessorClockCounter.GetClock: Int64; register;
asm
push edx
push ebx
push eax
mov ebx,eax
xor eax,eax // EAX & EDX are initialized to zero for
mov edx,eax // testing counter support
DW $310f // This instruction will make exception
sub eax,dword ptr [ebx+FStartValue] // or do nothing on processors wthout
sbb edx,dword ptr [ebx+FStartValue+4] // counter support
sub eax,dword ptr [ebx+FCalibration]
sbb edx,dword ptr [ebx+FCalibration+4]
mov dword ptr [esp + $10],eax
mov dword ptr [esp + $14],edx
pop eax
pop ebx
pop edx
ret
end;
procedure TProcessorClockCounter.PrecizeStartInCache; register;