{------------------------------------------------------------------------------}
{
   Unit Name: kErrors
   Purpose  : Handles errorlog.
   Author   : Vesa Lappalainen
   Date     : ??.1997
   Changed  : 13.4.1999
    + myös tiedostoon kirjoittaminen viestin kautta

   ToDo     :
}
{------------------------------------------------------------------------------}

unit kErrors;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, savepos, kComp, KParam;

const tab = #09;
const crlf = #13#10;
const WM_ADDERRORLINE = WM_USER + 100;
const WM_WRITEERRORLINE = WM_ADDERRORLINE + 1;


type
  TErrorHeader = function:string;
(*
  TCommError = (ceNone,ceCommError,ceCommDebug,ceModbusError,ceModbusDebug,
                ceLineError,ceLineDebug,
                ceUserChange,ceParamChange,cePressDebug,
                ceProgramDebug, ceCreasing, ceComment,
                ceLast);
*)

  TErrors = class;

  TCommError = class
    sc : string;
    expl : string;
    err : boolean;
    Errors : TErrors;
  public
    show : boolean;
    log : boolean;
    constructor Create(sc,expl : string;err,show,log:boolean); virtual;
    destructor Destroy; override;
    procedure Add(const s:string); virtual;
    procedure ShowErrors; virtual;
  end;

  TErrors = class(TForm)
    FErrorScreen: TMemo;
    PanelSettings: TPanel;
    SavePos1: TSavePos;
    CheckBoxErr: TCheckBox;
    ButtonClear: TButton;
    ButtonOptions: TButton;
    ParamErrorLimit: TkParam;
    ButtonMark: TButton;
    ButtonClose: TButton;
    ButtonComment: TButton;
    procedure FormHide(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure CheckBoxErrClick(Sender: TObject);
    procedure ButtonClearClick(Sender: TObject);
    procedure ButtonOptionsClick(Sender: TObject);
    procedure ButtonMarkClick(Sender: TObject);
    procedure ButtonCloseClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ButtonCommentClick(Sender: TObject);
  private
    f:Text;
    NoLogSave : boolean;
    FileName : string;
    LoggedErrors : integer;
    lasttext : string;
    optform : TForm;
    procedure WriteLine(etype: TCommError; const s: string);
  public
    ErrHeader : TErrorHeader;
    ShowErr : boolean;
    AutomaticShow : boolean;
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    function RegisterError(var etype:TCommError;const sc,expl:string; err,show,log:boolean):boolean; virtual;
    procedure AddLine(etype:TCommError;const s:string); virtual;
    procedure Add(etype:TCommError;const s:string);  virtual;
    procedure ShowErrors; virtual;
    procedure AddMark; virtual;
    procedure AddErrorLine(var Message: TMessage); message WM_ADDERRORLINE;
    procedure WriteErrorLine(var Message: TMessage); message WM_WRITEERRORLINE;
  published
    property ErrorScreen : TMemo read FErrorScreen write FErrorScreen;
  end;


var
  GlobalErrors: TErrors;
(*
  ErrorRec : array[ceNone..ceLast] of TErrorRec = (
    ( sc : 'ne'; expl : 'No error'                                            ),
    ( sc : 'ce'; expl : 'Communication error' ; err : True                    ),
    ( sc : 'cd'; expl : 'Communication debug'                                 ),
    ( sc : 'me'; expl : 'Modbus error'        ; err : True                    ),
    ( sc : 'md'; expl : 'Modbus debug'                                        ),
    ( sc : 'le'; expl : 'Line error'          ; err : True                    ),
    ( sc : 'ld'; expl : 'Line debug'                                          ),
    ( sc : 'uc'; expl : 'User change'                                         ),
    ( sc : 'pc'; expl : 'Param change'                                        ),
    ( sc : 'pr'; expl : 'Press debug'                                         ),
    ( sc : 'pd'; expl : 'Program debug'                                       ),
    ( sc : 'cr'; expl : 'Creasing'          ; err : False; show:true; log:true),
    ( sc : 'co'; expl : 'Comment'           ; err : False; show:false;log:true),
    ( sc : 'ma'; expl : 'An mark'           ; err : False; show:true; log:true)
  );
*)

function NowToStr:string;
function NowTo4Str:string;
function RegisterError(var etype:TCommError;const sc,expl:string;
 err:boolean=false;show:boolean=false;log:boolean=false):boolean;

function CRegisterError(var etype:Pointer;const sc,expl:PChar; err,show,log:boolean):boolean; stdcall;
procedure AddCError(etype:pointer;const s:PChar); stdcall;


var ceNone,ceMark : TCommError;

implementation

uses erroropt,ErrorCom;

{$R *.DFM}

function RegisterError(var etype:TCommError;const sc,expl:string; err,show,log:boolean):boolean;
begin
  Result := false;
//  if ( csDesigning in Application.ComponentState) then
//  ShowMessage(Application.ExeName + ' ' + sc + ' ' + expl);
//  exit;
  if ( GlobalErrors = nil ) then begin
    MessageBox(0,'RegisterError',PChar(Application.ExeName),0);
    GlobalErrors := TErrors.Create(Application);
    if ( GlobalErrors = nil ) then exit;
  end;
//  Result := GlobalErrors.RegisterError(etype,sc,expl,err,show,log);
end;

function TErrors.RegisterError(var etype:TCommError;const sc,expl:string; err,show,log:boolean):boolean;
// Registeres error sc.
// If no error shortcut sc is previously find, then a new is created
// and registered and result := true
// If sc is previously registered (even different expl) then
// this error is returned as a etype and false tells that etype is not a new one.
begin
  Result := false;
  if ( self = nil ) then exit;
  if ( self.OptForm <> nil ) then begin
    etype := TFormErrorOpt(self.OptForm).FindRegisteredError(sc);
    if ( etype <> nil ) then exit;
  end;

  etype := TCommError.Create(sc,expl,err,show,log);
  if ( etype = nil ) then exit;
  etype.Errors := self;
  if ( self.OptForm <> nil ) then
    TFormErrorOpt(self.OptForm).RegisterError(etype);
  result := true;
end;

function CRegisterError(var etype:Pointer;const sc,expl:PChar; err,show,log:boolean):boolean;
begin
  Result := RegisterError(TCommError(etype),sc,expl,err,show,log);
end;

procedure AddCError(etype:pointer;const s:PChar);
begin
  TCommError(etype).Add(s);
end;

function TR(s:string):string; begin Result := s; end;

function NowToStr:string;
var Hour,Min,Sec,MSec:Word; s:string;
begin
  DecodeTime(Time,Hour,Min,Sec,MSec);
  MSec := MSec div 10;
  s := IntToStr(MSec); if ( Length(s) < 2 ) then s := '0'+s;
  Result := FormatDateTime('yymmdd hhnnss',now)+'.'+s;
end;

function NowTo4Str:string;
var Hour,Min,Sec,MSec:Word; s:string;
begin
  DecodeTime(Time,Hour,Min,Sec,MSec);
  MSec := MSec div 10;
  s := IntToStr(MSec); if ( Length(s) < 2 ) then s := '0'+s;
  Result := FormatDateTime('yyyymmdd hhnnss',now)+'.'+s;
end;



constructor TErrors.Create(AOwner:TComponent);
begin
(*
  AutomaticShow := false;
  FileName := GetCurrentDir+'\errorlog.txt';
  AssignFile(F, FileName);
  NoLogSave := false;
  if ( Not FileExists(FileName) ) then begin
    try
      Rewrite(f);
      CloseFile(f);
    except
      NoLogSave := True;
    end;
  end;

  ShowErr := True;
  ErrHeader := NowToStr;
*)
  inherited Create(AOwner);
(*
  OptForm := TFormErrorOpt.Create(self);
*)  
end;

procedure TErrors.FormHide(Sender: TObject);
begin
  ShowErr := false;
  LoggedErrors := 0;
end;

const MaxErrLine = 63;
var ErrorBuf : array [0..MaxErrLine] of string;
var ErrorPtr : integer;
var LastWrite : integer;

procedure RoundInc(var i:integer);
begin
  inc(i); if ( i > MaxErrLine ) then i := 0;
end;

procedure TErrors.AddErrorLine(var Message: TMessage);
var etype : TCommError;
begin
  etype := TCommError(Message.LParam);
  if ( etype = nil ) then exit;
  ErrorScreen.Lines.Add(ErrorBuf[Message.wParam]);
//  if ( ErrorRec[etype].err ) then begin
  if ( etype.err ) then begin
    inc(LoggedErrors);
    if ( LoggedErrors >= ParamErrorLimit.Value ) then begin
      LoggedErrors := 0;
      if ( AutomaticShow ) then Show;
    end;
  end;
end;

procedure TErrors.WriteErrorLine(var Message: TMessage);
begin
  try
    Append(F);
    Writeln(f,ErrorBuf[Message.wParam]);
    LastWrite := Message.wParam;
    CloseFile(F);
    NoLogSave := False;
  except
    if ( not NoLogSave ) then
      ShowMessage(TR('Can''t write log file ')+FileName+'!');
    NoLogSave := True;
  end;
end;

{$DEFINE USEERRORMESSAGE}
procedure TErrors.AddLine(etype:TCommError; const s:string);
begin
{$IFDEF USEERRORMESSAGE}
  ErrorBuf[ErrorPtr] := s;
  PostMessage(self.handle,WM_ADDERRORLINE,ErrorPtr,integer(etype));
  RoundInc(ErrorPtr);
{$ELSE}
  ErrorScreen.Lines.Add(s);
{$ENDIF}
end;

procedure TErrors.WriteLine(etype:TCommError; const s:string);
begin
{$IFDEF USEERRORMESSAGE}
  ErrorBuf[ErrorPtr] := s;
  PostMessage(self.handle,WM_WRITEERRORLINE,ErrorPtr,integer(etype));
  RoundInc(ErrorPtr);
{$ELSE}
  try
    Append(F);
    Writeln(f,s);
    CloseFile(F);
    NoLogSave := False;
  except
    if ( not NoLogSave ) then
      ShowMessage(TR('Can''t write log file ')+FileName+'!');
    NoLogSave := True;
  end;
{$ENDIF}
end;

procedure TErrors.Add(etype:TCommError;const s:string);
var h:string;
begin
  if ( not Assigned(self) ) or ( etype = nil ) then exit;
//  if not (( ShowErr and ErrorRec[etype].show ) or ( ErrorRec[etype].log )) then exit;
  if not (( ShowErr and etype.show ) or ( etype.log )) then exit;
  if ( s = lasttext ) then exit;
//  exit;

  lasttext := s;
//  h := ErrorRec[etype].sc+tab+s;
  h := etype.sc+tab+s;
  if ( assigned(ErrHeader) ) then h := ErrHeader+tab+h;
//  if ( ShowErr and ErrorRec[etype].show ) then AddLine(etype,h);//ErrorScreen.Lines.Add(h);
  if ( ShowErr and etype.show ) then AddLine(etype,h);//ErrorScreen.Lines.Add(h);
//  if ( ( not NoLogSave ) and ErrorRec[etype].log ) then WriteLine(etype,h);
  if ( ( not NoLogSave ) and etype.log ) then WriteLine(etype,h);
end;

procedure TErrors.FormShow(Sender: TObject);
begin
  ShowErr := CheckBoxErr.Checked;
  LoggedErrors := 0;
end;

procedure TErrors.ShowErrors;
begin
  Show;
end;


procedure TErrors.CheckBoxErrClick(Sender: TObject);
begin
  ShowErr := CheckBoxErr.Checked;
end;

procedure TErrors.ButtonClearClick(Sender: TObject);
begin
  ErrorScreen.Lines.Clear;
  LoggedErrors := 0;
  lasttext := '';
end;

procedure TErrors.ButtonOptionsClick(Sender: TObject);
begin
  OptForm.Show;
end;

procedure TErrors.AddMark;
begin
  Add(ceMark,'Mark: ----------------------------');
end;

procedure TErrors.ButtonMarkClick(Sender: TObject);
begin
  AddMark;
end;

procedure TErrors.ButtonCloseClick(Sender: TObject);
begin
  Close;
end;

destructor TErrors.Destroy;
begin
  MessageBox(0,'Destroy','1',0);
  inherited;
  MessageBox(0,'Destroy','2',0);
end;

procedure TErrors.FormDestroy(Sender: TObject);
begin
  MessageBox(0,'FormDestroy','Menee',0);
//  RoundInc(LastWrite);
//  inc(LastWrite); if ( LastWrite > MaxErrLine ) then LastWrite := 0;
(*
  if ( LastWrite = ErrorPtr ) then exit;
  Append(F);
  repeat
    Writeln(f,ErrorBuf[LastWrite]);
    RoundInc(LastWrite);
  until ( LastWrite = ErrorPtr );
  CloseFile(F);
*)  
end;

procedure TErrors.ButtonCommentClick(Sender: TObject);
begin
  AddComment;
end;

{ TCommError }

procedure TCommError.Add(const s: string);
begin
  if ( self = nil ) then exit;
  if ( show ) or ( log ) then Errors.Add(self,s);
end;

constructor TCommError.Create(sc, expl: string; err, show, log: boolean);
begin
  self.sc := sc;
  self.expl := expl;
  self.err := err;
  self.show := show;
  self.log := log;
end;

destructor TCommError.Destroy;
begin
  inherited;

end;

procedure TCommError.ShowErrors;
begin
  if ( self = nil ) then exit;
  if ( errors = nil ) then exit;
  errors.ShowErrors;
end;




initialization begin
//    ( sc : 'ne'; expl : 'No error'                                            ),
//    ( sc : 'ma'; expl : 'An mark'           ; err : False; show:true; log:true)
  RegisterError(ceNone,'ne','No error');
  RegisterError(ceMark,'ma','An mark');
end;


end.