LMS-2_ReportAPI/exttypes.pas

unit extTypes;

{$mode ObjFPC}{$H+}

interface

uses
  Classes, SysUtils, LNet, syncobjs;
const
  version='0.0.1.2';
  cmdRequest=1;
  cmdAnswer=2;
  cmdError=3;
  StatusWaiting=1;
  StatusProcessing=2;
  StatusComplete=3;
  StatusError=4;
  PacketStart:qword=$1F2E3D4C5B6A7908;
  ErrorProcessor=1;
  ErrorLogin=2;
  ErrorConnect=3;
  ErrorCommand=4;
  ErrorComplete=5;
  ErrorArguments=6;
  ErrorInternal=$100;
  CONNECT_TIMEOUT=15;

type
  TBuffer=Array of Byte;
  TParamArray=Array of QWORD;
  TLogLevel=(mtError,mtWarning,mtInfo,mtDebug,mtExtra);
  TLogger=procedure(ALevel: TLogLevel; Sender: TObject; Msg: String ) of object;
  EFormatException=class(Exception);
  { TConnectionThread }

  { TRoundBuffer }

  TRoundBuffer=class
    private
      intdata: TBuffer;
      ptrRead,ptrWrite: integer;
      fSize,fDataSize: integer;
      fReadReady,fWriteReady: TSimpleEvent;
      fClosed: boolean;
      cs: TCriticalSection;
      fLogger: TLogger;
      procedure log(msg: string);
    public
      constructor Create(ALogger: TLogger; BufferSize: integer);
      destructor Destroy; override;
      function Push(const data; datasize: integer): integer;
      function Pop(var data; datasize: integer): integer;
      function ReadFromSocket(ASocket:TLSocket): integer;
      procedure Read(out Value: byte); overload;
      procedure Read(out Value: word); overload;
      procedure Read(out Value: dword); overload;
      procedure Read(out Value: qword); overload;
      procedure Close;
      property ReadReady: TSimpleEvent read fReadReady;
      property WriteReady: TSimpleEvent read fWriteReady;
  end;

  { TCommandData }

  TCommandData=class
    Code:DWORD;
    Param:QWord;
    Name: string;
    Keys: TStrings;
    iValues: TParamArray;
    Data: TStream;
    constructor Create(ACode:DWORD;AParam:QWord; AName: string; AKeys: TStrings; AValues: TParamArray; AData: TStream); overload;
    constructor Create(ACode:DWORD;AParam:QWord; AName: string;const AKeys: Array of string; AValues: TParamArray; AData: TStream); overload;
    destructor Destroy; override;
    procedure AssignTo(out ACode:DWORD;out AParam:QWord; out AName: string; out AKeys: TStrings; out AValues: TParamArray; out AData: TStream); overload;
    procedure AssignTo(out ACode:DWORD;out AParam:QWord; out AName: string; out AKeys: TStrings); overload;
  end;
procedure CopyBytes(var Dest: PByte; const Data: byte); overload;
procedure CopyBytes(var Dest: PByte; const Data: word); overload;
procedure CopyBytes(var Dest: PByte; const Data: dword); overload;
procedure CopyBytes(var Dest: PByte; const Data: qword); overload;
procedure CopyBytes(var Dest: PByte; const Data: TBuffer); overload;
procedure CopyParamArray(const Source: TParamArray; out Dest: TParamArray);
procedure LogStrings(ALevel: TLogLevel; logger: TLogger;Sender: TObject;Name: string; Data: TStrings);
implementation
procedure CopyParamArray(const Source: TParamArray; out Dest: TParamArray);
var
  i: integer;
begin
  setlength(Dest,length(Source));
  if length(Source)>0 then
  for i := low(Source) to High(Source) do
    Dest[i] := Source[i];
end;

procedure LogStrings(ALevel: TLogLevel; logger: TLogger; Sender: TObject;
  Name: string; Data: TStrings);
var
  i: integer;
begin
  if assigned(logger) and assigned(Data) then
    begin
      logger(ALevel,Sender,Name);
      for i := 0 to Data.Count-1 do
        logger(ALevel, Sender,' '+Data[i]);
    end;
end;

procedure CopyBytes(var Dest: PByte; const Data: byte);
begin
  dest^ := Data;
  inc(dest);
end;

procedure CopyBytes(var Dest: PByte; const Data: word);
var
  i: integer;
  l: word;
begin
  l := Data;
  for i:=0 to sizeof(word)-1 do
    begin
      Dest^ := l and $FF;
      l := l shr 8;
      inc(Dest);
    end;
end;

procedure CopyBytes(var Dest: PByte; const Data: dword);
var
  i: integer;
  l: dword;
begin
  l := Data;
  for i:=0 to sizeof(dword)-1 do
    begin
      Dest^ := l and $FF;
      l := l shr 8;
      inc(Dest);
    end;
end;

procedure CopyBytes(var Dest: PByte; const Data: qword);
var
  i: integer;
  l: qword;
begin
  l := Data;
  for i:=0 to sizeof(qword)-1 do
    begin
      Dest^ := l and $FF;
      l := l shr 8;
      inc(Dest);
    end;
end;

procedure CopyBytes(var Dest: PByte; const Data: TBuffer);
var
  i: integer;
begin
  for i := low(Data) to high(Data) do
    begin
      Dest^ := Data[i];
      inc(Dest);
    end;
end;

  { TRoundBuffer }

procedure TRoundBuffer.log(msg: string);
begin
  {$IFDEF DEBUG} if assigned(fLogger) then fLogger(mtExtra,self,msg); {$ENDIF}
end;

constructor TRoundBuffer.Create(ALogger: TLogger; BufferSize: integer);
begin
  inherited Create;
  flogger := ALogger;
  cs := TCriticalSection.Create;
  SetLength(self.intdata,BufferSize);
  fSize:=BufferSize;
  fDataSize := 0;
  self.ptrRead:=0;
  self.ptrWrite:=0;
  fReadReady := TSimpleEvent.Create;
  fWriteReady := TSimpleEvent.Create;
  fWriteReady.SetEvent;
  fClosed:=false;
end;

destructor TRoundBuffer.Destroy;
begin
  cs.free;
  fReadReady.Free;
  fWriteReady.Free;
  setLength(self.intdata,0);
  inherited Destroy;
end;

function TRoundBuffer.Push(const data; datasize: integer): integer;
var
  i,delta: integer;
  p:PByte;
  rem: integer;
  s: string;
begin
  result := 0;
  if dataSize<=0 then exit;
  if fClosed then exit;
  p := @data;
  i := ptrWrite;
  rem := dataSize;
  s := '';
  if fDataSize=fSize then
   fWriteReady.WaitFor(INFINITE);
  if fClosed then exit;
  delta := 0;
  log(format('Push size=%d, R=%d, W=%d ',[fDataSize,ptrRead,ptrWrite]));
  while not fClosed and (rem>0) and (fDataSize+delta<fSize) do
    begin
      intData[i] := p^;
      s := s + inttohex(p^,2)+' ';
      inc(p);
      i := (i+1) mod fSize;
      dec(rem);
      inc(delta);
    end;

  cs.Enter;
  ptrWrite := i;
  inc(fDataSize,delta);
  if fDataSize=fSize then
    begin
    fWriteReady.ResetEvent;
    log('buffer full');
    end;
  cs.Leave;

  result := delta;
  log(format('Push %d bytes size=%d',[result,fDataSize]));
  fReadReady.SetEvent;
end;

function TRoundBuffer.Pop(var data; datasize: integer): integer;
var
  i,delta: integer;
  p:PByte;
  rem: integer;
  s: string;
begin
  result := 0;
  if datasize<=0 then exit;
  if fClosed then exit;
  fReadReady.WaitFor(INFINITE);
  if fClosed then
    exit;
  p := @data;
  i := ptrRead;
  rem := dataSize;
  s := '';
  delta := 0;
  log(format('Pop size=%d, R=%d, W=%d ',[fDataSize,ptrRead,ptrWrite]));
  while not fClosed and (rem>0) and (fDataSize-delta>0) do
    begin
      p^:=intData[i];
      s := s + inttohex(intData[i],2)+' ';
      inc(p);
      i := (i+1) mod fSize;
      inc(delta);
      dec(rem);
    end;
  cs.Enter;
  ptrRead := i;
  dec(fDataSize,delta);
  if fDataSize=0 then
    begin
    fReadReady.ResetEvent;
    log('buffer empty');
    end;
  cs.Leave;
  result := delta;
  log(format('Pop %d bytes size=%d',[result,fDataSize]));
  fWriteReady.SetEvent;
end;

function TRoundBuffer.ReadFromSocket(ASocket: TLSocket): integer;
var
  p: PByte;
  s: integer;
begin
  if fClosed then exit;
  s := fSize-fDataSize;
  if s>0 then
  begin
    p := GetMem(s);
    try
    s := ASocket.Get(p^,s);
    result := Push(p^,s);
    finally
      FreeMem(p);
    end;
  end
  else
    begin
    result := -1;
    fReadReady.SetEvent;
    fWriteReady.SetEvent;
    end;
end;

procedure TRoundBuffer.Read(out Value: byte);
begin
  Pop(value,sizeof(byte));
end;

procedure TRoundBuffer.Read(out Value: word);
var
  rem,l : integer;
  p: PByte;
  lBytes: array[0..1] of byte;
begin
  Value := 0;
  rem := 2;
  p := PByte(lBytes);
  repeat
    l := pop(p^,rem);
    dec(rem,l);
    inc(p,l);
    if l=0 then sleep(100);
  until rem=0;
  for l := 1 downto 0 do
    Value := (Value shl 8) or lBytes[l];
end;

procedure TRoundBuffer.Read(out Value: dword);
var
  rem,l : integer;
  p: PByte;
  lBytes: array[0..3] of byte;
begin
  Value := 0;
  rem := 4;
  p := PByte(lBytes);
  repeat
    l := pop(p^,rem);
    dec(rem,l);
    inc(p,l);
    if l=0 then sleep(100);
  until rem=0;
  for l := 3 downto 0 do
    Value := (Value shl 8) or lBytes[l];
end;

procedure TRoundBuffer.Read(out Value: qword);
var
  rem,l : integer;
  p: PByte;
  lBytes: array[0..7] of byte;
begin
  Value := 0;
  rem := 8;
  p := PByte(lBytes);
  repeat
    l := pop(p^,rem);
    dec(rem,l);
    inc(p,l);
    if l=0 then
      sleep(10);
  until (rem=0) or fClosed;
  for l := 7 downto 0 do
    Value := (Value shl 8) or lBytes[l];
end;

procedure TRoundBuffer.Close;
begin
  fClosed := true;
  fReadReady.SetEvent;
  fWriteReady.SetEvent;
end;

{ TCommandData }

constructor TCommandData.Create(ACode: DWORD; AParam: QWord; AName: string;
  AKeys: TStrings; AValues: TParamArray; AData: TStream);
var
  i: integer;
begin
  Code := Acode;
  Param := AParam;
  Name := AName;
  if assigned(AKeys) then
    begin
      Keys := TStringList.Create;
      Keys.Assign(AKeys);
    end
  else
    Keys := nil;
  setLength(iValues,length(AValues));
  for i := low(iValues) to high(iValues) do
    iValues[i] := AValues[i];
  if assigned(AData) then
    begin
      Data := TMemoryStream.Create;
      AData.seek(0,soFromBeginning);
      Data.CopyFrom(AData,AData.Size);
    end
  else
    Data := nil;
end;

constructor TCommandData.Create(ACode: DWORD; AParam: QWord; AName: string;
  const AKeys: array of string; AValues: TParamArray; AData: TStream);
var
  l: TStrings;
  i: integer;
begin
  if length(AKeys)=0 then
     Create(ACode,AParam,AName,nil,AValues,AData)
  else
    begin
      l := TStringList.Create;
      try
        for i := low(AKeys) to high(AKeys) do
          l.add(AKeys[i]);
        Create(ACode,AParam,AName,l,AValues,AData)
      finally
        l.free;
      end;
    end;
end;

destructor TCommandData.Destroy;
begin
  if assigned(Keys) then Keys.Free;
  if assigned(Data) then Data.Free;
  setLength(iValues,0);
  inherited Destroy;
end;

procedure TCommandData.AssignTo(out ACode: DWORD; out AParam: QWord; out
  AName: string; out AKeys: TStrings; out AValues: TParamArray; out
  AData: TStream);
var
  i: integer;
begin

  ACode := Code;
  AParam := Param;
  AName := Name;
  if assigned(Keys) then
    begin
      AKeys := TStringList.Create;
      AKeys.Assign(Keys);
    end
  else
    AKeys := nil;
  if assigned(Data) then
    begin
      AData := TMemoryStream.Create;
      Data.Seek(0,soFromBeginning);
      AData.CopyFrom(Data,Data.Size);
    end
  else
    AData := nil;
  CopyParamArray(iValues,AValues);
end;

procedure TCommandData.AssignTo(out ACode: DWORD; out AParam: QWord; out
  AName: string; out AKeys: TStrings);
begin
  ACode := Code;
  AParam := Param;
  AName := Name;
  if assigned(Keys) then
    begin
      AKeys := TStringList.Create;
      AKeys.Assign(Keys);
    end
  else
    AKeys := nil;

end;

end.