alexey.zablotskiy/LMS-2_ReportAPI
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

logging

Browse Source
This commit is contained in:
Алексей Заблоцкий 2023-10-19 15:14:52 +03:00
parent 675fa2a89a
commit e9066d84e0
15 changed files with 168 additions and 184 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
U:/Apache/Apache24/cgi-bin/lms_cgi
View File

Binary file not shown.

26
baseconnection.pas
View File

@ -46,7 +46,7 @@ type
function CheckArgs(out Errors: TStrings): boolean; virtual; abstract; function CheckArgs(out Errors: TStrings): boolean; virtual; abstract;
function ParseCommand(ACode: DWORD; iParam: QWORD; ACommand: string; Args: TStrings; intArgs: TParamArray; CmdData: TStream; out Errors: TStrings): boolean; function ParseCommand(ACode: DWORD; iParam: QWORD; ACommand: string; Args: TStrings; intArgs: TParamArray; CmdData: TStream; out Errors: TStrings): boolean;
function ParseArguments(Args: TStrings; out Errors: TStrings): boolean; virtual; abstract; function ParseArguments(Args: TStrings; out Errors: TStrings): boolean; virtual; abstract;
procedure Log(msg: string); procedure Log(ALevel:TLogLevel; msg: string);
function ProcessOptionValues(ParamName: string; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean; virtual; abstract; function ProcessOptionValues(ParamName: string; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean; virtual; abstract;
end; end;
TCommandClass=class of TCommand; TCommandClass=class of TCommand;
@ -89,7 +89,7 @@ type
User: string; User: string;
UserID: integer; UserID: integer;
LastAccess: TDateTime; LastAccess: TDateTime;
procedure Log(sender: TObject; msg: string); procedure Log(ALevel:TLogLevel;sender: TObject; msg: string);
property Created: TDateTime read fCreated; property Created: TDateTime read fCreated;
property LastReceive: TDateTime read fCommandReceived; property LastReceive: TDateTime read fCommandReceived;
property LastComplete: TDateTime read fCommandCompleted; property LastComplete: TDateTime read fCommandCompleted;
@ -153,7 +153,7 @@ end;
destructor TBaseConnection.Destroy; destructor TBaseConnection.Destroy;
begin begin
log(self,'Destroy'); log(mtExtra,self,'Destroy');
Processor.Free; Processor.Free;
Commands.Free; Commands.Free;
DoneCommands.Free; DoneCommands.Free;
@ -168,7 +168,7 @@ var
cc: TCommandClass; cc: TCommandClass;
cmd: TCommand; cmd: TCommand;
begin begin
log(self,'AddCommand '+ACommandClass+ ' '+ACommandName); log(mtDebug,self,'AddCommand '+ACommandClass+ ' '+ACommandName);
fCommandReceived:=Now(); fCommandReceived:=Now();
cc := TCommandCollection.Find(ACommandClass,ACommandName); cc := TCommandCollection.Find(ACommandClass,ACommandName);
if assigned(cc) then if assigned(cc) then
@ -203,7 +203,7 @@ end;
function TBaseConnection.RunCommand(ACommand: TCommand): boolean; function TBaseConnection.RunCommand(ACommand: TCommand): boolean;
begin begin
ACommand.doRun(); ACommand.doRun();
log(Self,'complete '+ACommand.CommandID); log(mtDebug,Self,'complete '+ACommand.CommandID);
fCommandCompleted:=Now(); fCommandCompleted:=Now();
inc(nCommandReady); inc(nCommandReady);
end; end;
@ -238,7 +238,7 @@ begin
if LastAccess>d then d := LastAccess; if LastAccess>d then d := LastAccess;
if (now()-d)*24*60>fTimeout then if (now()-d)*24*60>fTimeout then
begin begin
log(self,'TIMEOUT'); log(mtInfo,self,'TIMEOUT');
terminate; terminate;
end end
else else
@ -268,23 +268,23 @@ begin
end; end;
end; end;
procedure TBaseConnection.Log(sender: TObject; msg: string); procedure TBaseConnection.Log(ALevel: TLogLevel; sender: TObject; msg: string);
begin begin
if assigned(fLogger) then if assigned(fLogger) then
flogger(sender,msg); flogger(ALevel,sender,msg);
end; end;
procedure TBaseConnection.Execute; procedure TBaseConnection.Execute;
var var
cmd: TCommand; cmd: TCommand;
begin begin
log(self,'started'); log(mtExtra,self,'started');
while not terminated do while not terminated do
begin begin
while Commands.Count>0 do while Commands.Count>0 do
begin begin
cmd := Commands.Objects[0] as TCommand; cmd := Commands.Objects[0] as TCommand;
log(self,format('run(%s) %s %s ',[cmd.CommandID,cmd.CommandName, cmd.CommandSubClass])); log(mtDebug,self,format('run(%s) %s %s ',[cmd.CommandID,cmd.CommandName, cmd.CommandSubClass]));
try try
RunCommand(cmd); RunCommand(cmd);
finally finally
@ -296,7 +296,7 @@ begin
if fCheckConnect then Idle; if fCheckConnect then Idle;
sleep(200); sleep(200);
end; end;
log(self,'finished'); log(mtExtra,self,'finished');
end; end;
function TBaseConnection.ProcessOptionValues(ReportName, ParamName: string; function TBaseConnection.ProcessOptionValues(ReportName, ParamName: string;
@ -421,9 +421,9 @@ begin
result := ParseArguments(fData.Keys,Errors); result := ParseArguments(fData.Keys,Errors);
end; end;
procedure TCommand.Log(msg: string); procedure TCommand.Log(ALevel: TLogLevel; msg: string);
begin begin
connect.log(self, self.CommandID+#09+msg) connect.log(ALevel,self, self.CommandID+#09+msg)
end; end;
end. end.

21
cgi_daemon.pas
View File

@ -50,14 +50,14 @@ end;
procedure TLMSReportCGI.DataModuleCreate(Sender: TObject); procedure TLMSReportCGI.DataModuleCreate(Sender: TObject);
begin begin
//{$IFDEF WINDOWS}
self.Logger.Active:=false; self.Logger.Active:=false;
{$IFDEF WINDOWS}
self.Logger.AppendContent:=true; self.Logger.AppendContent:=true;
self.Logger.LogType := ltFile; self.Logger.LogType := ltFile;
self.Logger.FileName := format('%s/server.log',[extractfilepath(paramstr(0))]); self.Logger.FileName := format('%s/server.log',[extractfilepath(paramstr(0))]);
{$ENDIF}
self.logger.Identification:='LMS-Report-Service';
self.Logger.Active:=true; self.Logger.Active:=true;
//{$ENDIF}
self.logger.Info('TLMSReportCGI.DataModuleCreate');
workThread := TDaemonThread.create(self); workThread := TDaemonThread.create(self);
end; end;
@ -68,15 +68,14 @@ end;
procedure TLMSReportCGI.DataModuleStart(Sender: TCustomDaemon; var OK: Boolean); procedure TLMSReportCGI.DataModuleStart(Sender: TCustomDaemon; var OK: Boolean);
begin begin
logger.Info('start daemon thread'); logger.Info('Запуск сервиса');
workThread.Start; workThread.Start;
logger.Info('daemon thread started');
OK := true; OK := true;
end; end;
procedure TLMSReportCGI.DataModuleStop(Sender: TCustomDaemon; var OK: Boolean); procedure TLMSReportCGI.DataModuleStop(Sender: TCustomDaemon; var OK: Boolean);
begin begin
debugln('stop daemon thread'); debugln('Останов сервиса');
workThread.Terminate; workThread.Terminate;
end; end;
@ -84,24 +83,20 @@ end;
procedure TDaemonThread.Execute; procedure TDaemonThread.Execute;
begin begin
flogger.Info('TDaemonThread.Execute'); flogger.debug('TDaemonThread.Execute');
fData := TConnectionsDM.CreateWithLog(fLogger); fData := TConnectionsDM.CreateWithLog(fLogger);
try try
fData.logger := fLogger;
fData.log(self,'logging');
flogger.Info('TDaemonThread.Execute.1');
fData.Start; fData.Start;
flogger.Info('TDaemonThread.Execute.2');
while not terminated do while not terminated do
begin begin
if sleepMin(2) then if sleepMin(5) then
fData.Idle(self); fData.Idle(self);
flogger.Info('TDaemonThread.Idle');
end; end;
fData.Stop; fData.Stop;
finally finally
fData.free; fData.free;
end; end;
flogger.debug('TDaemonThread.Execute.complete');
end; end;
function TDaemonThread.sleepMin(n: integer): boolean; function TDaemonThread.sleepMin(n: integer): boolean;

27
cgidm.pas
View File

@ -45,7 +45,7 @@ type
function GetData(ASQL: string): TDataSet; function GetData(ASQL: string): TDataSet;
function CheckUser(const login,password: string; out UserID: integer): boolean; function CheckUser(const login,password: string; out UserID: integer): boolean;
procedure OpenConnection; procedure OpenConnection;
procedure log(Sender: TObject; msg: string); procedure log(ALevel: TLogLevel; Sender: TObject; msg: string);
procedure LogError(Sender: TObject; e: Exception; msg: string); procedure LogError(Sender: TObject; e: Exception; msg: string);
procedure ExecuteSQL(ASQL: string); procedure ExecuteSQL(ASQL: string);
constructor CreateWithLogger(ALogger: TLogger); constructor CreateWithLogger(ALogger: TLogger);
@ -63,15 +63,14 @@ uses
procedure TNIDBDM.DataModuleCreate(Sender: TObject); procedure TNIDBDM.DataModuleCreate(Sender: TObject);
begin begin
log(sender,'TnnzConnection.Create'); log(mtDebug,sender,'TnnzConnection.Create');
fcon := TnnzConnection.Create(self); fcon := TnnzConnection.Create(self);
log(sender,'TnnzConnection.Create.ok');
end; end;
procedure TNIDBDM.DataModuleDestroy(Sender: TObject); procedure TNIDBDM.DataModuleDestroy(Sender: TObject);
begin begin
log(sender,'destroy'); log(mtDebug,sender,'destroy');
fcon.Connected:=false; fcon.Connected:=false;
fcon.free; fcon.free;
end; end;
@ -288,7 +287,7 @@ end;
function TNIDBDM.QueryValue(ASQL: string; Default: string): string; function TNIDBDM.QueryValue(ASQL: string; Default: string): string;
begin begin
log(self,'QueryValue'#13#10+ASQL); log(mtDebug,self,'QueryValue'#13#10+ASQL);
with TnnzQuery.Create(self) do with TnnzQuery.Create(self) do
try try
Connection := fcon; Connection := fcon;
@ -302,7 +301,7 @@ end;
function TNIDBDM.QueryIntValue(ASQL: string): integer; function TNIDBDM.QueryIntValue(ASQL: string): integer;
begin begin
log(self,'QueryIntValue'#13#10+ASQL); log(mtDebug,self,'QueryIntValue'#13#10+ASQL);
with TnnzQuery.Create(self) do with TnnzQuery.Create(self) do
try try
Connection := fcon; Connection := fcon;
@ -317,7 +316,7 @@ end;
function TNIDBDM.GetData(ASQL: string): TDataSet; function TNIDBDM.GetData(ASQL: string): TDataSet;
begin begin
log(self,'getData '#13#10+ASQL); log(mtDebug,self,'getData '#13#10+ASQL);
result := TnnzQuery.Create(self); result := TnnzQuery.Create(self);
with result as TnnzQuery do with result as TnnzQuery do
begin begin
@ -331,39 +330,39 @@ end;
function TNIDBDM.CheckUser(const login, password: string; out UserID: integer function TNIDBDM.CheckUser(const login, password: string; out UserID: integer
): boolean; ): boolean;
begin begin
log(self,'CheckUser'); log(mtInfo,self,'CheckUser '+login);
UserID := QueryIntValue(format('Select coalesce((select min(p.mid) from people p where login=%s and password=%s),0) ',[StringAsSQL(login),StringAsSQl(password)])); UserID := QueryIntValue(format('Select coalesce((select min(p.mid) from people p where login=%s and password=%s),0) ',[StringAsSQL(login),StringAsSQl(password)]));
result := UserID>0; result := UserID>0;
end; end;
procedure TNIDBDM.OpenConnection; procedure TNIDBDM.OpenConnection;
begin begin
log(self,'OpenConnection'); log(mtDebug,self,'OpenConnection');
fcon.Connected:=true; fcon.Connected:=true;
fcon.Identify; fcon.Identify;
end; end;
procedure TNIDBDM.log(Sender: TObject; msg: string); procedure TNIDBDM.log(ALevel: TLogLevel; Sender: TObject; msg: string);
begin begin
if assigned(flogger) then if assigned(flogger) then
flogger(Sender,msg); flogger(ALevel,Sender,msg);
end; end;
procedure TNIDBDM.LogError(Sender: TObject; e: Exception; msg: string); procedure TNIDBDM.LogError(Sender: TObject; e: Exception; msg: string);
begin begin
log(Sender,'!!ERROT at '+msg+#13#10+e.ClassName+#13#10+e.message); log(mtERROR,Sender,'!!ERROT at '+msg+#13#10+e.ClassName+#13#10+e.message);
end; end;
procedure TNIDBDM.ExecuteSQL(ASQL: string); procedure TNIDBDM.ExecuteSQL(ASQL: string);
begin begin
log(self,'ExecuteSQL '+ASQL); log(mtDebug,self,'ExecuteSQL '+ASQL);
connection.ExecuteSQL(ASQL); connection.ExecuteSQL(ASQL);
end; end;
constructor TNIDBDM.CreateWithLogger(ALogger: TLogger); constructor TNIDBDM.CreateWithLogger(ALogger: TLogger);
begin begin
fLogger := ALogger; fLogger := ALogger;
log(nil,'TNIDBDM.Create'); log(mtDebug,nil,'TNIDBDM.Create');
inherited Create(nil); inherited Create(nil);
end; end;

17
cgireport.pas
View File

@ -5,7 +5,7 @@ unit cgiReport;
interface interface
uses uses
Classes, SysUtils, baseconnection; Classes, SysUtils, baseconnection, extTypes;
type type
{ TReportCommand } { TReportCommand }
@ -13,7 +13,7 @@ type
private private
procedure CreateVariablesTable; procedure CreateVariablesTable;
procedure UpdateCodeWithArguments(var code: string); procedure UpdateCodeWithArguments(var code: string);
procedure SetStage(Sender:TObject; stageName: string); procedure SetStage(ALevel:TLogLevel; Sender:TObject; stageName: string);
public public
ReportID: integer; ReportID: integer;
ReportName: string; ReportName: string;
@ -32,7 +32,7 @@ type
implementation implementation
uses uses
cgiDM,extTypes,reportDMUnit, types, strutils, LazUTF8; cgiDM,reportDMUnit, types, strutils, LazUTF8;
{ TReportCommand } { TReportCommand }
procedure TReportCommand.CreateVariablesTable; procedure TReportCommand.CreateVariablesTable;
@ -54,7 +54,8 @@ begin
Code := StringReplace(Code,'{#user}',inttostr(self.Connect.UserID),[rfReplaceAll]); Code := StringReplace(Code,'{#user}',inttostr(self.Connect.UserID),[rfReplaceAll]);
end; end;
procedure TReportCommand.SetStage(Sender: TObject; stageName: string); procedure TReportCommand.SetStage(ALevel: TLogLevel; Sender: TObject;
stageName: string);
begin begin
fcurrentStage:=format('выполняется (%s)',[stageName]); fcurrentStage:=format('выполняется (%s)',[stageName]);
end; end;
@ -111,14 +112,14 @@ var
vs: string; vs: string;
vi: integer; vi: integer;
begin begin
log('FillVars'); log(mtDebug,'FillVars');
script := format('insert into tmp_report_variables(name,value_string,var_type) values(''UserName'',%s,0); ',[TNIDBDM.StringAsSQL(self.Connect.User)]); script := format('insert into tmp_report_variables(name,value_string,var_type) values(''UserName'',%s,0); ',[TNIDBDM.StringAsSQL(self.Connect.User)]);
ASQL := format('select name,query from xp_report_variables where xp_rpt_id=%d and var_type=0',[ReportID]); ASQL := format('select name,query from xp_report_variables where xp_rpt_id=%d and var_type=0',[ReportID]);
with connect.Processor.GetData(ASQL) do with connect.Processor.GetData(ASQL) do
try try
while not eof do while not eof do
begin begin
log(FieldByName('name').asString); log(mtDebug, FieldByName('name').asString);
q := FieldByName('query').AsString; q := FieldByName('query').AsString;
UpdateCodeWithArguments(q); UpdateCodeWithArguments(q);
try try
@ -139,7 +140,7 @@ begin
try try
while not eof do while not eof do
begin begin
log(FieldByName('name').asString); log(mtDebug, FieldByName('name').asString);
q := FieldByName('query').AsString; q := FieldByName('query').AsString;
UpdateCodeWithArguments(q); UpdateCodeWithArguments(q);
try try
@ -177,7 +178,7 @@ begin
end; end;
ReportTitle := connect.Processor.QueryValue(format('select r.name from xp_report_cgi g join xp_report r on r.xp_rpt_id=g.xp_rpt_id where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)])); ReportTitle := connect.Processor.QueryValue(format('select r.name from xp_report_cgi g join xp_report r on r.xp_rpt_id=g.xp_rpt_id where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)]));
CreateVariablesTable; CreateVariablesTable;
log(ReportTitle); log(mtInfo,'Построение отчета '+ReportTitle);
connect.ReportProcessor.RecordID:=ReportID; connect.ReportProcessor.RecordID:=ReportID;
fcurrentStage := 'исполняется (подготовка)'; fcurrentStage := 'исполняется (подготовка)';
try try

53
connectionsdmunit.pas
View File

@ -24,7 +24,6 @@ type
procedure DataModuleCreate(Sender: TObject); procedure DataModuleCreate(Sender: TObject);
procedure DataModuleDestroy(Sender: TObject); procedure DataModuleDestroy(Sender: TObject);
private private
fLogFolder: string;
MainCon: TNIDBDM; MainCon: TNIDBDM;
conlist: TList; conlist: TList;
Input: TServerMainThread; Input: TServerMainThread;
@ -34,7 +33,6 @@ type
fServicePort: integer; fServicePort: integer;
fLogger: TEventLog; fLogger: TEventLog;
fTimeOut: integer; fTimeOut: integer;
LogLock: TCriticalSection;
fRunning: boolean; fRunning: boolean;
function getConnection(ID: string): TBaseConnection; function getConnection(ID: string): TBaseConnection;
function NewConnection: TBaseConnection; function NewConnection: TBaseConnection;
@ -52,7 +50,7 @@ type
property DataPort: integer read fDataPort; property DataPort: integer read fDataPort;
property DataBase: string read fDataBase; property DataBase: string read fDataBase;
property Logger: TEventLog read fLogger write fLogger; property Logger: TEventLog read fLogger write fLogger;
procedure Log(Sender: TObject; msg: string); procedure Log(ALevel: TLogLevel; Sender: TObject; msg: string);
procedure Start; procedure Start;
procedure Stop; procedure Stop;
procedure Idle(Sender: TObject); procedure Idle(Sender: TObject);
@ -78,26 +76,16 @@ uses
procedure TConnectionsDM.DataModuleCreate(Sender: TObject); procedure TConnectionsDM.DataModuleCreate(Sender: TObject);
begin begin
log(sender,'datamodulecreate-0');
fRunning := false; fRunning := false;
log(sender,'datamodulecreate.1');
LogLock := TCriticalSection.Create;
conList := TList.Create; conList := TList.Create;
log(sender,'datamodulecreate.2');
MainCon := TNIDBDM.CreateWithLogger(@log); MainCon := TNIDBDM.CreateWithLogger(@log);
log(sender,'datamodulecreate.3');
MainCon.logger:=@log;
LoadConfig; LoadConfig;
log(sender,'datamodulecreate.4');
input := TServerMainThread.Create(@log,fServicePort,@ProcessRequest); input := TServerMainThread.Create(@log,fServicePort,@ProcessRequest);
log(sender,'datamodulecreate.ok');
end; end;
procedure TConnectionsDM.DataModuleDestroy(Sender: TObject); procedure TConnectionsDM.DataModuleDestroy(Sender: TObject);
begin begin
log(Sender,'Destroy'); log(mtExtra,Sender,'Destroy');
ClearConnections; ClearConnections;
if fRunning then if fRunning then
@ -107,7 +95,6 @@ begin
end; end;
Input.Free; Input.Free;
MainCon.Free; MainCon.Free;
LogLock.Free;
conList.Free; conList.Free;
end; end;
@ -137,7 +124,7 @@ begin
result.Host:=DataHost; result.Host:=DataHost;
result.port:=DataPort; result.port:=DataPort;
result.DataBase:=DataBase; result.DataBase:=DataBase;
log(self, 'New '+result.ConnectionID); log(mtDebug, self, 'New '+result.ConnectionID);
result.Init; result.Init;
end; end;
@ -150,7 +137,7 @@ begin
for i := conList.Count-1 downto 0 do for i := conList.Count-1 downto 0 do
if TBaseConnection(conlist[i]).ConnectionID=ID then if TBaseConnection(conlist[i]).ConnectionID=ID then
begin begin
log(self,'terminate '+ID); log(mtDebug,self,'terminate '+ID);
TBaseConnection(conlist[i]).terminate; TBaseConnection(conlist[i]).terminate;
exit; exit;
end; end;
@ -162,7 +149,7 @@ var
i: integer; i: integer;
con: TBaseConnection; con: TBaseConnection;
begin begin
log(self,'ClearConnections'); log(mtDebug, self,'ClearConnections');
for i := 0 to conList.Count-1 do for i := 0 to conList.Count-1 do
begin begin
con := TBaseConnection(conlist[i]); con := TBaseConnection(conlist[i]);
@ -183,7 +170,7 @@ begin
con := TBaseConnection(conlist[i]); con := TBaseConnection(conlist[i]);
if con.Finished then if con.Finished then
begin begin
log(self,'Destroy terminated '+con.ConnectionID); log(mtDebug, self,'Destroy terminated '+con.ConnectionID);
con.free; con.free;
conlist.delete(i); conlist.delete(i);
end; end;
@ -206,7 +193,7 @@ var
userName,conID,cmdID: string; userName,conID,cmdID: string;
cmd: TCommand; cmd: TCommand;
begin begin
log(Self,'Process Request '+ACommand); log(mtInfo, Self,'Process Request '+ACommand);
ClearTerminated; ClearTerminated;
result := false; result := false;
RetValue := 0; RetValue := 0;
@ -485,36 +472,40 @@ begin
fDataPort := ini.ReadInteger('DATA','port',7079); fDataPort := ini.ReadInteger('DATA','port',7079);
fDataBase:= ini.ReadString('DATA','database',''); fDataBase:= ini.ReadString('DATA','database','');
fServicePort := ini.ReadInteger('PARAMS','port',6543); fServicePort := ini.ReadInteger('PARAMS','port',6543);
flogFolder:=ini.ReadString('PARAMS','log','');
fTimeOut:=ini.ReadInteger('PARAMS','timeout',CONNECT_TIMEOUT); fTimeOut:=ini.ReadInteger('PARAMS','timeout',CONNECT_TIMEOUT);
log(self,format('server %s:%d/%s',[fDataHost,fDataPort,fDataBase])); log(mtInfo,self,format('server %s:%d/%s',[fDataHost,fDataPort,fDataBase]));
finally finally
ini.free; ini.free;
end; end;
end; end;
procedure TConnectionsDM.Log(Sender: TObject; msg: string); procedure TConnectionsDM.Log(ALevel: TLogLevel; Sender: TObject; msg: string);
var var
f: TextFile; s: string;
begin begin
if not assigned(fLogger) then exit; if not assigned(fLogger) then exit;
try try
// assignefile(fLogFolder // assignefile(fLogFolder
if Sender is TComponent then if Sender is TComponent then
flogger.Debug(DateTimeToStr(NOW())+#09+Sender.ClassName+'-'+(Sender as TComponent).Name+#09+Msg) s := Sender.ClassName+'-'+(Sender as TComponent).Name
else if Assigned(Sender) then else if assigned(Sender) then
flogger.Debug(DateTimeToStr(NOW())+#09+Sender.ClassName+ #09+ Msg) s := Sender.ClassName
else else
flogger.Debug(DateTimeToStr(NOW())+#09+ #09+ Msg); s := '[NIL]';
except on e: Exception do s := DateTimeToStr(NOW())+#09+s+#09+Msg;
raise; case ALevel of
mtError: fLogger.Error(s);
mtWarning: fLogger.Warning(s);
mtInfo: flogger.Info(s);
mtDebug: fLogger.Debug(s);
end;
except
end; end;
end; end;
procedure TConnectionsDM.Start; procedure TConnectionsDM.Start;
begin begin
log(self,'Start');
MainCon.connection.RemoteHost:=DataHost; MainCon.connection.RemoteHost:=DataHost;
MainCon.connection.RemotePort:=DataPort; MainCon.connection.RemotePort:=DataPort;
MainCon.connection.Database:=DataBase; MainCon.connection.Database:=DataBase;

13
exttypes.pas
View File

@ -28,7 +28,8 @@ const
type type
TBuffer=Array of Byte; TBuffer=Array of Byte;
TParamArray=Array of QWORD; TParamArray=Array of QWORD;
TLogger=procedure(Sender: TObject; Msg: String) of object; TLogLevel=(mtError,mtWarning,mtInfo,mtDebug,mtExtra);
TLogger=procedure(ALevel: TLogLevel; Sender: TObject; Msg: String ) of object;
EFormatException=class(Exception); EFormatException=class(Exception);
{ TConnectionThread } { TConnectionThread }
@ -73,7 +74,7 @@ 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: qword); overload;
procedure CopyBytes(var Dest: PByte; const Data: TBuffer); overload; procedure CopyBytes(var Dest: PByte; const Data: TBuffer); overload;
procedure CopyParamArray(const Source: TParamArray; out Dest: TParamArray); procedure CopyParamArray(const Source: TParamArray; out Dest: TParamArray);
procedure LogStrings(logger: TLogger;Sender: TObject;Name: string; Data: TStrings); procedure LogStrings(ALevel: TLogLevel; logger: TLogger;Sender: TObject;Name: string; Data: TStrings);
implementation implementation
procedure CopyParamArray(const Source: TParamArray; out Dest: TParamArray); procedure CopyParamArray(const Source: TParamArray; out Dest: TParamArray);
var var
@ -85,16 +86,16 @@ begin
Dest[i] := Source[i]; Dest[i] := Source[i];
end; end;
procedure LogStrings(logger: TLogger; Sender: TObject; Name: string; procedure LogStrings(ALevel: TLogLevel; logger: TLogger; Sender: TObject;
Data: TStrings); Name: string; Data: TStrings);
var var
i: integer; i: integer;
begin begin
if assigned(logger) and assigned(Data) then if assigned(logger) and assigned(Data) then
begin begin
logger(Sender,Name); logger(ALevel,Sender,Name);
for i := 0 to Data.Count-1 do for i := 0 to Data.Count-1 do
logger(Sender,' '+Data[i]); logger(ALevel, Sender,' '+Data[i]);
end; end;
end; end;

25
lms_cgi.lpr
View File

@ -22,7 +22,7 @@ Type
const Code:DWORD; const QValue: QWORD; const Answer: string; const Values: TStrings; const iValues: TParamArray; const Data: TStream): boolean; const Code:DWORD; const QValue: QWORD; const Answer: string; const Values: TStrings; const iValues: TParamArray; const Data: TStream): boolean;
Public Public
Procedure HandleRequest(ARequest : Trequest; AResponse : TResponse); override; Procedure HandleRequest(ARequest : Trequest; AResponse : TResponse); override;
procedure log(Sender: TObject; msg: string); procedure log(ALevel: TLogLevel; Sender: TObject; msg: string);
end; end;
@ -50,7 +50,6 @@ function TMyCGIHandler.answerReady(Sender: TMainThread; const mode: byte;
const Values: TStrings; const iValues: TParamArray; const Data: TStream const Values: TStrings; const iValues: TParamArray; const Data: TStream
): boolean; ): boolean;
begin begin
log(self,'AnswerReady');
fAnswer:=Answer; fAnswer:=Answer;
fMode:=mode; fMode:=mode;
fCode:=code; fCode:=code;
@ -76,8 +75,8 @@ var
k,v: string; k,v: string;
allfields: TStrings; allfields: TStrings;
begin begin
log(self,'HandleRequest'); log(mtInfo,self,'Request '+ARequest.Command);
LogStrings(@log,self,'QueryFields',Arequest.QueryFields); LogStrings(mtInfo, @log,self,'QueryFields',Arequest.QueryFields);
allfields := TStringList.Create; allfields := TStringList.Create;
try try
allfields.AddStrings(ARequest.QueryFields); allfields.AddStrings(ARequest.QueryFields);
@ -89,7 +88,7 @@ begin
finally finally
allfields.free; allfields.free;
end; end;
log(self,'Data READY'); log(mtDebug,self,'Data READY');
if not assigned(fData) then if not assigned(fData) then
begin begin
AResponse.ContentType := 'application/json'; AResponse.ContentType := 'application/json';
@ -117,19 +116,27 @@ begin
fData.Seek(0,soFromBeginning); fData.Seek(0,soFromBeginning);
AResponse.ContentStream := fData; AResponse.ContentStream := fData;
end; end;
log(self,'Sending'); log(mtDebug,self,'Sending');
AResponse.SendContent; AResponse.SendContent;
log(self,'Sent'); log(mtDebug,self,'Sent');
end; end;
procedure TMyCGIHandler.log(Sender: TObject; msg: string); procedure TMyCGIHandler.log(ALevel: TLogLevel; Sender: TObject; msg: string);
var var
f: TextFile; f: TextFile;
s: string;
begin begin
if (Owner as TMyCGIApp).LogFolder='' then exit; if (Owner as TMyCGIApp).LogFolder='' then exit;
case ALevel of
mtError: s := '!!ERROR: ';
mtWarning: s := '!WARNING: ';
mtInfo: s := #09;
mtDebug: s := #09#09;
mtExtra: s := #09#09#09;
end;
assignfile(f, (Owner as TMyCGIApp).LogFolder); assignfile(f, (Owner as TMyCGIApp).LogFolder);
if fileexists((Owner as TMyCGIApp).LogFolder) then append(f) else rewrite(f); if fileexists((Owner as TMyCGIApp).LogFolder) then append(f) else rewrite(f);
writeln(f,msg); writeln(f,s+msg);
closefile(f); closefile(f);
end; end;

BIN
lms_cgi_server
View File

Binary file not shown.

BIN
lmsreport
View File

Binary file not shown.

13
maintcpserver.pas
View File

@ -7,7 +7,7 @@ interface
uses uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls, Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
tcpClient,tcpServer, tcpthreadhelper, tcpClient,tcpServer, tcpthreadhelper,
ConnectionsDmUnit, syncobjs, extTypes; ConnectionsDmUnit, syncobjs, extTypes, eventlog;
type type
@ -36,7 +36,7 @@ type
procedure FormCreate(Sender: TObject); procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject); procedure FormDestroy(Sender: TObject);
private private
fLogger: TEventLog;
Server: TConnectionsDM; Server: TConnectionsDM;
Client: TClientMainThread; Client: TClientMainThread;
cmdDone: boolean; cmdDone: boolean;
@ -65,7 +65,13 @@ uses
procedure TCGIServerGUI.FormCreate(Sender: TObject); procedure TCGIServerGUI.FormCreate(Sender: TObject);
begin begin
Server := TConnectionsDM.Create(self); fLogger := TEventLog.Create(self);
fLogger.LogType:=TLogType.ltFile;
fLogger.FileName:=ChangeFileExt(paramstr(0),'.log');
flogger.Identification:='LMS-Report-Test';
fLogger.Active:=false;
fLogger.Active:=true;
Server := TConnectionsDM.CreateWithLog(fLogger);
ConnectionsDM := Server; ConnectionsDM := Server;
cmdDone := true; cmdDone := true;
started := false; started := false;
@ -104,6 +110,7 @@ end;
procedure TCGIServerGUI.FormDestroy(Sender: TObject); procedure TCGIServerGUI.FormDestroy(Sender: TObject);
begin begin
Server.Free; Server.Free;
fLogger.Free;
end; end;
procedure TCGIServerGUI.LogQuery(const qtype: integer; const command: string; procedure TCGIServerGUI.LogQuery(const qtype: integer; const command: string;

46
reportdmunit.pas
View File

@ -173,13 +173,13 @@ end;
procedure TReportDM.frxReportLoadTemplate(Report: TfrxReport; procedure TReportDM.frxReportLoadTemplate(Report: TfrxReport;
const TemplateName: String); const TemplateName: String);
begin begin
NidbData.log(self,'LoadTemplate '+TemplateName); NidbData.log(mtDebug,self,'LoadTemplate '+TemplateName);
end; end;
function TReportDM.frxReportLoadDetailTemplate(Report: TfrxReport; function TReportDM.frxReportLoadDetailTemplate(Report: TfrxReport;
const TemplateName: String; const AHyperlink: TfrxHyperlink): Boolean; const TemplateName: String; const AHyperlink: TfrxHyperlink): Boolean;
begin begin
NidbData.log(self,'LoadDetailTemplate '+TemplateName); NidbData.log(mtDebug,self,'LoadDetailTemplate '+TemplateName);
end; end;
procedure TReportDM.CreateDBDataSet(Query: TReportQuery; EditReport: Boolean); procedure TReportDM.CreateDBDataSet(Query: TReportQuery; EditReport: Boolean);
@ -190,7 +190,7 @@ var
begin begin
if Query.ID>0 then if Query.ID>0 then
begin begin
NidbData.log(self,'CreateDBDataSet '+Query.Name); NidbData.log(mtDebug,self,'CreateDBDataSet '+Query.Name);
ds := TfrxDBDataset.Create(Self); ds := TfrxDBDataset.Create(Self);
Query.Data := ds; Query.Data := ds;
ds.Tag := PtrInt(Query); ds.Tag := PtrInt(Query);
@ -363,7 +363,7 @@ var
q: TReportquery; q: TReportquery;
i: integer; i: integer;
begin begin
NidbData.log(self,'LoadQueries'); NidbData.log(mtDebug,self,'LoadQueries');
SQL := format( SQL := format(
'select q.xp_rpt_q_id,qp.xp_rpt_q_id as ParentID,q.Link_field, '+ 'select q.xp_rpt_q_id,qp.xp_rpt_q_id as ParentID,q.Link_field, '+
' q.Name,'+ ' q.Name,'+
@ -394,12 +394,12 @@ begin
for i := ReportQueries.QueryCount-1 downto 0 do for i := ReportQueries.QueryCount-1 downto 0 do
if ReportQueries.Queries[i].ParentID>0 then if ReportQueries.Queries[i].ParentID>0 then
begin begin
NidbData.log(self,'LoadQueries.'+ReportQueries.Queries[i].Name); NidbData.log(mtDebug,self,'LoadQueries.'+ReportQueries.Queries[i].Name);
q := ReportQueries.Find(ReportQueries.Queries[i].ParentID); q := ReportQueries.Find(ReportQueries.Queries[i].ParentID);
if assigned(q) then if assigned(q) then
q.AddQuery(ReportQueries.Queries[i]); q.AddQuery(ReportQueries.Queries[i]);
end; end;
NidbData.log(self,'LoadQueries-OK'); NidbData.log(mtDebug,self,'LoadQueries-OK');
end; end;
procedure TReportDM.LoadDefaultVariables(AVariables: TxpMemParamManager); procedure TReportDM.LoadDefaultVariables(AVariables: TxpMemParamManager);
@ -408,7 +408,7 @@ var
l: TStrings; l: TStrings;
i: integer; i: integer;
begin begin
NidbData.log(self,'LoadDefaultVariables'); NidbData.log(mtDebug,self,'LoadDefaultVariables');
SQL := 'select name,value from options where name in (''GOU_Name'',''Dep_Name'')'; SQL := 'select name,value from options where name in (''GOU_Name'',''Dep_Name'')';
with NidbData.GetData(sql) do with NidbData.GetData(sql) do
@ -432,7 +432,7 @@ var
s: TStream; s: TStream;
v: Variant; v: Variant;
begin begin
NidbData.log(self,'LoadLogos'); NidbData.log(mtDebug,self,'LoadLogos');
SQL := 'select name,value from options where name in (''Dep_Logo'',''GOU_Logo'')'; SQL := 'select name,value from options where name in (''Dep_Logo'',''GOU_Logo'')';
with NidbData.GetData(sql) do with NidbData.GetData(sql) do
try try
@ -464,13 +464,13 @@ procedure TReportDM.LoadVariables(AVariables, AParam: TxpMemParamManager);
var var
sql: string; sql: string;
begin begin
NidbData.log(self,'LoadVariables'); NidbData.log(mtDebug,self,'LoadVariables');
sql := 'select name,value_string, value_int from tmp_report_variables where var_type=0'; sql := 'select name,value_string, value_int from tmp_report_variables where var_type=0';
with NidbData.GetData(sql) do with NidbData.GetData(sql) do
try try
while not eof do while not eof do
begin begin
NidbData.log(self,fieldbyname('name').AsString); NidbData.log(mtDebug,self,fieldbyname('name').AsString);
if not fieldbyname('value_string').IsNull then if not fieldbyname('value_string').IsNull then
AVariables[fieldbyname('name').AsString] := fieldbyname('value_string').AsString AVariables[fieldbyname('name').AsString] := fieldbyname('value_string').AsString
else if not fieldbyname('value_int').IsNull then else if not fieldbyname('value_int').IsNull then
@ -480,13 +480,13 @@ begin
finally finally
free; free;
end; end;
NidbData.log(self,'LoadParams'); NidbData.log(mtDebug,self,'LoadParams');
sql := 'select name,value_string, value_int from tmp_report_variables where var_type=1'; sql := 'select name,value_string, value_int from tmp_report_variables where var_type=1';
with NidbData.GetData(sql) do with NidbData.GetData(sql) do
try try
while not eof do while not eof do
begin begin
NidbData.log(self,fieldbyname('name').AsString); NidbData.log(mtDebug,self,fieldbyname('name').AsString);
if not fieldbyname('value_string').IsNull then if not fieldbyname('value_string').IsNull then
AParam[fieldbyname('name').AsString] := fieldbyname('value_string').AsString AParam[fieldbyname('name').AsString] := fieldbyname('value_string').AsString
else if not fieldbyname('value_int').IsNull then else if not fieldbyname('value_int').IsNull then
@ -499,7 +499,7 @@ begin
// //
// //
NidbData.log(self,'LoadVariables-OK'); NidbData.log(mtDebug,self,'LoadVariables-OK');
end; end;
procedure TReportDM.OnMasterRecord(Sender: TObject); procedure TReportDM.OnMasterRecord(Sender: TObject);
@ -544,7 +544,7 @@ var
BlobStream : TStream; BlobStream : TStream;
begin begin
NidbData.log(self,'ExportReport.TemplateArh'); NidbData.log(mtDebug,self,'ExportReport.TemplateArh');
ReportStream := TMemoryStream.Create; ReportStream := TMemoryStream.Create;
try try
with NidbData.GetData(format('select TemplateArh from xp_report where xp_rpt_id=%d',[RecordID])) do with NidbData.GetData(format('select TemplateArh from xp_report where xp_rpt_id=%d',[RecordID])) do
@ -582,7 +582,7 @@ var
i: integer; i: integer;
v: variant; v: variant;
begin begin
NidbData.log(self,'CopyReportVariables'); NidbData.log(mtDebug,self,'CopyReportVariables');
for I := Low(AVariables.Params) to High(AVariables.Params) do for I := Low(AVariables.Params) to High(AVariables.Params) do
begin begin
if VarIsStr(AVariables.Params[i][1]) then if VarIsStr(AVariables.Params[i][1]) then
@ -613,13 +613,13 @@ var
AVariables, AParam: TxpMemParamManager; AVariables, AParam: TxpMemParamManager;
begin begin
frxReport.EngineOptions.EnableThreadSafe:=true; frxReport.EngineOptions.EnableThreadSafe:=true;
NidbData.log(self,'ExportReport'); NidbData.log(mtDebug,self,'ExportReport');
ReportQueries := TReportQuery.Create; ReportQueries := TReportQuery.Create;
AVariables := TxpMemParamManager.Create; AVariables := TxpMemParamManager.Create;
AParam := TxpMemParamManager.Create; AParam := TxpMemParamManager.Create;
try try
if assigned(OnStage) then if assigned(OnStage) then
OnStage(self,'список запросов'); OnStage(mtExtra, self,'список запросов');
LoadQueries; LoadQueries;
LoadDefaultVariables(AVariables); LoadDefaultVariables(AVariables);
LoadLogos(AVariables); LoadLogos(AVariables);
@ -627,18 +627,17 @@ begin
frxReport.EngineOptions.DestroyForms := False; frxReport.EngineOptions.DestroyForms := False;
// Создаём источники данных // Создаём источники данных
if assigned(OnStage) then if assigned(OnStage) then
OnStage(self,'подготовка данных'); OnStage(mtExtra,self,'подготовка данных');
CreateDBDataSet(ReportQueries); CreateDBDataSet(ReportQueries);
if assigned(OnStage) then if assigned(OnStage) then
OnStage(self,'загрузка шаблона'); OnStage(mtExtra,self,'загрузка шаблона');
LoadReportTemplate; LoadReportTemplate;
CopyReportVariables(AVariables,AParam); CopyReportVariables(AVariables,AParam);
TxpFRFunctions.SetReport(NidbData,AVariables); TxpFRFunctions.SetReport(NidbData,AVariables);
NidbData.log(self,'preparing');
if assigned(OnStage) then if assigned(OnStage) then
OnStage(self,'формирование отчета'); OnStage(mtExtra,self,'формирование отчета');
begin begin
try try
@ -659,9 +658,8 @@ begin
end; end;
try try
if assigned(OnStage) then if assigned(OnStage) then
OnStage(self,'выгрузка'); OnStage(mtExtra,self,'выгрузка');
NidbData.log(self,'exporting');
flt.ShowDialog := false; flt.ShowDialog := false;
flt.Stream := Data; flt.Stream := Data;
flt.FileName:=''; flt.FileName:='';
@ -685,7 +683,7 @@ begin
AVariables.Free; AVariables.Free;
AParam.Free; AParam.Free;
end; end;
NidbData.log(self,'Report complete'); NidbData.log(mtDebug,self,'Report complete');
end; end;

10
tcpclient.pas
View File

@ -67,7 +67,7 @@ end;
destructor TClientMainThread.Destroy; destructor TClientMainThread.Destroy;
begin begin
log(self,'destroy'); log(mtExtra, self,'destroy');
Connect.Disconnect(); Connect.Disconnect();
fFields.Free; fFields.Free;
inherited Destroy; inherited Destroy;
@ -76,7 +76,7 @@ end;
procedure TClientMainThread.execute; procedure TClientMainThread.execute;
begin begin
doStart; doStart;
log(self,'start main thread'); log(mtExtra, self,'start main thread');
Connect.Connect(Host,Port); Connect.Connect(Host,Port);
while not terminated do while not terminated do
begin begin
@ -84,7 +84,7 @@ begin
sleep(10); sleep(10);
end; end;
Connect.Disconnect(); Connect.Disconnect();
log(self,'terminated'); log(mtExtra, self,'terminated');
end; end;
procedure TClientMainThread.ProcessConnect(thread: TConnectionThread); procedure TClientMainThread.ProcessConnect(thread: TConnectionThread);
@ -108,7 +108,7 @@ begin
except on e:Exception do except on e:Exception do
begin begin
log(self,'!!ERROR ProcessAnswer '+e.message); log(mtError, self,'!!ERROR ProcessAnswer '+e.message);
raise; raise;
end; end;
end; end;
@ -123,7 +123,7 @@ procedure TClientThread.ProcessMessage(const mode: byte; const Code: DWORD;
const Param: QWord; const ACommand: string; const Values: TStrings; const Param: QWord; const ACommand: string; const Values: TStrings;
const intData: TParamArray; const Data: TStream); const intData: TParamArray; const Data: TStream);
begin begin
log(format('ProcessMessage(%d) Param=%x, Answer=%s ',[code,Param,ACommand])); log(mtDebug,format('ProcessMessage(%d) Param=%x, Answer=%s ',[code,Param,ACommand]));
terminate; terminate;
Owner.Terminate; Owner.Terminate;
(Owner as TClientMainThread).ProcessAnswer(mode,code,Param,ACommand,Values,intData,Data); (Owner as TClientMainThread).ProcessAnswer(mode,code,Param,ACommand,Values,intData,Data);

12
tcpserver.pas
View File

@ -40,12 +40,12 @@ function TServerMainThread.processReceive(const CommandID: DWORD;
RetValue: QWord; out Answer: string; out rValues: TStrings; out RetValue: QWord; out Answer: string; out rValues: TStrings; out
iValues: TParamArray; out ByteData: TStream): boolean; iValues: TParamArray; out ByteData: TStream): boolean;
begin begin
log(self,'ProcessReceive '+ACommand); log(mtDebug,self,'ProcessReceive '+ACommand);
if assigned(fOnReceive) then if assigned(fOnReceive) then
result := fOnReceive(self,CommandID,Param,ACommand,Fields,IParams,Data,Code,RetValue,Answer,rValues,iValues,ByteData) result := fOnReceive(self,CommandID,Param,ACommand,Fields,IParams,Data,Code,RetValue,Answer,rValues,iValues,ByteData)
else else
begin begin
log(self,'Processor not assigned'); log(mtWarning,self,'Processor not assigned');
result := false; result := false;
Code := ErrorProcessor; Code := ErrorProcessor;
RetValue := 0; RetValue := 0;
@ -61,7 +61,7 @@ var
n: integer; n: integer;
begin begin
doStart; doStart;
log(self,'start main thread'); log(mtExtra,self,'start main thread');
Connect.Listen(Port); Connect.Listen(Port);
n := 0; n := 0;
while not terminated do while not terminated do
@ -70,7 +70,7 @@ begin
Connect.CallAction; Connect.CallAction;
except on e: Exception do except on e: Exception do
log(e, '!!ERROR '+e.message); log(mtError,e, '!!ERROR '+e.message);
end; end;
sleep(10); sleep(10);
inc(n); inc(n);
@ -110,7 +110,7 @@ var
iVals: TParamArray; iVals: TParamArray;
ok: boolean; ok: boolean;
begin begin
log(format('ProcessMessage(%d) Param=%x, Command %s ',[code,Param,ACommand])); log(mtDebug, format('ProcessMessage(%d) Param=%x, Command %s ',[code,Param,ACommand]));
try try
ok := (Owner as TServerMainThread).ProcessReceive(Code,Param,ACommand,Values,IntData,Data,res,rVal,s,Vals,iVals,B); ok := (Owner as TServerMainThread).ProcessReceive(Code,Param,ACommand,Values,IntData,Data,res,rVal,s,Vals,iVals,B);
try try
@ -125,7 +125,7 @@ begin
except on e:Exception do except on e:Exception do
begin begin
log('!!ERROR ProcessMessage '+e.message); log(mtError,'!!ERROR ProcessMessage '+e.message);
raise; raise;
end; end;
end; end;

89
tcpthreadhelper.pas
View File

@ -47,7 +47,7 @@ type
property Owner: TMainThread read fOwner; property Owner: TMainThread read fOwner;
property Socket:TLSocket read fSocket; property Socket:TLSocket read fSocket;
property Cache: TRoundBuffer read fCache; property Cache: TRoundBuffer read fCache;
procedure log(msg: string); procedure log(ALevel: TLogLevel; msg: string);
procedure ProcessMessage(const mode: byte;const Code:DWORD; const Param:QWord; const ACommand: string;const Values: TStrings; const intData: TParamArray; const Data: TStream); virtual; abstract; procedure ProcessMessage(const mode: byte;const Code:DWORD; const Param:QWord; const ACommand: string;const Values: TStrings; const intData: TParamArray; const Data: TStream); virtual; abstract;
class function Role: string; virtual; abstract; class function Role: string; virtual; abstract;
procedure SendBuffer(const Buffer: TBuffer; Len: dword); procedure SendBuffer(const Buffer: TBuffer; Len: dword);
@ -89,7 +89,7 @@ type
function getThread(index: TLSocket): TConnectionThread; function getThread(index: TLSocket): TConnectionThread;
procedure TerminateClients; procedure TerminateClients;
protected protected
procedure Log(Sender:TObject; msg: string); procedure Log(ALevel: TLogLevel; Sender:TObject; msg: string);
procedure doStart; virtual; procedure doStart; virtual;
public public
property Port: integer read fPort; property Port: integer read fPort;
@ -127,11 +127,11 @@ begin
if TConnectionThread(fclients[i]).Socket=index then if TConnectionThread(fclients[i]).Socket=index then
begin begin
result := TConnectionThread(fclients[i]); result := TConnectionThread(fclients[i]);
log(self,format('getThread(%d) %s',[index.Handle,guidToString(result.ID)])); log(mtDebug,self,format('getThread(%d) %s',[index.Handle,guidToString(result.ID)]));
exit; exit;
end; end;
result := fThreadClass.Create(self,index); result := fThreadClass.Create(self,index);
log(self,format('new Thread(%d) %s',[index.Handle,guidToString(result.ID)])); log(mtDebug,self,format('new Thread(%d) %s',[index.Handle,guidToString(result.ID)]));
fclients.Add(Result); fclients.Add(Result);
end; end;
@ -141,19 +141,19 @@ var
i: integer; i: integer;
clt: TConnectionThread; clt: TConnectionThread;
begin begin
log(Self,'Terminate Clients'); log(mtDebug,Self,'Terminate Clients');
for i := fclients.Count-1 downto 0 do for i := fclients.Count-1 downto 0 do
begin begin
sleep(0); sleep(0);
clt := TConnectionThread(fclients[i]); clt := TConnectionThread(fclients[i]);
try try
log(self,GuidToString(clt.ID)); log(mtDebug,self,GuidToString(clt.ID));
clt.Terminate; clt.Terminate;
clt.WaitFor; clt.WaitFor;
clt.free; clt.free;
except on e: Exception do except on e: Exception do
begin begin
log(self, '!!ERROR Destroy ' + e.Message); log(mtError,self, '!!ERROR Destroy ' + e.Message);
end; end;
end; end;
end; end;
@ -161,10 +161,10 @@ begin
end; end;
procedure TMainThread.Log(Sender: TObject; msg: string); procedure TMainThread.Log(ALevel: TLogLevel; Sender: TObject; msg: string);
begin begin
if assigned(fLogger) then if assigned(fLogger) then
fLogger(Sender,Msg); fLogger(ALevel, Sender,Msg);
end; end;
procedure TMainThread.doStart; procedure TMainThread.doStart;
@ -182,7 +182,7 @@ procedure TMainThread.dataReady(aSocket: TLSocket);
var var
clt: TConnectionThread; clt: TConnectionThread;
begin begin
log(self,'dataReady'); log(mtDebug,self,'dataReady');
if Terminated then exit; if Terminated then exit;
clt := Client[aSocket]; clt := Client[aSocket];
@ -207,10 +207,10 @@ procedure TMainThread.Accept(aSocket: TLSocket);
var var
clt: TConnectionThread; clt: TConnectionThread;
begin begin
log(self,'connect'); log(mtDebug,self,'connect');
if Terminated then exit; if Terminated then exit;
clt := Client[aSocket]; clt := Client[aSocket];
log(self,format('connected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle])); log(mtDebug,self,format('connected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
ProcessAccept(clt); ProcessAccept(clt);
clt.start; clt.start;
@ -221,17 +221,17 @@ var
clt: TConnectionThread; clt: TConnectionThread;
begin begin
if terminated then exit; if terminated then exit;
log(self,'disconnect'); log(mtDebug,self,'disconnect');
try try
clt := Client[aSocket]; clt := Client[aSocket];
if clt.terminated then exit; if clt.terminated then exit;
log(self,format('disconnected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle])); log(mtDebug,self,format('disconnected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
clt.Terminate; clt.Terminate;
fclients.remove(clt); fclients.remove(clt);
except on e: Exception do except on e: Exception do
begin begin
log(self,'!!ERROR doDisconnect '+e.Message); log(mtError,self,'!!ERROR doDisconnect '+e.Message);
raise; raise;
end; end;
end; end;
@ -241,10 +241,10 @@ procedure TMainThread.doConnect(aSocket: TLSocket);
var var
clt: TConnectionThread; clt: TConnectionThread;
begin begin
log(self,'doConnect'); log(mtDebug,self,'doConnect');
if Terminated then exit; if Terminated then exit;
clt := Client[aSocket]; clt := Client[aSocket];
log(self,format('connected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle])); log(mtDebug,self,format('connected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
ProcessConnect(clt); ProcessConnect(clt);
clt.Start; clt.Start;
end; end;
@ -262,9 +262,9 @@ end;
procedure TMainThread.NetError(const msg: string; aSocket: TLSocket); procedure TMainThread.NetError(const msg: string; aSocket: TLSocket);
begin begin
if assigned(aSocket) then if assigned(aSocket) then
log(self,'!!NETERROR on '+inttostr(aSocket.Handle)+#09+msg) log(mtWarning, self,'!!NETERROR on '+inttostr(aSocket.Handle)+#09+msg)
else else
log(self,'!!NETERROR '+msg); log(mtWarning, self,'!!NETERROR '+msg);
end; end;
constructor TMainThread.Create(AThreadClass: TConnectionThreadClass; constructor TMainThread.Create(AThreadClass: TConnectionThreadClass;
@ -281,7 +281,7 @@ begin
Connect.OnDisconnect:=@doDisconnect; Connect.OnDisconnect:=@doDisconnect;
Connect.OnReceive:=@dataReady; Connect.OnReceive:=@dataReady;
Connect.Timeout:=100; Connect.Timeout:=100;
log(self,'create main thread'); log(mtDebug,self,'create main thread');
end; end;
destructor TMainThread.Destroy; destructor TMainThread.Destroy;
@ -575,10 +575,10 @@ begin
end; end;
procedure TConnectionThread.log(msg: string); procedure TConnectionThread.log(ALevel: TLogLevel; msg: string);
begin begin
if assigned(fOwner) then if assigned(fOwner) then
fOwner.log(self,Role+#09+ GuidToString(ID)+#09+msg); fOwner.log(ALevel, self,Role+#09+ GuidToString(ID)+#09+msg);
end; end;
@ -590,7 +590,7 @@ var
part_id,tmp: QWORD; part_id,tmp: QWORD;
b2: array[0..7] of byte; b2: array[0..7] of byte;
begin begin
log('Send buffer '+inttostr(len)); log(mtExtra,'Send buffer '+inttostr(len));
try try
rem := len+Sizeof(integer)+Sizeof(QWord); rem := len+Sizeof(integer)+Sizeof(QWord);
p := GetMem(rem); p := GetMem(rem);
@ -614,7 +614,7 @@ begin
end; end;
except on e:Exception do except on e:Exception do
begin begin
log('!!ERROR SendBuffer '+e.message); log(mtError,'!!ERROR SendBuffer '+e.message);
raise; raise;
end; end;
end; end;
@ -646,11 +646,11 @@ begin
inc(p,l); inc(p,l);
if Terminated then exit; if Terminated then exit;
until terminated or (rem<=0) ; until terminated or (rem<=0) ;
log('Receive buffer '+inttostr(len)); log(mtExtra,'Receive buffer '+inttostr(len));
result := true; result := true;
except on e:Exception do except on e:Exception do
begin begin
log('!!ERROR ReceiveBuffer '+e.message); log(mtError,'!!ERROR ReceiveBuffer '+e.message);
raise; raise;
end; end;
end; end;
@ -664,7 +664,7 @@ var
pos: integer; pos: integer;
begin begin
try try
log(format('SendHeader(%d) Code=%d, Param=%x, Command=%s',[packettype,Code,QP,SP])); log(mtExtra,format('SendHeader(%d) Code=%d, Param=%x, Command=%s',[packettype,Code,QP,SP]));
InitBuffer(sizeof(BYTE)*(Length(SP)+2)+16+2*sizeof(QWord)+sizeof(DWORD)*2,Buffer,pos); InitBuffer(sizeof(BYTE)*(Length(SP)+2)+16+2*sizeof(QWord)+sizeof(DWORD)*2,Buffer,pos);
AddToBuffer(packetType,Buffer,pos); AddToBuffer(packetType,Buffer,pos);
AddToBuffer(state,Buffer,pos); AddToBuffer(state,Buffer,pos);
@ -677,7 +677,7 @@ begin
except on e:Exception do except on e:Exception do
begin begin
log('!!ERROR SendHeader '+e.message); log(mtError,'!!ERROR SendHeader '+e.message);
raise; raise;
end; end;
end; end;
@ -703,12 +703,12 @@ begin
ReadFromBuffer(Code,Buffer,pos); ReadFromBuffer(Code,Buffer,pos);
ReadFromBuffer(QP,Buffer,pos); ReadFromBuffer(QP,Buffer,pos);
ReadFromBuffer(SP,Buffer,pos); ReadFromBuffer(SP,Buffer,pos);
log(format('ReceiveHeader(%d) Code=%d, Param=%x, Command=%s',[packettype,Code,QP,SP])); log(mtExtra,format('ReceiveHeader(%d) Code=%d, Param=%x, Command=%s',[packettype,Code,QP,SP]));
result := true; result := true;
except on e:Exception do except on e:Exception do
begin begin
log('!!ERROR ReceiveHeader '+e.message); log(mtError,'!!ERROR ReceiveHeader '+e.message);
raise; raise;
end; end;
end; end;
@ -837,7 +837,7 @@ var
len,i: integer; len,i: integer;
begin begin
try try
LogStrings(fOwner.flogger,self,'KEYS',Data); LogStrings(mtExtra,fOwner.flogger,self,'KEYS',Data);
len := 1+4+8*Data.Count; len := 1+4+8*Data.Count;
for i:=0 to Data.Count-1 do for i:=0 to Data.Count-1 do
inc(len,length(Data[i])); inc(len,length(Data[i]));
@ -891,7 +891,7 @@ begin
result := false; result := false;
if Terminated then exit; if Terminated then exit;
try try
log('ReceiveMessage'); log(mtExtra,'ReceiveMessage');
if not ReceiveHeader(b,mode,Sender,rNum,CommandID,QParam,Value) then exit; if not ReceiveHeader(b,mode,Sender,rNum,CommandID,QParam,Value) then exit;
if Terminated then exit; if Terminated then exit;
case b of case b of
@ -901,7 +901,7 @@ begin
ReadFromBuffer(b,Buffer,pos); ReadFromBuffer(b,Buffer,pos);
if b<>1 then raise EFormatException.Create(''); if b<>1 then raise EFormatException.Create('');
ReadFromBuffer(Keys,Buffer,pos); ReadFromBuffer(Keys,Buffer,pos);
LogStrings(fOwner.flogger,self,'KEYS',Keys); LogStrings(mtExtra, fOwner.flogger,self,'KEYS',Keys);
end; end;
2: begin 2: begin
if not ReceiveBuffer(Buffer,len) then exit; if not ReceiveBuffer(Buffer,len) then exit;
@ -965,7 +965,7 @@ begin
except on e:Exception do except on e:Exception do
begin begin
log('!!ERROR ReceiveMessage '+e.message); log(mtError,'!!ERROR ReceiveMessage '+e.message);
raise; raise;
end; end;
end; end;
@ -982,7 +982,7 @@ begin
fOwner := AOwner; fOwner := AOwner;
CreateGuid(ID); CreateGuid(ID);
recNo := 0; recNo := 0;
log('Create'); log(mtExtra,'Create');
end; end;
destructor TConnectionThread.Destroy; destructor TConnectionThread.Destroy;
@ -1003,11 +1003,10 @@ var
Data: TStream; Data: TStream;
mode: byte; mode: byte;
begin begin
log('start thread'); log(mtExtra,'start thread');
while not terminated do while not terminated do
begin begin
if cache.ReadReady.WaitFor(1000)<>wrSignaled then begin sleep(10);continue;end; if cache.ReadReady.WaitFor(1000)<>wrSignaled then begin sleep(10);continue;end;
log('received');
if terminated then break; if terminated then break;
if not Socket.Connected then break; if not Socket.Connected then break;
Keys := nil; Keys := nil;
@ -1028,25 +1027,11 @@ end;
procedure TConnectionThread.TerminatedSet; procedure TConnectionThread.TerminatedSet;
begin begin
log('terminate required'); log(mtExtra,'terminate required');
Cache.Close; Cache.Close;
fOwner.removeClient(self); fOwner.removeClient(self);
end; end;
{ TClientThread }
const
HexChars='0123456789abcdef';
end. end.