unit ULDriver;{ Delphi interface to UL_DRV.SYS (uLAN driver) }
{
  (C) 2000 - 2001 Jindrich Jindrich, Pavel Pisa, PiKRON Ltd.

  Originators of the CHROMuLAN project:

  Jindrich Jindrich - http://www.jindrich.com
                      http://orgchem.natur.cuni.cz/Chromulan
                      software developer, project coordinator
  Pavel Pisa        - http://cmp.felk.cvut.cz/~pisa
                      embeded software developer
  PiKRON Ltd.       - http://www.pikron.com
                      project initiator, sponsor, instrument developer

  The CHROMuLAN project is distributed under the GNU General Public Licence.
  See file COPYING for details.

  Originators reserve the right to use and publish sources
  under different conditions too. If third party contributors
  do not accept this condition, they can delete this statement
  and only GNU license will apply.
}

{
  UL_DRV.SYS:

  (C) Copyright 1996,1999 by Pavel Pisa

  The uLAN driver is distributed under the Gnu General Public Licence.
  See file COPYING for details.

}
interface
uses
  Windows, Classes, Dialogs, SysUtils, Math, Forms,
  WinIOCtl, InfoFrm, Timer, Stru, BinHex,
  ULDrvTyp, ULDrvUtl, ModuType, {v0.24}ExeLogu {/v0.24 LogType, Logu},
  UlanType, UlanGlob, Registry,
  DrvLogu, DevDrv{v0.28}, Language{/v0.28}
  {v0.50}, ULDrvFilteru{/v0.50};

type
  EULException = class(Exception);
    { All Ulan driver exceptions ancestor. }

  EULOSException = class(EULException);
    { Exceptions caused by failure of system/ driver calls (IOCtrl) }
  EULPrgException = class(EULException);
    { Exceptions caused by incorrect usage of the interface }

{drXXXX}
type
  TULDriverResult = (
    drOK,
    { will cause ULOSException: }
    drDevIOCtrlFailed,
    drDriverOpenFailed,
    drMessageWriteFailed,
    drMessageReadFailed,
    { will cause ULPrgException: }
    drNoMessages,
      { MessageOpen was called but no messages are waiting. }
    drInvalidMessageMode,
      { Some method was called, that expected different MessageMode. }
    drDriverNotOpened,
      { Some method was called that expects that the driver is opened. }
    drMessageTailMissing,
      { From SendQueryWait }
    drFileReadFailed
  );
{/drXXXX}

{mmXXXX}
type
  TULMessageMode = (
    mmClosed,
      { MessageOpen or MessageCreate were not called. }
    mmCreate,
      { MessageCreate was called and MessageClose or MessageAbort were
        not called since then. Creating new message to be sent. }
    mmOpen
      { MessageOpen was called and MessageClose or MessageAbort were
        not called since then. Reading incoming message. }
  );
{/mmXXXX}

type
  TULMessageList = class(TList)
    { List of Ulan messages (ULMsgInfo), not used right now }
    function MessageAdd(const AMessage: TULMessage): boolean;
      { Add AMessage to the list. }
    function MessageFind(AStamp: longint; var AMessage: TULMessage; Erase:boolean): boolean;
      { Find message in the list with given AStamp value. If Erase = true, then
        alse remove the message from the list (dispose). }
    destructor Destroy; override;
      { Overriden to dispose the TULMessage records }
  end;
{v0.49}
const
  FInstanceCount: integer = 0;
type
{/v0.49}

  TULDriver = class(TComponent)
    constructor Create(AOwner: TComponent; AOSDeviceName: string); reintroduce;
    {v0.14}
    constructor CreateCopyOf(AOwner: TComponent; ADriver: TULDriver);
    {/v0.14}
    destructor Destroy; override;
  private
    FDrvLoader: TDevDrv;
    FD: Handle;
      { Handle to ULan device driver. }
    FBlockingCallsTimeout: longint;
      { DefaULt timeout value used in blocking calls. }
    FLocAddr: longint;
      { Addr of PC in ULan network (=2 usually) }
    FOSDeviceName: string;
      { Name of the OS device driver used for communication through ULan
        network. Used just during SetActive(true). Does not include '\\.\' }
    FLastError: integer;
      { Error code value of the last error encountered. }
    FLastResult: TULDriverResult;
      { Result code of the last method call. }
    FErrorCount: integer;
      { Number or errors encountered since this ULDriver
        instance creation }
    FSndMessage,
    FRcvMessage,
    FFiltMessage: TULMessage;
      { ULan Message record to by used during MessageXXXX
        or FilterAdd calls }
    FMessageMode: TULMessageMode;
      { MessageXXXX calls status (see mmXXXX). }
    {FMessageList: TULMessageList;
      { List of query messages sent asynchronously, that were not answered yet. }
    FMessageSentCount: integer;
      { Number of messages sent successfully out through
        this ULDriver instance. }
    FMessageRcvdCount: integer;
      { Number of messages received successfully through
        this ULDriver instance. }
    FIsInSetResult: boolean;
      { recursion preventer }
    FLogIsOn: boolean;
      { should log events to DrvLog? }
    FBuf: pointer;
      { pointer to currently read/write data, non nil just during
        ReadBuf/WriteBuf calls, used for logging }
    FBufSize: integer;
      { size of currently beeing read/written data, non zero just
        during ReadBuf/WriteBuf calls, used for logging }
    FPortAddr: integer;
      { initialized to default value from ulanglob PortAddr,
        then updated from registry if found there }
    FPortIrq: integer;
      { initialized to default value from ulanglob, updated from registry
        if found there }
    {v0.21}
    FBaudRate: integer;
    {/v0.21}
    {v0.28}
    FInDrvRegFilters: TList;
      { list of filters added by FilterAdd method (for those, next FilterAdd
        method call will do nothing) }
    {/v0.28}
    {v0.50}
    FFilterList: TULDrvFilterList;
    {/v0.50}
    {v0.49}
    function GetInstanceCount: integer;
    {/v0.49}
  protected
    procedure SetActive(OnOff: boolean);
      { Open/Close driver. }
    function GetActive: boolean;
      { Get info if open or closed. }
    procedure ClearResult;
    procedure SetResult(dr: TULDriverResult; const msg: string);
    procedure DoEvent(de: TULDriverEventID);
    procedure Log(de: TULDriverEventID);
    function GetMessage: TULMessage;
    {v0.14}
    function GetPortName: TDevicePortName;
    {/v0.14}
  public
    function MessageAvailable: boolean;
      { Any message in driver for us? }
    function MessageCreate(ADestAddr: integer; ACommand: integer;
      AMessageFlags: integer): integer;
      { Create the first frame of the new message; get ready for writing
        message data using MessageWriteBuf method. Followed by
        [MessageWriteBuf MessageTailCreate] MessageClose. }
    function MessageTailCreate(ADestAddr: integer; ACommand: integer;
      AMessageFlags: integer): integer;
      { Add next frame into the created message. }
    function MessageTailOpen: integer;
    function MessageOpen: integer;
      { Open incoming message (exception will occur if no message
        for us - i.e. MessageAvailable should be called before
        MessageOpen) }
    function MessageClose: integer;
      { Close message - if the message was opened by MessageCreate, the
        message will be sent. }
    {v0.50}
    function MessageRewind: integer;{not working?}
      { Resets read position of the message to the beginning }
    {/v0.50}
    procedure MessageAbort;
      { Abort the message creation. }
    function MessageWriteBuf(const ABuf; ABufSize: integer): integer;
      { Write data in buffer to message opened by MessageCreate call. }
    function MessageReadBuf(var ABuf; ABufSize: integer): integer;
      { Read data to buffer from message opened by MessageOpen call.
        Will raise exception if ABufSize bytes could not be read. }
    function MessageRead(var ABuf; ABufSize: integer; var ARead: DWORD): boolean;
       { As messageReadBuf but if there is not ABufSize bytes in the buffer,
         exception is not raised and the really read number of bytes is returned
         in ARead. Data read by this function is not logged to DRV.LOG file. }
    procedure FilterAdd(ASrcAddr: integer; ACommand: integer);
      { Will be receiving messages with specified field values. }
    {v0.28}
    function FilterRegistered(ASrcAddr: integer; ACommand: integer): boolean;
    procedure FilterRegister(ASrcAddr: integer; ACommand: integer);
    {/v0.28}
    {v0.50}
    procedure EventFilterRegister(AULDrvFilter: TULDrvFilter);
    procedure EventFilterUnregister(AULDrvFilter: TULDrvFilter);
    procedure EventFiltersReregister;
    function MessageFilteredOut: boolean;
      { Returns false if no filter registered or the ULDrvFilter.DoEvent returns
        false }
    {/v0.50}

    procedure CheckMessageMode(mm: TULMessageMode);
      { Check if FMessageMode = mm, if not exception is raised. }
    function ScanForModules(var sl: TStringList): integer;
      { Fills sl (-must be already created) with names of autodetected
        modules, returns number of detected modules (= sl.Count) }
    function QuerySend(ADestAddr: integer; ACommand: integer;
      AMessageFlags: integer; OutBuf: pointer; OutBufSize: integer): integer;

    function QuerySendWait(ADestAddr: integer; ACommand: integer;
      AMessageFlags: integer; OutBuf: pointer; OutBufSize: integer;
      var InBuf: pointer; var InBufSize: integer): integer;
    function Clone: TULDriver;
    function UpdateSetup: boolean;
      { called if AutoConfigDriver ini var is true and if could not found
        ul_drv. Returns true, if the drivers was successfully configured
        and is running }
      procedure UpdateReg{v0.11}(read:boolean){/v0.11};
      { called from Create, UpdateSetup; read/write some params from/to Windows system Registry }


    property Active: boolean read GetActive write SetActive;
    property LocAddr: integer read FLocAddr write FLocAddr;
    property BlockingCallsTimeout: integer read FBlockingCallsTimeout write FBlockingCallsTimeout;
    property OSDeviceName: string read FOSDeviceName write FOSDeviceName;
    property MessageMode: TULMessageMode read FMessageMode;
    property LastError: integer read FLastError;
    property LastResult: TULDriverResult read FLastResult;
    property ErrorCount: integer read FErrorCount;
    property MessageSentCount: integer read FMessageSentCount;
    property MessageRcvdCount: integer read FMessageRcvdCount;
    property Message: TULMessage read GetMessage;
    {v0.14}
    property PortName: TDevicePortName read GetPortName;
    property LogIsOn: boolean read FLogIsOn;
    property PortAddr: integer read FPortAddr;
    property PortIrq: integer read FPortIrq;
    {/v0.14}
    {v0.21}
    property BaudRate: integer read FBaudRate;
    {/v0.21}
    {v0.49}
    property InstanceCount: integer read GetInstanceCount;{how many TULDriver objects exists}
    {/v0.49}
  end;

{v0.14}
function GetComNameFromBaseAddr(APortAddr: integer): string;
{/v0.14}

implementation
{TULMessageList}
function TULMessageList.MessageAdd(const AMessage: TULMessage): boolean;
var p: PULMessage;
begin
  Result := true;
  New(p);
  p^ := AMessage;
  Add(p);
end;

function TULMessageList.MessageFind(AStamp: longint; var AMessage: TULMessage; Erase:boolean): boolean;
var
  p: PULMessage;
  i: integer;
begin
  Result := false;
  for i := 0 to Count - 1 do begin
    p := PULMessage(Items[i]);{tlist}
    if p^.Stamp = AStamp then begin
      AMessage := p^;
      if Erase then begin
        Delete(i);
        Dispose(p);
      end;
      Result := true;
      exit;
    end;
  end;
end;

destructor TULMessageList.Destroy;
var i: integer;
begin
  for i := 0 to Count - 1 do begin
    Dispose(PULMessage(Items[i]));
  end;
  inherited Destroy;
end;
{/TULMessageList}

{TULDriver}
constructor TULDriver.Create(AOwner: TComponent; AOSDeviceName: string);
begin
  inherited Create(AOwner);
  {v0.49}
  inc(FInstanceCount);
  {/v0.49}
  FOSDeviceName := AOSDeviceName;
  FD := INVALID_HANDLE_VALUE;
  FBlockingCallsTimeout := 1000;
  FLocAddr:= PCUlanAddr;
  FLogIsOn := true;
  FPortAddr := PortAddr;{ulanglob}
  FPortIrq := PortIrq;
  {v0.21}
  FBaudRate := UlanBaudRate;
  {/v0.21}
  {v0.14}
  UpdateReg(true); { read FPortAddr, FPortIrq, FBaudRate from system registry
    (if present there, otherwise remains unchanged) }
  {/v0.14}
  Active := true;
end;

{v0.14}
constructor TULDriver.CreateCopyOf(AOwner: TComponent; ADriver: TULDriver);
begin
  {v0.49}
  inc(FInstanceCount);
  {/v0.49}
  FOSDeviceName := ADriver.OSDeviceName;
  FD := INVALID_HANDLE_VALUE;
  FBlockingCallsTimeout := 1000;
  FLocAddr:= ADriver.LocAddr;
  FLogIsOn := ADriver.LogIsOn;
  FPortAddr := ADriver.PortAddr;
  FPortIrq := ADriver.PortIrq;
  {v0.21}
  FBaudRate := ADriver.BaudRate;
  {/v0.21}
  Active := true;
end;
{/v0.14}

function TULDriver.UpdateSetup: boolean;
var
  sd, dd:TDevDrv;
  wasActive:boolean;
begin
  Result := false;
  if not AutoConfigDriver then
    exit;
  wasActive := Active;
  Active := false;
  dd := nil;
  sd := nil;
  try
    sd := TDevDrv.Create('serial',0);
    sd.CheckDeviceStopped(true, false);

    dd := TDevDrv.Create(FOSDeviceName, 0);
    {v0.11 read eventual values from reqistry now,
      because unloading will remove all entries}
    UpdateReg(true);
    {/v0.11}
    dd.CheckDeviceStopped(true, {v0.49}false{/v0.49 true}); {force stop, force unload;  devdrv}
    UpdateReg(false);
    Result := dd.CheckDeviceStarted = 0;
    sd.CheckDeviceStarted;
  finally
    dd.Free;
    sd.Free;
    Active := wasActive;
  end;
end;

procedure TULDriver.UpdateReg(read:boolean);
begin
  {v0.21}
  ULDrvReqReadWrite(read, FPortAddr, FPortIrq,
  FLocAddr, FBaudRate{v0.49}, ULDrvStartType {/v0.49});
  {/v0.21
  ULDrvReqReadWrite(read, FPortAddr, FPortIrq,
  FLocAddr)};
end;

procedure TULDriver.SetActive(OnOff: boolean);
var
  fn: array[0..255]of char;
  {v0.53}
  {prefix: string;}
  {/v0.53}
begin
  if OnOff then begin
    if not Active then begin
      {v0.53}
      {if pos('COM', FOSDeviceName) = 1 then
        StrPCopy(fn, FOSDeviceName)
      else
        StrPCopy(fn, '\\.\' + FOSDeviceName);}
      {/v0.53}
      StrPCopy(fn, '\\.\' + FOSDeviceName);
      FD := CreateFile(fn, GENERIC_READ or GENERIC_WRITE,
        0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);

      if (FD = INVALID_HANDLE_VALUE) then begin

        if (FDrvLoader = nil) and AutoConfigDriver then begin
          { try to load and start the driver }

          if UpdateSetup then begin
          {FDrvLoader := TDevDrv.Create(FOSDeviceName, 0);
          FDrvLoader.CheckDeviceUnloaded;
            { ... to make sure the registry and service entries are cleared }
          {UpdateRegistry;}
          {if FDrvLoader.CheckDeviceStarted = 0 then begin}
            FD := CreateFile(fn, GENERIC_READ or GENERIC_WRITE,
              0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
          end;
        end;

        if (FD = INVALID_HANDLE_VALUE) then begin
          if not (csDesigning in ComponentState) then begin
            SetResult(drDriverOpenFailed, 'TULDriver.SetActive '
              {v0.53}+ fn + ' ER:'  + IntToStr(GetLastError){/v0.53})
          end;
        end;
      end;
      DoEvent(deDrvOpen);
      {v0.50}
      EventFiltersReregister;
      {/v0.50}
    end;
  end else begin
    if Active then begin
      DoEvent(deDrvClose);
      CloseHandle(FD);
      {v0.28}
      FInDrvRegFilters.Free;
      FInDrvRegFilters := nil;
      {/v0.28}
      {v0.50}
      if FFilterList <> nil then
        FFilterList.Suspend;
      {/v0.50}
    end;
  end;
end;

function TULDriver.GetActive: boolean;
begin
  Result := (FD <> INVALID_HANDLE_VALUE);
end;

function TULDriver.MessageAvailable: boolean;
 { Any message in driver for us? }
var
  ret:longint;
  bytes_ret: DWORD;
begin
  Result := false;
  ClearResult;
  if not Active then begin
    SetResult(drDriverNotOpened, '');
    exit;
  end;
  if (not DeviceIoControl(FD, UL_INEPOLL, nil, 0, @ret,
     sizeof(ret), bytes_ret,nil)) then
  begin
    SetResult(drDevIOCtrlFailed, 'MessageAvailable ' + IntToStr(ret));
    exit;
  end;
  Result := ret <> 0;
end;

function TULDriver.MessageClose: integer;
var
  ret: longint;
  bytes_ret: DWORD;
begin
  if (not DeviceIoControl(FD, UL_FREEMSG, nil, 0, @ret, sizeof(ret),
    bytes_ret, nil)) then
  begin
    SetResult(drDevIOCtrlFailed, 'MessageClose');
  end;
  DoEvent(deMessageClose);
  FMessageMode := mmClosed;
  Result := ret;
end;

{v0.50}
function TULDriver.MessageRewind: integer;
var
  ret: longint;
  bytes_ret: DWORD;
begin
  CheckMessageMode(mmOpen);{uldrvtyp uldrvutl}
  if (not DeviceIoControl(FD, UL_REWMSG, nil, 0, @ret, sizeof(ret),
    bytes_ret, nil)) then
  begin
    SetResult(drDevIOCtrlFailed, 'MessageRewind');
  end;
{  DoEvent(deMessageRewind);}
  Result := ret;
end;
{/v0.50}

procedure TULDriver.MessageAbort;
var
  b_ret: DWORD;
begin
  if FMessageMode = mmClosed then
    exit;
  if not DeviceIoControl(FD, UL_ABORTMSG, nil, 0, nil, 0, b_ret, nil) then
  begin
    SetResult(drDevIOCtrlFailed, 'MessageAbort');
  end;
  DoEvent(deMessageAbort);
  FMessageMode := mmClosed;
end;

function TULDriver.MessageCreate(ADestAddr: integer;
  ACommand: integer; AMessageFlags: integer): integer;
var
  bytes_ret: DWORD;
begin
  Result := 0;
  CheckMessageMode(mmClosed);
  FillChar(FSndMessage, sizeof(FSndMessage), 0);
  FSndMessage.sadr := LocAddr;
  FSndMessage.dadr := ADestAddr;
  FSndMessage.cmd := ACommand;
  FSndMessage.flg := AMessageFlags or UL_BFL_M2IN;
  if not DeviceIoControl(FD, UL_NEWMSG, @FSndMessage, sizeof(TULMessage),
    nil, 0, bytes_ret, nil) then
  begin
    SetResult(drDevIOCtrlFailed, 'MessageCreate');
  end;
  FMessageMode := mmCreate;
  DoEvent(deMessageCreate);
end;

function TULDriver.MessageWriteBuf(const ABuf; ABufSize: integer): integer;
var
  b_ret: DWORD;
begin
  Result := 0;
  if ABufSize = 0 then
    exit;
  CheckMessageMode(mmCreate);
  if (not WriteFile(FD, ABuf, ABufSize, b_ret, nil)) or
     (integer(b_ret) <> ABufSize)
  then begin
    SetResult(drMessageWriteFailed, 'MessageWriteBuf');
  end;
  FBuf := @ABuf;
  FBufSize := ABufSize;
  DoEvent(deMessageWriteBuf);
  FBuf := nil;
  FBufSize := 0;
  MessageWriteBuf := ABufSize;
end;

function TULDriver.MessageReadBuf(var ABuf; ABufSize: integer): integer;
var b_ret: DWORD;
begin
  if not MessageRead(ABuf, ABufSize, b_ret) then
    SetResult(drMessageReadFailed, 'MessageReadBuf');
  FBuf := @ABuf;
  FBufSize := ABufSize;
  DoEvent(deMessageReadBuf);
  FBuf := nil;
  FBufSize := 0;
  Result := b_ret;
end;

function TULDriver.MessageRead(var ABuf; ABufSize: integer; var ARead: DWORD): boolean;
begin
  CheckMessageMode(mmOpen);
  if (not ReadFile(FD, ABuf, ABufSize, ARead, nil)) or (ARead <> DWORD(ABufSize)) then begin
    Result := false;
  end else begin
    Result := true;
  end;
end;

function TULDriver.MessageOpen: integer;
var
  bytes_ret: DWORD;
begin
  Result := 0;
  CheckMessageMode(mmClosed);
  if (not DeviceIoControl(FD, UL_ACCEPTMSG, nil, 0,
    @FRcvMessage, sizeof(TULMessage), bytes_ret, nil)) then
  begin
    SetResult(drNoMessages, 'MessageOpen');
  end;
  FMessageMode := mmOpen;
  if (FRcvMessage.flg and UL_BFL_FAIL) <> 0 then begin
    DoEvent(deMessageOpenFail);
  end else begin
    DoEvent(deMessageOpen);
  end;
end;

procedure TULDriver.DoEvent(de: TULDriverEventID);
begin
  Log(de);
end;

procedure TULDriver.Log(de: TULDriverEventID);

  function GetMessageLogStr(const AMessage: TULMessage): string;
  var
    s: string;
    {i: integer;}
  begin  {uldrvtyp}
    s := 'DA:' +  IntToString(AMessage.dadr, 3) + ' SA:' + IntToString(AMessage.sadr, 3) +
      ' CM:' + IntToString(AMessage.cmd, 3) + ' F:$' + LongToHex(AMessage.flg) +
      ' L:' + IntToString(AMessage.len, 3) + ' S:$' + LongToHex(AMessage.flg);
    {
    for i := 0 to sizeof(FMessage)- 1 do begin
      s := s + IntToString(FMessage.Data[i], 4);
    end;
    }
    Result := s;
  end;

  function GetMessageBufLogStr: string;
  var
    s: string;
    i: integer;
  begin
    s := '';
    for i := 0 to FBufSize - 1 do begin
      s := s + IntToString(PByteArray(FBuf)^[i], 4);
    end;
    Result := s;
  end;

var s: string;
begin
  if not FLogIsOn then
    exit;
  s := '';
  case de of
    deMessageCreate: begin
      s := 'SD  ' + GetMessageLogStr(FSndMessage);
    end;
    deMessageOpenFail: begin
      s := 'RVF ' + GetMessageLogStr(FRcvMessage);
    end;
    deMessageOpen: begin
      s := 'RV  ' + GetMessageLogStr(FRcvMessage);
    end;
    deMessageTailOpen: begin
      s := 'RVT ' + GetMessageLogStr(FRcvMessage);
    end;
    deMessageTailCreate: begin
      s := 'SDT ' + GetMessageLogStr(FSndMessage);
    end;
    deMessageReadBuf: begin
      s := 'RD  ' + GetMessageBufLogStr;
    end;
    deMessageWriteBuf: begin
      s := 'WR  ' + GetMessageBufLogStr;
    end;
    deMessageClose: begin
    end;
    deFilterAdd: begin
      s := 'FLT ' + GetMessageLogStr(FFiltMessage);
    end;
    deMessageAbort: begin
      if MessageMode = mmCreate then begin
        s := 'ABT ' + GetMessageLogStr(FSndMessage);
      end else if MessageMode = mmOpen then begin
        s := 'ABT ' + GetMessageLogStr(FRcvMessage);
      end;
    end;

    deDrvOpen: begin
      s := 'OPEN';
    end;
    deDrvClose: begin
      s := 'CLOSE';
    end;

  end;
  if s <> '' then begin
    DrvLog('FD:' + copy(LongToHex(FD), 5, 4) + ' ' + s);
  end;
end;

{v0.28}
function TULDriver.FilterRegistered(ASrcAddr: integer; ACommand: integer): boolean;
begin
  Result := false;
  if FInDrvRegFilters = nil then
    exit;
  if FInDrvRegFilters.IndexOf(pointer(MakeLong(ASrcAddr, ACommand))) < 0 then
    exit;
  Result := true;
end;

procedure TULDriver.FilterRegister(ASrcAddr: integer; ACommand: integer);
begin
  if FInDrvRegFilters = nil then
    FInDrvRegFilters := TList.Create;
  FInDrvRegFilters.Add(pointer(MakeLong(ASrcAddr, ACommand)));
end;
{/v0.28}

procedure TULDriver.FilterAdd(ASrcAddr: integer; ACommand: integer);
var bytes_ret: DWORD;
begin
  {v0.28}
  if FilterRegistered(ASrcAddr, ACommand) then
    exit;
  {/v0.28}
  CheckMessageMode(mmClosed);
  FillChar(FFiltMessage, sizeof(FFiltMessage), 0);
  FFiltMessage.sadr := ASrcAddr;
  FFiltMessage.cmd := ACommand;
  if not (DeviceIoControl(FD, UL_ADDFILT, @FFiltMessage, sizeof(TULMessage),
					   nil,0, bytes_ret, nil))
  then
    SetResult(drDevIOCtrlFailed, 'FilterAdd');
  DoEvent(deFilterAdd);
  {v0.28}
  FilterRegister(ASrcAddr, ACommand);
  {/v0.28}
end;

procedure TULDriver.CheckMessageMode(mm: TULMessageMode);
begin
  if FMessageMode <> mm then
    SetResult(drInvalidMessageMode, IntToStr(ord(mm)) + ' x ' +
      IntToStr(ord(FMessageMode)));
end;

procedure TULDriver.ClearResult;
begin
  FLastResult := drOK;
end;

procedure TULDriver.SetResult(dr: TULDriverResult; const Msg: string);
var s: string;
begin
  if FIsInSetResult then
    exit;
  FIsInSetResult := true;
  FLastResult := dr;
  s := '';
  try

    if dr <> drOK then begin
      FLastError := ord(dr);
      s := 'TULDriver ' + IntToStr(ord(dr)) + ' ';
      if MessageMode <> mmClosed then
        MessageAbort;
    end;

    case dr of

      drOK:;

      drDevIOCtrlFailed: begin
        s := s + 'DevIOCtrl Error:'+IntToStr(GetLastError);
        {v0.24}ExeLog.LogEvent([leError], s);{/v0.24 SysLogLog(leError, s);}
        raise EULOSException.Create(s); {getlasterror}
      end;

      drDriverOpenFailed: begin
        {UlanGlob}
        {v0.11}{/v0.11 CurDeviceMode := dmApex;}
        s := s + 'Open Failed. ' + Msg;
        {v0.24}ExeLog.LogEvent([leError], s);{/v0.24 SysLogLog(leError, s);}
        raise EULOSException.Create(s);
      end;{ulbrowsefrm logfrm ulanrecs.lst}

      drMessageWriteFailed,
      drMessageReadFailed: begin      { subclasser lngobju ulobju lngtobju ulprobju }
        s := s + 'OS ' + Msg;
        {v0.24}ExeLog.LogEvent([leError], s);{/v0.24 SysLogLog(leError, s);}
        raise EULOSException.Create(s);
      end;

      drNoMessages,
      drInvalidMessageMode,
      drDriverNotOpened: begin
        s := s + 'Prg ' + Msg;
        {v0.24}ExeLog.LogEvent([leError], s);{/v0.24 SysLogLog(leError, s);}
        raise EULPrgException.Create(s);
      end;

    else
      s := s + ' ' + Msg;
      {v0.24}ExeLog.LogEvent([leError], s);{/v0.24 SysLogLog(leError, s);}
      raise EULException.Create(s);
    end;
  finally
    FIsInSetResult := false;
  end;
end;

function TULDriver.QuerySend(ADestAddr: integer; ACommand: integer;
  AMessageFlags: integer; OutBuf: pointer; OutBufSize: integer): integer;
var
  b_ret: DWORD;
begin
  MessageCreate(ADestAddr, ACommand, UL_BFL_M2IN or AMessageFlags);

  if (OutBufSize > 0) and (OutBuf <> nil) then begin
    if not WriteFile(FD, OutBuf^, OutBufSize, b_ret, nil) or
      (integer(b_ret) <> OutBufSize)
    then begin
      MessageAbort;
      Result := -1;
      exit;
    end;
  end;

  MessageTailCreate(0, 0, UL_BFL_REC or UL_BFL_M2IN);
{  FillChar(FMessage,sizeof(FMessage),0);
  FMessage.flg := UL_BFL_REC or UL_BFL_M2IN;

  if (not DeviceIoControl(FD, UL_TAILMSG, @FMessage,
    sizeof(TULMessage), nil, 0, bytes_ret, nil)) then
  begin
    DeviceIoControl(FD, UL_ABORTMSG, nil, 0, nil, 0, bytes_ret, nil);
    Result := -1;
    exit;
  end;
  }
  Result := MessageClose;
end;

function TULDriver.MessageTailCreate(ADestAddr: integer; ACommand: integer;
  AMessageFlags: integer): integer;
var
  bytes_ret: DWORD;
begin
  Result := 0;
  CheckMessageMode(mmCreate);
  FillChar(FSndMessage, sizeof(FSndMessage), 0);
  FSndMessage.dadr := ADestAddr;
  FSndMessage.cmd := ACommand;
  FSndMessage.flg := AMessageFlags;
  if not DeviceIoControl(FD, UL_TAILMSG, @FSndMessage, sizeof(TULMessage),
    nil, 0, bytes_ret, nil) then
  begin
    SetResult(drDevIOCtrlFailed, 'MessageTailCreate');
  end;
  DoEvent(deMessageTailCreate);
end;

function TULDriver.MessageTailOpen: integer;
var bytes_ret: DWORD;
begin
  Result := 0;
  CheckMessageMode(mmOpen);
  if (not DeviceIoControl(FD, UL_ACTAILMSG, nil,
    0, @FRcvMessage, sizeof(TULMessage), bytes_ret, nil)) then
  begin
    SetResult(drDevIOCtrlFailed, 'MessageTailOpen');
  end;
  DoEvent(deMessageTailOpen);
end;

function TULDriver.QuerySendWait(ADestAddr: integer; ACommand: integer;
   AMessageFlags: integer; OutBuf: pointer; OutBufSize: integer;
   var InBuf: pointer; var InBufSize: integer): integer;
var
  stamp: longint;
  len: longint;
{  b_ret: DWORD;}
  endtime: integer;
begin
  Result := 0;
  stamp := QuerySend(ADestAddr, ACommand, AMessageFlags, OutBuf, OutBufSize);
  if (stamp < 0) then begin
    Result := stamp;
    exit;
  end;

  endtime := mstime + BlockingCallsTimeout;
  while true do begin

    if MessageAvailable then begin
      MessageOpen;
      if (FRcvMessage.stamp = stamp) then begin

        if(FRcvMessage.flg and UL_BFL_FAIL) <> 0 then begin
          MessageClose;
          Result := -2;
          exit;
        end;

        if (FRcvMessage.flg and UL_BFL_TAIL) <> 0 then begin
          MessageTailOpen;
          if FRcvMessage.len > 0 then begin
            len := FRcvMessage.len;
            if InBuf = nil then begin
              GetMem(InBuf, len)
            end else begin
              {SetResult(drInvalidParam}
              if InBufSize < len then
                len := InBufSize;
            end;
            MessageReadBuf(InBuf^, len);
            {
            if (not ReadFile(FD, InBuf^, len, b_ret, nil)) or (longint(b_ret) <> len) then
            begin
              SetResult(drFileReadFailed, 'QuerySendWait');
            end;
            }
            InBufSize := len;
          end;
        end else begin
          SetResult(drMessageTailMissing, 'QuerySendWait');
        end;

        MessageClose;
        Result := FRcvMessage.len;
        break;
      end;
      MessageClose;
    end else begin
      if mstime > endtime then begin
        Result := -1;
        break;
      end;
      Application.ProcessMessages;
    end;
  end;

end;

function TULDriver.ScanForModules(var sl: TStringList): integer;
var
  ret, i: longint;

  buf: PCharBuffer;
  buf_len: longint;

  s,sn: shortstring;
label ex;
begin
  buf := nil;
  buf_len := 0;
  sl.Clear;

  InfoFormShow(GetTxt('Detecting modules...'));
  try
    for i := 1 to MaxULAddr do begin
      ret := QuerySendWait(i, UL_CMD_SID, UL_BFL_NORE or UL_BFL_PRQ,
        nil, 0, pointer(buf), buf_len);
      if( ret >= 0 ) then begin
        ret := 0;
        s := '';
        while (ret < buf_len) and (buf^[ret] <> #0) do begin
          s := s + buf^[ret];
          inc(ret);
        end;
        str(i:2, sn);
        sl.Add(sn + ' ' + s);
      end;
      if (buf <> nil) then
        FreeMem(buf);
      buf := nil;
    end;
  finally
    InfoFormHide;
  end;
  Result := sl.Count;
end;

function TULDriver.Clone: TULDriver;
begin
  {v0.14}
  Result := TULDriver.CreateCopyOf(Owner, Self);
  {/v0.14
  Result := TULDriver.Create(Owner, OSDeviceName);}
end;

destructor TULDriver.Destroy;
begin
  {v0.49}
  if FInstanceCount > 0 then
    dec(FInstanceCount);
  {/v0.49}
  Active := false;
  {v0.28}
  FInDrvRegFilters.Free;
  {/v0.28}
  {v0.50}
  if FFilterList <> nil then begin
    FFilterList.Free;
    FFilterList := nil;
  end;
  {/v0.50}
  if FDrvLoader <> nil then begin
    FDrvLoader.CheckDeviceStopped(false, false);
    FDrvLoader.Free;
  end;
  inherited Destroy;
end;

function TULDriver.GetMessage: TULMessage;
begin
  case FMessageMode of
    mmOpen: Result := FRcvMessage;
    mmCreate: Result := FSndMessage;
  else
    SetResult(drInvalidMessageMode, '');
  end;
end;

{v0.14}
function TULDriver.GetPortName: TDevicePortName;
begin
  Result := GetComNameFromBaseAddr(FPortAddr);
  if Result = '' then
    Result := 'COM2';
end;

function GetComNameFromBaseAddr(APortAddr: integer): string;
begin
  if APortAddr = $3f8 then
    Result := 'COM1'
  else if APortAddr = $2f8 then
    Result := 'COM2'
  else if APortAddr = $3e8 then
    Result := 'COM3'
  else if APortAddr = $2e8 then
    Result := 'COM4'
  else
    Result := '';
end;
{/v0.14}

{v0.49}
function TULDriver.GetInstanceCount: integer;
begin
  Result := FInstanceCount;
end;
{/v0.49}

{v0.50}

procedure TULDriver.EventFilterRegister(AULDrvFilter: TULDrvFilter);
begin
  if FFilterList = nil then
    FFilterList := TULDrvFilterList.Create;

  if AULDrvFilter.RegisteredAt = Self then
    exit;

  FilterAdd(AULDrvFilter.Msg.sadr, AULDrvFilter.Msg.cmd);
  AULDrvFilter.RegisteredAt := Self;
  FFilterList.Add(AULDrvFilter);
end;

procedure TULDriver.EventFilterUnregister(AULDrvFilter: TULDrvFilter);
var i: integer;
begin
  if FFilterList = nil then
    exit;
  i := FFilterList.IndexOf(AULDrvFilter);
  if i >= 0 then begin
    AULDrvFilter.RegisteredAt := nil;
    FFilterList.Delete(i);
  end;
end;

procedure TULDriver.EventFiltersReregister;
{var i: integer;}
begin
  if FFilterList = nil then
    exit;
  FFilterList.Resume;
end;

function TULDriver.MessageFilteredOut: boolean;
var
  i, cnt: integer;
  f: TULDrvFilter;
begin
  Result := false;
  if FFilterList = nil then
    exit;
  i := -1;
  repeat
    inc(i);
    if i >= FFilterList.Count then
      break;
    f := TULDrvFilter(FFilterList[i]);
    if (f.Msg.sadr <> 0) and (f.Msg.sadr <> FRcvMessage.sadr) then
      continue;
    if (f.Msg.dadr <> 0) and (f.Msg.dadr <> FRcvMessage.dadr) then
      continue;
    if (f.Msg.cmd <> 0) and (f.Msg.cmd <> FRcvMessage.cmd) then
      continue;
    if (f.Msg.stamp <> 0) and (f.Msg.stamp <> FRcvMessage.stamp) then
      continue;
    cnt := FFilterList.Count;
    f.DoEvent(Self, FRcvMessage, Result);
    if Result then
      break;
    {MessageRewind;}
    if cnt > FFilterList.Count then
      dec(i);
  until false;
end;

{/v0.50}

{/TULDriver.}

end.


