idmodbusserver.pas

MODBUS-TCP控件

{===============================================================================

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.

Alternatively, the contents of this file may be used under the terms of the
GNU General Public License Version 2 or later (the "GPL"), in which case
the provisions of the GPL are applicable instead of those above. If you wish to
allow use of your version of this file only under the terms of the GPL and not
to allow others to use your version of this file under the MPL, indicate your
decision by deleting the provisions above and replace them with the notice and
other provisions required by the GPL. If you do not delete the provisions
above, a recipient may use your version of this file under either the MPL or
the GPL.

$Id: IdModbusServer.pas,v 1.6 2004/02/04 14:25:37 plpolak Exp $

===============================================================================}

{$I compiler.inc}

unit IdModBusServer;

interface

uses
  Classes
 ,SysUtils
 ,IdTCPServer
 ,IdTCPClient
 ,ModBusConsts
 ,ModbusTypes;

type
  TModRegisterData = array[0..MaxBlockLength] of Word;

type
  TModRegisterReadEvent = procedure(const Sender: TIdPeerThread; const RegNr, Count: Integer; var Data: TModRegisterData) of object;
  TModRegisterWriteEvent = procedure(const Sender: TIdPeerThread; const RegNr, Count: Integer; const Data: TModRegisterData) of object;
  TModErrorEvent = procedure(const Sender: TIdPeerThread; var ErrorCode: SmallInt) of object;
  TModInvalidFunctionEvent = procedure(const Sender: TIdPeerThread; const FunctionCode: TModBusFunction) of object;

type
  TIdModBusServer = class(TIdTCPServer)
  private
    FRefNumber: Integer;
    FRange: Integer;
    FOnError: TModErrorEvent;
    FOnInvalidFunction: TModInvalidFunctionEvent;
    FOnReadRegisters: TModRegisterReadEvent;
    FOnWriteRegisters: TModRegisterWriteEvent;
    procedure SetRange(const Value: Integer);
    procedure SetRefNumber(const Value: Integer);
    procedure SendResponse(const Thread: TIdPeerThread; const FunctionCode: Integer;
      const ReceiveBuffer: TCommsBuffer; const Data: TModRegisterData);
    function GetVersion: String;
    procedure SetVersion(const Value: String);
  protected
    procedure DoConnect(AThread: TIdPeerThread); override;
    function DoExecute(AThread: TIdPeerThread): Boolean; override;
    procedure GetRegisters(const Count: Integer; const Buffer: TCommsBuffer; var Data: TModRegisterData);
  public
    constructor Create(AOwner: TComponent); override;
  published
    property DefaultPort default MB_PORT;
    property Range: Integer read FRange write SetRange default MaxRange;
    property RefNumber: Integer read FRefNumber write SetRefNumber default 1;
    property Version: String read GetVersion write SetVersion stored False;
  { events }
    property OnError: TModErrorEvent read FOnError write FOnError;
    property OnInvalidFunction: TModInvalidFunctionEvent read FOnInvalidFunction write FOnInvalidFunction;
    property OnReadRegisters: TModRegisterReadEvent read FOnReadRegisters write FOnReadRegisters;
    property OnWriteRegisters: TModRegisterWriteEvent read FOnWriteRegisters write FOnWriteRegisters;
  end; { TIdModBusServer }

implementation

{ TIdModBusServer }

constructor TIdModBusServer.Create(AOwner: TComponent);
begin
  inherited;
  DefaultPort := MB_PORT;
  FRange := MaxRange;
  FRefNumber := 1;
  FOnError := nil;
  FOnInvalidFunction := nil;
  FOnReadRegisters := nil;
  FOnWriteRegisters := nil;
end; { Create }


procedure TIdModBusServer.DoConnect(AThread: TIdPeerThread);
var
  iCount: Integer;
  iRegNr: Integer;
  iErrorCode: SmallInt;
  ReceiveBuffer: TCommsBuffer;
  Data: TModRegisterData;
begin
  inherited;
{ Initialize all register data to 0 }
  FillChar(Data, SizeOf(Data), 0);
{ Read the data from the peer connection }
  AThread.Connection.Socket.Recv(ReceiveBuffer, 256);
{ Process the data }
  if ((Byte(ReceiveBuffer.FunctionCode) and $80) <> 0) then
  begin
    iErrorCode := Integer(ReceiveBuffer.MBPData[0]);
    SendResponse(AThread, iErrorCode, ReceiveBuffer, Data);
  end
  else
  begin
    case ReceiveBuffer.FunctionCode of
      mbfReadRegs:
        begin
          iRegNr := Swap(Word((@ReceiveBuffer.MBPData[0])^)) + 1;
          iCount := Swap(Word((@ReceiveBuffer.MBPData[2])^));
        { Signal the user that data is needed }
          if Assigned(FOnReadRegisters) then
            FOnReadRegisters(AThread, iRegNr, iCount, Data);
        { Send back the response to the master }
          SendResponse(AThread, mbfReadRegs, ReceiveBuffer, Data);
        end;
      mbfWriteOneReg:
        begin
        { Get the register number }
          iRegNr := Swap(Word((@ReceiveBuffer.MBPData[0])^)) + 1;
        { Get the register value }
          Data[0] := Swap(Word((@ReceiveBuffer.MBPData[2])^));
        { This function always writes one register }
          iCount := 1;

          if ((iRegNr < FRefNumber) or ((iRegNr + iCount) >= (FRefNumber + FRange))) then
            SendResponse(AThread, mbfInvalidRegister, ReceiveBuffer, Data)
          else
          begin
          { Send back the response to the master }
            SendResponse(AThread, mbfWriteOneReg, ReceiveBuffer, Data);
          { Pass the result to the application }
            if Assigned(FOnWriteRegisters) then
              FOnWriteRegisters(AThread, iRegNr, iCount, Data);
          end;
        end;
      mbfWriteRegs:
        begin
          iRegNr := Swap(Word((@ReceiveBuffer.MBPData[0])^)) + 1;
          iCount := Swap(Word((@ReceiveBuffer.MBPData[2])^));
          if ((iRegNr < FRefNumber) or ((iRegNr + iCount) >= (FRefNumber + FRange))) then
            SendResponse(AThread, mbfInvalidRegister, ReceiveBuffer, Data)
          else
          begin
          { Decode the contents of the Registers }
            GetRegisters(iCount, ReceiveBuffer, Data);
          { Send back the response to the master }
            SendResponse(AThread, mbfWriteRegs, ReceiveBuffer, Data);
          { Pass the result to the application }
            if Assigned(FOnWriteRegisters) then
              FOnWriteRegisters(AThread, iRegNr, iCount, Data);
          end;
        end;
    else
      if (ReceiveBuffer.FunctionCode <> 0) then
      begin
      { Illegal or unsupported function code }
        SendResponse(AThread, mbfUndefined, ReceiveBuffer, Data);
        if Assigned(FOnInvalidFunction) then
          FOnInvalidFunction(AThread, ReceiveBuffer.FunctionCode);
      end;
    end;
  end;
{ The server terminates the connection, after the request has been handled }
  AThread.Connection.Disconnect;
end; { DoConnect }


function TIdModBusServer.DoExecute(AThread: TIdPeerThread): Boolean;
begin
  Result := True;
end; { DoExecute }


procedure TIdModBusServer.GetRegisters(const Count: Integer; const Buffer: TCommsBuffer; var Data: TModRegisterData);
var
  WPtr: ^Word;
  i: Integer;
begin
  WPtr := @Buffer.MbpData[5];
  for i := 0 to (Count - 1) do
  begin
    Data[i] := Swap(WPtr^);
    Inc(WPtr);
  end;
end; { GetRegisters }


procedure TIdModBusServer.SendResponse(const Thread: TIdPeerThread;
  const FunctionCode: Integer; const ReceiveBuffer: TCommsBuffer;
  const Data: TModRegisterData);
var
  SendBuffer: TCommsBuffer;
  iErrorCode: SmallInt;
  iBytesToWrite: Byte;
  L, i: Integer;
  WordPtr: ^Word;
begin
  if Active then
  begin
    SendBuffer.TransactionID := ReceiveBuffer.TransactionID;
    SendBuffer.ProtocolID := ReceiveBuffer.ProtocolID;
    SendBuffer.UnitID := ReceiveBuffer.UnitID;
    SendBuffer.FunctionCode := ReceiveBuffer.FunctionCode;
    SendBuffer.RecLength := Swap(0);
    iErrorCode := 0;

    case FunctionCode of
      mbfWriteRegs:
        begin
          SendBuffer.MBPData[0] := ReceiveBuffer.MBPData[0];
          SendBuffer.MBPData[1] := ReceiveBuffer.MBPData[1];
          SendBuffer.MBPData[2] := ReceiveBuffer.MBPData[2];
          SendBuffer.MBPData[3] := ReceiveBuffer.MBPData[3];
          SendBuffer.RecLength := Swap(6);
        end;
      mbfWriteOneReg:
        begin
          SendBuffer.MBPData[0] := ReceiveBuffer.MBPData[0];
          SendBuffer.MBPData[1] := ReceiveBuffer.MBPData[1];
          SendBuffer.MBPData[2] := ReceiveBuffer.MBPData[2];
          SendBuffer.MBPData[3] := ReceiveBuffer.MBPData[3];
          SendBuffer.RecLength := Swap(6);
        end;
      mbfReadRegs:
        begin
          L := Swap(Word((@ReceiveBuffer.MBPData[2])^));
          if (L <= MaxBlockLength) then
          begin
            iBytesToWrite := Byte(L shl 1);
            SendBuffer.MBPData[0] := iBytesToWrite;
            WordPtr := @SendBuffer.MBPData[1];
            for i := 0 to (L - 1) do
            begin
              WordPtr^ := Swap(Data[i]);
              Inc(WordPtr);
            end;
            SendBuffer.RecLength := Swap(3 + iBytesToWrite);
          end
          else
            iErrorCode := 2;
        end;
    else
      iErrorCode := - FunctionCode;
    end;

    if (iErrorCode > 0) then
    begin
      SendBuffer.FunctionCode := SendBuffer.FunctionCode or $80;
      if Assigned(FOnError) then
        FOnError(Thread, iErrorCode);
      SendBuffer.MBPData[0] := iErrorCode;
    end;
    Thread.Connection.Socket.Send(SendBuffer, Swap(SendBuffer.RecLength) + 6);
  end;
end; { SendResponse }


function TIdModBusServer.GetVersion: String;
begin
  Result := DMB_VERSION;
end; { GetVersion }


procedure TIdModBusServer.SetVersion(const Value: String);
begin
{ This is a readonly property }
end; { SetVersion }


procedure TIdModBusServer.SetRange(const Value: Integer);
begin
  if (Value < 1) then
    FRange := 1
  else if (Value > (MaxRange - FRange + 1)) then
    FRange := MaxRange - FRange + 1
  else
    FRange := Value;
end; { SetRange }


procedure TIdModBusServer.SetRefNumber(const Value: Integer);
begin
  if (Value < 1) then
    FRefNumber := 1
  else if (Value > MaxRange) then
    FRefNumber := MaxRange
  else
    FRefNumber := Value;
end; { SetRefNumber }


end.