library AIOWDM;

uses
  Windows, SysUtils, Classes, WinSvc, Registry, WDMIO;

{$R *.RES}

{//$DEFINE EXPORT_BENCH}

type
  TOS = (osDunno, osWin95, osWin98, osNT, osNT5);

  TCardInfo = packed record
    DeviceID: LongWord;
    BaseAddress: Word;
    Reserved: Word;
  end;

const
  IFKey = 'System\CurrentControlSet\Control\DeviceClasses\{E77894A2-697F-11D0-958E-AF1FDADB2F1B}';
  {E77894A2-697F-11D0-958E-AF1FDADB2F1B}
  //GUID = $E77894A2697F11D0958EAF1FDADB2F1B;
  //MSMungedGUID: PChar = #$A2#$94#$78#$E7#$7F#$69#$D0#$11#$95#$8E#$AF#$1F#$DA#$DB#$2F#$1B;
  //MSMungedGUID: TGUID = (D1: $E77894A2; D2: $697F; D3: $11D0; D4: ($95, $8E, $AF, $1F, $DA, $DB, $2F, $1B));
  //BaseMSMungedGUID: PChar = #$A2#$94#$78#$E7#$7F#$69#$D0#$11#$95#$8E#$AF#$1F#$DA#$DB#$2F#$1B;
  PCIFindKey = 'Software\PCIFind';
  IOCTL_QUERY_INFO     = $80FF6000;
  IOCTL_QUERY_BAR_BASE = $80FF6004;
  IOCTL_IRQ_WAIT_BEGIN = $80FF6040;
  IOCTL_IRQ_WAIT_ABORT = $80FF2048;
  IOCTL_IRQ_POLL       = $80FF6050;
  IOCTL_GET_BENCH      = $80FF60C0;
  IOCTL_FORGET_IRP     = $80FFA200;
  LongTrue = LongWord(-1);

var
  OS: TOS = osDunno;
  StupidXPShutdownIssue: Boolean;
  Devices: array of record
    SymbolicLink: String;
    hDevice: THandle;
    Base: Word;
    BaseOK: ByteBool;
    WDGOK: ByteBool;
    WDGCountsA,
    WDGCountsB: Word;
    IsOpen: WordBool;
    Reserved: Word;
    WDGAction: LongWord;
  end;
  hCentralDevice: THandle;
  CurCardNum: Integer = 0;
  Args: PChar = nil;
  //MSMungedGUID: PGUID absolute BaseMSMungedGUID;



function EnsureCardOpen(CardNum: Integer; EnsureWDG: Boolean = False): Boolean;
begin
  Result := False;
  if (CardNum < 0) or (CardNum > High(Devices)) then begin
    SetLastError(ERROR_INVALID_PARAMETER);
    Exit;
  end;
  if Devices[CardNum].hDevice <> INVALID_HANDLE_VALUE then begin
    if EnsureWDG and not Devices[CardNum].WDGOK then begin
      SetLastError(ERROR_BAD_TOKEN_TYPE);
      Result := False;
    end
    else begin
      SetLastError(ERROR_ALREADY_EXISTS);
      Result := True;
    end;
    Exit;
  end;
  if EnsureWDG then
    SetLastError(ERROR_BAD_TOKEN_TYPE)
  else begin
    Devices[CardNum].hDevice := CreateFile(
      PChar(Devices[CardNum].SymbolicLink),
      GENERIC_READ or GENERIC_WRITE,
      FILE_SHARE_READ or FILE_SHARE_WRITE,
      nil,
      OPEN_EXISTING,
      FILE_FLAG_OVERLAPPED,
      0
    );
    Result := Devices[CardNum].hDevice <> INVALID_HANDLE_VALUE;
  end;
end;

function   RelInPortB (CardNum, Offset: LongWord                 ): Word;     cdecl;   begin Result := $AA55; if not EnsureCardOpen(CardNum) then Exit; Result := _InPortB (Devices[CardNum].hDevice, Offset);        end;
function   RelInPort  (CardNum, Offset: LongWord                 ): Word;     cdecl;   begin Result := $AA55; if not EnsureCardOpen(CardNum) then Exit; Result := _InPort  (Devices[CardNum].hDevice, Offset);        end;
function   RelInPortL (CardNum, Offset: LongWord                 ): LongWord; cdecl;   begin Result := $AA55; if not EnsureCardOpen(CardNum) then Exit; Result := _InPortL (Devices[CardNum].hDevice, Offset);        end;
function   RelOutPortB(CardNum, Offset: LongWord; Value: Byte    ): Word;     cdecl;   begin Result := $AA55; if not EnsureCardOpen(CardNum) then Exit; Result := _OutPortB(Devices[CardNum].hDevice, Offset, Value); end;
function   RelOutPort (CardNum, Offset: LongWord; Value: Word    ): Word;     cdecl;   begin Result := $AA55; if not EnsureCardOpen(CardNum) then Exit; Result := _OutPort (Devices[CardNum].hDevice, Offset, Value); end;
function   RelOutPortL(CardNum, Offset: LongWord; Value: LongWord): Word;     cdecl;   begin Result := $AA55; if not EnsureCardOpen(CardNum) then Exit; Result := _OutPortL(Devices[CardNum].hDevice, Offset, Value); end;

function VBRelInPortB (CardNum, Offset: LongWord                 ): Word;     stdcall; begin Result := RelInPortB (CardNum, Offset);        end;
function VBRelInPort  (CardNum, Offset: LongWord                 ): Word;     stdcall; begin Result := RelInPort  (CardNum, Offset);        end;
function VBRelInPortL (CardNum, Offset: LongWord                 ): LongWord; stdcall; begin Result := RelInPortL (CardNum, Offset);        end;
function VBRelOutPortB(CardNum, Offset: LongWord; Value: Byte    ): Word;     stdcall; begin Result := RelOutPortB(CardNum, Offset, Value); end;
function VBRelOutPort (CardNum, Offset: LongWord; Value: Word    ): Word;     stdcall; begin Result := RelOutPort (CardNum, Offset, Value); end;
function VBRelOutPortL(CardNum, Offset: LongWord; Value: LongWord): Word;     stdcall; begin Result := RelOutPortL(CardNum, Offset, Value); end;

function      InPortB (Addr: LongWord                 ): Word;     cdecl;   begin if hCentralDevice = INVALID_HANDLE_VALUE then begin SetLastError(ERROR_INVALID_HANDLE); Result := $AA55; Exit; end; Result := _InPortB (hCentralDevice, Addr);        end;
function      InPort  (Addr: LongWord                 ): Word;     cdecl;   begin if hCentralDevice = INVALID_HANDLE_VALUE then begin SetLastError(ERROR_INVALID_HANDLE); Result := $AA55; Exit; end; Result := _InPort  (hCentralDevice, Addr);        end;
function      InPortL (Addr: LongWord                 ): LongWord; cdecl;   begin if hCentralDevice = INVALID_HANDLE_VALUE then begin SetLastError(ERROR_INVALID_HANDLE); Result := $AA55; Exit; end; Result := _InPortL (hCentralDevice, Addr);        end;
function      OutPortB(Addr: LongWord; Value: Byte    ): Word;     cdecl;   begin if hCentralDevice = INVALID_HANDLE_VALUE then begin SetLastError(ERROR_INVALID_HANDLE); Result := $AA55; Exit; end; Result := _OutPortB(hCentralDevice, Addr, Value); end;
function      OutPort (Addr: LongWord; Value: Word    ): Word;     cdecl;   begin if hCentralDevice = INVALID_HANDLE_VALUE then begin SetLastError(ERROR_INVALID_HANDLE); Result := $AA55; Exit; end; Result := _OutPort (hCentralDevice, Addr, Value); end;
function      OutPortL(Addr: LongWord; Value: LongWord): Word;     cdecl;   begin if hCentralDevice = INVALID_HANDLE_VALUE then begin SetLastError(ERROR_INVALID_HANDLE); Result := $AA55; Exit; end; Result := _OutPortL(hCentralDevice, Addr, Value); end;

function    VBInPortB (Addr: LongWord                 ): Word;     stdcall; begin Result := InPortB (Addr);        end;
function    VBInPort  (Addr: LongWord                 ): Word;     stdcall; begin Result := InPort  (Addr);        end;
function    VBInPortL (Addr: LongWord                 ): LongWord; stdcall; begin Result := InPortL (Addr);        end;
function    VBOutPortB(Addr: LongWord; Value: Byte    ): Word;     stdcall; begin Result := OutPortB(Addr, Value); end;
function    VBOutPort (Addr: LongWord; Value: Word    ): Word;     stdcall; begin Result := OutPort (Addr, Value); end;
function    VBOutPortL(Addr: LongWord; Value: LongWord): Word;     stdcall; begin Result := OutPortL(Addr, Value); end;

function       InMemB (Addr: LongWord                 ): Word;     cdecl;   begin if hCentralDevice = INVALID_HANDLE_VALUE then begin SetLastError(ERROR_INVALID_HANDLE); Result := $AA55; Exit; end; Result := _InMemB (hCentralDevice, Addr);        end;
function       InMem  (Addr: LongWord                 ): Word;     cdecl;   begin if hCentralDevice = INVALID_HANDLE_VALUE then begin SetLastError(ERROR_INVALID_HANDLE); Result := $AA55; Exit; end; Result := _InMem  (hCentralDevice, Addr);        end;
function       InMemL (Addr: LongWord                 ): LongWord; cdecl;   begin if hCentralDevice = INVALID_HANDLE_VALUE then begin SetLastError(ERROR_INVALID_HANDLE); Result := $AA55; Exit; end; Result := _InMemL (hCentralDevice, Addr);        end;
function       OutMemB(Addr: LongWord; Value: Byte    ): Word;     cdecl;   begin if hCentralDevice = INVALID_HANDLE_VALUE then begin SetLastError(ERROR_INVALID_HANDLE); Result := $AA55; Exit; end; Result := _OutMemB(hCentralDevice, Addr, Value); end;
function       OutMem (Addr: LongWord; Value: Word    ): Word;     cdecl;   begin if hCentralDevice = INVALID_HANDLE_VALUE then begin SetLastError(ERROR_INVALID_HANDLE); Result := $AA55; Exit; end; Result := _OutMem (hCentralDevice, Addr, Value); end;
function       OutMemL(Addr: LongWord; Value: LongWord): Word;     cdecl;   begin if hCentralDevice = INVALID_HANDLE_VALUE then begin SetLastError(ERROR_INVALID_HANDLE); Result := $AA55; Exit; end; Result := _OutMemL(hCentralDevice, Addr, Value); end;

function     VBInMemB (Addr: LongWord                 ): Word;     stdcall; begin Result := InMemB (Addr);        end;
function     VBInMem  (Addr: LongWord                 ): Word;     stdcall; begin Result := InMem  (Addr);        end;
function     VBInMemL (Addr: LongWord                 ): LongWord; stdcall; begin Result := InMemL (Addr);        end;
function     VBOutMemB(Addr: LongWord; Value: Byte    ): Word;     stdcall; begin Result := OutMemB(Addr, Value); end;
function     VBOutMem (Addr: LongWord; Value: Word    ): Word;     stdcall; begin Result := OutMem (Addr, Value); end;
function     VBOutMemL(Addr: LongWord; Value: LongWord): Word;     stdcall; begin Result := OutMemL(Addr, Value); end;

procedure CtrMode(CardNum: LongWord; Ctr, Mode: Byte);
begin
  RelOutPortB(CardNum, 3, (Ctr shl 6) or $30 or (Mode shl 1));
end;

procedure CtrLoad(CardNum: LongWord; Ctr: Byte; Data: Word);
begin
  RelOutPortB(CardNum, Ctr, Lo(Data));
  RelOutPortB(CardNum, Ctr, Hi(Data));
end;



procedure GetPrivilege(Priv: PChar);
var
  TP: TTokenPrivileges;
  LUID: Int64;
  hToken: THandle;
  cbRet: LongWord;

begin
  if (OS <> osNT) and (OS <> osNT5) then Exit;

  LookupPrivilegeValue(nil, Priv, LUID);

  TP.PrivilegeCount := 1;
  TP.Privileges[0].Luid := LUID;
  TP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

  OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES, hToken);

  AdjustTokenPrivileges(
    hToken,
    FALSE,
    TP,
    sizeof(TOKEN_PRIVILEGES),
    nil,
    cbRet
  );

end;


function GetNumCards: Integer; cdecl;
begin
  Result := Length(Devices);
end;



function QueryCardInfo(CardNum: Integer; pDeviceID, pBase: PLongWord; pNameSize: pLongWord; pName: PChar): LongWord; cdecl;
var
  cbRet: LongWord;
  Data: TCardInfo;
  Reg: TRegistry;
  Buf: String;
  I: Integer;

begin
  Result := 0;
  Reg := nil;
  if not EnsureCardOpen(CardNum) then Exit;

  ZeroMemory(@Data, SizeOf(Data));
  if DeviceIOControl(Devices[CardNum].hDevice, IOCTL_QUERY_INFO, nil, 0, @Data, SizeOf(Data), cbRet, nil) then begin
    Result := LongTrue;
    Devices[CardNum].Base := Data.BaseAddress;
    Devices[CardNum].BaseOK := True;
    if pDeviceID <> nil then pDeviceID^ := Data.DeviceID;
    if pBase     <> nil then pBase^ := Data.BaseAddress;
    if (pName    <> nil) or (pNameSize <> nil) then try try
        Reg := TRegistry.Create(KEY_QUERY_VALUE);
        Reg.RootKey := HKEY_LOCAL_MACHINE;
        Reg.OpenKey(PCIFindKey, False);
        Buf := Reg.ReadString('Company');
        Reg.CloseKey;
        Reg.OpenKey('Software\' + Buf + '\Cardlist', False);
        Buf := Reg.ReadString(IntToHex(Data.DeviceID, 4));
        Reg.CloseKey;
        if pNameSize <> nil then begin
          I := pNameSize^;
          pNameSize^ := Length(Buf) + 1;
        end
        else
          I := 0
        ;
        if Length(Buf) + 1 < I then
          I := Length(Buf) + 1
        ;
        if I <> 0 then
          if I <> 1 then
            CopyMemory(pName, PChar(Buf), I)
          else
            pName^ := #0//Failed to get name
        ;
      except
        if pNameSize <> nil then
          pNameSize^ := 0
        ;
        Result := 0;
      end;
    finally
      FreeAndNil(Reg);
    end;
  end;
end;

function QueryBARBase(CardNum: Integer; BARIndex: LongWord; pBase: PLongWord): LongWord; cdecl;
var
  cbRet: LongWord;
  Data: LongWord;

begin
  Result := 0;
  if pBase = nil then begin
    SetLastError(ERROR_INVALID_ACCESS);
    Exit;
  end
  else if BARIndex > 5 then begin
    SetLastError(ERROR_INVALID_PARAMETER);
    Exit;
  end;
  if not EnsureCardOpen(CardNum) then Exit;

  Data := BARIndex;
  if DeviceIOControl(Devices[CardNum].hDevice, IOCTL_QUERY_BAR_BASE, @Data, SizeOf(Data), @Data, SizeOf(Data), cbRet, nil) then begin
    Result := LongTrue;
    pBase^ := Data;
  end;
end;



function WaitForIRQ(CardNum: Integer): LongWord; cdecl;
var
  O : TOverlapped;
  hEvent, cbRet: LongWord;

begin
  Result := 0;
  if not EnsureCardOpen(CardNum) then Exit;

  hEvent := CreateEvent(nil, true, false, '');
  try
    O.Internal := 0;
    O.InternalHigh := 0;
    O.Offset := 0;
    O.OffsetHigh := 0;
    O.hEvent := hEvent;

    Devices[CardNum].IsOpen := True;
    try
      if not DeviceIOControl(Devices[CardNum].hDevice, IOCTL_IRQ_WAIT_BEGIN, nil, 0, nil, 0, cbRet, @O) then begin
        if GetLastError <> ERROR_IO_PENDING then Exit; // some error occurred in the driver so return false
        GetOverlappedResult(Devices[CardNum].hDevice, O, cbRet, true);
        case GetLastError of
          ERROR_SUCCESS, ERROR_NO_MORE_FILES: ;
          else Exit; // IRP was cancelled(wait was aborted), so return false
        end;
      end;
    finally
      Devices[CardNum].IsOpen := False;
    end;

    Result := LongTrue;
  finally
    CloseHandle(hEvent);
  end;
end;



function COSWaitForIRQ(CardNum: Integer; PPIs: LongWord; pData: Pointer): LongWord; cdecl;
var
  O : TOverlapped;
  hEvent, cbRet: LongWord;
  Data: array of Byte;

begin
  Result := 0;
  if not EnsureCardOpen(CardNum) then Exit;

  hEvent := CreateEvent(nil, true, false, '');
  try
    O.Internal := 0;
    O.InternalHigh := 0;
    O.Offset := 0;
    O.OffsetHigh := 0;
    O.hEvent := hEvent;

    SetLength(Data, PPIs * 3);

    Devices[CardNum].IsOpen := True;
    try
      if not DeviceIOControl(Devices[CardNum].hDevice, IOCTL_IRQ_WAIT_BEGIN, nil, 0, Data, PPIs * 3, cbRet, @O) then begin
        if GetLastError <> ERROR_IO_PENDING then Exit; // some error occurred in the driver so return false
        GetOverlappedResult(Devices[CardNum].hDevice, O, cbRet, true);
        case GetLastError of
          ERROR_SUCCESS, ERROR_NO_MORE_FILES: ;
          else Exit; // IRP was cancelled(wait was aborted), so return false
        end;
      end;
      CopyMemory(pData, @Data[0], PPIs * 3);
    finally
      Devices[CardNum].IsOpen := False;
    end;

    Result := LongTrue;
  finally
    CloseHandle(hEvent);
  end;
end;



function EnsureCardOpenAndWDGAndBaseOK(CardNum: Integer): Boolean;
begin
  Result := False;
  if not EnsureCardOpen(CardNum, True) then Exit;

  Result := Devices[CardNum].BaseOK;

  if not Result then begin
    QueryCardInfo(CardNum, nil, nil, nil, nil);
    Result := Devices[CardNum].BaseOK;
  end;
end;



function HandlerThread(CardNum: Integer): Integer;
var
  Flags, ShutdownFlag: set of (ewxShutdown, ewxReboot, ewxForce, ewxPoweroff, ewxForceIfHung);
  Disable: Boolean;

begin
  Result := ERROR_CANCELLED;
  if WaitForIRQ(CardNum) = 0 then Exit;

  //If we get to here, an IRQ has just occurred
  Flags := [];
  Disable := Devices[CardNum].WDGAction and (1 shl 0) <> 0;
  if Disable or StupidXPShutdownIssue then
    ShutdownFlag := [ewxReboot]
  else
    ShutdownFlag := [ewxShutdown]
  ;
  if Devices[CardNum].WDGAction and (1 shl 1) <> 0 then Flags := Flags + ShutdownFlag;
  if Devices[CardNum].WDGAction and (1 shl 2) <> 0 then Flags := Flags + ShutdownFlag + [ewxForce];

  if Disable then
    RelInPortB(CardNum, 7)
  else if Flags <> [] then begin
    CtrMode(CardNum, 1, 3);
    CtrLoad(CardNum, 1, 2860); // 90 sec @ 2.0833 MHz
  end;
  if Flags <> [] then begin
    GetPrivilege('SeShutdownPrivilege');
    ExitWindowsEx(Byte(Flags), 0);
  end;
end;

function WDGHandleIRQ(CardNum: Integer; Action: LongWord): LongWord; cdecl;
var
  cbRet: LongWord;

begin
  Result := 0;
  if Action > 5 then begin
    SetLastError(ERROR_INVALID_PARAMETER);
    Exit;
  end;

  if Devices[CardNum].IsOpen then begin
    SetLastError(ERROR_INVALID_FUNCTION);
    Exit;
  end;

  if not EnsureCardOpenAndWDGAndBaseOK(CardNum) then Exit;

  Devices[CardNum].IsOpen := True;
  Devices[CardNum].WDGAction := Action;
  Result := BeginThread(nil, 0, @HandlerThread, Pointer(CardNum), 0, cbRet);
  if Result = 0 then Devices[CardNum].IsOpen := False;
end;



function WDGInit(CardNum: Integer): LongWord; cdecl;
begin
  Result := 0;

  if not Devices[CardNum].BaseOK then
    QueryCardInfo(CardNum, nil, nil, nil, nil)
  ;

  if Devices[CardNum].BaseOK then begin
    Devices[CardNum].WDGOK := True;
    Devices[CardNum].WDGCountsA := $FFFF;
    Devices[CardNum].WDGCountsB := $27C;
    Result := LongTrue;
  end;
end;



function WDGSetTimeout(CardNum: Integer; Milliseconds, MHzClockRate: Double): Double; cdecl;
begin
  Result := 0;
  if not EnsureCardOpenAndWDGAndBaseOK(CardNum) then Exit;

  if Milliseconds < 0 then Exit;
  if (Milliseconds > 4800000) and (MHzClockRate > 0.890) then Exit; //Exit if ISA and counts too high
  if (Milliseconds > 2060000) and (MHzClockRate > 2.0  ) then Exit; //Exit if PCI and counts too high

  Devices[CardNum].WDGCountsB := Round(Milliseconds * (MHzClockRate * 1000) / $FFFF);
  if Devices[CardNum].WDGCountsB = 0 then Devices[CardNum].WDGCountsB := 1;

  RelInPortB(CardNum, 7); //Disable counters
  CtrMode(CardNum, 2, 0); //Lower counter 2 to clear the reset
  CtrMode(CardNum, 2, 1);

  CtrMode(CardNum, 0, 2);
  CtrLoad(CardNum, 0, Devices[CardNum].WDGCountsA);
  CtrMode(CardNum, 1, 2);
  CtrLoad(CardNum, 1, Devices[CardNum].WDGCountsB);

  Result := Devices[CardNum].WDGCountsB / (MHzClockRate * 1000) * $FFFF;
end;



function WDGSetResetDuration(CardNum: Integer; Milliseconds, MHzClockRate: Double): Double; cdecl;
var
  Counts: LongWord;

begin
  Result := 0;
  if not EnsureCardOpenAndWDGAndBaseOK(CardNum) then Exit;

  if Milliseconds < 0 then Exit;
  if Milliseconds = 0 then CtrMode(CardNum, 2, 0); //Set counter 2 to mode 0, ISA disable buzzer
  if Milliseconds > 0 then CtrMode(CardNum, 2, 1); //Set counter 2 to mode 1, ISA enable buzzer
  if Milliseconds <= 1 then Exit;

  Counts := Round(Milliseconds * MHzClockRate * 1000);
  if Counts > $FFFF then Exit; //Exit if counts too high
  if Counts = 0 then Counts := 1;
  CtrMode(CardNum, 2, 2);
  CtrLoad(CardNum, 2, Counts);
  Result := Counts / (MHzClockRate * 1000);
end;



function WDGPet(CardNum: Integer): LongWord; cdecl;
begin
  Result := 0;
  if not EnsureCardOpenAndWDGAndBaseOK(CardNum) then Exit;

  //This algorithm leaves at least two places the system could lock up and the card not catch it.
  //Ideally, there'd be a single write to the CPLD that would cause it to drop the gates for one tick.
  //Pre-moding the counters appropriately, with MSB-only mode, and just writing to the larger counter would also work, but would have less flexibility.
  CtrMode(CardNum, 0, 3);
  CtrLoad(CardNum, 0, Devices[CardNum].WDGCountsA);
  CtrMode(CardNum, 1, 2);
  CtrLoad(CardNum, 1, Devices[CardNum].WDGCountsB);
  Result := LongTrue;
end;

function WDGReadTemp(CardNum: Integer): Double; cdecl;
begin
  Result := 0;
  if not EnsureCardOpenAndWDGAndBaseOK(CardNum) then Exit;

  // calculate temp in F
  Result := RelInPortB(CardNum, 5) * (11 / 15) + 7;
end;

function WDGReadStatus(CardNum: Integer): LongWord; cdecl;
begin
  Result := $1000;
  if not EnsureCardOpenAndWDGAndBaseOK(CardNum) then Exit;

  Result := RelInPortB(CardNum, 4); //Read Status Register - also enables IRQs
end;

function WDGStart(CardNum: Integer): LongWord; cdecl;
begin
  Result := 0;
  if not EnsureCardOpenAndWDGAndBaseOK(CardNum) then Exit;

  RelOutPortB(CardNum, 7, 0); //Enable counters
  Result := LongTrue;
end;

function WDGStop(CardNum: Integer): LongWord; cdecl;
begin
  Result := 0;
  if not EnsureCardOpen(CardNum, True) then Exit;

  RelInPortB(CardNum, 7); //disable counters
  Result := LongTrue;
end;

function EmergencyReboot(): LongWord; cdecl;
begin
  GetPrivilege('SeShutdownPrivilege');
  if ExitWindowsEx(EWX_REBOOT or EWX_FORCE, 0) then
    Result := LongTrue
  else
    Result := 0
  ;
end;



function AbortRequest(CardNum: Integer): LongWord; cdecl;
var
  cbRet: LongWord;

begin
  Result := 0;
  if not EnsureCardOpen(CardNum) then Exit;

  if DeviceIOControl(Devices[CardNum].hDevice, IOCTL_IRQ_WAIT_ABORT, nil, 0, nil, 0, cbRet, nil) then
    Result := LongTrue
  ;
end;

function ForgetIRP(CardNum: Integer): LongWord; cdecl;
var
  cbRet: LongWord;

begin
  Result := 0;
  if not EnsureCardOpen(CardNum) then Exit;

  if DeviceIOControl(Devices[CardNum].hDevice, IOCTL_FORGET_IRP, nil, 0, nil, 0, cbRet, nil) then
    Result := LongTrue
  ;
end;

function PollForIRQ(CardNum: Integer): LongWord; cdecl;
var
  cbRet: LongWord;

begin
  Result := 0;
  if not EnsureCardOpen(CardNum) then Exit;

  SetLastError(ERROR_SUCCESS);
  DeviceIOControl(Devices[CardNum].hDevice, IOCTL_IRQ_POLL, nil, 0, nil, 0, cbRet, nil);
  Result := GetLastError;
end;



function CloseCard(CardNum: Integer): LongWord; cdecl;
begin
  if (CardNum < 0) or (CardNum > High(Devices)) then begin
    Result := 0;
    SetLastError(ERROR_INVALID_PARAMETER);
    Exit;
  end;

  if Devices[CardNum].hDevice = INVALID_HANDLE_VALUE then begin
    Result := 1;
    SetLastError(ERROR_SUCCESS);
    Exit;
  end;

  if Devices[CardNum].IsOpen then AbortRequest(CardNum);
  Result := 1;
  CloseHandle(Devices[CardNum].hDevice);
  Devices[CardNum].hDevice := INVALID_HANDLE_VALUE;
  Devices[CardNum].WDGOK := False;
end;

{$IFDEF EXPORT_BENCH}
function GetBench(CardNum: Integer): Integer; cdecl;
var
  cbRet: LongWord;

begin
  Result := -1;
  if not EnsureCardOpen(CardNum) then Exit;

  if not DeviceIOControl(Devices[CardNum].hDevice, IOCTL_GET_BENCH, nil, 0, @Result, 4, cbRet, nil) then
    Result := -1
  ;
end;
{$ENDIF}



{
function CallbackOnIRQ(CardNum: Integer; ExtraDataType: LongWord; ExtraDataSize: LongWord; pExtraData: Pointer): LongWord; cdecl;
var
  T: TIRQThread;

begin
  //@
end;
}



function VBGetNumCards: Integer; stdcall;
begin
  Result := GetNumCards;
end;

function VBQueryCardInfo(CardNum: Integer; pDeviceID, pBase: PLongWord; pNameSize: pLongWord; pName: PChar): LongWord; stdcall;
begin
  Result := QueryCardInfo(CardNum, pDeviceID, pBase, pNameSize, pName);
end;

function VBQueryBARBase(CardNum: Integer; BARIndex: LongWord; pBase: PLongWord): LongWord; stdcall;
begin
  Result := QueryBARBase(CardNum, BARIndex, pBase);
end;

function VBWaitForIRQ(CardNum: Integer): LongWord; stdcall;
begin
  Result := WaitForIRQ(CardNum);
end;

function VBAbortRequest(CardNum: Integer): LongWord; stdcall;
begin
  Result := AbortRequest(CardNum);
end;

function VBForgetIRP(CardNum: Integer): LongWord; stdcall;
begin
  Result := ForgetIRP(CardNum);
end;

function VBPollForIRQ(CardNum: Integer): LongWord; stdcall;
begin
  Result := PollForIRQ(CardNum);
end;

function VBCloseCard(CardNum: Integer): LongWord; stdcall;
begin
  Result := CloseCard(CardNum);
end;

function VBCOSWaitForIRQ(CardNum: Integer; PPIs: LongWord; pData: Pointer): LongWord; stdcall;
begin
  Result := COSWaitForIRQ(CardNum, PPIs, pData);
end;

function VBWDGHandleIRQ(CardNum: Integer; Action: LongWord): LongWord; stdcall;
begin
  Result := WDGHandleIRQ(CardNum, Action);
end;

function VBWDGInit(CardNum: Integer): LongWord; stdcall;
begin
  Result := WDGInit(CardNum);
end;

function VBWDGSetTimeout(CardNum: Integer; Milliseconds, MHzClockRate: Double): Double; stdcall;
begin
  Result := WDGSetTimeout(CardNum, Milliseconds, MHzClockRate);
end;

function VBWDGSetResetDuration(CardNum: Integer; Milliseconds, MHzClockRate: Double): Double; stdcall;
begin
  Result := WDGSetResetDuration(CardNum, Milliseconds, MHzClockRate);
end;

function VBWDGPet(CardNum: Integer): LongWord; stdcall;
begin
  Result := WDGPet(CardNum);
end;

function VBWDGReadTemp(CardNum: Integer): Double; stdcall;
begin
  Result := WDGReadTemp(CardNum);
end;

function VBWDGReadStatus(CardNum: Integer): LongWord; stdcall;
begin
  Result := WDGReadStatus(CardNum);
end;

function VBWDGStart(CardNum: Integer): LongWord; stdcall;
begin
  Result := WDGStart(CardNum);
end;

function VBWDGStop(CardNum: Integer): LongWord; stdcall;
begin
  Result := WDGStop(CardNum);
end;

function VBEmergencyReboot(): LongWord; stdcall;
begin
  Result := EmergencyReboot;
end;

type
  TIRQCallback = procedure(Context: LongWord); stdcall;

type
  TIRQThread = class(TThread)
  public
    MyCardNum: Integer;
    MyCallback: TIRQCallback;
    MyContext: LongWord;
  protected
    procedure Execute; override;
  end;

procedure TIRQThread.Execute;
begin
  while WaitForIRQ(MyCardNum) <> 0 do
    MyCallback(MyContext)
  ;
end;
  
function VBStartIRQCallback(CardNum: Integer; Callback: TIRQCallback; Context: LongWord): LongWord; stdcall;
begin
  try
    Result := LongTrue;

    with TIRQThread.Create(True) do begin
      FreeOnTerminate := True;
      MyCardNum := CardNum;
      MyCallback := Callback;
      MyContext := Context;
      Resume;
    end;
  except
    Result := 0;
  end;
end;



exports
{$IFDEF EXPORT_BENCH}
  GetBench,
{$ENDIF}
  VBStartIRQCallback,

  QueryBARBase,        QueryBARBase        name '_QueryBARBase',        VBQueryBARBase,
  //Variable ordinals down to this point
  ForgetIRP,           ForgetIRP           name '_ForgetIRP',           VBForgetIRP,
  PollForIRQ,          PollForIRQ          name '_PollForIRQ',          VBPollForIRQ,

  OutMemL     name 'OutMemDword'    , OutMemL     name '_OutMemDWord',            VBOutMemL      name 'VBOutMemDWord',
  InMemL      name 'InMemDWord'     , InMemL      name '_InMemDWord',             VBInMemL       name 'VBInMemDWord',
  OutMemL                           , OutMemL     name '_OutMemL',                VBOutMemL,
  InMemL                            , InMemL      name '_InMemL',                 VBInMemL,
  OutMem                            , OutMem      name '_OutMem',                 VBOutMem,
  InMem                             , InMem       name '_InMem',                  VBInMem,
  OutMemB                           , OutMemB     name '_OutMemB',                VBOutMemB,
  InMemB                            , InMemB      name '_InMemB',                 VBInMemB,

  RelOutPortL name 'RelOutPortDword', RelOutPortL name '_RelOutPortDWord',        VBRelOutPortL  name 'VBRelOutPortDWord',
  RelInPortL  name 'RelInPortDWord' , RelInPortL  name '_RelInPortDWord',         VBRelInPortL   name 'VBRelInPortDWord',
  RelOutPortL                       , RelOutPortL name '_RelOutPortL',            VBRelOutPortL,
  RelInPortL                        , RelInPortL  name '_RelInPortL',             VBRelInPortL,
  RelOutPort                        , RelOutPort  name '_RelOutPort',             VBRelOutPort,
  RelInPort                         , RelInPort   name '_RelInPort',              VBRelInPort,
  RelOutPortB                       , RelOutPortB name '_RelOutPortB',            VBRelOutPortB,
  RelInPortB                        , RelInPortB  name '_RelInPortB',             VBRelInPortB,

  OutPortL    name 'OutPortDword'   , OutPortL    name '_OutPortDWord',           VBOutPortL     name 'VBOutPortDWord',
  InPortL     name 'InPortDWord'    , InPortL     name '_InPortDWord',            VBInPortL      name 'VBInPortDWord',
  OutPortL                          , OutPortL    name '_OutPortL',               VBOutPortL,
  InPortL                           , InPortL     name '_InPortL',                VBInPortL,
  OutPort                           , OutPort     name '_OutPort',                VBOutPort,
  InPort                            , InPort      name '_InPort',                 VBInPort,
  OutPortB                          , OutPortB    name '_OutPortB',               VBOutPortB,
  InPortB                           , InPortB     name '_InPortB',                VBInPortB,

  EmergencyReboot,     EmergencyReboot     name '_EmergencyReboot',     VBEmergencyReboot,
  WDGStop,             WDGStop             name '_WDGStop',             VBWDGStop,
  WDGStart,            WDGStart            name '_WDGStart',            VBWDGStart,
  WDGReadStatus,       WDGReadStatus       name '_WDGReadStatus',       VBWDGReadStatus,
  WDGReadTemp,         WDGReadTemp         name '_WDGReadTemp',         VBWDGReadTemp,
  WDGPet,              WDGPet              name '_WDGPet',              VBWDGPet,
  WDGSetResetDuration, WDGSetResetDuration name '_WDGSetResetDuration', VBWDGSetResetDuration,
  WDGSetTimeout,       WDGSetTimeout       name '_WDGSetTimeout',       VBWDGSetTimeout,
  WDGHandleIRQ,        WDGHandleIRQ        name '_WDGHandleIRQ',        VBWDGHandleIRQ,
  WDGInit,             WDGInit             name '_WDGInit',             VBWDGInit,
  COSWaitForIRQ,       COSWaitForIRQ       name '_COSWaitForIRQ',       VBCOSWaitForIRQ,
  CloseCard,           CloseCard           name '_CloseCard',           VBCloseCard,
  AbortRequest,        AbortRequest        name '_AbortRequest',        VBAbortRequest,
  WaitForIRQ,          WaitForIRQ          name '_WaitForIRQ',          VBWaitForIRQ,
  QueryCardInfo,       QueryCardInfo       name '_QueryCardInfo',       VBQueryCardInfo,
  GetNumCards,         GetNumCards         name '_GetNumCards',         VBGetNumCards
  ;



{
type
  TDeviceInterfaceData = packed record
    cbSize: LongWord;
    InterfaceClassGuid: TGUID;
    Flags: LongWord;
    Reserved: LongWord;
  end;
  PDeviceInterfaceData = ^TDeviceInterfaceData;

  SP_DEVINFO_DATA = packed record
    cbSize: LongWord;
    ClassGuid: TGUID;
    DevInst: LongWord;    // DEVINST handle
    Reserved: LongWord;
  end;
  PSP_DEVINFO_DATA = ^SP_DEVINFO_DATA;

  TDeviceInterfaceDetail = packed record
    cbSize: LongWord;
    FirstChar: Char;
  end;
  PDeviceInterfaceDetail = ^TDeviceInterfaceDetail;

function SetupDiGetClassDevs(
  GUID: PGUID;
  Enumerator: PChar;
  hParent: THandle;
  Flags: LongWord
): THandle; stdcall; external 'SetupAPI.dll' name 'SetupDiGetClassDevsA';

function SetupDiEnumDeviceInterfaces(
  DeviceInfoSet: THandle;
  DeviceInfoData: PSP_DEVINFO_DATA;
  InterfaceClassGuid: PGUID;
  MemberIndex: LongWord;
  var DeviceInterfaceData: TDeviceInterfaceData
): LongBool; stdcall; external 'SetupAPI.dll';

function SetupDiGetDeviceInterfaceDetail(
  DeviceInfoSet: THandle;
  var DeviceInterfaceData: TDeviceInterfaceData;
  DeviceInterfaceDetailData: PDeviceInterfaceDetail;
  DeviceInterfaceDetailDataSize: LongWord;
  RequiredSize: PLongWord;
  DeviceInfoData: PSP_DEVINFO_DATA
): LongBool; stdcall; external 'SetupAPI.dll' name 'SetupDiGetDeviceInterfaceDetailA';

const
  DIGCF_DEFAULT         = $00000001; // only valid with DIGCF_DEVICEINTERFACE
  DIGCF_PRESENT         = $00000002;
  DIGCF_ALLCLASSES      = $00000004;
  DIGCF_PROFILE         = $00000008;
  DIGCF_DEVICEINTERFACE = $00000010;

procedure LoadCardList;
var
  hDevInfo: THandle;
  IFData: TDeviceInterfaceData;
  I, L: LongWord;
  Detail: PDeviceInterfaceDetail;
  DID: SP_DEVINFO_DATA;

begin
  SetLength(Devices, 0);
  hDevInfo := SetupDiGetClassDevs(@MSMungedGUID, nil, 0, DIGCF_PRESENT or DIGCF_DEVICEINTERFACE);
  if hDevInfo = INVALID_HANDLE_VALUE then Exit;
  ZeroMemory(@IFData, SizeOf(IFData));
  IFData.cbSize := SizeOf(IFData);
  I := 0;
  while SetupDiEnumDeviceInterfaces(hDevInfo, nil, @MSMungedGUID, I, IFData) do begin
    SetupDiGetDeviceInterfaceDetail(hDevInfo, IFData, nil, 0, @L, nil);
    GetMem(Detail, L);
    DID.cbSize := SizeOf(DID);
    Detail.cbSize := SizeOf(Detail^);
    if not SetupDiGetDeviceInterfaceDetail(hDevInfo, IFData, Detail, L, nil, @DID) then begin
      FreeMem(Detail);
      Continue;
    end;
    L := Length(Devices);
    SetLength(Devices, L + 1);
    Devices[L].SymbolicLink := PChar(@Detail.FirstChar);
    Devices[L].hDevice := INVALID_HANDLE_VALUE;
    Inc(I);
  end;
end;
}

{}
procedure LoadCardList;
var
  Reg: TRegistry;
  I: Integer;
  SubKeys: TStringList;
  Linked: Boolean;

begin
  Reg := TRegistry.Create(KEY_ENUMERATE_SUB_KEYS or KEY_QUERY_VALUE);
  Reg.RootKey := HKEY_LOCAL_MACHINE;
  if Reg.OpenKey(IFKey, False) then begin
    SubKeys := TStringList.Create;
    Reg.GetKeyNames(SubKeys);
    Reg.CloseKey;
    I := 0;
    while I < SubKeys.Count do begin
      if Reg.OpenKey(IFKey + '\' + SubKeys[I] + '\#\Control', False) then begin
        try
          Linked := Reg.ReadBool('Linked');
        except
          Linked := False;
        end;
        Reg.CloseKey;
        if not Linked then begin
          SubKeys.Delete(I);
          Continue;
        end;
      end
      else begin
        SubKeys.Delete(I);
        Continue;
      end;
      if not Reg.OpenKey(IFKey + '\' + SubKeys[I] + '\#', False) then begin
        SubKeys.Delete(I);
        Continue;
      end;
      try
        SubKeys[I] := Reg.ReadString('SymbolicLink');
        Inc(I);
      except
        SubKeys.Delete(I);
      end;
      Reg.CloseKey;
    end;
    SetLength(Devices, SubKeys.Count);
    for I := 0 to High(Devices) do begin
      Devices[I].SymbolicLink := SubKeys[I];
      Devices[I].hDevice := INVALID_HANDLE_VALUE;
    end;
    SubKeys.Free;
  end;
  Reg.Free;
end;
{}

function GetOS: TOS;
var
  V: OSVERSIONINFO;
  VerNum: LongWord;
  VerNums: packed record Min, Maj: Word; end absolute VerNum;

begin
  Result := osDunno; //Assume we're on Win9x if we can't tell where we are

  V.dwOSVersionInfoSize := sizeof(OSVERSIONINFO);
  GetVersionEx(V);
  VerNums.Min := V.dwMinorVersion;
  VerNums.Maj := V.dwMajorVersion;
  case V.dwPlatformId of
  VER_PLATFORM_WIN32s: Result := osWin95; // Win32s doesn't have WDM, does it?
  VER_PLATFORM_WIN32_WINDOWS:
    if VerNum < $4000A then
      Result := osWin95
    else
      Result := osWin98
    ;
  VER_PLATFORM_WIN32_NT:
    if VerNum < $50000 then
      Result := osNT
    else begin
      Result := osNT5;
      if VerNum >= $50001 then
        StupidXPShutdownIssue := True
      ;
    end;
  end;
end;

procedure DLLHandler(Reason: Integer);
var
  I: Integer;

begin
  if (Reason = DLL_PROCESS_DETACH) then begin
    for I := 0 to High(Devices) do
      if Devices[I].hDevice <> INVALID_HANDLE_VALUE then
        CloseHandle(Devices[I].hDevice)
    ;
    CloseHandle(hCentralDevice);
  end;
end;

begin
  if OS <> osDunno then Exit;
  DLLProc := @DLLHandler;
  OS := GetOS;
  LoadCardList;
  hCentralDevice := CreateFile('\\.\AIOWDMCore', GENERIC_WRITE or GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
  if hCentralDevice = 0 then hCentralDevice := INVALID_HANDLE_VALUE;
end.