{*******************************************************}
{                                                       }
{       nrCommLib Communication Library for Delphi      }
{       Data Processor (VCL)                            }
{       Copyright (c) 1997-2011 Roman Novgorodov        }
{       v9.27                                           }
{       last update: 20 Oct 2008                        }
{                                                       }
{       e-mail:noro@deepsoftware.com                    }
{       DeepSoftware                                    }
{       http://www.deepsoftware.com/                    }
{                                                       }
{*******************************************************}
{$I nrcommlib.inc}
unit nrdataproc;
interface
uses  {$IFDEF LINUX}
      nrlinux,
      {$ELSE}
      nrwin32, windows,
      {$ENDIF}
      nrcomm, nrclasses, classes;

Const
  CN_DEFAULT_MAX_PACKET_LENGTH = 16 * 1024;
  CN_MIN_PACKET_LENGTH = 512;

Type

  TnrDataProtocol = class;
  TnrDataPacket = class;

  TnrDataPacketState = (dpsInactive, dpsWaitBegin, dpsWaitLength, dpsWaitEnd, dpsWaitTimeout);

  TnrDataPacketLengthEvent = procedure (Packet:TnrDataPacket; chData:byte; var IsHandled:boolean) of object;

  TnrDataPacket = class(TCollectionItem)
  private
    fCaption : string;
    fPacketBegin: AnsiString;
    fPacketEnd: AnsiString;
    fPacketLength: integer;
    fActive: boolean;
    fResetOthers: boolean;
    fEvent: TCommEventNew;
    fState : TnrDataPacketState;
    fDataBuffer : PAnsiChar;
    //fDataResult : PAnsiChar;
    fDataLength : integer;
    //fData : AnsiString;
    fByTimeout: boolean;
    fOnPacketLength: TnrDataPacketLengthEvent;
    fOnPacketLengthOnce: TnrDataPacketLengthEvent;
    fPacketLengthMax: integer;
    fTag: integer;
    fPacketBeginLength: integer;
    fPacketEndLength: integer;
    procedure SetPacketLengthMax(Value: integer);
    procedure FreeBuffers;
    function GetDataAsString: AnsiString;
    procedure SetPacketBegin(const Value: AnsiString);
    procedure SetPacketEnd(const Value: AnsiString);
  protected
    function GetDisplayName: string; override;
    function GetMinorState:TnrDataPacketState;
    procedure PrepareData;
    function IsTimeoutHandle:boolean;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Reset;
    function IsPacket(ch:byte):boolean;
    function IsPossible:boolean;
    property Data:AnsiString read GetDataAsString;
    property DataPtr: PAnsiChar read fDataBuffer;
    property DataLength:integer read fDataLength;
    property PacketLengthMax:integer read fPacketLengthMax write SetPacketLengthMax;
    property PacketBeginLength: integer read fPacketBeginLength;
    property PacketEndLength: integer read fPacketEndLength;

  published
    property Active: boolean read fActive write fActive;
    property ResetOthers: boolean read fResetOthers write fResetOthers;
    property Caption : string read fCaption write fCaption;
    property PacketBegin: AnsiString read fPacketBegin write SetPacketBegin;
    property PacketEnd: AnsiString read fPacketEnd write SetPacketEnd;
    property PacketLength: integer read fPacketLength write fPacketLength;
    property PacketEndByTimeout: boolean read fByTimeout write fByTimeout;
    property OnPacketLength:TnrDataPacketLengthEvent read fOnPacketLength
                                                     write fOnPacketLength;
    property Tag: integer read fTag write fTag;
  end;

  TnrDataPackets = class(TCollection)
  private
    fIsPacketPossible:boolean;
    fDataProcessor: TnrDataProtocol;
    function GetItem(Index: Integer): TnrDataPacket;
    procedure SetItem(Index: Integer; Value: TnrDataPacket);
  protected
    function GetOwner: TPersistent; override;
    function IsTimeoutHandle:integer;
    procedure ResetOthers(iExcept:integer);
  public
    constructor Create(DataProcessor: TnrDataProtocol);
    function Add: TnrDataPacket;
    function AddItem(Item: TnrDataPacket; Index: Integer): TnrDataPacket;
    function Insert(Index: Integer): TnrDataPacket;
    function IsPacket(ch:byte):integer;
    procedure Reset;
    property Items[Index: Integer]: TnrDataPacket read GetItem write SetItem; default;
    property IsPacketPossible:boolean read fIsPacketPossible;
  end;

  TnrDataPacketEvent = procedure (Sender:TObject; Packet:TnrDataPacket) of object;

  TnrDataProtocol = class(TnrCustomDataProcessor)
  private
    fPackets:TnrDataPackets;
    fOnDataPacket : TnrDataPacketEvent;
    fTimeout: integer;
    fOnTimeout: TNotifyEvent;
    function GetDataPackets: TnrDataPackets;
    procedure SetDataPackets(const Value: TnrDataPackets);
  protected
    flSkipFurtherProcessing:boolean;
    procedure DoMediumOpened; override;
    procedure DoMediumClosed; override;
    procedure DoHandlePacket(i:integer); virtual;
    procedure DoTimeoutError;             virtual;
    function IsPacket(ch:byte):integer;  virtual;
    property DataPackets:TnrDataPackets read GetDataPackets write SetDataPackets;
    property OnDataPacket: TnrDataPacketEvent read fOnDataPacket write fOnDataPacket;
    property OnTimeout: TNotifyEvent read fOnTimeout write fOnTimeout;
    property Timeout:integer read fTimeout write fTimeout;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy;override;
    procedure DoProcessing(Data:PAnsiChar; Len:cardinal; var R:TIgnoreTypes); override;
    procedure DoAsyncTimeout(Sender:TObject); override;
    procedure Reset; virtual;
    function IsPacketPossible:boolean; virtual;

//  published
//    property Active;
//    property DataProcessor;
//    property Log;
//    property OnFatalError;
  end;

  TnrDataProcessor = class(TnrDataProtocol)
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Active;
    property DataPackets;//:TnrDataPackets read GetDataPackets write SetDataPackets;
    property DataProcessor;
    property OnDataPacket;//: TnrDataPacketEvent read fOnDataPacket write fOnDataPacket;
    property OnTimeout;//: TNotifyEvent read fOnTimeout write fOnTimeout;
    property Log;
    property OnFatalError;
    property Timeout;//:integer read fTimeout write fTimeout;
  end;

implementation
uses sysutils;

{ TnrDataPacket }

constructor TnrDataPacket.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  PacketLengthMax := CN_DEFAULT_MAX_PACKET_LENGTH;
  Active := True;
  fEvent := TCommEventNew.Create('');
end;

destructor TnrDataPacket.Destroy;
begin
  Active := False;
  fEvent.Free;
  FreeBuffers;
  inherited;
end;

procedure TnrDataPacket.Assign(Source: TPersistent);
begin
  if (Source is TnrDataPacket) then
  begin
    Active  := TnrDataPacket(Source).Active;
    ResetOthers  := TnrDataPacket(Source).ResetOthers;
    Caption  := TnrDataPacket(Source).Caption;
    PacketBegin  := TnrDataPacket(Source).PacketBegin;
    PacketEnd  := TnrDataPacket(Source).PacketEnd;
    PacketLength  := TnrDataPacket(Source).PacketLength;
  end
  else inherited Assign(Source);
end;

function TnrDataPacket.GetDisplayName: string;
begin
  if Trim(Caption) <> ''
    then Result := Caption
    else Result := inherited GetDisplayName;
end;

function TnrDataPacket.GetMinorState: TnrDataPacketState;
begin

  if Length(fPacketEnd) > 0 then begin
    fEvent.Str := fPacketEnd;
    Result := dpsWaitEnd;
    exit;
  end;

  if (fPacketLength > 0) or (Assigned(fOnPacketLengthOnce)) then begin
    Result := dpsWaitLength;
    exit;
  end;

  if PacketEndByTimeout
    then Result := dpsWaitTimeout
    else Result := dpsInactive;

end;

procedure TnrDataPacket.Reset;
begin

  //fDataBuffer := '';
  fDataLength := 0;

  // variable length and handler in event copy it ...
  fOnPacketLengthOnce := fOnPacketLength;

  if Length(fPacketBegin) > 0 then begin
    fEvent.Str := fPacketBegin;
    fState := dpsWaitBegin;
    exit;
  end;

  fState := GetMinorState;

end;

function TnrDataPacket.IsPacket(ch: byte): boolean;
var fl:boolean;
begin

  Result := False;

  if (not Active) or (fState = dpsInactive) then exit;

  if fState <> dpsWaitBegin then begin
    // begin is detected, therefore accumulate all data
    //fDataBuffer := fDataBuffer + AnsiChar(ch);
    fDataBuffer[fDataLength] := AnsiChar(ch);
    Inc(fDataLength);
    if fDataLength > fPacketLengthMax then fDataLength := 0;
  end;

  if fState = dpsWaitTimeout then exit;

  if fState = dpsWaitLength then begin

    fl := not Assigned(fOnPacketLengthOnce);

    if not fl then begin
      // this handler should set new correct PacketLength and set fl in true
      fOnPacketLengthOnce(Self, ch, fl);
      // if so this handler no more needed
      if fl then begin
        fOnPacketLengthOnce := nil;
      end;
    end;

    if fl then begin
      Result := fDataLength >= fPacketLength;
    end;

  end else begin

    Result := fEvent.IsEvent(Ch);

    if Result then begin

      if fState = dpsWaitBegin then begin
        //include packet header into result ...
        fDataLength := fEvent.Len;
        CopyMemory(fDataBuffer, @fPacketBegin[1], fDataLength);
        //fDataBuffer := fPacketBegin;
        //get next state
        fState := GetMinorState;
        Result := (fState = dpsInactive);
                  //or ((fState = dpsWaitLength) and (fDataLength >= fPacketLength));
      end;

    end;

  end;

  if Result then begin
    PrepareData;
    //Reset;
  end;

end;

function TnrDataPacket.IsPossible:boolean;
begin
  Result := (DataLength > 0) or fEvent.IsPossible;
end;

procedure TnrDataPacket.PrepareData;
begin
  if (fState = dpsWaitLength) or (Length(fPacketBegin) > 0) then begin
    //OutputDebugString('eeee');
  end else
    if (fPacketLength > 0) and ( fPacketLength < fDataLength) then begin
      CopyMemory(fDataBuffer, @fDataBuffer[fDataLength - fPacketLength], fPacketLength);
      fDataLength := fPacketLength;
      //OutputDebugString('xxxxx');
    end;

//  CopyMemory(fDataResult,@fDataBuffer[i], len); // copy result

{  fData := fDataBuffer;
  if (fState = dpsWaitLength) or (Length(fPacketBegin) > 0) then begin
    OutputDebugString('eeee');
    exit;
  end;
  if (fPacketLength > 0) and ( fPacketLength < fDataLength) then begin
    //SetLength(fData,fPacketLength);
    CopyMemory(@fData[1], @fDataBuffer[1+fDataLength-fPacketLength], fPacketLength);
    OutputDebugString('xxxxx');
  end;
  }
end;

function TnrDataPacket.IsTimeoutHandle:boolean;
begin
  Result := False;
  if PacketEndByTimeout then begin
    PrepareData;
    //Reset;
    //Result := Length(fData) > 0;
    Result :=  fDataLength > 0;
  end;
end;

procedure TnrDataPacket.SetPacketLengthMax(Value: integer);
begin

  if Value < CN_MIN_PACKET_LENGTH then  Value := CN_MIN_PACKET_LENGTH;

  if fPacketLengthMax <> Value then begin
    fPacketLengthMax := Value;
    FreeBuffers;
    fDataBuffer := PAnsiChar(LocalAlloc(LPTR, fPacketLengthMax));
//    fDataResult := LocalAlloc(LPTR, fPacketLengthMax);
  end;
end;

procedure TnrDataPacket.FreeBuffers;
begin
  if fDataBuffer <> nil then LocalFree(Dword(fDataBuffer));
  fDataBuffer := nil;
end;

function TnrDataPacket.GetDataAsString: AnsiString;
begin
  if fDataLength > 0 then begin
    SetLength(Result, fDataLength);
    CopyMemory( @Result[1], fDataBuffer, fDataLength);
  end else Result := '';
end;

procedure TnrDataPacket.SetPacketBegin(const Value: AnsiString);
begin
  fPacketBegin := Value;
  fPacketBeginLength := Length(Value);
end;

procedure TnrDataPacket.SetPacketEnd(const Value: AnsiString);
begin
  fPacketEnd := Value;
  fPacketEndLength := Length(Value);  
end;

{ TnrDataPackets }

constructor TnrDataPackets.Create(DataProcessor: TnrDataProtocol);
begin
  inherited Create(TnrDataPacket);
  fDataProcessor := DataProcessor;
end;

function TnrDataPackets.GetOwner: TPersistent;
begin
  Result := fDataProcessor;
end;

function TnrDataPackets.Add: TnrDataPacket;
begin
  Result := TnrDataPacket(inherited Add);
end;

function TnrDataPackets.AddItem(Item: TnrDataPacket;
  Index: Integer): TnrDataPacket;
begin
  if Item = nil
    then Result := TnrDataPacket.Create(Self)
    else Result := Item;
  if Assigned(Result) then begin
    Result.Collection := Self;
    if Index < 0 then Index := Count - 1;
    Result.Index := Index;
  end;
end;

function TnrDataPackets.Insert(Index: Integer): TnrDataPacket;
begin
  Result := AddItem(nil, Index);
end;

function TnrDataPackets.GetItem(Index: Integer): TnrDataPacket;
begin
  Result := TnrDataPacket(inherited GetItem(Index));
end;

procedure TnrDataPackets.SetItem(Index: Integer; Value: TnrDataPacket);
begin
  inherited SetItem(Index, Value);
end;

function TnrDataPackets.IsPacket(ch: byte): integer;
var i:integer;
begin
  Result := -1;
  fIsPacketPossible := False;
  for i := 0 to Count - 1 do
    if Items[i].IsPacket(ch) then begin
      Result := i;
      if Items[i].ResetOthers then ResetOthers(i);
      break;
    end else fIsPacketPossible := fIsPacketPossible or Items[i].IsPossible;
end;

procedure TnrDataPackets.Reset;
var i:integer;
begin
  for i := 0 to Count - 1
    do Items[i].Reset;
end;

function TnrDataPackets.IsTimeoutHandle: integer;
var i:integer;
begin
  Result := -1;
  for i := 0 to Count - 1 do
    if Items[i].IsTimeoutHandle then begin
      Result := i;
      if Items[i].ResetOthers then ResetOthers(i);
      break;
    end;
end;

procedure TnrDataPackets.ResetOthers(iExcept: integer);
var i:integer;
begin
  for i := 0 to Count - 1 do
    if i <> iExcept then Items[i].Reset;
end;

{ TnrDataProcessor }

constructor TnrDataProtocol.Create(AOwner: TComponent);
begin
  inherited;
  sLogPrefix:='nrDataProt: ';
  fPackets := TnrDataPackets.Create(Self);
end;

destructor TnrDataProtocol.Destroy;
begin
  fPackets.Free;
  inherited;
end;

function TnrDataProtocol.GetDataPackets: TnrDataPackets;
begin
  Result := fPackets;
end;

procedure TnrDataProtocol.SetDataPackets(const Value: TnrDataPackets);
begin
  fPackets.Assign(Value);
end;

procedure TnrDataProtocol.DoMediumClosed;
begin
  inherited;
  flSkipFurtherProcessing := False;
  Reset;
end;

procedure TnrDataProtocol.DoMediumOpened;
begin
  flSkipFurtherProcessing := False;
  Reset;
  inherited;
end;

function TnrDataProtocol.IsPacket(ch:byte):integer;
begin
  Result := fPackets.IsPacket(ch);
  if Result >= 0 then begin
    DoHandlePacket(Result);
    fPackets[Result].Reset;
  end;
end;

procedure TnrDataProtocol.DoProcessing(Data: PAnsiChar; Len: cardinal;
  var R: TIgnoreTypes);
var i, j, tm :integer;
begin
  tm := fTimeout;
  if Active  and (fPackets.Count > 0) then begin
    for i := 0 to Len - 1 do begin
      j := fPackets.IsPacket(Byte(Data[i]));
      if (j >= 0) //and Assigned(fOnDataPacket)
        then begin
          DoHandlePacket(j);
          ResetTimeout(0); // stop timeout ...
          fPackets[j].Reset;
        end;
      if not Active then begin
        tm := 0;
        break;
      end;
    end;
    ResetTimeout(tm); // restart timout
    if flSkipFurtherProcessing then R := [itTerminal];
  end;
  inherited DoProcessing(Data, Len, R);
end;

procedure TnrDataProtocol.DoAsyncTimeout(Sender: TObject);
var i:integer;
begin
  inherited DoAsyncTimeout(Sender);
  i := fPackets.IsTimeoutHandle();
  if (i >= 0) then begin
    if Assigned(fOnDataPacket) then DoHandlePacket(i);
    fPackets[i].Reset;
  end else
    DoTimeoutError;
  ResetTimeout(0); // stop timout ...
end;

procedure TnrDataProtocol.DoHandlePacket(i: integer);
begin
  if (i >= 0) then begin
    Logging(dlDebug, 'DataPacket is detected: ' + fPackets[i].GetDisplayName);
    if Assigned(fOnDataPacket) then
    try

      fOnDataPacket(Self,fPackets[i]);
    except
      on E:Exception do DoFatalErrors(ECC_DATAPROC, 1,
         'EXCEPTION in DataPacket handler [' + fPackets[i].GetDisplayName + ']' +
         E.Message);
    end;
  end;
end;

procedure TnrDataProtocol.DoTimeoutError;
begin
  if Assigned(fOnTimeout) then
    try
      fOnTimeout(Self);
    except
      on E:Exception do DoFatalErrors(ECC_DATAPROC, 1,
         'EXCEPTION in OnTimout handler.' + E.Message);
  end;
end;

procedure TnrDataProtocol.Reset;
begin
  fPackets.Reset;
end;

{ TnrDataProcessor }

constructor TnrDataProcessor.Create(AOwner: TComponent);
begin
  inherited;
  sLogPrefix:='nrDataProc: ';
  Active := True;
end;

function TnrDataProtocol.IsPacketPossible: boolean;
begin
  Result := fPackets.IsPacketPossible;
end;

end.
