LMS-2_ReportAPI/commandcol.pas

unit commandcol;

{$mode ObjFPC}{$H+}

interface

uses
  Classes, SysUtils,Contnrs, extTypes, cgiDM;
type
  { TCommand }

  TCommand=class
    protected
      fData,
      fResult: TCommandData;
    fCommandID: string;
    fStatus: integer;
    fcurrentStage: string;
    fProcessor: TNIDBDM;
    fisDone,fisFinished: boolean;
    fIsError: boolean;

    fSubClass: string;
    fUser: integer;
    fUserName: string;
    fLogger: TLogger;
    function getInt(keyName: string;defaultValue: integer=0): integer;
    function getString(keyName: string): string;
    public
      AccessTime: TDateTime;
      TimeOut: single;
      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 write fIsError;
      property isFinished: boolean read fIsFinished;
      property CurrentStage: string read fCurrentStage;
      property Processor: TNIDBDM read fProcessor;
      property UserID: integer read fUser;
      property UserName: string read fUserName;
      constructor Create(ID: string; aProcessor: TNIDBDM; ASubClass: string; aLogger:TLogger; AUser: string; IDUser: integer); virtual;
    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(ALevel:TLogLevel; 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;

implementation
{ TCommandCollection }

class procedure TCommandCollection.Register(ACommand: TCommandClass);
begin
  {if not assigned(fCollection) then
    Init;}
  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
  if not assigned(fCollection) then
    fCollection := TCommandCollection.Create;
end;

class procedure TCommandCollection.Done;
begin
  fCollection.Free;
end;
{ TCommand }

function TCommand.getInt(keyName: string; defaultValue: integer): integer;
begin
  result := StrToIntDef(fData.Keys.Values[keyName],defaultValue);
end;

function TCommand.getString(keyName: string): string;
begin
  result := fData.Keys.Values[KeyName];
end;

constructor TCommand.Create(ID: string; aProcessor: TNIDBDM; ASubClass: string;
  aLogger: TLogger; AUser: string; IDUser: integer);
begin
  fProcessor := AProcessor;
  fSubClass := ASubClass;
  fStatus:=StatusWaiting;
  fcurrentStage := 'в очереди';
  fUserName := AUser;
  fUser := IDUser;
  fLogger := ALogger;
  TimeOut:=1/24/4;
  fCommandID:=ID;
  fResult := nil;
  fData := nil;
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';
      if assigned(Results) then
        Results.Free;
      fResult := TCommandData.Create(ErrorInternal,0,e.ClassName,[e.Message],[],nil);
      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(ALevel: TLogLevel; msg: string);
begin
  if assigned(flogger) then
  fLogger(ALevel,self, self.CommandID+#09+msg)
end;

initialization
  TCommandCollection.Init;
finalization
  TCommandCollection.Done;

end.