423 lines
11 KiB
ObjectPascal
423 lines
11 KiB
ObjectPascal
unit baseconnection;
|
|
|
|
{$mode ObjFPC}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, extTypes, Contnrs, cgiDM,reportDMUnit;
|
|
type
|
|
{ TBaseConnection }
|
|
TBaseConnection=class;
|
|
|
|
{ TCommand }
|
|
|
|
TCommand=class
|
|
protected
|
|
fData,
|
|
fResult: TCommandData;
|
|
fCommandID: string;
|
|
fStatus: integer;
|
|
fcurrentStage: string;
|
|
fconnect: TBaseConnection;
|
|
TimeOut: single;
|
|
fisDone,fisFinished: boolean;
|
|
fIsError: boolean;
|
|
fSubClass: string;
|
|
public
|
|
AccessTime: TDateTime;
|
|
|
|
property Arguments: TCommandData read fData;
|
|
property Results: TCommandData read fResult;
|
|
property CommandID: string read fCommandID;
|
|
property Status: integer read fStatus;
|
|
property isDone: boolean read fIsDone;
|
|
property Error: boolean read fIsError;
|
|
property isFinished: boolean read fIsFinished;
|
|
property CurrentStage: string read fCurrentStage;
|
|
property Connect: TBaseConnection read fConnect;
|
|
constructor Create(aConnect: TBaseConnection; ASubClass: string);
|
|
destructor Destroy; override;
|
|
procedure doRun;
|
|
procedure Done;
|
|
function Run: boolean; virtual; abstract;
|
|
class function CommandName: string; virtual; abstract;
|
|
class function CommandSubClass: string; 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 ParseArguments(Args: TStrings; out Errors: TStrings): boolean; virtual; abstract;
|
|
procedure Log(msg: string);
|
|
function ProcessOptionValues(ParamName: string; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean; virtual; abstract;
|
|
end;
|
|
TCommandClass=class of TCommand;
|
|
|
|
{ TCommandCollection }
|
|
TCommandCollection=Class;
|
|
TCommandCollection=Class(TClassList)
|
|
private
|
|
class var fCollection: TCommandCollection;
|
|
public
|
|
class procedure Register(ACommand: TCommandClass);
|
|
class function Find(Action,SubClass: string): TCommandClass;
|
|
class procedure Init;
|
|
class procedure Done;
|
|
end;
|
|
|
|
TBaseConnection=class(TThread)
|
|
private
|
|
fOwner:TObject;
|
|
fLogger: TLogger;
|
|
fConnectionID: string;
|
|
fTimeout: integer;
|
|
fProcessor: TNIDBDM;
|
|
fReportProcessor: TReportDM;
|
|
Commands: TStrings;
|
|
DoneCommands: TList;
|
|
fCreated,
|
|
fCommandReceived,
|
|
fCommandCompleted: TDateTime;
|
|
nCommandComplete: integer;
|
|
nCommandReceived: integer;
|
|
nCommandReady: integer;
|
|
nErrors: integer;
|
|
|
|
procedure CleanDone;
|
|
public
|
|
Host: string;
|
|
port: integer;
|
|
DataBase: string;
|
|
User: string;
|
|
UserID: integer;
|
|
LastAccess: TDateTime;
|
|
procedure Log(sender: TObject; msg: string);
|
|
property Created: TDateTime read fCreated;
|
|
property LastReceive: TDateTime read fCommandReceived;
|
|
property LastComplete: TDateTime read fCommandCompleted;
|
|
property CountReceived: integer read nCommandReceived;
|
|
property CountCompleted: integer read nCommandComplete;
|
|
property CountReady: integer read nCommandReady;
|
|
property CountErrors: integer read nErrors;
|
|
property Owner: TObject read fOwner;
|
|
property ConnectionID: string read fConnectionID;
|
|
property Processor: TNIDBDM read fProcessor;
|
|
property ReportProcessor: TReportDM read fReportProcessor;
|
|
procedure Init;
|
|
constructor Create(AOwner: TObject;ATimeOut: integer; aLogger: TLogger);
|
|
destructor Destroy; override;
|
|
// CommandID,Param,ACommand,Fields,iParam.Data
|
|
function AddCommand(ACode: DWORD; iParam: QWORD; ACommandClass,ACommandName: string; Arguments: TStrings; intArgs: TParamArray; CmdData: TStream; out ID: string; out retCode:DWORD; out Errors: TStrings): boolean;
|
|
function RunCommand(ACommand: TCommand): boolean;
|
|
function FindCommand(IDCommand: string): TCommand;
|
|
procedure Idle;
|
|
procedure Execute; override;
|
|
function ProcessOptionValues(ReportName,ParamName: string; ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean;
|
|
class function newID: string;
|
|
end;
|
|
|
|
implementation
|
|
{ TBaseConnection }
|
|
|
|
procedure TBaseConnection.Init;
|
|
begin
|
|
Processor.connection.RemoteHost:=Host;
|
|
Processor.connection.RemotePort:=Port;
|
|
Processor.connection.Database:=DataBase;
|
|
Processor.OpenConnection;
|
|
end;
|
|
|
|
|
|
constructor TBaseConnection.Create(AOwner: TObject; ATimeOut: integer;
|
|
aLogger: TLogger);
|
|
begin
|
|
inherited Create(true);
|
|
fTimeout:=ATimeOut;
|
|
fOwner := AOwner;
|
|
flogger := ALogger;
|
|
fProcessor:=TNIDBDM.Create(nil);
|
|
fProcessor.logger:=aLogger;
|
|
fReportProcessor:=TReportDM.Create(nil);
|
|
fReportProcessor.NidbData := fProcessor;
|
|
Commands:=TStringList.Create;
|
|
DoneCommands:=TList.Create;
|
|
fCreated := now();
|
|
fCommandReceived := 0;
|
|
fCommandCompleted := 0;
|
|
nCommandComplete:=0;
|
|
nCommandReceived:=0;
|
|
nCommandReady:=0;
|
|
nErrors:=0;
|
|
fConnectionID:=newID;
|
|
|
|
end;
|
|
|
|
destructor TBaseConnection.Destroy;
|
|
begin
|
|
log(self,'Destroy');
|
|
Processor.Free;
|
|
Commands.Free;
|
|
DoneCommands.Free;
|
|
inherited;
|
|
end;
|
|
|
|
function TBaseConnection.AddCommand(ACode: DWORD; iParam: QWORD; ACommandClass,
|
|
ACommandName: string; Arguments: TStrings; intArgs: TParamArray;
|
|
CmdData: TStream; out ID: string; out retCode: DWORD; out Errors: TStrings
|
|
): boolean;
|
|
var
|
|
cc: TCommandClass;
|
|
cmd: TCommand;
|
|
begin
|
|
log(self,'AddCommand '+ACommandClass+ ' '+ACommandName);
|
|
fCommandReceived:=Now();
|
|
cc := TCommandCollection.Find(ACommandClass,ACommandName);
|
|
if assigned(cc) then
|
|
begin
|
|
cmd := cc.Create(self,ACommandName);
|
|
cmd.AccessTime:=NOW();
|
|
result := cmd.ParseCommand(ACode,iParam,ACommandName,Arguments,intArgs,CmdData, Errors);
|
|
if result then
|
|
begin
|
|
Commands.AddObject(ACommandName,cmd);
|
|
ID := cmd.CommandID;
|
|
retCode := Commands.Count;
|
|
end
|
|
else
|
|
begin
|
|
ID := 'неверные параметры запроса';
|
|
retCode := ErrorArguments;
|
|
inc(nErrors);
|
|
cmd.fIsError:=true;
|
|
cmd.Done;
|
|
DoneCommands.Add(cmd);
|
|
end;
|
|
inc(nCommandReceived);
|
|
|
|
|
|
|
|
end
|
|
else
|
|
inc(nErrors);
|
|
end;
|
|
|
|
function TBaseConnection.RunCommand(ACommand: TCommand): boolean;
|
|
begin
|
|
ACommand.doRun();
|
|
log(Self,'complete '+ACommand.CommandID);
|
|
fCommandCompleted:=Now();
|
|
inc(nCommandReady);
|
|
end;
|
|
|
|
function TBaseConnection.FindCommand(IDCommand: string): TCommand;
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to Commands.Count-1 do
|
|
if (Commands.Objects[i] as TCommand).CommandID=IDCommand then
|
|
begin
|
|
result := Commands.Objects[i] as TCommand;
|
|
result.AccessTime:=now();
|
|
exit;
|
|
end;
|
|
for i := DoneCommands.Count-1 downto 0 do
|
|
if TCommand(DoneCommands[i]).CommandID=IDCommand then
|
|
begin
|
|
result := TCommand(DoneCommands[i]);
|
|
result.AccessTime:=now();
|
|
exit;
|
|
end;
|
|
result := nil;
|
|
end;
|
|
|
|
procedure TBaseConnection.Idle;
|
|
var
|
|
d: TDateTime;
|
|
begin
|
|
d := Created;
|
|
if LastAccess>d then d := LastAccess;
|
|
if (now()-d)*24*60>fTimeout then
|
|
begin
|
|
log(self,'TIMEOUT');
|
|
terminate;
|
|
end
|
|
else
|
|
fProcessor.ExecuteSQL('SELECT 1');
|
|
end;
|
|
|
|
procedure TBaseConnection.CleanDone;
|
|
var
|
|
i: integer;
|
|
cmd: TCommand;
|
|
begin
|
|
for i := DoneCommands.Count-1 downto 0 do
|
|
begin
|
|
cmd := TCommand(DoneCommands[i]);
|
|
if cmd.isDone or (now()-cmd.AccessTime > cmd.TimeOut) then
|
|
begin
|
|
cmd.free;
|
|
DoneCommands.Delete(i);
|
|
Dec(nCommandReady);
|
|
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TBaseConnection.Log(sender: TObject; msg: string);
|
|
begin
|
|
if assigned(fLogger) then
|
|
flogger(sender,msg);
|
|
end;
|
|
|
|
procedure TBaseConnection.Execute;
|
|
var
|
|
cmd: TCommand;
|
|
begin
|
|
log(self,'started');
|
|
while not terminated do
|
|
begin
|
|
while Commands.Count>0 do
|
|
begin
|
|
cmd := Commands.Objects[0] as TCommand;
|
|
log(self,format('run(%s) %s %s ',[cmd.CommandID,cmd.CommandName, cmd.CommandSubClass]));
|
|
try
|
|
RunCommand(cmd);
|
|
finally
|
|
Commands.Delete(0);
|
|
DoneCommands.Add(cmd);
|
|
end;
|
|
end;
|
|
CleanDone;
|
|
sleep(100);
|
|
end;
|
|
log(self,'finished');
|
|
end;
|
|
|
|
function TBaseConnection.ProcessOptionValues(ReportName, ParamName: string;
|
|
ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out
|
|
OptionValues: TStrings): boolean;
|
|
var
|
|
c: TCommand;
|
|
tmp: TStrings;
|
|
begin
|
|
with TCommandCollection.Find('report',Reportname).Create(self,ReportName) do
|
|
try
|
|
ParseCommand(0,0,ReportName,ParamValues,[],nil,tmp);
|
|
if assigned(tmp) then FreeAndNil(tmp);
|
|
result := ProcessOptionValues(ParamName,answer,RetValue,OptionValues);
|
|
finally
|
|
free
|
|
end;
|
|
end;
|
|
|
|
class function TBaseConnection.newID: string;
|
|
var
|
|
g: TGUID;
|
|
i: integer;
|
|
begin
|
|
createguid(g);
|
|
result := inttohex(g.D1,8)+inttohex(g.D2,4)+inttohex(g.D3,4);
|
|
for i := 0 to 7 do
|
|
result := result + inttohex(g.D4[i],2);
|
|
end;
|
|
|
|
|
|
{ TCommandCollection }
|
|
|
|
class procedure TCommandCollection.Register(ACommand: TCommandClass);
|
|
begin
|
|
fCollection.Add(ACommand);
|
|
end;
|
|
|
|
class function TCommandCollection.Find(Action, SubClass: string): TCommandClass;
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to fCollection.Count-1 do
|
|
if fCollection.Items[i].InheritsFrom(TCommand) and SameText(Action, TCommandClass(fCollection.Items[i]).CommandName) and SameText(SubClass, TCommandClass(fCollection.Items[i]).CommandSubClass) then
|
|
begin
|
|
result := TCommandClass(fCollection.Items[i]) ;
|
|
exit;
|
|
end;
|
|
for i := 0 to fCollection.Count-1 do
|
|
if fCollection.Items[i].InheritsFrom(TCommand) and SameText(Action, TCommandClass(fCollection.Items[i]).CommandName) and SameText('', TCommandClass(fCollection.Items[i]).CommandSubClass) then
|
|
begin
|
|
result := TCommandClass(fCollection.Items[i]) ;
|
|
exit;
|
|
end;
|
|
result := nil;
|
|
end;
|
|
|
|
class procedure TCommandCollection.Init;
|
|
begin
|
|
fCollection := TCommandCollection.Create;
|
|
end;
|
|
|
|
class procedure TCommandCollection.Done;
|
|
begin
|
|
fCollection.Free;
|
|
end;
|
|
|
|
{ TCommand }
|
|
|
|
constructor TCommand.Create(aConnect: TBaseConnection; ASubClass: string);
|
|
begin
|
|
fconnect := AConnect;
|
|
fSubClass := ASubClass;
|
|
fStatus:=StatusWaiting;
|
|
fcurrentStage := 'в очереди';
|
|
TimeOut:=1/24/4;
|
|
fCommandID:=TBaseConnection.newID;
|
|
end;
|
|
|
|
destructor TCommand.Destroy;
|
|
begin
|
|
if assigned(fData) then fData.Free;
|
|
if assigned(fResult) then fResult.free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TCommand.doRun;
|
|
begin
|
|
fStatus:=StatusProcessing;
|
|
fcurrentStage := 'исполняется';
|
|
try
|
|
if Run then
|
|
begin
|
|
fStatus:=StatusComplete;
|
|
fcurrentStage := 'завершена';
|
|
end
|
|
else
|
|
begin
|
|
fStatus := StatusError;
|
|
fcurrentStage := 'завершена c ошибкой';
|
|
end;
|
|
|
|
except on e: Exception do
|
|
begin
|
|
fStatus:=StatusError;
|
|
fcurrentStage := 'error';
|
|
Results.Name:=e.Message;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TCommand.Done;
|
|
begin
|
|
fisDone:=true;
|
|
end;
|
|
|
|
function TCommand.ParseCommand(ACode: DWORD; iParam: QWORD; ACommand: string;
|
|
Args: TStrings; intArgs: TParamArray; CmdData: TStream; out Errors: TStrings
|
|
): boolean;
|
|
begin
|
|
self.fData := TCommandData.Create(ACode,iParam,ACommand,Args,intArgs,cmdData);
|
|
result := ParseArguments(fData.Keys,Errors);
|
|
end;
|
|
|
|
procedure TCommand.Log(msg: string);
|
|
begin
|
|
connect.log(self, self.CommandID+#09+msg)
|
|
end;
|
|
|
|
end.
|
|
|