connect.pas

boomerang library 5.11 internet ed

(* Connect - connection components library
 * Copyright (C) 1999-2003  Tomas Mandys-MandySoft
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330,
 * Boston, MA  02111-1307  USA
 *)

{ URL: http://www.2p.cz }

unit {$IFDEF CLR}MandySoft.Vcl.{$ENDIF}Connect;
{HTX: -oProt}
{ Connect.htx }

interface
uses
  Classes, SysUtils {$IFDEF LINUX}, Libc, Types{$ELSE}, Windows{$ENDIF}, SyncObjs;

{ DONE 31.3.2003 Kylix compatability }
{ DONE 4.1.2004 TCommunicationConnection calls Log in Send and Retrieve }
{ DONE 13.9.2006 improved detection of CRLF for lfStamp }

const
  lchNull = 0;  // fex. channel splitter
  lchOut = 1;
  lchIn = 2;
  lchError = 3;

  devNull = {$IFDEF LINUX}_PATH_DEVNULL{$ELSE}'NUL'{$ENDIF};
type
  TString = {$IFDEF CLR}AnsiString{$ELSE}string{$ENDIF};  // 1 byte string
  TChar = {$IFDEF CLR}AnsiChar{$ELSE}Char{$ENDIF};        // 1 byte char

  TConnection = class;

  TConnectionNotifyEvent = procedure(DataSet: TConnection) of object;

  TConnection = class(TComponent)
  private
    FActive: Boolean;
    FStreamedActive: Boolean;
    FBeforeOpen, FBeforeClose, FAfterOpen, FAfterClose: TConnectionNotifyEvent;
    procedure SetActive(aEnable: Boolean);
  protected
    procedure OpenConn; virtual; abstract;
    procedure CloseConn; virtual; abstract;
    procedure DoBeforeOpen; virtual;
    procedure DoBeforeClose; virtual;
    procedure DoAfterOpen; virtual;
    procedure DoAfterClose; virtual;
    procedure Loaded; override;
    procedure CheckInactive;
    procedure CheckActive;
  public
    destructor Destroy; override;
    procedure Open;
    procedure Close;
  published
    property Active: Boolean read FActive write SetActive;

    property BeforeOpen: TConnectionNotifyEvent read FBeforeOpen write FBeforeOpen;
    property BeforeClose: TConnectionNotifyEvent read FBeforeClose write FBeforeClose;
    property AfterOpen: TConnectionNotifyEvent read FAfterOpen write FAfterOpen;
    property AfterClose: TConnectionNotifyEvent read FAfterClose write FAfterClose;
  end;

  TAcceptChannelEvent = procedure(Sender: TComponent; const aLogName: string; aChannel: Byte; var aAccept: Boolean) of object;
  TOnExceptionEvent = procedure(Sender: TComponent; E: Exception; const aName: string; aChannel: Byte; const aOriginalMessage: string) of object;

  TLogger = class(TConnection)
  private
    FCriticalSection: TCriticalSection;
    FCriticalSection2: TCriticalSection;
    fAutoOpen: Boolean;
    fOnException: TOnExceptionEvent;
    procedure SetAutoOpen(aValue: Boolean);
  protected
    FAcceptChannel: TAcceptChannelEvent;
    procedure DoLog(const aText: string); virtual; abstract;
    procedure DoLog2(const aName: string; aChannel: Byte; const aText: string); virtual;
    function PreformatText(const aName: string; aChannel: Byte; aText: string): string; virtual; abstract;
    procedure DoOnException(E: Exception; const aName: string; aChannel: Byte; const aOriginalMessage: string); virtual;
  public
    property CriticalSection: TCriticalSection read fCriticalSection;
    property CriticalSection2: TCriticalSection read fCriticalSection2 write fCriticalSection2;
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    procedure Log(const aName: string; aChannel: Byte; aText: string);
  published
    property AcceptChannel: TAcceptChannelEvent read FAcceptChannel write FAcceptChannel;
    property AutoOpen: Boolean read fAutoOpen write SetAutoOpen;
    property OnException: TOnExceptionEvent read fOnException write fOnException;
  end;

  TLogFormatFlag = (lfInsertName, lfInsertChannel, lfDivideNames, lfDivideChannels, lfDivideStream, lfHexadecimal, lfStamp, lfAutoCR);
  TLogFormatFlags = set of TLogFormatFlag;
  TOnDivideStream = procedure(Sender: TComponent; const aLogName: string; aChannel: Byte; var aText: string; var I: Integer; var aDivide: Boolean) of object;

  TStreamLogger = class(TLogger)
  private
    FLogStream: TStream;
    FLogFlags: TLogFormatFlags;
    FMaxLineLength: Integer;
    FLastChannel: Byte;
    FLastName: string;
    FLineLength: Integer;
    FOnDivideStream: TOnDivideStream;
    FLastCRLF: Char;
    procedure SetLogStream(Value: TStream);
  protected
    procedure OpenConn; override;
    procedure DoLog(const aText: string); override;
    function PreformatText(const aName: string; aChannel: Byte; aText: string): string; override;
    function DivideStream(const aName: string; aChannel: Byte; var aText: string; var I: Integer): Boolean; virtual;
  public
    constructor Create(aOwner: TComponent); override;
    property LogStream: TStream read FLogStream write SetLogStream;
  published
    property LogFlags: TLogFormatFlags read FLogFlags write FLogFlags;
    property MaxLineLength: Integer read FMaxLineLength write FMaxLineLength;
    property OnDivideStream: TOnDivideStream read FOnDivideStream write FOnDivideStream;
  end;

  TFileLogger = class(TStreamLogger)
  private
    FLogFile: TFileName;
    FMaxFileSize: LongInt;
    FRotateCount: Word;
    procedure SetLogFile(const aFile: TFileName);
    function GetRotateLogFile(I: Integer): string;
  protected
    procedure DoLog(const aText: string); override;
    procedure OpenConn; override;
    procedure CloseConn; override;
  public
  published
    property LogFile: TFileName read FLogFile write SetLogFile;
    property MaxFileSize: LongInt read fMaxFileSize write fMaxFileSize default 0;
    property RotateCount: Word read fRotateCount write fRotateCount default 0;
  end;

  TFormatLogEvent = procedure(Sender: TComponent; aChannel: Byte; var aText: string) of object;

  TLogConnection = class(TConnection)
  private
    FLogger: TLogger;
    FOnFormatLog: TFormatLogEvent;
    FLogName: string;
  protected
    procedure DoFormatLog(aChannel: Byte; var aText: string); virtual;
  public
    procedure Log(aChannel: Byte; aText: string);
    procedure LogFromStream(aChannel: Byte; aStream: TStream);
  published
    property Logger: TLogger read FLogger write FLogger;
    property LogName: string read FLogName write FLogName;
    property OnFormatLog: TFormatLogEvent read FOnFormatLog write FOnFormatLog;
  end;

  TCommRxCharEvent = procedure(Sender: TObject; Count: Integer) of object;

  TCommunicationConnection = class(TLogConnection)
  private
    FOnRxChar: TCommRxCharEvent;
    FDontSynchronize: Boolean;
  public
    function Send(S: TString): Integer;  { wait until not sent }
    function InQueCount: Integer; virtual; abstract;
    function Retrieve(aCount: Integer): TString;
    procedure PurgeIn; virtual; abstract;
    procedure PurgeOut; virtual; abstract;
    property OnRxChar: TCommRxCharEvent read FOnRxChar write FOnRxChar;
    property DontSynchronize: Boolean read FDontSynchronize write FDontSynchronize;
  protected
    function Write({$IFNDEF CLR}{const}var {$ENDIF}Buf {$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer): Integer; virtual; abstract;
    function Read({$IFNDEF CLR}{const}var {$ENDIF}Buf {$IFDEF CLR}:TBytes{$ENDIF}; Count: Integer): Integer; virtual; abstract;
    procedure DoOnRxChar(Count: Integer); virtual;
  end;

  EConnectError = class(Exception)
  end;

function NowUTC: TDateTime;
function DateTimemsToStr(aDT: TDateTime): string;

function StreamReadString(St: TStream): TString;
procedure StreamWriteString(St: TStream; S: TString);

function StreamToString(St: TStream): TString; overload;
function StreamToString(St: TStream; aLen: Longint): TString; overload;
procedure StringToStream(const S: TString; St: TStream);

function Bin2Hex(const S: TString): TString;
function Hex2Bin(const S: TString): TString;
function B2C(B: Byte): {$IFDEF CLR}TString {AnsiChar concat error}{$ELSE}TChar{$ENDIF};
function B2C1(B: Byte): TChar;
function UpString(S: TString): TString;

procedure Register;

resourcestring
  sActiveConnection = 'Connection is active';
  sInactiveConnection = 'Connection is inactive';

implementation

procedure ComError(const Msg: string);
begin
  raise EConnectError.Create(Msg);
end;

function Bin2Hex(const S: TString): TString;
var
  I: Integer;
begin
  Result:= '';
  for I:= 1 to Length(S) do
    Result:= Result+ Format('%.2x', [Ord(S[I])]);
  Result:= UpString(Result);
end;

function Hex2Bin(const S: TString): TString;
var
  I: Integer;
  B: Integer;
begin
  Result:= '';
  I:= 1;
  while I <= Length(S) do
  begin
    B:= StrToInt('$'+Copy(S, I, 2));
    Result:= Result + Chr(B);
    Inc(I, 2);
  end;
end;

function B2C; // (B: Byte): TChar;
begin
  {$IFDEF CLR}
  Result:= TChar(Ord(B)); 
  {$ELSE}
  Result:= TChar(Chr(B));
  {$ENDIF}
end;

function B2C1;
begin
  Result:= B2C(B){$IFDEF CLR}[1]{$ENDIF};
end;

function UpString(S: TString): TString;
var
  I: Integer;
begin
  Result:='';
  for I:=1 to Length(S) do
    Result:= Result + UpCase(S[I]);
end;

function  NowUTC: TDateTime;
var
{$IFDEF LINUX}
  T: TTime_T;
  TV: TTimeVal;
  UT: TUnixTime;
{$ELSE}
  SystemTime: TSystemTime;
{$ENDIF}
begin
{$IFDEF LINUX}
  gettimeofday(TV, nil);
  T := TV.tv_sec;
  gmtime_r(@T, UT);
  Result := EncodeDate(UT.tm_year + 1900, UT.tm_mon + 1, UT.tm_mday) +
    EncodeTime(UT.tm_hour, UT.tm_min, UT.tm_sec, TV.tv_usec div 1000);
{$ELSE}
  GetSystemTime(SystemTime);
  with SystemTime do
    Result := EncodeDate(wYear, wMonth, wDay)+
              EncodeTime(wHour, wMinute, wSecond, wMilliseconds);
{$ENDIF}
end;

function DateTimemsToStr(aDT: TDateTime): string;
begin
  Result:= FormatDateTime(ShortDateFormat+' hh:nn:ss.zzz', aDT);
end;

function StreamReadString(St: TStream): TString;
var
  W: Word;
{$IFDEF CLR}
  B: TBytes;
{$ENDIF}
begin
{$IFDEF CLR}
  SetLength(B, SizeOf(W));
  St.ReadBuffer(B, Length(B));
  W:= B[0]+B[1] shl 8;
  SetLength(B, W);
  St.ReadBuffer(B, W);
  Result:= AnsiEncoding.GetString(B);
{$ELSE}
  St.ReadBuffer(W, SizeOf(W));
  SetLength(Result, W);
  if Result <> '' then
    St.ReadBuffer(Result[1], Length(Result));
{$ENDIF}
end;

procedure StreamWriteString(St: TStream; S: TString);
var
  W: Word;
{$IFDEF CLR}
  B: TBytes;
{$ENDIF}
begin
  W:= Length(S);
{$IFDEF CLR}
  SetLength(B, SizeOf(W));
  B[0]:= W mod 256;
  B[1]:= W div 256;
  St.WriteBuffer(B, Length(B));
  if W > 0 then
  begin
    B:= BytesOf(S);
    St.WriteBuffer(B, Length(B));
  end;
{$ELSE}
  St.WriteBuffer(W, SizeOf(W));
  if S <> '' then
    St.WriteBuffer(S[1], Length(S));
{$ENDIF}
end;

function StreamToString(St: TStream): TString;
var
  L: Longint;
begin
  if St.Size > St.Position then
    L:= St.Size - St.Position
  else
    L:= 0;
  Result:= StreamToString(St, L);
end;

function StreamToString(St: TStream; aLen: Longint): TString;
{$IFDEF CLR}
var
  B: TBytes;
{$ENDIF}
begin
{$IFDEF CLR}
  SetLength(B, aLen);
  St.ReadBuffer(B, Length(B));
  Result:= AnsiEncoding.GetString(B);
{$ELSE}
  SetLength(Result, aLen);
  if Result <> '' then
    St.ReadBuffer(Result[1], Length(Result));
{$ENDIF}
end;

procedure StringToStream(const S: TString; St: TStream);
{$IFDEF CLR}
var
  B: TBytes;
{$ENDIF}
begin
{$IFDEF CLR}
  if S <> '' then
  begin
    B:= BytesOf(S);
    St.WriteBuffer(B, Length(B));
  end;
{$ELSE}
  if S <> '' then
    St.WriteBuffer(S[1], Length(S));
{$ENDIF}
end;

destructor TConnection.Destroy;
begin
  Destroying;
  Close;
  inherited;
end;

procedure TConnection.Open;
begin
  Active:= True;
end;

procedure TConnection.Close;
begin
  Active:= False;
end;

procedure TConnection.SetActive;
begin
  if (csReading in ComponentState) then
  begin
    if aEnable then
      FStreamedActive := True;
  end
else
  if FActive <> aEnable then
  begin
    if aEnable then