Первая версия

.gitignore

@@ -26,7 +26,7 @@
 backup/
 *.bak
 lib/
-
+out/
 # Application bundle for Mac OS
 *.app/
 

baseconnection.pas

@@ -0,0 +1,422 @@
+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.
+

cgi_daemon.lfm

@@ -0,0 +1,8 @@
+object LMSReportCGI: TLMSReportCGI
+  OldCreateOrder = False
+  OnStart = DataModuleStart
+  Height = 150
+  HorizontalOffset = 840
+  VerticalOffset = 384
+  Width = 445
+end

cgi_daemon.pas

@@ -0,0 +1,67 @@
+unit cgi_daemon;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, DaemonApp;
+
+type
+  TLMSReportCGI=class;
+  { TDaemonThread }
+
+  TDaemonThread=class(TThread)
+    fOwner: TLMSReportCGI;
+    procedure Execute;override;
+    constructor Create(AOwner: TLMSReportCGI);
+  end;
+
+  { TLMSReportCGI }
+
+  TLMSReportCGI = class(TDaemon)
+    procedure DataModuleStart(Sender: TCustomDaemon; var OK: Boolean);
+  private
+    workThread: TDaemonThread;
+  public
+
+  end;
+
+var
+  LMSReportCGI: TLMSReportCGI;
+
+implementation
+
+procedure RegisterDaemon;
+begin
+  RegisterDaemonClass(TLMSReportCGI)
+end;
+
+{$R *.lfm}
+
+{ TLMSReportCGI }
+
+procedure TLMSReportCGI.DataModuleStart(Sender: TCustomDaemon; var OK: Boolean);
+begin
+  workThread := TDaemonThread(self);
+  workThread.Start;
+end;
+
+{ TDaemonThread }
+
+procedure TDaemonThread.Execute;
+begin
+
+end;
+
+constructor TDaemonThread.Create(AOwner: TLMSReportCGI);
+begin
+  inherited Create(true);
+  fOwner:=AOwner;
+end;
+
+
+initialization
+  RegisterDaemon;
+end.
+

cgi_mapper.lfm

@@ -0,0 +1,20 @@
+object DaemonMapper1: TDaemonMapper1
+  DaemonDefs = <  
+    item
+      DaemonClassName = 'TLMSReportCGI'
+      Name = 'lmsRepCGI'
+      Description = 'Служба создания отчетовв LMS 2'
+      DisplayName = 'LMS2 (отчеты)'
+      Options = [doAllowStop, doAllowPause]
+      WinBindings.Dependencies = <>
+      WinBindings.StartType = stBoot
+      WinBindings.WaitHint = 0
+      WinBindings.IDTag = 0
+      WinBindings.ServiceType = stWin32
+      WinBindings.ErrorSeverity = esIgnore
+      WinBindings.AcceptedCodes = []
+      LogStatusReport = False
+    end>
+  Left = 1065
+  Top = 332
+end

cgi_mapper.pas

@@ -0,0 +1,34 @@
+unit cgi_mapper;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, DaemonApp;
+
+type
+  TDaemonMapper1 = class(TDaemonMapper)
+  private
+
+  public
+
+  end;
+
+var
+  DaemonMapper1: TDaemonMapper1;
+
+implementation
+
+procedure RegisterMapper;
+begin
+  RegisterDaemonMapper(TDaemonMapper1)
+end;
+
+{$R *.lfm}
+
+
+initialization
+  RegisterMapper;
+end.
+

cgicommand.pas

@@ -0,0 +1,13 @@
+unit cgiCommand;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils;
+
+implementation
+
+end.
+

cgidm.lfm

@@ -0,0 +1,38 @@
+object NIDBDM: TNIDBDM
+  OnCreate = DataModuleCreate
+  OnDestroy = DataModuleDestroy
+  OldCreateOrder = False
+  Height = 150
+  HorizontalOffset = 417
+  VerticalOffset = 131
+  Width = 150
+  object nnzQuery1: TnnzQuery
+    FieldDefs = <>
+    ReadOnly = True
+    FilterOptions = []
+    Left = 25
+    Top = 36
+  end
+  object frxReport1: TfrxReport
+    Version = '2023.1'
+    DotMatrixReport = False
+    IniFile = '\Software\Fast Reports'
+    PreviewOptions.Buttons = [pbPrint, pbLoad, pbSave, pbExport, pbZoom, pbFind, pbOutline, pbPageSetup, pbTools, pbEdit, pbNavigator, pbExportQuick, pbCopy, pbSelection]
+    PreviewOptions.Zoom = 1
+    PrintOptions.Printer = 'Default'
+    PrintOptions.PrintOnSheet = 0
+    ReportOptions.CreateDate = 45099.7272582292
+    ReportOptions.LastChange = 45099.7272582292
+    ScriptLanguage = 'PascalScript'
+    ScriptText.Strings = (
+      'begin'
+      ''
+      'end.'
+    )
+    Left = 64
+    Top = 92
+    Datasets = <>
+    Variables = <>
+    Style = <>
+  end
+end

cgidm.pas

@@ -0,0 +1,363 @@
+unit cgiDM;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, nnz_data_components, frxClass, nnzDBClient,DB,extTypes;
+
+type
+
+  { TNIDBDM }
+
+  TNIDBDM = class(TDataModule)
+    frxReport1: TfrxReport;
+    nnzQuery1: TnnzQuery;
+    procedure DataModuleCreate(Sender: TObject);
+    procedure DataModuleDestroy(Sender: TObject);
+  private
+    fcon: TnnzConnection;
+    fMid: integer;
+    fLogin: string;
+    fID: TGUID;
+    fLastConnectTime: TDateTime;
+    flogger: TLogger;
+    class function DeleteLastChar(const St: String; const CharCount: integer=1): String;
+  public
+    class function FloatAsSQL(Value: Double): String;
+    class function PeriodAsSQL(BegDate, EndDate: TDateTime): string;
+    class function DateAsSQL(Date: TDateTime): String;
+    class function DateTimeAsSQL(Stamp: TDateTime): String;
+    class function CurrencyAsSQL(Value: Currency): string;
+    class function VariantAsSQL(const Value: Variant): String;
+    class function BooleanAsSQL(Value: Boolean): String;
+    class function StringAsSQL(const St: String): String;
+    class function StringAsJSON(const St: String): String;
+    class function StreamAsSQL(s: TStream): String;
+    class function BytesAsSQL(const data: array of byte; dataSize: integer): string;
+    class function IntArrayAsSQL(const data: array of integer): string;
+    class procedure UpdateWithArguments(var code: string; const Arguments: TStrings);
+    property logger: TLogger read flogger write flogger;
+    property connection: TnnzConnection read fCon;
+    function QueryValue(ASQL: string; Default: string=''): string;
+    function QueryIntValue(ASQL: string): integer;
+    function GetData(ASQL: string): TDataSet;
+    function CheckUser(const login,password: string; out UserID: integer): boolean;
+    procedure OpenConnection;
+    procedure log(Sender: TObject; msg: string);
+    procedure LogError(Sender: TObject; e: Exception; msg: string);
+    procedure ExecuteSQL(ASQL: string);
+  end;
+
+var
+  NIDBDM: TNIDBDM;
+
+implementation
+uses
+  variants,LazUTF8;
+{$R *.lfm}
+
+{ TNIDBDM }
+
+procedure TNIDBDM.DataModuleCreate(Sender: TObject);
+begin
+  log(self,'connecting');
+  fcon := TnnzConnection.Create(self);
+
+
+end;
+
+procedure TNIDBDM.DataModuleDestroy(Sender: TObject);
+begin
+  log(sender,'destroy');
+  fcon.Connected:=false;
+  fcon.free;
+end;
+
+class function TNIDBDM.DeleteLastChar(const St: String;
+  const CharCount: integer): String;
+begin
+  Result := utf8Copy(St, 1, utf8Length(St) - CharCount);
+end;
+
+class function TNIDBDM.FloatAsSQL(Value: Double): String;
+var
+  fs: TFormatSettings;
+begin
+  fs.DecimalSeparator := '.';
+  Result := FloatToStr(Value, fs);
+end;
+
+
+class function TNIDBDM.PeriodAsSQL(BegDate, EndDate: TDateTime): string;
+begin
+  if (BegDate <= 2) and (EndDate <= 2) then
+    Result := '>=''1900-01-01'''
+  else
+    Result := 'BETWEEN ' + DateAsSQL(BegDate) + ' AND ' + DateAsSQL(EndDate);
+end;
+
+
+class function TNIDBDM.DateAsSQL(Date: TDateTime): String;
+begin
+  if FormatSettings.ShortMonthNames[1] <> 'JAN' then
+  begin
+    FormatSettings.ShortMonthNames[1] := 'JAN';
+    // без этого дурит MSSQL7/MSSQL2000, который не понимает
+    FormatSettings.ShortMonthNames[2] := 'FEB'; // дату в формате '13 окт 1999'
+    FormatSettings.ShortMonthNames[3] := 'MAR';
+    FormatSettings.ShortMonthNames[4] := 'APR';
+    FormatSettings.ShortMonthNames[5] := 'MAY';
+    FormatSettings.ShortMonthNames[6] := 'JUN';
+    FormatSettings.ShortMonthNames[7] := 'JUL';
+    FormatSettings.ShortMonthNames[8] := 'AUG';
+    FormatSettings.ShortMonthNames[9] := 'SEP';
+    FormatSettings.ShortMonthNames[10] := 'OCT';
+    FormatSettings.ShortMonthNames[11] := 'NOV';
+    FormatSettings.ShortMonthNames[12] := 'DEC';
+  end;
+  if Date < 2 then
+    Date := 2; // приводим к 1 января 1900 - это ноль для SMALLDATETIME
+  Result := QuotedStr(FormatDateTime('yyyy-mm-dd', Date));
+end;
+class function TNIDBDM.DateTimeAsSQL(Stamp: TDateTime): String;
+begin
+    // Result := FloatToStr(Real(Stamp) - 2); старый вариант - ldm
+  Result := '';
+  DateTimeToString(Result, 'hh:nn:ss', Stamp);
+  Result := DeleteLastChar(DateAsSQL(Stamp)) + ' ' + Result + '''';
+end;
+
+class function TNIDBDM.CurrencyAsSQL(Value: Currency): string;
+begin
+  Result := StringAsSQL(CurrToStr(Value));
+end;
+
+class function TNIDBDM.VariantAsSQL(const Value: Variant): String;
+var
+  Stream: TStringStream;
+begin
+  case VarType(Value) of
+    varNull:
+      Result := 'NULL';
+    varEmpty:
+      Result := 'NULL';
+    varSmallInt, varInteger, varShortInt, varByte, varWord, varLongWord,
+      varInt64, varUInt64:
+      Result := VarToStr(Value);
+    varSingle, varCurrency:
+      Result := CurrencyAsSQL(Value);
+    varDouble:
+      Result := FloatAsSQL(Value);
+    varDate:
+      Result := DateAsSQL(Value);
+    varOleStr:
+      begin
+        Stream := TStringStream.Create(Value);
+        try
+          Result := StreamAsSQL(Stream);
+        finally
+          Stream.Free;
+        end;
+      end;
+    varBoolean:
+      Result := BooleanAsSQL(Value);
+    varString, varUString:
+      Result := StringAsSQL(Value);
+  else
+    raise Exception.Create('VariantAsSQL: Неверный тип ' + VarToStr(Value));
+  end;
+end;
+
+class function TNIDBDM.BooleanAsSQL(Value: Boolean): String;
+begin
+  if value then result := 'true' else result := 'false';
+end;
+
+
+class function TNIDBDM.StreamAsSQL(s: TStream): String;
+var
+  i: Integer;
+  b: Byte;
+begin
+  result := 'null';
+  if s.size=0 then exit;
+  //Result := '0x'; //MySQL
+  Result := 'E''\\x';  //PostgreSQL
+  s.Position := 0;
+  for i := 1 to s.Size do
+  begin
+    s.Read(b, 1);
+    Result := Result + IntToHex(b, 2);
+  end;
+  result := result +'''';
+end;
+
+class function TNIDBDM.BytesAsSQL(const data: array of byte;
+  dataSize: integer): string;
+var
+  i: integer;
+  b: byte;
+begin
+  result := 'null';
+  if datasize=0 then exit;
+  Result := 'E''\\x';  //PostgreSQL
+  for i := 0 to dataSize-1 do
+    begin
+      b := data[i];
+      Result := Result + IntToHex(b, 2);
+    end;
+  result := result +'''';
+end;
+
+
+class function TNIDBDM.IntArrayAsSQL(const data: array of integer): string;
+var
+  i: integer;
+begin
+  if length(data)=0 then
+    result := 'ARRAY[]::integer[]'
+  else
+    begin
+      result := inttostr(data[low(data)]);
+      for i := low(data)+1 to high(data) do
+        result := result +','+inttostr(data[i]);
+      result := format('ARRAY[%s]::integer[]',[result]);
+    end;
+end;
+
+class procedure TNIDBDM.UpdateWithArguments(var code: string;
+  const Arguments: TStrings);
+var
+  i: integer;
+  s,v: string;
+begin
+  for i := 0 to Arguments.Count-1 do
+    begin
+      s := Arguments.Names[i];
+      v := Arguments.Values[s];
+      Code := StringReplace(Code,'{s#'+s+'}',  TNidbDM.StringAsSQL(v),[rfReplaceAll]);
+      Code := StringReplace(Code,'{d#'+s+'}',TNidbDM.StringAsSQL(v),[rfReplaceAll]);
+      Code := StringReplace(Code,'{#'+s+'}',v,[rfReplaceAll]);
+    end;
+end;
+
+
+
+
+class function TNIDBDM.StringAsSQL(const St: String): String;
+var
+  len,i: Cardinal;
+  c: Char;
+  hasSpecial: boolean;
+begin
+//  Result := QuotedStr(StringReplace(St, '\', '\\',
+//    [rfReplaceAll, rfIgnoreCase]));
+  Result:='';
+  len:=Length(St);
+  hasSpecial := false;
+  for i:=1 to len do begin
+    c:=St[i];
+    hasSpecial := hasSpecial or (c in [#0,'''','"','\',#8,#10,#13,#9,#26]);
+    case(c) of
+      #0:  Result:=Result+'\0';
+      '''','"','\':  Result:=Result+'\'+c;
+      #8:   Result:=Result+'\b';
+      #10:  Result:=Result+'\n';
+      #13:  Result:=Result+'\r';
+      #9:   Result:=Result+'\t';
+      #26:  Result:=Result+'\Z';
+    else
+      Result:=Result+c;
+    end;
+  end;
+  Result:=''''+Result+'''';
+  if hasSpecial  then Result :='E'+Result;
+
+end;
+
+class function TNIDBDM.StringAsJSON(const St: String): String;
+begin
+  result := st;
+  result := UTF8StringReplace(result,'\','\\',[rfReplaceAll]);
+  result := UTF8StringReplace(result,'"','\"',[rfReplaceAll]);
+end;
+
+
+function TNIDBDM.QueryValue(ASQL: string; Default: string): string;
+begin
+  log(self,'QueryValue'#13#10+ASQL);
+  with TnnzQuery.Create(self) do
+    try
+      Connection := fcon;
+      SQL.Text:=ASQL;
+      Open;
+      if not eof and not Fields[0].IsNull then result := Fields[0].AsString else result := Default;
+    finally
+      free;
+    end;
+end;
+
+function TNIDBDM.QueryIntValue(ASQL: string): integer;
+begin
+  log(self,'QueryIntValue'#13#10+ASQL);
+  with TnnzQuery.Create(self) do
+    try
+      Connection := fcon;
+      SQL.Text:=ASQL;
+      Open;
+      if not eof then result := Fields[0].AsInteger else result := 0;
+    finally
+      free;
+    end;
+end;
+
+
+function TNIDBDM.GetData(ASQL: string): TDataSet;
+begin
+  log(self,'getData '#13#10+ASQL);
+  result := TnnzQuery.Create(self);
+  with result as TnnzQuery do
+    begin
+      Connection := fcon;
+      SQL.Text:=ASQL;
+      Open;
+
+    end;
+end;
+
+function TNIDBDM.CheckUser(const login, password: string; out UserID: integer
+  ): boolean;
+begin
+  log(self,'CheckUser');
+  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;
+end;
+
+procedure TNIDBDM.OpenConnection;
+begin
+  log(self,'OpenConnection');
+  fcon.Connected:=true;
+  fcon.Identify;
+end;
+
+procedure TNIDBDM.log(Sender: TObject; msg: string);
+begin
+  if assigned(flogger) then
+    flogger(Sender,msg);
+end;
+
+procedure TNIDBDM.LogError(Sender: TObject; e: Exception; msg: string);
+begin
+  log(Sender,'!!ERROT at '+msg+#13#10+e.ClassName+#13#10+e.message);
+end;
+
+procedure TNIDBDM.ExecuteSQL(ASQL: string);
+begin
+  log(self,'ExecuteSQL '+ASQL);
+  connection.ExecuteSQL(ASQL);
+end;
+
+end.
+

cgireport.pas

@@ -0,0 +1,329 @@
+unit cgiReport;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils,  baseconnection;
+type
+  { TReportCommand }
+
+  TReportCommand=class(TCommand)
+    private
+    procedure CreateVariablesTable;
+    procedure UpdateCodeWithArguments(var code: string);
+    procedure SetStage(Sender:TObject; stageName: string);
+    public
+    ReportID: integer;
+    ReportName: string;
+    ReportTitle: string;
+    ReportCode: string;
+    Varcode: string;
+    class function CommandName: string; override;
+    class function CommandSubClass: string; override;
+    procedure Prepare; virtual;
+    procedure PrepareVars; virtual;
+    procedure FillVars;
+    function Run: boolean; override;
+    function ParseArguments(Args: TStrings; out Errors: TStrings): boolean; override;
+    function ProcessOptionValues(ParamName: string;  out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean; override;
+  end;
+
+implementation
+uses
+  cgiDM,extTypes,reportDMUnit, types, strutils, LazUTF8;
+{ TReportCommand }
+
+procedure TReportCommand.CreateVariablesTable;
+begin
+  connect.Processor.ExecuteSQL(
+    'drop table if exists tmp_report_variables; '+
+    'create temporary table tmp_report_variables ( '+
+    'name character varying,'+
+    'value_string character varying, '+
+    'value_int integer, '+
+    'var_type integer '+
+    '); '
+  );
+end;
+
+procedure TReportCommand.UpdateCodeWithArguments(var code: string);
+begin
+  TNIDBDM.UpdateWithArguments(code,Arguments.Keys);
+  Code := StringReplace(Code,'{#user}',inttostr(self.Connect.UserID),[rfReplaceAll]);
+end;
+
+procedure TReportCommand.SetStage(Sender: TObject; stageName: string);
+begin
+  fcurrentStage:=format('выполняется (%s)',[stageName]);
+end;
+
+class function TReportCommand.CommandName: string;
+begin
+  result := 'report';
+end;
+
+class function TReportCommand.CommandSubClass: string;
+begin
+  result := '';
+end;
+
+procedure TReportCommand.Prepare;
+var
+  ASQL: string;
+  v: string;
+  d: TStringDynArray;
+  i: integer;
+begin
+  ReportCode := connect.Processor.QueryValue(format('select report_routine from xp_report_cgi where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)]));
+  UpdateCodeWithArguments(ReportCode);
+  if reportcode<>'' then
+    connect.Processor.ExecuteSQL(format('select %s;',[ReportCode]));
+  ASQL := format( 'select array_to_string(extra_routines,'';'') as v from  xp_report_cgi where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)]);
+  v := connect.Processor.QueryValue(ASQL);
+  if v>'' then
+    begin
+      d := SplitString(v,';');
+      for i := low(d) to high(d) do
+        begin
+          v := d[i];
+          UpdateCodeWithArguments(v);
+          if v<>'' then
+            connect.Processor.ExecuteSQL(v);
+        end;
+    end;
+end;
+
+procedure TReportCommand.PrepareVars;
+begin
+  VarCode := connect.Processor.QueryValue(format('select report_routine_vars from xp_report_cgi where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)]));
+  UpdateCodeWithArguments(VarCode);
+  if VarCode<>'' then
+    connect.Processor.ExecuteSQL(format('select %s;',[VarCode]));
+end;
+
+procedure TReportCommand.FillVars;
+var
+  ASQL: string;
+  q: string;
+  script: string;
+  vs: string;
+  vi: integer;
+begin
+  log('FillVars');
+  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]);
+  with connect.Processor.GetData(ASQL) do
+    try
+      while not eof do
+        begin
+          log(FieldByName('name').asString);
+          q := FieldByName('query').AsString;
+          UpdateCodeWithArguments(q);
+          try
+          vs := connect.Processor.QueryValue(q);
+
+          except
+            vs := '';
+          end;
+          script := script + format(#13#10'insert into tmp_report_variables(name,value_string,var_type) values (%s,%s,0); ',
+            [TNIDBDM.StringAsSQL(fieldByName('name').asString),TNidbDM.StringAsSQL(vs)]);
+          Next;
+        end;
+    finally
+      free;
+    end;
+  ASQL := format('select name,query from xp_report_variables where xp_rpt_id=%d and var_type=1',[ReportID]);
+  with connect.Processor.GetData(ASQL) do
+    try
+      while not eof do
+        begin
+          log(FieldByName('name').asString);
+          q := FieldByName('query').AsString;
+          UpdateCodeWithArguments(q);
+          try
+          vi := connect.Processor.QueryIntValue(q);
+
+          except
+            vi := 0;
+          end;
+          script := script + format('insert into tmp_report_variables(name,value_int,var_type) values (%s,%d,1); '#13#10,
+            [TNIDBDM.StringAsSQL(fieldByName('name').asString),vi]);
+          Next;
+        end;
+    finally
+      free;
+    end;
+  if script<>'' then
+      connect.Processor.ExecuteSQL(script);
+end;
+
+function TReportCommand.Run: boolean;
+var
+  i: integer;
+  s: string;
+  fileData: TStream;
+begin
+  result := false;
+  fcurrentStage := 'исполняется (инициализация)';
+  fileData := TMemoryStream.Create;
+  try
+  ReportID  := connect.Processor.QueryIntValue(format('select xp_rpt_id from xp_report_cgi where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)]));
+  if ReportID<=0 then
+    begin
+      fResult := TCommandData.Create(ErrorArguments,0,'Отчет не найден',nil,[],nil);
+      exit;
+    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)]));
+  CreateVariablesTable;
+    log(ReportTitle);
+  connect.ReportProcessor.RecordID:=ReportID;
+  fcurrentStage := 'исполняется (подготовка)';
+  try
+  Prepare;
+  except on e: Exception do
+    begin
+      connect.Processor.LogError(self,e,'prepare');
+      fResult := TCommandData.Create(ErrorInternal,0,'Ошибка составления',nil,[],nil);
+      exit;
+    end;
+  end;
+  fcurrentStage := 'исполняется (настройка)';
+  try
+  FillVars;
+  PrepareVars;
+  except on e: Exception do
+    begin
+      connect.Processor.LogError(self,e,'vars');
+      fResult := TCommandData.Create(ErrorInternal,0,'Ошибка составления',nil,[],nil);
+      exit;
+    end;
+  end;
+  fcurrentStage := 'исполняется ()';
+  try
+  connect.ReportProcessor.ExportReport(ftPDF,fileData,@SetStage);
+  except on e: Exception do
+    begin
+      connect.Processor.LogError(self,e,'ExportReport');
+      fResult := TCommandData.Create(ErrorInternal,0,'Ошибка составления',nil,[],nil);
+      exit;
+    end;
+  end;
+  fResult := TCommandData.Create(0,fileData.size,ReportTitle+'.pdf',nil,[],fileData);
+  fileData.Seek(0,soFromBeginning);
+  result := true;
+  finally
+    fileData.Free;
+  end;
+end;
+
+function TReportCommand.ParseArguments(Args: TStrings; out Errors: TStrings
+  ): boolean;
+var
+  asql: string;
+  ids: string;
+  i: integer;
+begin
+  result := false;
+  ids := '';
+  for i := 0 to Arguments.Keys.Count-1 do
+    if ids='' then
+      ids := TNIDBDM.StringAsSQL(Arguments.Keys.Names[i])
+    else
+      ids := ids + ','+ TNIDBDM.StringAsSQL(Arguments.Keys.Names[i]);
+  ReportName := Arguments.Keys.Values['name'];
+
+  asql := format(
+    'select p.name from xp_report_cgi c '+
+    'join xp_report_params p on p.xp_rpt_id=c.xp_rpt_id and  coalesce(p.required,true) '+
+    'where c.cgi_name=%s and p.name not in (%s) '+
+    'order by fill_order,p.name ',
+    [TNIDBDM.StringAsSQL(ReportName),TNIDBDM.StringAsSQL(ids)]);
+  with Connect.Processor.GetData(asql) do
+    try
+      if not eof then
+        begin
+         Errors := TStringList.Create;
+         while not eof do
+           begin
+             Errors.add(format('"%s"',[TNIDBDM.StringAsJSON(FieldByName('name').AsString)]));
+             next;
+           end;
+        end
+      else
+        result := true;
+    finally
+      free;
+    end;
+
+end;
+
+function TReportCommand.ProcessOptionValues(ParamName: string; out
+  Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean;
+var
+  ASQL: string;
+  code,s,k,v: string;
+  i,p: integer;
+  d: TStringDynArray;
+begin
+  result := false;
+  ASQL := format(
+    'select  source from xp_report_params p '+
+    ' join xp_report_cgi c on c.xp_rpt_id=p.xp_rpt_id '+
+    'where c.cgi_name=%s and p.name=%s and p.type in (0,1,2,17) ',
+    [TNIDBDM.StringAsSQL(fSubClass), TNIDBDM.StringAsSQL(ParamName)]);
+  code := connect.Processor.QueryValue(ASQL);
+  if code='' then exit;
+  if code[1]='(' then
+    begin
+      OptionValues := TStringList.Create;
+      code := copy(code,2,length(code)-2);
+      d := splitstring(code,',');
+      for i := low(d) to high(d) do
+        begin
+          s:= d[i];
+          p:=pos(':',s);
+          if p>1 then
+            begin
+              k := copy(s,1,p-1);
+              v := copy(s,p+1,length(s));
+              OptionValues.add(format('{"id":"%s","value":"%s"}',[TNIDBDM.StringAsJSON(k),TNIDBDM.StringAsJSON(v)]));
+            end
+          else
+            OptionValues.add(format('"%s"',[TNIDBDM.StringAsJSON(s)]));
+        end;
+    end
+  else
+  begin
+  UpdateCodeWithArguments(code);
+  if pos('{',code)>0 then
+    begin
+      result := false;
+      Answer := 'недостаточно данных';
+      exit;
+    end;
+  ASQL := code;
+  OptionValues := TStringList.Create;
+  if ASQL<>'' then
+    with connect.Processor.GetData(ASQL) do
+      try
+        while not eof do
+          begin
+            OptionValues.Add(format('{"id":"%d","value":"%s"}',
+              [Fields[0].AsInteger, TNIDBDM.StringAsJSON(Fields[1].AsString)]));
+            next;
+          end;
+      finally
+        free;
+      end;
+
+  end;
+  result := true;
+end;
+
+
+Initialization
+  TCommandCollection.Register(TReportCommand);
+end.
+

connectionsdmunit.lfm

@@ -0,0 +1,32 @@
+object ConnectionsDM: TConnectionsDM
+  OnCreate = DataModuleCreate
+  OnDestroy = DataModuleDestroy
+  OldCreateOrder = False
+  Height = 150
+  HorizontalOffset = 677
+  VerticalOffset = 301
+  Width = 533
+  object Process1: TProcess
+    Active = False
+    Options = []
+    Priority = ppNormal
+    StartupOptions = []
+    ShowWindow = swoNone
+    WindowColumns = 0
+    WindowHeight = 0
+    WindowLeft = 0
+    WindowRows = 0
+    WindowTop = 0
+    WindowWidth = 0
+    FillAttribute = 0
+    Left = 63
+    Top = 37
+  end
+  object Hash: TDCP_sha1
+    Id = 2
+    Algorithm = 'SHA1'
+    HashSize = 160
+    Left = 240
+    Top = 60
+  end
+end

connectionsdmunit.pas

@@ -0,0 +1,538 @@
+unit ConnectionsDmUnit;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, Contnrs, SysUtils, types, process, cgiDM, reportDMUnit, LNet,
+  lnetbase,tcpserver, tcpthreadhelper, DCPsha1, extTypes,syncobjs, baseconnection;
+
+type
+
+  { TCommand }
+
+
+
+
+
+  { TConnectionsDM }
+
+  TConnectionsDM = class(TDataModule)
+    Hash: TDCP_sha1;
+    Process1: TProcess;
+    procedure DataModuleCreate(Sender: TObject);
+    procedure DataModuleDestroy(Sender: TObject);
+  private
+    fLogFolder: string;
+    MainCon: TNIDBDM;
+    conlist: TList;
+    Input: TServerMainThread;
+    fDataHost: string;
+    fDataPort: integer;
+    fDataBase: string;
+    fServicePort: integer;
+
+    fTimeOut: integer;
+    LogLock: TCriticalSection;
+    fRunning: boolean;
+     function getConnection(ID: string): TBaseConnection;
+    function NewConnection: TBaseConnection;
+    procedure Remove(ID: string);
+    procedure ClearConnections;
+    procedure ClearTerminated;
+    procedure ConnectNew(aSocket: TLSocket);
+    function ProcessLogin(UserName,UserPassword: string; out UserID: integer):boolean;
+    function ProcessArguments(ReportName: string; out RetValue: QWORD;out ReportTitle: string; out rValues: TStrings): boolean;
+    function ProcessReports(out rValues: TStrings): boolean;
+    function ProcessOptionValues(ReportName,ParamName: string; ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean;
+    procedure LoadConfig;
+  public
+    property DataHost: string read fDataHost;
+    property DataPort: integer read fDataPort;
+    property DataBase: string read fDataBase;
+    procedure Log(Sender: TObject; msg: string);
+    procedure Start;
+    procedure Idle(Sender: TObject);
+    property Running: boolean read fRunning;
+    function ProcessRequest(Sender: TMainThread;
+      const CommandID:DWORD; const Param:QWord; const ACommand: string; const Fields: TStrings; const iParams: TParamArray;  const Data: TStream;
+      out Code: DWORD; out RetValue: QWord; out Answer: string; out rValues: TStrings; out iValues: TParamArray; out ByteData: TStream ): boolean;
+
+  end;
+
+var
+  ConnectionsDM: TConnectionsDM;
+
+implementation
+uses
+  xpUtilUnit, strutils, xpAccessUnit, inifiles;
+{$R *.lfm}
+
+
+
+
+{ TConnectionsDM }
+
+procedure TConnectionsDM.DataModuleCreate(Sender: TObject);
+begin
+  MainCon := TNIDBDM.Create(nil);
+  MainCon.logger:=@log;
+  LogLock := TCriticalSection.Create;
+  conList := TList.Create;
+  LoadConfig;
+  fRunning := false;
+  input := TServerMainThread.Create(@log,fServicePort,@ProcessRequest);
+end;
+
+procedure TConnectionsDM.DataModuleDestroy(Sender: TObject);
+begin
+  log(Sender,'Destroy');
+  ClearConnections;
+
+  if fRunning then
+    begin
+      Input.Terminate;
+      Input.WaitFor;
+    end;
+  Input.Free;
+  MainCon.Free;
+  LogLock.Free;
+  conList.Free;
+
+end;
+
+function TConnectionsDM.getConnection(ID: string): TBaseConnection;
+var
+  i: integer;
+begin
+  for i := 0 to conList.Count-1 do
+    if TBaseConnection(conlist[i]).ConnectionID=ID then
+      begin
+        result := TBaseConnection(conlist[i]);
+        result.LastAccess := NOW();
+        exit;
+      end;
+  result := nil;
+end;
+
+function TConnectionsDM.NewConnection: TBaseConnection;
+var
+  g: TGUID;
+  s: string;
+  i: integer;
+begin
+  result := TBaseConnection.Create(self,fTimeOut,@Log);
+  conlist.add(result);
+  result.Host:=DataHost;
+  result.port:=DataPort;
+  result.DataBase:=DataBase;
+  log(self, 'New '+result.ConnectionID);
+  result.Init;
+
+end;
+
+procedure TConnectionsDM.Remove(ID: string);
+var
+  i: integer;
+begin
+
+  for i := conList.Count-1 downto 0 do
+    if TBaseConnection(conlist[i]).ConnectionID=ID then
+      begin
+        log(self,'terminate '+ID);
+        TBaseConnection(conlist[i]).terminate;
+        exit;
+      end;
+end;
+
+
+procedure TConnectionsDM.ClearConnections;
+var
+  i: integer;
+  con: TBaseConnection;
+begin
+  log(self,'ClearConnections');
+  for i := 0 to conList.Count-1 do
+    begin
+      con := TBaseConnection(conlist[i]);
+      con.terminate;
+      con.WaitFor;
+      con.Free;
+    end;
+  conList.Clear;
+end;
+
+procedure TConnectionsDM.ClearTerminated;
+var
+  i: integer;
+  con: TBaseConnection;
+begin
+  for i := conlist.Count-1 downto 0 do
+    begin
+      con := TBaseConnection(conlist[i]);
+      if con.Finished then
+        begin
+          log(self,'Destroy terminated '+con.ConnectionID);
+          con.free;
+          conlist.delete(i);
+        end;
+    end;
+end;
+
+procedure TConnectionsDM.ConnectNew(aSocket: TLSocket);
+begin
+//  aSocket
+end;
+
+function TConnectionsDM.ProcessRequest(Sender: TMainThread;
+  const CommandID: DWORD; const Param: QWord; const ACommand: string;
+  const Fields: TStrings; const iParams: TParamArray; const Data: TStream; out
+  Code: DWORD; out RetValue: QWord; out Answer: string; out rValues: TStrings;
+  out iValues: TParamArray; out ByteData: TStream): boolean;
+var
+  UserID: integer;
+  con: TBaseConnection;
+  userName,conID,cmdID: string;
+  cmd: TCommand;
+begin
+  log(Self,'Process Request '+ACommand);
+  ClearTerminated;
+  result := false;
+  RetValue := 0;
+  Code := 0;
+  rValues := nil;
+  ByteData := nil;
+  setLength(iValues,0);
+  if ACommand='stop' then
+    begin
+      ClearConnections;
+      Input.Terminate;
+      fRunning:=false;
+      result := true;
+      exit;
+    end;
+  if ACommand='version' then
+    begin
+      result := true;
+      Answer := extTypes.version;
+      exit;
+    end;
+  if ACommand='arguments' then
+    begin
+      result := ProcessArguments(Fields.Values['name'],RetValue,Answer,rValues);
+      if not result then
+        begin
+          Code := ErrorArguments;
+        end;
+      exit;
+    end;
+  if ACommand='reports' then
+    begin
+      result := ProcessReports(rValues);
+      exit;
+    end;
+  if ACommand='login' then
+    begin
+      UserName :=Fields.Values['user'];
+      if ProcessLogin(UserName,EncryptText(Fields.Values['password']),UserID) then
+        begin
+          con := NewConnection;
+          con.User:=UserName;
+          con.UserID := UserID;
+          Answer := con.ConnectionID;
+          con.Start;
+          result := true;
+        end
+      else
+        begin
+          Answer := 'Invalid password';
+          code := ErrorLogin;
+        end;
+      exit;
+    end;
+  conID := fields.Values['connect'];
+  con := getConnection(conID);
+
+  if not assigned(con) or (con.Finished) then
+    begin
+      Answer := 'invalid connectionID';
+      code := ErrorConnect;
+      exit;
+    end;
+  if ACommand='test' then
+    begin
+      result := true;
+      answer := 'OK';
+      exit;
+    end;
+  if ACommand='logout' then
+    begin
+      result := true;
+      Answer := 'OK';
+      Remove(con.ConnectionID);
+      exit;
+    end;
+  if ACommand='connectStatus' then
+    begin
+      result := true;
+      SetLength(iValues,7);
+      iValues[0] := round(con.Created*24*60*60*100);
+      iValues[1] := round(con.LastReceive*24*60*60*100);
+      iValues[2] := round(con.LastComplete*24*60*60*100);
+      iValues[3] := con.CountReceived;
+      iValues[4] := con.CountCompleted;
+      iValues[5] := con.CountReady;
+      iValues[6] := con.CountErrors;
+      Answer := 'OK';
+      exit;
+    end;
+  if (ACommand='option_values') then
+    begin
+      result := con.ProcessOptionValues(fields.Values['report'],fields.Values['name'],fields,Answer,RetValue,rValues);
+      exit;
+    end;
+
+  if (ACommand='status') or (ACommand='result') then
+    begin
+  cmdID := fields.Values['operation'];
+  cmd := con.FindCommand(cmdID);
+  if not assigned(cmd) then
+    begin
+      Answer := 'command not found';
+      Code := ErrorCommand;
+      exit;
+    end;
+  if ACommand='status' then
+    begin
+      Answer := cmd.currentStage;
+      code := cmd.Status;
+      if (code=StatusComplete) and assigned(cmd.Results.Data) then
+        RetValue:=cmd.Results.Data.Size
+      else
+        RetValue := 0;
+      result := true;
+      exit;
+    end;
+  if ACommand='result' then
+    begin
+      if cmd.Status=StatusComplete then
+        begin
+          cmd.Results.AssignTo(Code,RetValue,Answer,rValues,iValues,ByteData);
+          cmd.Done;
+          result := true;
+        end
+      else
+        begin
+          Code := ErrorComplete;
+          Answer:='command not complete';
+        end;
+      exit;
+    end;
+
+    end;
+   result := con.AddCommand(CommandID,Param,ACommand,Fields.Values['name'],Fields,iValues,Data,Answer,Code, rValues);
+
+end;
+
+function TConnectionsDM.ProcessLogin(UserName, UserPassword: string; out  UserID: integer): boolean;
+var
+  ASQL: string;
+begin
+  Result := MainCon.CheckUser(UserName,UserPassword,UserID);
+end;
+
+function TConnectionsDM.ProcessArguments(ReportName: string; out
+  RetValue: QWORD; out ReportTitle: string; out rValues: TStrings): boolean;
+var
+  ASQL: string;
+begin
+  result := false;
+  rValues := TStringList.Create;
+  ASQL := format(
+    'select r.xp_rpt_id,r.name as reportname,p.name as paramname, '+
+    'case p.type '+
+    '  when 0 then ''A'' '+
+    '  when 1 then ''ID'' '+
+    '  when 2 then ''N'' '+
+    '  when 3 then ''F'' '+
+    '  when 4 then ''D'' '+
+    '  when 5 then ''T'' '+
+    '  when 6 then ''B'' '+
+    '  when 17 then ''IDS'' '+
+    'end as type, '+
+
+    'case coalesce(p.required,false) or p.def_val is  null '+
+    'when true then ''!'' '+
+    'else p.def_val '+
+    'end as def_val, '+
+    'string_agg(''"'' || p.argument || ''"'','';'') as arguments, '+
+    'p.description '+
+    'from xp_report_cgi c '+
+    ' join xp_report r on r.xp_rpt_id=c.xp_rpt_id '+
+    ' left join ( '+
+    ' select xp_rpt_id, type,name, required,def_val,description,fill_order, unnest(coalesce(arguments,array[null])) as argument '+
+    '  from  xp_report_params '+
+    ')p on p.xp_rpt_id=r.xp_rpt_id '+
+    'where c.cgi_name=%0:s '+
+    'group by   r.xp_rpt_id,r.name, p.name,p.type,p.required, p.def_val,p.description, p.fill_order '+
+    'order by p.fill_order, p.name ',
+    [TNIDBDM.StringAsSQL(ReportName)]);
+  with MainCon.GetData(ASQL) do
+    try
+      while not eof do
+        begin
+          ReportTitle := fieldByName('reportname').AsString;
+          rValues.Add(format('{"name":"%s","type":"%s","default":"%s","arguments":[%s],"description":"%s"}',
+          [fieldbyname('paramname').asString, fieldbyname('type').asString,fieldbyname('def_val').asString,fieldbyname('arguments').asString, TNIDBDM.StringAsJSON(fieldbyname('description').asString)]));
+          result := true;
+          next;
+        end;
+    finally
+      free;
+    end;
+
+end;
+
+function TConnectionsDM.ProcessReports(out rValues: TStrings): boolean;
+var
+  ASQL: string;
+begin
+  rValues := TStringList.Create;
+  ASQL :=
+    'select c.cgi_name,r.name as rep_name '+
+    'from xp_report_cgi c '+
+    ' join xp_report r on r.xp_rpt_id=c.xp_rpt_id '+
+    'order by 2 ';
+  with MainCon.GetData(ASQL) do
+    try
+      while not eof do
+        begin
+          rValues.Add(format('{"name":"%s","title":"%s"}',[fieldbyname('cgi_name').asString, TNIDBDM.StringAsJSON(fieldbyname('rep_name').asString)]));
+          result := true;
+          next;
+        end;
+    finally
+      free;
+    end;
+  result := true;
+end;
+
+function TConnectionsDM.ProcessOptionValues(ReportName, ParamName: string;
+  ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out
+  OptionValues: TStrings): boolean;
+var
+  ASQL: string;
+  code: string;
+  i: integer;
+begin
+  ASQL := format(
+    'select  source from xp_report_params p '+
+    ' join xp_report_cgi c on c.xp_rpt_id=p.xp_rpt_id '+
+    'where c.cgi_name=%s and p.name=%s and p.type= in (1,17) ',
+    [TNIDBDM.StringAsSQL(ReportName), TNIDBDM.StringAsSQL(ParamName)]);
+  code := MainCon.QueryValue(ASQL);
+  TNIDBDM.UpdateWithArguments(code,ParamValues);
+  if pos('{',code)>0 then
+    begin
+      result := false;
+      Answer := 'недостаточно данных';
+      exit;
+    end;
+  ASQL := code;
+  OptionValues := TStringList.Create;
+  if ASQL<>'' then
+    with MainCon.GetData(ASQL) do
+      try
+        while not eof do
+          begin
+            OptionValues.Add(format('{"id":"%d","value":"%s"}',
+              [Fields[0].AsInteger, TNIDBDM.StringAsJSON(Fields[1].AsString)]));
+            next;
+          end;
+      finally
+        free;
+      end;
+  result := true;
+end;
+
+
+procedure TConnectionsDM.LoadConfig;
+var
+  ini: TIniFile;
+  inifile: string;
+begin
+  inifile := ChangeFileExt(ParamStr(0),'.ini');
+  ini := TIniFile.Create(inifile);
+  try
+     fDataHost := ini.ReadString('DATA','host','localhost');
+     fDataPort := ini.ReadInteger('DATA','port',7079);
+     fDataBase:= ini.ReadString('DATA','database','');
+     fServicePort := ini.ReadInteger('PARAMS','port',6543);
+     flogFolder:=ini.ReadString('PARAMS','log','');
+     fTimeOut:=ini.ReadInteger('PARAMS','timeout',CONNECT_TIMEOUT);
+  finally
+     ini.free;
+  end;
+end;
+
+procedure TConnectionsDM.Log(Sender: TObject; msg: string);
+var
+  f: TextFile;
+begin
+
+  try
+    if fLogFolder='' then exit;
+    LogLock.Enter;
+    try
+  AssignFile(f, fLogFolder);
+  if fileexists(fLogFolder) then
+    append(f)
+  else
+    rewrite(f);
+  if Sender is TComponent then
+    writeln(f,DateTimeToStr(NOW()),#09,Sender.ClassName,'-',(Sender as TComponent).Name, #09, Msg)
+  else if Assigned(Sender) then
+    writeln(f,DateTimeToStr(NOW()),#09,Sender.ClassName, #09, Msg)
+  else
+    writeln(f,DateTimeToStr(NOW()),#09, #09, Msg);
+  closeFile(f);
+
+    finally
+      logLock.Leave;
+    end;
+
+  except on e: Exception do
+    raise;
+  end;
+end;
+
+procedure TConnectionsDM.Start;
+begin
+  log(self,'Start');
+  MainCon.connection.RemoteHost:=DataHost;
+  MainCon.connection.RemotePort:=DataPort;
+  MainCon.connection.Database:=DataBase;
+  MainCon.OpenConnection;
+  Input.OnIdle:=@Idle;
+  Input.Start;
+  fRunning:=true;
+end;
+
+
+procedure TConnectionsDM.Idle(Sender: TObject);
+var
+  i: integer;
+begin
+  MainCon.ExecuteSQL('select 1');
+  for i := conlist.Count-1 downto 0 do
+    if not TBaseConnection(conList[i]).Finished then
+      TBaseConnection(conList[i]).Idle;
+end;
+
+initialization
+  TCommandCollection.Init;
+finalization
+  TCommandCollection.Done;
+end.
+

exttypes.pas

@@ -0,0 +1,422 @@
+unit extTypes;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, LNet, syncobjs;
+const
+  version='0.0.0.1';
+  cmdRequest=1;
+  cmdAnswer=2;
+  cmdError=3;
+  StatusWaiting=1;
+  StatusProcessing=2;
+  StatusComplete=3;
+  StatusError=4;
+  PacketStart:qword=$1F2E3D4C5B6A7908;
+  ErrorProcessor=1;
+  ErrorLogin=2;
+  ErrorConnect=3;
+  ErrorCommand=4;
+  ErrorComplete=5;
+  ErrorArguments=6;
+  ErrorInternal=$100;
+  CONNECT_TIMEOUT=15;
+
+type
+  TBuffer=Array of Byte;
+  TParamArray=Array of QWORD;
+  TLogger=procedure(Sender: TObject; Msg: String) of object;
+  EFormatException=class(Exception);
+  { TConnectionThread }
+
+  { TRoundBuffer }
+
+  TRoundBuffer=class
+    private
+      intdata: TBuffer;
+      ptrRead,ptrWrite: integer;
+      fSize,fDataSize: integer;
+      fReadReady,fWriteReady: TSimpleEvent;
+      fClosed: boolean;
+      cs: TCriticalSection;
+    public
+      constructor Create(BufferSize: integer);
+      destructor Destroy; override;
+      function Push(const data; datasize: integer): integer;
+      function Pop(var data; datasize: integer): integer;
+      function ReadFromSocket(ASocket:TLSocket): integer;
+      procedure Read(out Value: byte); overload;
+      procedure Read(out Value: word); overload;
+      procedure Read(out Value: dword); overload;
+      procedure Read(out Value: qword); overload;
+      procedure Close;
+      property ReadReady: TSimpleEvent read fReadReady;
+      property WriteReady: TSimpleEvent read fWriteReady;
+  end;
+  TCommandData=class
+    Code:DWORD;
+    Param:QWord;
+    Name: string;
+    Keys: TStrings;
+    iValues: TParamArray;
+    Data: TStream;
+    constructor Create(ACode:DWORD;AParam:QWord; AName: string; AKeys: TStrings; AValues: TParamArray; AData: TStream);
+    destructor Destroy; override;
+    procedure AssignTo(out ACode:DWORD;out AParam:QWord; out AName: string; out AKeys: TStrings; out AValues: TParamArray; out AData: TStream);
+  end;
+procedure CopyBytes(var Dest: PByte; const Data: byte); overload;
+procedure CopyBytes(var Dest: PByte; const Data: word); overload;
+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: TBuffer); overload;
+procedure CopyParamArray(const Source: TParamArray; out Dest: TParamArray);
+procedure LogStrings(logger: TLogger;Sender: TObject;Name: string; Data: TStrings);
+implementation
+procedure CopyParamArray(const Source: TParamArray; out Dest: TParamArray);
+var
+  i: integer;
+begin
+  setlength(Dest,length(Source));
+  if length(Source)>0 then
+  for i := low(Source) to High(Source) do
+    Dest[i] := Source[i];
+end;
+
+procedure LogStrings(logger: TLogger; Sender: TObject; Name: string;
+  Data: TStrings);
+var
+  i: integer;
+begin
+  if assigned(logger) and assigned(Data) then
+    begin
+      logger(Sender,Name);
+      for i := 0 to Data.Count-1 do
+        logger(Sender,' '+Data[i]);
+    end;
+end;
+
+procedure CopyBytes(var Dest: PByte; const Data: byte);
+begin
+  dest^ := Data;
+  inc(dest);
+end;
+
+procedure CopyBytes(var Dest: PByte; const Data: word);
+var
+  i: integer;
+  l: word;
+begin
+  l := Data;
+  for i:=0 to sizeof(word)-1 do
+    begin
+      Dest^ := l and $FF;
+      l := l shr 8;
+      inc(Dest);
+    end;
+end;
+
+procedure CopyBytes(var Dest: PByte; const Data: dword);
+var
+  i: integer;
+  l: dword;
+begin
+  l := Data;
+  for i:=0 to sizeof(dword)-1 do
+    begin
+      Dest^ := l and $FF;
+      l := l shr 8;
+      inc(Dest);
+    end;
+end;
+
+procedure CopyBytes(var Dest: PByte; const Data: qword);
+var
+  i: integer;
+  l: qword;
+begin
+  l := Data;
+  for i:=0 to sizeof(qword)-1 do
+    begin
+      Dest^ := l and $FF;
+      l := l shr 8;
+      inc(Dest);
+    end;
+end;
+
+procedure CopyBytes(var Dest: PByte; const Data: TBuffer);
+var
+  i: integer;
+begin
+  for i := low(Data) to high(Data) do
+    begin
+      Dest^ := Data[i];
+      inc(Dest);
+    end;
+end;
+
+  { TRoundBuffer }
+
+
+constructor TRoundBuffer.Create(BufferSize: integer);
+begin
+  inherited Create;
+  cs := TCriticalSection.Create;
+  SetLength(self.intdata,BufferSize);
+  fSize:=BufferSize;
+  fDataSize := 0;
+  self.ptrRead:=0;
+  self.ptrWrite:=0;
+  fReadReady := TSimpleEvent.Create;
+  fWriteReady := TSimpleEvent.Create;
+  fWriteReady.SetEvent;
+  fClosed:=false;
+end;
+
+destructor TRoundBuffer.Destroy;
+begin
+  cs.free;
+  fReadReady.Free;
+  fWriteReady.Free;
+  setLength(self.intdata,0);
+  inherited Destroy;
+end;
+
+function TRoundBuffer.Push(const data; datasize: integer): integer;
+var
+  i,delta: integer;
+  p:PByte;
+  rem: integer;
+  s: string;
+begin
+  result := 0;
+  if dataSize<=0 then exit;
+  if fClosed then exit;
+  p := @data;
+  i := ptrWrite;
+  rem := dataSize;
+  s := '';
+  if fDataSize=fSize then
+   fWriteReady.WaitFor(INFINITE);
+  if fClosed then exit;
+  delta := 0;
+  while not fClosed and (rem>0) and (fDataSize+delta<fSize) do
+    begin
+      intData[i] := p^;
+      s := s + inttohex(p^,2)+' ';
+      inc(p);
+      i := (i+1) mod fSize;
+      dec(rem);
+      inc(delta);
+    end;
+  cs.Enter;
+  ptrWrite := i;
+  inc(fDataSize,delta);
+  if fDataSize=fSize then
+    fWriteReady.ResetEvent;
+  cs.Leave;
+
+  result := datasize-rem;
+  fReadReady.SetEvent;
+end;
+
+function TRoundBuffer.Pop(var data; datasize: integer): integer;
+var
+  i,delta: integer;
+  p:PByte;
+  rem: integer;
+  s: string;
+begin
+  result := 0;
+  if datasize<=0 then exit;
+  if fClosed then exit;
+  if fDataSize<=0 then
+    fReadReady.WaitFor(INFINITE);
+  if fClosed then exit;
+  p := @data;
+  i := ptrRead;
+  rem := dataSize;
+  s := '';
+  delta := fDataSize;
+  while not fClosed and (rem>0) and (delta>0) do
+    begin
+      p^:=intData[i];
+      s := s + inttohex(intData[i],2)+' ';
+      inc(p);
+      i := (i+1) mod fSize;
+      dec(delta);
+      dec(rem);
+    end;
+  cs.Enter;
+  ptrRead := i;
+  fDataSize:=delta;
+  if fDataSize=0 then
+    fReadReady.ResetEvent;
+  cs.Leave;
+  result := datasize-rem;
+  fWriteReady.SetEvent;
+end;
+
+function TRoundBuffer.ReadFromSocket(ASocket: TLSocket): integer;
+var
+  p: PByte;
+  s: integer;
+begin
+  if fClosed then exit;
+  s := fSize-fDataSize;
+  if s>0 then
+  begin
+    p := GetMem(s);
+    try
+    s := ASocket.Get(p^,s);
+    result := Push(p^,s);
+    finally
+      FreeMem(p);
+    end;
+  end
+  else
+    begin
+    result := -1;
+    fReadReady.SetEvent;
+    end;
+end;
+
+procedure TRoundBuffer.Read(out Value: byte);
+begin
+  Pop(value,sizeof(byte));
+end;
+
+procedure TRoundBuffer.Read(out Value: word);
+var
+  rem,l : integer;
+  p: PByte;
+  lBytes: array[0..1] of byte;
+begin
+  Value := 0;
+  rem := 2;
+  p := PByte(lBytes);
+  repeat
+    l := pop(p^,rem);
+    dec(rem,l);
+    inc(p,l);
+    if l=0 then sleep(100);
+  until rem=0;
+  for l := 1 downto 0 do
+    Value := (Value shl 8) or lBytes[l];
+end;
+
+procedure TRoundBuffer.Read(out Value: dword);
+var
+  rem,l : integer;
+  p: PByte;
+  lBytes: array[0..3] of byte;
+begin
+  Value := 0;
+  rem := 4;
+  p := PByte(lBytes);
+  repeat
+    l := pop(p^,rem);
+    dec(rem,l);
+    inc(p,l);
+    if l=0 then sleep(100);
+  until rem=0;
+  for l := 3 downto 0 do
+    Value := (Value shl 8) or lBytes[l];
+end;
+
+procedure TRoundBuffer.Read(out Value: qword);
+var
+  rem,l : integer;
+  p: PByte;
+  lBytes: array[0..7] of byte;
+begin
+  Value := 0;
+  rem := 8;
+  p := PByte(lBytes);
+  repeat
+    l := pop(p^,rem);
+    dec(rem,l);
+    inc(p,l);
+    if l=0 then
+      sleep(10);
+  until (rem=0) or fClosed;
+  for l := 7 downto 0 do
+    Value := (Value shl 8) or lBytes[l];
+end;
+
+procedure TRoundBuffer.Close;
+begin
+  fClosed := true;
+  fReadReady.SetEvent;
+  fWriteReady.SetEvent;
+end;
+
+{ TCommandData }
+
+constructor TCommandData.Create(ACode: DWORD; AParam: QWord; AName: string;
+  AKeys: TStrings; AValues: TParamArray; AData: TStream);
+var
+  i: integer;
+begin
+  Code := Acode;
+  Param := AParam;
+  Name := AName;
+  if assigned(AKeys) then
+    begin
+      Keys := TStringList.Create;
+      Keys.Assign(AKeys);
+    end
+  else
+    Keys := nil;
+  setLength(iValues,length(AValues));
+  for i := low(iValues) to high(iValues) do
+    iValues[i] := AValues[i];
+  if assigned(AData) then
+    begin
+      Data := TMemoryStream.Create;
+      AData.seek(0,soFromBeginning);
+      Data.CopyFrom(AData,AData.Size);
+    end
+  else
+    Data := nil;
+end;
+
+destructor TCommandData.Destroy;
+begin
+  if assigned(Keys) then Keys.Free;
+  if assigned(Data) then Data.Free;
+  setLength(iValues,0);
+  inherited Destroy;
+end;
+
+procedure TCommandData.AssignTo(out ACode: DWORD; out AParam: QWord; out
+  AName: string; out AKeys: TStrings; out AValues: TParamArray; out
+  AData: TStream);
+var
+  i: integer;
+begin
+  ACode := Code;
+  AParam := Param;
+  AName := Name;
+  if assigned(Keys) then
+    begin
+      AKeys := TStringList.Create;
+      AKeys.Assign(Keys);
+    end
+  else
+    AKeys := nil;
+  if assigned(Data) then
+    begin
+      AData := TMemoryStream.Create;
+      Data.Seek(0,soFromBeginning);
+      AData.CopyFrom(Data,Data.Size);
+    end
+  else
+    AData := nil;
+  CopyParamArray(iValues,AValues);
+end;
+
+end.
+

fr_utils.pas

@@ -0,0 +1,91 @@
+unit fr_utils;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  SysUtils, Classes, fs_iinterpreter, xpMemParamManagerUnit, controls, frxClass, cgiDM;
+type
+
+  { TxpFRFunctions }
+
+  TxpFRFunctions = class(TfsRTTIModule)
+  private
+    class var fData: TNIDBDM;
+    class var fVars: TxpMemParamManager;
+    function CallMethod(Instance: TObject; AClassType: TClass; const AMethodName: String; var Params: Variant): Variant;
+    function _(const szMsgId: string): string;
+  public
+    constructor Create(AScript: TfsScript); override;
+    class procedure SetReport(Adata: TNIDBDM; AVariables: TxpMemParamManager);
+  end;
+
+implementation
+
+uses
+ //gnugettext,
+  numberinwords;
+function TxpFRFunctions._(const szMsgId: string): string;
+begin
+  Result := szMsgId;
+  if Assigned(fData) then
+    begin
+       result := fData.QueryValue(format('select interpretation from xp_vocabulary where term=%s',[TNidbDM.StringAsSQL(szMsgId)]),szMsgId);
+    end;
+end;
+constructor TxpFRFunctions.Create(AScript: TfsScript);
+begin
+  inherited Create(AScript);
+  with AScript do
+  begin
+    AddMethod('function _(str:string):string', @CallMethod, 'LMS функции', 'Функция _()');
+    AddMethod('function Log(str:string):integer', @CallMethod, 'LMS функции', 'Функция LOG()');
+    AddMethod('function Variable(str:string):string', @CallMethod, 'LMS функции', 'Функция Variable()');
+    AddMethod('function AnsiLowerCase(str:string):string', @CallMethod, 'LMS функции', 'Функция AnsiLowerCase()');
+
+    AddMethod('function ЧислоСловами(number:integer;gender:integer;declension:integer):string', @CallMethod, 'LMS функции', 'Функция ЧислоСловами(число, род (0=М,1=Ж,2=С), падеж (0=И,5=П))');
+    AddMethod('function НомерСловами(number:integer;gender:integer;declension:integer):string', @CallMethod, 'LMS функции', 'Функция НомерСловами(число, род (0=М,1=Ж,2=С), падеж (0=И,5=П))');
+
+    AddMethod('function Нагрузка(reqname: string; paramNumber: integer):string', @CallMethod, 'LMS функции', 'Функция Нагрузка(параметр нагрузки, номер поля (1=не менее,2=не более))');
+    AddMethod('procedure Логотип(ControlName: string; ImageName: string)',@CallMethod,'LMS функции','Отображение логотипа');
+  end;
+end;
+
+class procedure TxpFRFunctions.SetReport(Adata: TNIDBDM;
+  AVariables: TxpMemParamManager);
+begin
+  fData := AData;
+  fVars := AVariables;
+end;
+
+function TxpFRFunctions.CallMethod(Instance: TObject; AClassType: TClass;
+    const AMethodName: String; var Params: Variant): Variant;
+begin
+  if AMethodName = '_' then Result := _(Params[0])
+  else
+  if AnsiSameText(AMethodName,'Log') then begin
+    {$IFDEF DEBUG} cxlogger.TLogSystem.Loggers['fastreport'].writelog(Params[0],Params[1]); {$ENDIF}
+    result := true;
+  end
+  else
+  if AnsiSameText(AMethodName,'Variable') then
+    begin
+      if fVars<>nil then
+        Result := fVars[(Params[0])]
+      else
+        Result := '';
+    end
+  else
+  if AnsiSameText(AMethodName, 'AnsiLowerCase') then Result := AnsiLowerCase(Params[0])
+  else
+  if AnsiSameText(AMethodName, 'ЧислоСловами') then Result := number999(Params[0],Params[1],Params[2])
+  else
+  if AnsiSameText(AMethodName, 'НомерСловами') then Result := number999_ord(Params[0],Params[1],Params[2])
+end;
+
+
+
+initialization
+  fsRTTIModules.Add(TxpFRFunctions);
+end.

lms_cgi.lpi

@@ -0,0 +1,108 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <PathDelim Value="\"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+        <MainUnitHasScaledStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="lms_cgi"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <BuildModes>
+      <Item Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+    </RunParams>
+    <RequiredPackages>
+      <Item>
+        <PackageName Value="lnetbase"/>
+      </Item>
+      <Item>
+        <PackageName Value="DataPortLasarus"/>
+      </Item>
+      <Item>
+        <PackageName Value="Abbrevia"/>
+      </Item>
+      <Item>
+        <PackageName Value="frxe_lazarus"/>
+      </Item>
+      <Item>
+        <PackageName Value="dcpcrypt"/>
+      </Item>
+      <Item>
+        <PackageName Value="fr_lazarus"/>
+      </Item>
+      <Item>
+        <PackageName Value="nnzdata"/>
+      </Item>
+      <Item>
+        <PackageName Value="WebLaz"/>
+      </Item>
+      <Item>
+        <PackageName Value="FCL"/>
+      </Item>
+    </RequiredPackages>
+    <Units>
+      <Unit>
+        <Filename Value="lms_cgi.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+      <Unit>
+        <Filename Value="tcpthreadhelper.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+      <Unit>
+        <Filename Value="tcpclient.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="tcpClient"/>
+      </Unit>
+      <Unit>
+        <Filename Value="exttypes.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="extTypes"/>
+      </Unit>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="U:\Apache\Apache24\cgi-bin"/>
+    </SearchPaths>
+    <Other>
+      <CustomOptions Value="-dDEBUG
+-dLOG
+-dCGI"/>
+      <OtherDefines Count="3">
+        <Define0 Value="DEBUG"/>
+        <Define1 Value="LOG"/>
+        <Define2 Value="CGI"/>
+      </OtherDefines>
+    </Other>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions>
+      <Item>
+        <Name Value="EAbort"/>
+      </Item>
+      <Item>
+        <Name Value="ECodetoolError"/>
+      </Item>
+      <Item>
+        <Name Value="EFOpenError"/>
+      </Item>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

lms_cgi.lpr

@@ -0,0 +1,166 @@
+program lms_cgi;
+
+{$mode objfpc}{$H+}
+
+uses
+  Interfaces,  Classes, SysUtils, inifiles, httpDefs, fpweb, custweb, custcgi,
+  cxlogger, abbrevia, lnetbase, tcpClient, tcpthreadhelper, extTypes;
+
+Type
+
+  { TMyCGIHandler }
+
+  TMyCGIHandler = Class(TCgiHandler)
+  Private
+    fAnswer: string;
+    fMode: byte;
+    fCode: DWORD;
+    fParam: QWORD;
+    fValues: TStrings;
+    fData: TStream;
+    function answerReady(Sender: TMainThread; const mode: byte;
+    const Code:DWORD; const QValue: QWORD; const Answer: string; const Values: TStrings; const iValues: TParamArray; const Data: TStream): boolean;
+  Public
+    Procedure HandleRequest(ARequest : Trequest; AResponse : TResponse); override;
+    procedure log(Sender: TObject; msg: string);
+  end;
+
+
+  { TMyCGIApp }
+
+  TMyCGIApp = Class(TCustomCGIApplication)
+  private
+    flogFolder: string;
+    fHost: string;
+    fPort: integer;
+    procedure LoadConfig;
+  Protected
+   function InitializeWebHandler: TWebHandler; override;
+  public
+   property Host: string read fHost;
+   property Port: integer read fPort;
+   property LogFolder: string read fLogFolder;
+  end;
+
+const
+  aTypes: array[0..3] of string=('"UNKNOWN"','"REQUEST"','"ANSWER"','"ERROR"');
+
+function TMyCGIHandler.answerReady(Sender: TMainThread; const mode: byte;
+  const Code: DWORD; const QValue: QWORD; const Answer: string;
+  const Values: TStrings; const iValues: TParamArray; const Data: TStream
+  ): boolean;
+begin
+  log(self,'AnswerReady');
+  fAnswer:=Answer;
+  fMode:=mode;
+  fCode:=code;
+  fParam:=QValue;
+  if assigned(Values) then
+    begin
+      fValues:=TStringList.Create;
+      fValues.assign(Values);
+    end;
+  if assigned(Data) then
+    begin
+      fData := TMemoryStream.Create;
+      Data.seek(0,soFromBeginning);
+      fData.CopyFrom(Data,Data.Size);
+    end;
+  Sender.Terminate;
+end;
+
+procedure TMyCGIHandler.HandleRequest(ARequest: Trequest; AResponse: TResponse);
+var
+  clt: TClientMainThread;
+  i: integer;
+  k,v: string;
+  allfields: TStrings;
+begin
+  log(self,'HandleRequest');
+  LogStrings(@log,self,'QueryFields',Arequest.QueryFields);
+  allfields := TStringList.Create;
+  try
+  allfields.AddStrings(ARequest.QueryFields);
+  allfields.AddStrings(ARequest.ContentFields);
+  clt := TClientMainThread.Create(ARequest.QueryFields.Values['action'],allfields,@Log,(Owner as TMyCGIApp).Host,(Owner as TMyCGIApp).Port,@answerReady);
+  clt.start;
+  clt.waitFor;
+
+  finally
+     allfields.free;
+  end;
+  log(self,'Data READY');
+  if not assigned(fData) then
+    begin
+  AResponse.ContentType := 'application/json';
+  AResponse.Contents.add('{');
+  AResponse.Contents.add('"type":'+aTypes[fMode]+',');
+  AResponse.Contents.add('"code":'+inttostr(fCode)+',');
+  AResponse.Contents.add('"value":'+inttostr(fParam)+',');
+  AResponse.Contents.add('"name":"'+(fAnswer)+'",');
+  if assigned(fValues) then
+    begin
+      AResponse.Contents.add('"values":[');
+      for i := 0 to fValues.Count-1 do
+        begin
+          AResponse.Contents.Add(fValues[i]+',');
+        end;
+      AResponse.Contents.add(']');
+      fValues.Free;
+    end;
+  AResponse.Contents.add('}');
+  end
+  else
+    begin
+       AResponse.FreeContentStream := true;
+      AResponse.ContentType:='application/pdf';
+      fData.Seek(0,soFromBeginning);
+      AResponse.ContentStream := fData;
+    end;
+  log(self,'Sending');
+  AResponse.SendContent;
+  log(self,'Sent');
+end;
+
+procedure TMyCGIHandler.log(Sender: TObject; msg: string);
+var
+  f: TextFile;
+begin
+  if (Owner as TMyCGIApp).LogFolder='' then exit;
+  assignfile(f, (Owner as TMyCGIApp).LogFolder);
+  if fileexists((Owner as TMyCGIApp).LogFolder) then append(f) else rewrite(f);
+  writeln(f,msg);
+  closefile(f);
+end;
+
+procedure TMyCGIApp.LoadConfig;
+var
+  ini: TIniFile;
+begin
+  ini := TIniFile.Create(ChangeFileExt(ParamStr(0),'.ini'));
+  try
+     fHost := ini.ReadString('PARAMS','host','localhost');
+     fPort := ini.ReadInteger('PARAMS','port',6543);
+     flogFolder:=ini.ReadString('PARAMS','log','');
+  finally
+     ini.free;
+  end;
+end;
+
+function TMyCGIApp.InitializeWebHandler: TWebHandler;
+begin
+  LoadConfig;
+  Result:=TMyCgiHandler.Create(self);
+end;
+
+
+
+begin
+    with TMyCGIApp.create(nil) do
+     try
+        Initialize;
+        Run;
+     finally
+        Free;
+     end;
+end.

lmsreport.ini

@@ -0,0 +1,7 @@
+[DATA]
+host=10.120.7.20
+port=7079
+database=lms
+[PARAMS]
+port=6543
+log=D:\PROJECTS\LAZARUS\LMS\out\server.log

lmsreport.lpi

@@ -0,0 +1,161 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <PathDelim Value="\"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="lmsreport"/>
+      <Scaled Value="True"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <XPManifest>
+        <DpiAware Value="True"/>
+      </XPManifest>
+      <Icon Value="0"/>
+    </General>
+    <BuildModes>
+      <Item Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+    </RunParams>
+    <RequiredPackages>
+      <Item>
+        <PackageName Value="Abbrevia"/>
+      </Item>
+      <Item>
+        <PackageName Value="frxe_lazarus"/>
+      </Item>
+      <Item>
+        <PackageName Value="fr_lazarus"/>
+      </Item>
+      <Item>
+        <PackageName Value="dcpcrypt"/>
+      </Item>
+      <Item>
+        <PackageName Value="nnzdata"/>
+      </Item>
+      <Item>
+        <PackageName Value="lnetbase"/>
+      </Item>
+      <Item>
+        <PackageName Value="LCL"/>
+      </Item>
+    </RequiredPackages>
+    <Units>
+      <Unit>
+        <Filename Value="lmsreport.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+      <Unit>
+        <Filename Value="maintcpserver.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="CGIServerGUI"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="Form"/>
+        <UnitName Value="MainTcpServer"/>
+      </Unit>
+      <Unit>
+        <Filename Value="tcpthreadhelper.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+      <Unit>
+        <Filename Value="connectionsdmunit.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="ConnectionsDM"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="DataModule"/>
+        <UnitName Value="ConnectionsDmUnit"/>
+      </Unit>
+      <Unit>
+        <Filename Value="reportdmunit.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="ReportDM"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="DataModule"/>
+        <UnitName Value="reportDMUnit"/>
+      </Unit>
+      <Unit>
+        <Filename Value="cgidm.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="NIDBDM"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="DataModule"/>
+        <UnitName Value="cgiDM"/>
+      </Unit>
+      <Unit>
+        <Filename Value="xpaccessunit.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="xpAccessUnit"/>
+      </Unit>
+      <Unit>
+        <Filename Value="exttypes.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="extTypes"/>
+      </Unit>
+      <Unit>
+        <Filename Value="tcpserver.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+      <Unit>
+        <Filename Value="tcpclient.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="tcpClient"/>
+      </Unit>
+      <Unit>
+        <Filename Value="cgireport.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="cgiReport"/>
+      </Unit>
+      <Unit>
+        <Filename Value="cgicommand.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="cgiCommand"/>
+      </Unit>
+      <Unit>
+        <Filename Value="fr_utils.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+      <Unit>
+        <Filename Value="baseconnection.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="lmsreport"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions>
+      <Item>
+        <Name Value="EAbort"/>
+      </Item>
+      <Item>
+        <Name Value="ECodetoolError"/>
+      </Item>
+      <Item>
+        <Name Value="EFOpenError"/>
+      </Item>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

lmsreport.lpr

@@ -0,0 +1,38 @@
+program lmsreport;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}
+  cthreads,
+  {$ENDIF}
+  {$IFDEF HASAMIGA}
+  athreads,
+  {$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  sysutils,Forms, abbrevia, lnetbase, MainTcpServer, tcpthreadhelper, reportDMUnit,
+  ConnectionsDmUnit, cgiDM, xpAccessUnit, extTypes, tcpserver, tcpClient,
+cgiReport, cgiCommand, fr_utils, baseconnection
+  { you can add units after this };
+
+{$R *.res}
+
+begin
+  RequireDerivedFormResource:=True;
+  Application.Scaled:=True;
+  Application.Initialize;
+  if paramstr(1)='console' then
+  begin
+  Application.CreateForm(TCGIServerGUI, CGIServerGUI);
+  Application.Run;
+  end
+  else
+  begin
+  Application.CreateForm(TConnectionsDM,ConnectionsDM);
+  ConnectionsDM.start;
+  while ConnectionsDM.running do
+    sleep(1000);
+
+  end;
+end.
+

maintcpserver.lfm

@@ -0,0 +1,146 @@
+object CGIServerGUI: TCGIServerGUI
+  Left = 333
+  Height = 309
+  Top = 224
+  Width = 870
+  Caption = 'Сервер отчетов LMS'
+  ClientHeight = 309
+  ClientWidth = 870
+  OnCreate = FormCreate
+  OnDestroy = FormDestroy
+  LCLVersion = '2.2.4.0'
+  object Panel1: TPanel
+    Left = 0
+    Height = 50
+    Top = 0
+    Width = 870
+    Align = alTop
+    Caption = 'остановлен'
+    ClientHeight = 50
+    ClientWidth = 870
+    TabOrder = 0
+    object SendButton: TButton
+      Left = 96
+      Height = 25
+      Top = 14
+      Width = 75
+      Caption = 'Запрос'
+      OnClick = SendButtonClick
+      TabOrder = 0
+    end
+    object StartButton: TButton
+      Left = 8
+      Height = 25
+      Top = 14
+      Width = 75
+      Caption = 'Запуск'
+      OnClick = StartButtonClick
+      TabOrder = 1
+    end
+  end
+  object GroupBox1: TGroupBox
+    Left = 0
+    Height = 259
+    Top = 50
+    Width = 368
+    Align = alLeft
+    Caption = 'Запрос'
+    ClientHeight = 239
+    ClientWidth = 364
+    TabOrder = 1
+    object Keys: TMemo
+      Left = 0
+      Height = 216
+      Top = 23
+      Width = 364
+      Align = alClient
+      Lines.Strings = (
+        'user=nnz'
+        'password=Sochi-2020'
+      )
+      TabOrder = 0
+    end
+    object edtRequest: TComboBox
+      Left = 0
+      Height = 23
+      Top = 0
+      Width = 364
+      Align = alTop
+      ItemHeight = 15
+      ItemIndex = 3
+      Items.Strings = (
+        'version'
+        'reports'
+        'arguments'
+        'login'
+        'test'
+        'logout'
+        'option_values'
+        'report'
+        'status'
+        'result'
+      )
+      TabOrder = 1
+      Text = 'login'
+    end
+  end
+  object GroupBox2: TGroupBox
+    Left = 373
+    Height = 259
+    Top = 50
+    Width = 497
+    Align = alClient
+    Caption = 'Ответ'
+    ClientHeight = 239
+    ClientWidth = 493
+    TabOrder = 2
+    object edtAnswer: TEdit
+      Left = 0
+      Height = 23
+      Top = 25
+      Width = 493
+      Align = alTop
+      OnDblClick = edtAnswerDblClick
+      TabOrder = 0
+    end
+    object retValues: TMemo
+      Left = 0
+      Height = 88
+      Top = 71
+      Width = 493
+      Align = alClient
+      TabOrder = 1
+    end
+    object intValues: TListBox
+      Left = 0
+      Height = 80
+      Top = 159
+      Width = 493
+      Align = alBottom
+      ItemHeight = 0
+      TabOrder = 2
+    end
+    object edtQValue: TEdit
+      Left = 0
+      Height = 23
+      Top = 48
+      Width = 493
+      Align = alTop
+      TabOrder = 3
+    end
+    object StatusPanel: TPanel
+      Left = 0
+      Height = 25
+      Top = 0
+      Width = 493
+      Align = alTop
+      TabOrder = 4
+    end
+  end
+  object Splitter1: TSplitter
+    Left = 368
+    Height = 259
+    Top = 50
+    Width = 5
+  end
+end

maintcpserver.pas

@@ -0,0 +1,182 @@
+unit MainTcpServer;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
+  tcpClient,tcpServer, tcpthreadhelper,
+  ConnectionsDmUnit, syncobjs, extTypes;
+
+type
+
+  { TClientThread }
+
+
+  { TCGIServerGUI }
+
+  TCGIServerGUI = class(TForm)
+    edtAnswer: TEdit;
+    edtQValue: TEdit;
+    edtRequest: TComboBox;
+    GroupBox1: TGroupBox;
+    GroupBox2: TGroupBox;
+    intValues: TListBox;
+    StatusPanel: TPanel;
+    retValues: TMemo;
+    Keys: TMemo;
+    SendButton: TButton;
+    Panel1: TPanel;
+    Splitter1: TSplitter;
+    StartButton: TButton;
+    procedure edtAnswerDblClick(Sender: TObject);
+    procedure SendButtonClick(Sender: TObject);
+    procedure StartButtonClick(Sender: TObject);
+    procedure FormCreate(Sender: TObject);
+    procedure FormDestroy(Sender: TObject);
+  private
+
+   Server: TConnectionsDM;
+   Client: TClientMainThread;
+   cmdDone: boolean;
+   started: boolean;
+    procedure LogQuery(const qtype: integer; const command: string; const aKeys: TStrings; const code: DWORD; const Param: QWORD; const data: TParamArray);
+    function onAnswer(Sender: TMainThread; const mode: byte;
+    const Code:DWORD; const QValue: QWORD; const Answer: string; const Values: TStrings; const iValues: TParamArray; const Data: TStream): boolean;
+  public
+
+  end;
+
+  { TConnectionThread }
+
+
+var
+  CGIServerGUI: TCGIServerGUI;
+
+implementation
+
+{$R *.lfm}
+uses
+  types,strUtils;
+
+
+{ TCGIServerGUI }
+
+procedure TCGIServerGUI.FormCreate(Sender: TObject);
+begin
+  Server := TConnectionsDM.Create(self);
+  ConnectionsDM := Server;
+  cmdDone := true;
+  started := false;
+  SendButton.Enabled := false;
+end;
+
+procedure TCGIServerGUI.SendButtonClick(Sender: TObject);
+begin
+  if not started then exit;
+  client := TClientMainThread.Create(edtRequest.Text,Keys.Lines,@Server.log,'localhost',6543,@onAnswer);
+  LogQuery(0,edtRequest.Text,Keys.Lines,0,0,[]);
+  cmdDone := false;
+  edtAnswer.Text := '';
+  edtQValue.Text := '';
+  StatusPanel.Caption := 'Ожидание';
+  retValues.Clear;
+  client.Start;
+
+end;
+
+procedure TCGIServerGUI.edtAnswerDblClick(Sender: TObject);
+begin
+  Keys.Lines.Add('='+edtanswer.text);
+end;
+
+procedure TCGIServerGUI.StartButtonClick(Sender: TObject);
+begin
+
+  Server.Start;
+  started := true;
+  Panel1.Caption := 'запущен';
+  SendButton.Enabled := true;
+end;
+
+procedure TCGIServerGUI.FormDestroy(Sender: TObject);
+begin
+  Server.Free;
+end;
+
+procedure TCGIServerGUI.LogQuery(const qtype: integer; const command: string;
+  const aKeys: TStrings; const code: DWORD; const Param: QWORD;
+  const data: TParamArray);
+var
+  f: textfile;
+  logfile: string;
+  i: integer;
+begin
+  logfile := ExtractFilePath(paramstr(0))+'out/query.log';
+  assignfile(f,logfile);
+  if fileexists(logfile) then
+    append(f)
+  else
+    rewrite(f);
+  case qType of
+    0: writeln(f,DateTimeToStr(now()),#09,'REQUEST');
+    1: writeln(f,DateTimeToStr(now()),#09,'RESULT');
+  end;
+  writeln(f,#09,command);
+  if qType=1 then
+    writeln(f,#09,format('code=%d, value=0x%x',[code,Param]));
+  if assigned(aKeys) then
+    for i := 0 to akeys.Count-1 do
+      writeln(f,#09,#09,aKeys[i]);
+
+  closefile(f);
+end;
+
+
+
+function TCGIServerGUI.onAnswer(Sender: TMainThread; const mode: byte;
+  const Code: DWORD; const QValue: QWORD; const Answer: string;
+  const Values: TStrings; const iValues: TParamArray; const Data: TStream
+  ): boolean;
+var
+  i: integer;
+  fs: TFileStream;
+begin
+  try
+  LogQuery(1,Answer,Values,code,QValue,iValues);
+  edtAnswer.Text := Answer;
+  case mode of
+    cmdAnswer: StatusPanel.Caption := format('OK(%d)',[code]);
+    cmdError: StatusPanel.Caption := format('ERROR(%d)',[code]);
+  end;
+  edtQValue.Text:=IntToHex(QValue,16);
+  if assigned(Values) then
+    retValues.Lines.Assign(Values)
+  else
+    retValues.Clear;
+  intValues.Clear;
+  for i := low(iValues) to high(iValues) do
+    intValues.AddItem(inttostr(ivalues[i]),TObject(PtrInt(iValues[i])));
+  if Assigned(Data) then
+    begin
+      Data.seek(0,soFromBeginning);
+      fs := TFileStream.Create(Answer,fmCreate);
+      try
+        fs.CopyFrom(Data,Data.size);
+      finally
+        fs.free;
+      end;
+    end;
+  finally
+    Sender.Terminate;
+    cmdDone := true;
+  end;
+
+end;
+
+
+
+
+end.
+

numberinwords.pas

@@ -0,0 +1,464 @@
+unit numberinwords;
+
+interface
+function number999(number: integer; gender: integer; declension: integer): string;
+function number999_ord(number: integer; gender: integer; declension: integer): string;
+implementation
+function number900(centi: integer; declension: integer): string;
+begin
+  case centi of
+    0:;
+    1: case declension of
+         0: Result := 'сто';
+         1: Result := 'ста';
+         2: Result := 'ста';
+         3: Result := 'сто';
+         4: Result := 'ста';
+         5: Result := 'ста';
+       end;
+    2: case declension of
+         0: Result := 'двести';
+         1: Result := 'двухсот';
+         2: Result := 'двумстам';
+         3: Result := 'двести';
+         4: Result := 'двумястами';
+         5: Result := 'двухстах';
+       end;
+    3: case declension of
+         0: Result := 'триста';
+         1: Result := 'трехсот';
+         2: Result := 'тремстам';
+         3: Result := 'триста';
+         4: Result := 'тремястами';
+         5: Result := 'трехстах';
+       end;
+    4: case declension of
+         0: Result := 'четыреста';
+         1: Result := 'четырехсот';
+         2: Result := 'четыремстам';
+         3: Result := 'четыреста';
+         4: Result := 'четырьмястами';
+         5: Result := 'четырехстах';
+       end;
+    5: case declension of
+         0: Result := 'пятьсот';
+         1: Result := 'пятисот';
+         2: Result := 'пятистам';
+         3: Result := 'пятьсот';
+         4: Result := 'пятьюстами';
+         5: Result := 'пятистах';
+       end;
+    6: case declension of
+         0: Result := 'шестьсот';
+         1: Result := 'шестисот';
+         2: Result := 'шестистам';
+         3: Result := 'шестьсот';
+         4: Result := 'шестьюстами';
+         5: Result := 'шестистах';
+       end;
+    7: case declension of
+         0: Result := 'семьсот';
+         1: Result := 'семисот';
+         2: Result := 'семистам';
+         3: Result := 'семьсот';
+         4: Result := 'семьюстами';
+         5: Result := 'семистах';
+       end;
+    8: case declension of
+         0: Result := 'восемьсот';
+         1: Result := 'восьмисот';
+         2: Result := 'восьмистам';
+         3: Result := 'восемьсот';
+         4: Result := 'восемьюстами';
+         5: Result := 'восьмистах';
+       end;
+    9: case declension of
+         0: Result := 'девятьсот';
+         1: Result := 'девятисот';
+         2: Result := 'девятистам';
+         3: Result := 'девятьсот';
+         4: Result := 'девятьюстами';
+         5: Result := 'девятистах';
+       end;
+  end;
+end;
+function Adjective1(gender,declension: integer): string;
+begin
+  case declension  of
+    0: case gender of
+         0: result := 'ый';
+         1: result := 'ая';
+         2: result := 'ое';
+       end;
+    1: case gender of
+         0: result := 'ого';
+         1: result := 'ой';
+         2: result := 'ого';
+       end;
+    2: case gender of
+         0: result := 'ому';
+         1: result := 'ой';
+         2: result := 'ому';
+       end;
+    3: case gender of
+         0: result := 'ый';
+         1: result := 'ую';
+         2: result := 'ое';
+       end;
+    4: case gender of
+         0: result := 'ым';
+         1: result := 'ой';
+         2: result := 'ым';
+       end;
+    5: case gender of
+         0: result := 'ом';
+         1: result := 'ой';
+         2: result := 'ом';
+       end;
+  end;
+end;
+function Adjective2(gender,declension: integer): string;
+begin
+  if (gender=0) and (declension in [0,3]) then result := 'ой'
+                                          else result := Adjective1(gender,declension);
+end;
+function Adjective3(gender,declension: integer): string;
+begin
+  case declension  of
+    0: case gender of
+         0: result := 'ий';
+         1: result := 'яя';
+         2: result := 'ье';
+       end;
+    1: case gender of
+         0: result := 'ьего';
+         1: result := 'ей';
+         2: result := 'ьего';
+       end;
+    2: case gender of
+         0: result := 'ьему';
+         1: result := 'ей';
+         2: result := 'ьему';
+       end;
+    3: case gender of
+         0: result := 'ий';
+         1: result := 'ью';
+         2: result := 'ье';
+       end;
+    4: case gender of
+         0: result := 'ьим';
+         1: result := 'ьей';
+         2: result := 'ьим';
+       end;
+    5: case gender of
+         0: result := 'ьем';
+         1: result := 'ьей';
+         2: result := 'ьем';
+       end;
+  end;
+end;
+
+function number900_ord(centi: integer; gender: integer; declension: integer): string;
+begin
+  case centi of
+  0:;
+  1:  result := 'сот'+Adjective1( gender, declension);
+  2:  result := 'двухсот'+Adjective1( gender, declension);
+  3:  result := 'трехсот'+Adjective1( gender, declension);
+  4:  result := 'четырехсот'+Adjective1( gender, declension);
+  5:  result := 'пятисот'+Adjective1( gender, declension);
+  6:  result := 'шестисот'+Adjective1( gender, declension);
+  7:  result := 'семисот'+Adjective1( gender, declension);
+  8:  result := 'восьмисот'+Adjective1( gender, declension);
+  9:  result := 'девятисот'+Adjective1( gender, declension);
+  end;
+end;
+
+function number90(decades: integer; declension: integer): string;
+begin
+  case decades of
+    0,1:;
+    2: case declension of
+         0: Result := 'двадцать';
+         1: Result := 'двадцати';
+         2: Result := 'двадцати';
+         3: Result := 'двадцать';
+         4: Result := 'двадцатью';
+         5: Result := 'двадцати';
+       end;
+    3: case declension of
+         0: Result := 'тридцать';
+         1: Result := 'тридцати';
+         2: Result := 'тридцати';
+         3: Result := 'тридцать';
+         4: Result := 'тридцатью';
+         5: Result := 'тридцати';
+       end;
+    4: case declension of
+         0: Result := 'сорок';
+         1: Result := 'сорока';
+         2: Result := 'сорока';
+         3: Result := 'сорок';
+         4: Result := 'сорока';
+         5: Result := 'сорока';
+       end;
+    5: case declension of
+         0: Result := 'пятьдесят';
+         1: Result := 'пятидесяти';
+         2: Result := 'пятидесяти';
+         3: Result := 'пятьдесят';
+         4: Result := 'пятьюдесятью';
+         5: Result := 'пятидесяти';
+       end;
+    6: case declension of
+         0: Result := 'шестьдесят';
+         1: Result := 'шестидесяти';
+         2: Result := 'шестидесяти';
+         3: Result := 'шестьдесят';
+         4: Result := 'шестьюдесятью';
+         5: Result := 'шестидесяти';
+       end;
+    7: case declension of
+         0: Result := 'семьдесят';
+         1: Result := 'семидесяти';
+         2: Result := 'семидесяти';
+         3: Result := 'семьдесят';
+         4: Result := 'семьюдесятью';
+         5: Result := 'семидесяти';
+       end;
+    8: case declension of
+         0: Result := 'восемьдесят';
+         1: Result := 'восьмидесяти';
+         2: Result := 'восьмидесяти';
+         3: Result := 'восемьдесят';
+         4: Result := 'восьмьюдесятью';
+         5: Result := 'восьмидесяти';
+       end;
+    9: case declension of
+         0: Result := 'девяносто';
+         1: Result := 'девяноста';
+         2: Result := 'девяноста';
+         3: Result := 'девяносто';
+         4: Result := 'девяноста';
+         5: Result := 'девяноста';
+       end;
+  end;
+end;
+function number90_ord(decades: integer; gender: integer; declension: integer): string;
+begin
+  case decades  of
+    0,1:;
+    2: Result := 'двадцат' + Adjective1(gender,declension);
+    3: Result := 'тридцат' + Adjective1(gender,declension);
+    4: Result := 'сороков' + Adjective2(gender,declension);
+    5: Result := 'пятидесят' + Adjective1(gender,declension);
+    6: Result := 'шестидесят' + Adjective1(gender,declension);
+    7: Result := 'седидесят' + Adjective1(gender,declension);
+    8: Result := 'восьмидесят' + Adjective1(gender,declension);
+    9: Result := 'девяност' + Adjective1(gender,declension);
+  end;
+end;
+function number19(number: integer; declension: integer): string;
+var
+ p1,p2: string;
+begin
+  case declension of
+    0: p2 := 'надцать';
+    1: p2 := 'надцати';
+    2: p2 := 'надцати';
+    3: p2 := 'надцать';
+    4: p2 := 'надцатью';
+    5: p2 := 'надцати';
+  end;
+  case number of
+    11: p1 := 'один';
+    12: p1 := 'две';
+    13: p1 := 'три';
+    14: p1 := 'четыр';
+    15: p1 := 'пят';
+    16: p1 := 'шест';
+    17: p1 := 'семь';
+    18: p1 := 'восемь';
+    19: p1 := 'девят';
+  end;
+  Result := p1 + p2;
+end;
+function number19_ord(number: integer; gender: integer; declension: integer): string;
+var
+  p1: string;
+begin
+  case number of
+    11: p1 := 'один';
+    12: p1 := 'две';
+    13: p1 := 'три';
+    14: p1 := 'четыр';
+    15: p1 := 'пят';
+    16: p1 := 'шест';
+    17: p1 := 'семь';
+    18: p1 := 'восемь';
+    19: p1 := 'девят';
+  end;
+  Result := Result +'надцат'+Adjective1(gender,declension)
+end;
+function number9(number: integer; gender: integer; declension: integer): string;
+begin
+  case number of
+    0:;
+    1: case declension of
+         0: case gender of
+              0: Result := 'один';
+              1: Result := 'одна';
+              2: Result := 'одно';
+            end;
+         1: case gender of
+              0: Result := 'одного';
+              1: Result := 'одной';
+              2: Result := 'одного';
+            end;
+         2: case gender of
+              0: Result := 'одному';
+              1: Result := 'одной';
+              2: Result := 'одному';
+            end;
+         3: case gender of
+              0: Result := 'один';
+              1: Result := 'одну';
+              2: Result := 'одно';
+            end;
+         4: case gender of
+              0: Result := 'одним';
+              1: Result := 'одной';
+              2: Result := 'одним';
+            end;
+         5: case gender of
+              0: Result := 'одном';
+              1: Result := 'одной';
+              2: Result := 'одном';
+            end;
+       end;
+    2: case declension of
+         0: case gender of
+              0,2: Result := 'два';
+              1: Result := 'две';
+            end;
+         1: Result := 'двух';
+         2: Result := 'двум';
+         3: Result := 'двух';
+         4: Result := 'двумя';
+         5: Result := 'двух';
+       end;
+    3: case declension of
+         0: Result := 'три';
+         1: Result := 'трех';
+         2: Result := 'трем';
+         3: Result := 'три';
+         4: Result := 'тремя';
+         5: Result := 'трех';
+       end;
+    4: case declension of
+         0: Result := 'четыре';
+         1: Result := 'четырех';
+         2: Result := 'четырем';
+         3: Result := 'четыре';
+         4: Result := 'четырьмя';
+         5: Result := 'четырех';
+       end;
+    5: case declension of
+         0: Result := 'пять';
+         1: Result := 'пяти';
+         2: Result := 'пяти';
+         3: Result := 'пять';
+         4: Result := 'пятью';
+         5: Result := 'пяти';
+       end;
+    6: case declension of
+         0: Result := 'шесть';
+         1: Result := 'шести';
+         2: Result := 'шести';
+         3: Result := 'шесть';
+         4: Result := 'шестью';
+         5: Result := 'шести';
+       end;
+    7: case declension of
+         0: Result := 'семь';
+         1: Result := 'семи';
+         2: Result := 'семи';
+         3: Result := 'семь';
+         4: Result := 'семью';
+         5: Result := 'семи';
+       end;
+    8: case declension of
+         0: Result := 'восемь';
+         1: Result := 'восьми';
+         2: Result := 'восьми';
+         3: Result := 'восемь';
+         4: Result := 'восемью';
+         5: Result := 'восьми';
+       end;
+    9: case declension of
+         0: Result := 'девять';
+         1: Result := 'девяти';
+         2: Result := 'девяти';
+         3: Result := 'девять';
+         4: Result := 'девятью';
+         5: Result := 'девяти';
+       end;
+
+  end;
+end;
+function number9_ord(number: integer; gender: integer; declension: integer): string;
+begin
+  case number of
+   1: result := 'перв' + Adjective1(gender,declension);
+   2: result := 'втор' + Adjective2(gender,declension);
+   3: result := 'трет' + Adjective3(gender,declension);
+   4: result := 'четверт' + Adjective1(gender,declension);
+   5: result := 'пят' + Adjective1(gender,declension);
+   6: result := 'шест' + Adjective2(gender,declension);
+   7: result := 'седьм' + Adjective2(gender,declension);
+   8: result := 'восьм' + Adjective2(gender,declension);
+   9: result := 'девят' + Adjective1(gender,declension);
+  end;
+end;
+function number999(number: integer; gender: integer; declension: integer): string;
+begin
+  result := number900(number div 100, declension);
+  number := number mod 100;
+  case number  of
+  0..9:   result := result + ' ' + number9(number,gender,declension);
+  11..19: result := result + ' ' + number19(number,declension);
+  else    begin
+           result := result +' '+ number90(number div 10,declension);
+           number := number mod 10;
+           result := result +' '+ number9(number,gender,declension);
+          end;
+  end;
+end;
+
+function number999_ord(number: integer; gender: integer; declension: integer): string;
+var
+  top,rem: integer;
+begin
+  top := number div 100;
+  rem := number mod 100;
+  if rem = 0 then
+  begin
+    result := number900_ord(top,gender,declension);
+    exit;
+  end;
+  result := number900(top,0);
+  top := rem;
+  rem := top mod 10;
+  case top  of
+  1..9:   result := result + ' ' + number9_ord(top,gender,declension);
+  11..19: result := result + ' ' + number19_ord(top,gender,declension);
+  else    begin
+           if rem = 0 then
+             result := result +' '+ number90_ord(top div 10,gender,declension)
+           else
+              result := result +' '+ number90(top div 10, 0) + ' ' + number9_ord(rem,gender,declension);
+          end;
+  end;
+
+end;
+end.

reportdmunit.lfm

@@ -0,0 +1,94 @@
+object ReportDM: TReportDM
+  OldCreateOrder = False
+  Height = 213
+  HorizontalOffset = 694
+  VerticalOffset = 317
+  Width = 330
+  object frxReport: TfrxReport
+    Version = '2023.1'
+    DotMatrixReport = False
+    EngineOptions.SilentMode = True
+    EngineOptions.NewSilentMode = simSilent
+    IniFile = '\Software\Fast Reports'
+    PreviewOptions.Buttons = [pbPrint, pbLoad, pbSave, pbExport, pbZoom, pbFind, pbOutline, pbPageSetup, pbTools, pbEdit, pbNavigator, pbExportQuick, pbCopy, pbSelection]
+    PreviewOptions.Zoom = 1
+    PrintOptions.Printer = 'Default'
+    PrintOptions.PrintOnSheet = 0
+    ReportOptions.CreateDate = 45166.790207419
+    ReportOptions.LastChange = 45166.790207419
+    ScriptLanguage = 'PascalScript'
+    ScriptText.Strings = (
+      'begin'
+      ''
+      'end.'
+    )
+    OnLoadTemplate = frxReportLoadTemplate
+    OnLoadDetailTemplate = frxReportLoadDetailTemplate
+    Left = 176
+    Top = 24
+    Datasets = <>
+    Variables = <>
+    Style = <>
+  end
+  object frxPDFExport1: TfrxPDFExport
+    UseFileCache = True
+    ShowProgress = True
+    OverwritePrompt = False
+    DataOnly = False
+    EmbedFontsIfProtected = False
+    InteractiveFormsFontSubset = 'A-Z,a-z,0-9,#43-#47 '
+    OpenAfterExport = False
+    PrintOptimized = False
+    Outline = False
+    Background = False
+    HTMLTags = True
+    Quality = 95
+    Author = 'FastReport'
+    Subject = 'FastReport PDF export'
+    Creator = 'FastReport'
+    ProtectionFlags = [ePrint, eModify, eCopy, eAnnot]
+    HideToolbar = False
+    HideMenubar = False
+    HideWindowUI = False
+    FitWindow = False
+    CenterWindow = False
+    PrintScaling = False
+    PdfA = False
+    PDFStandard = psNone
+    PDFVersion = pv17
+    Left = 55
+    Top = 97
+  end
+  object frxODSExport1: TfrxODSExport
+    UseFileCache = True
+    ShowProgress = True
+    OverwritePrompt = False
+    DataOnly = False
+    PictureType = gpPNG
+    OpenAfterExport = False
+    Background = True
+    Creator = 'FastReport'
+    Language = 'en'
+    SuppressPageHeadersFooters = False
+    Left = 47
+    Top = 24
+  end
+  object frxODTExport1: TfrxODTExport
+    UseFileCache = True
+    ShowProgress = True
+    OverwritePrompt = False
+    DataOnly = False
+    PictureType = gpPNG
+    OpenAfterExport = False
+    Background = True
+    Creator = 'FastReport'
+    Language = 'en'
+    SuppressPageHeadersFooters = False
+    Left = 108
+    Top = 61
+  end
+  object AbUnZipper1: TAbUnZipper
+    Left = 180
+    Top = 86
+  end
+end

reportdmunit.pas

@@ -0,0 +1,693 @@
+unit reportDMUnit;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, frxClass, frxExportPDF, frxExportODF,
+  xpMemParamManagerUnit, AbUnzper, frxDBSet, cgiDM,extTypes;
+
+type
+  TExportFileType = (ftPDF,ftRTF,ftXLS);//(ftPDF,ftMail,ftRTF,ftXLS,ftHTML);
+  { TReportDM }
+  TReportQuery=class;
+
+  { TReportQuery }
+
+  TReportQuery=class
+    private
+      fQueries: TList;
+      fOwner: TReportQuery;
+      fData: TNIDBDM;
+      function getQuery(index: integer): TReportQuery;
+      function getQueryCount: integer;
+    public
+    Name,SQL,LinkField,Description: string;
+    ID,ParentID: integer;
+    Data: TfrxDBDataset;
+    property Queries[index: integer]:TReportQuery read getQuery;
+    property QueryCount: integer read getQueryCount;
+    property MasterQuery: TReportQuery read fOwner;
+    constructor Create;
+    destructor Destroy; override;
+    procedure Clear;
+    procedure AddQuery(q: TReportQuery);
+    procedure RemoveQuery(q: TReportQuery);
+    function Find(QueryID: integer): TReportQuery;
+  end;
+
+  TReportDM = class(TDataModule)
+    AbUnZipper1: TAbUnZipper;
+    frxODSExport1: TfrxODSExport;
+    frxODTExport1: TfrxODTExport;
+    frxPDFExport1: TfrxPDFExport;
+    frxReport: TfrxReport;
+    function frxReportLoadDetailTemplate(Report: TfrxReport;
+      const TemplateName: String; const AHyperlink: TfrxHyperlink): Boolean;
+    procedure frxReportLoadTemplate(Report: TfrxReport;
+      const TemplateName: String);
+  private
+    TempTableAlreadyCreated : Boolean;
+    ComponentContainer : TList;
+    MasterDataSets: TStringList; // Список Master-датасетов (TfrxDBDataset) - не забыть создать/удалить как ComponentContainer. Возможно, не нужен???
+    DetailDataSets: TStringList; // Список Detail-датасетов. В Objects - TStringList (id query + Detail-датасет(TfrxDBDataset))
+    ReportVariables: TxpMemParamManager;
+    ReportQueries: TReportQuery;
+    procedure CreateDBDataSet(Query:TReportQuery;  EditReport: Boolean = False);
+    procedure CreateSignaturesDataSet(EditReport: Boolean = False);
+    procedure CreateLogosDataSet(EditReport: Boolean = False);
+    procedure BuildPodpis(AVariables :  TxpMemParamManager);
+    // Возвращает имя Master-датасета по id Detail-а (пустую строку если датасет не имеет Master-а)
+    function GetMasterDSName(qryID: integer): string;
+    // Возвращает имя ключевого поля (для Master-датасета - ключевое поле, для Detail-датасета - поле внешнего ключа)
+    function GetLinkFieldName(qryID: integer): string;
+    // Возвращает строку для фильтрации Detail-датасета. Параметры:
+    // - detail_key_fields, master_key_fields - строки, описывающие поля связи master и detail - датасета,
+    // - Link_type - тип связи ("ID" - по id, "BETWEEN" - по диапазону дат, "LIKE" - по подстроке и т.п. - сейчас пока только по id)
+    // - MasterDataSet - Master-датасет.
+    function GetFilterClause(detail_key_fields, master_key_fields, Link_type: string; MasterDataSet: TfrxDBDataset): string;
+    procedure PrepareBuildInfo(AVariables :  TxpMemParamManager);
+    function GetVariable(AVariables: TxpMemParamManager; VarName: string; DefaultValue: string): string;
+    class function maskFRSpecial(value: string): string;
+    class function maskFRSpecialPreservingEOLs(value: string): string;
+    procedure frxReportPreview(Sender: TObject);
+    procedure LoadQueries;
+    procedure LoadDefaultVariables(AVariables : TxpMemParamManager);
+    procedure LoadLogos(AVariables : TxpMemParamManager);
+    procedure LoadVariables(AVariables, AParam : TxpMemParamManager);
+    procedure OnMasterRecord(Sender: TObject);
+    procedure LoadReportTemplate();
+    procedure CopyReportVariables(AVariables, AParam: TxpMemParamManager);
+  public
+    RecordID: integer;
+    NidbData: TNIDBDM;
+    procedure ExportReport( ExportType: TExportFileType; Data: TStream; OnStage: TLogger);
+  end;
+
+var
+  ReportDM: TReportDM;
+
+implementation
+uses
+  xpReportUtil, Variants,DB,lazUTF8, xpUtilUnit,nnz_data_components,frxCross, Graphics, fr_utils;
+{$R *.lfm}
+
+{ TReportQuery }
+
+function TReportQuery.getQuery(index: integer): TReportQuery;
+begin
+  result :=TReportQuery(fQueries[index]);
+end;
+
+function TReportQuery.getQueryCount: integer;
+begin
+  result := fQueries.Count;
+end;
+
+constructor TReportQuery.Create;
+begin
+  fQueries := TList.Create;
+  fOwner := nil;
+  ID := 0;
+  ParentID := 0;
+end;
+
+destructor TReportQuery.Destroy;
+begin
+  Clear;
+  fQueries.Free;
+  if assigned(Data) then
+    FreeAndNil(Data);
+  inherited Destroy;
+end;
+
+procedure TReportQuery.Clear;
+var
+  i: integer;
+begin
+  for i := 0 to fQueries.Count-1 do
+    TReportQuery(fQueries[i]).Free;
+  fQueries.Clear;
+end;
+
+procedure TReportQuery.AddQuery(q: TReportQuery);
+var
+  p: TReportQuery;
+begin
+  p := self;
+  while assigned(p) do
+    begin
+      if p=q then exit;
+      p := p.MasterQuery;
+    end;
+  if assigned(q.MasterQuery) then
+    q.MasterQuery.RemoveQuery(q);
+  fQueries.Add(q);
+  q.fOwner := self;
+end;
+
+procedure TReportQuery.RemoveQuery(q: TReportQuery);
+begin
+  fQueries.Remove(q);
+end;
+
+function TReportQuery.Find(QueryID: integer): TReportQuery;
+var
+  i: integer;
+begin
+  result := nil;
+  if self.ID=QueryID then result := self
+  else
+    for i := 0 to QueryCount-1 do
+      begin
+        Result := Queries[i].Find(QueryID);
+        if assigned(Result) then
+          exit;
+      end;
+
+end;
+
+{ TReportDM }
+
+procedure TReportDM.frxReportLoadTemplate(Report: TfrxReport;
+  const TemplateName: String);
+begin
+  NidbData.log(self,'LoadTemplate '+TemplateName);
+end;
+
+function TReportDM.frxReportLoadDetailTemplate(Report: TfrxReport;
+  const TemplateName: String; const AHyperlink: TfrxHyperlink): Boolean;
+begin
+  NidbData.log(self,'LoadDetailTemplate '+TemplateName);
+end;
+
+procedure TReportDM.CreateDBDataSet(Query: TReportQuery; EditReport: Boolean);
+var
+  i: integer;
+  DBQuery: TnnzQuery;
+  ds: TfrxDBDataset;
+begin
+  if Query.ID>0 then
+    begin
+          NidbData.log(self,'CreateDBDataSet '+Query.Name);
+        ds := TfrxDBDataset.Create(Self);
+        Query.Data := ds;
+        ds.Tag := PtrInt(Query);
+        // Master/Detail
+        if Query.ParentID=0 then
+        begin // Если это мастер-датасет, добавить его в список и присвоить ему события
+          Query.Data.OnFirst := @OnMasterRecord;
+          Query.Data.OnNext := @OnMasterRecord;
+        end;
+        Query.Data.Name := Query.Name;
+
+
+        DBQuery := TnnzQuery.Create(Self);
+        DBQuery.Connection := NidbData.connection;
+        DBQuery.SQL.Text := Query.SQL;
+        try
+        DBQuery.Open;
+        except on E: Exception do
+          begin
+            NidbData.logError(self,e,Query.SQL);
+            raise Exception.Create(Format('%s::"%s"'#13#10' '#13#10'%s',[e.ClassName,e.Message,Query.SQL]));
+          end;
+        end;
+        Query.Data.DataSet := DBQuery;
+
+    end;
+  for i := 0 to Query.QueryCount-1 do
+    begin
+      CreateDBDataSet(query.Queries[i],EditReport);
+    end;
+end;
+
+procedure TReportDM.CreateSignaturesDataSet(EditReport: Boolean);
+begin
+
+end;
+
+procedure TReportDM.CreateLogosDataSet(EditReport: Boolean);
+begin
+
+end;
+
+procedure TReportDM.BuildPodpis(AVariables: TxpMemParamManager);
+begin
+
+end;
+
+function TReportDM.GetMasterDSName(qryID: integer): string;
+begin
+
+end;
+
+function TReportDM.GetLinkFieldName(qryID: integer): string;
+begin
+
+end;
+
+function TReportDM.GetFilterClause(detail_key_fields, master_key_fields,
+  Link_type: string; MasterDataSet: TfrxDBDataset): string;
+begin
+
+end;
+
+procedure TReportDM.PrepareBuildInfo(AVariables: TxpMemParamManager);
+begin
+
+end;
+
+function TReportDM.GetVariable(AVariables: TxpMemParamManager; VarName: string;
+  DefaultValue: string): string;
+begin
+
+end;
+
+class function TReportDM.maskFRSpecial(value: string): string;
+var
+  i: integer;
+  isSpace: boolean;
+  uchar: string;
+begin
+  isSpace := false;
+  result := '';
+  value := UTF8Trim(value);
+  for i := 1 to UTF8Length(value) do
+    begin
+      uchar := UTF8Copy(value,i,1);
+    if  uchar <= ' ' then // убиваем и заменяем одинарным пробелом все последовательности непечатаемых символов, включая перенос строки
+    begin
+      if not isSpace then
+        result := result + ' ';
+
+      isSpace := true;
+    end
+    else
+    begin
+      if uchar = #39 then // одиночная кавычка, апостроф (')
+        result := result + #39#39
+      else
+        result := result + uchar;
+
+      isSpace := false;
+    end;
+
+    end;
+
+    result := #39 + result + #39; // 'result'
+//    result :=QuotedStr('');
+end;
+class function TReportDM.maskFRSpecialPreservingEOLs(value: string): string;
+var
+  i: integer;
+  isSpace, isEOL: boolean;
+  uchar: string;
+begin
+  isSpace := false;
+  isEOL := false;
+  result := '';
+  value := UTF8Trim(value);
+  for i := 1 to UTF8length(value) do
+    begin
+      uchar := UTF8Copy(value,i,1);
+    if inArray(uChar,[#13,#10],false) then // любые последовательности переноса строк, в т.ч. от макоси (#13) и линукса (#10), меняем одним #13#10
+    begin
+      if not isEOL then
+        result := result + sFRBreak;
+      isEOL := true;
+      isSpace := false;
+    end
+    else if (uchar <= ' ') then // заменяем одинарным пробелом все последовательности пробелов и непечатаемых символов, КРОМЕ переносов строк
+    begin
+      if not isSpace then
+        result := result + ' ';
+
+      isSpace := true;
+      isEOL := false;
+    end
+    else
+    begin
+      if uchar = #39 then // одиночная кавычка, апостроф (')
+        result := result + #39#39
+      else
+        result := result + UTF8Copy(value,i,1);
+
+      isSpace := false;
+      isEOL := false;
+    end;
+
+    end;
+
+  if (utf8pos(#13, result) = 0) then // в строке result нет символа CR; нужно забрать всё в одинарные кавычки, и FR их не покажет
+    result := #39 + result + #39;
+//  result := QuotedStr('');
+end;
+
+procedure TReportDM.frxReportPreview(Sender: TObject);
+var
+  Report: TfrxReport;
+begin
+  inherited;
+  try
+    Report := Sender as TfrxReport;
+    Report.PreviewForm.BringToFront;
+  except
+  end;
+end;
+
+procedure TReportDM.LoadQueries;
+var
+  SQL: string;
+  q: TReportquery;
+  i: integer;
+begin
+  NidbData.log(self,'LoadQueries');
+  SQL := format(
+      'select q.xp_rpt_q_id,qp.xp_rpt_q_id as ParentID,q.Link_field, '+
+      ' q.Name,'+
+      ' q.Description, q.SQL '+
+      'FROM xp_report_query q '+
+      ' left join xp_report_query qp ON q.Parent_q_id=qp.xp_rpt_q_id AND qp.xp_rpt_id=q.xp_rpt_id '+
+      'WHERE q.xp_rpt_id = %0:d '+
+      'ORDER BY qp.xp_rpt_q_id is not null, q.Name  ',
+      [integer(RecordID)]);
+  with NidbData.GetData(SQL) do
+    try
+      while not eof do
+        begin
+          q := TReportQuery.Create;
+          ReportQueries.AddQuery(q);
+          q.Name:=fieldbyname('Name').AsString;
+          q.SQL:=fieldbyname('SQL').AsString;
+          q.LinkField:=fieldbyname('Link_field').AsString;
+          q.Description:=fieldbyname('Description').AsString;
+          q.ID:=fieldbyname('xp_rpt_q_id').AsInteger;
+          q.ParentID:=fieldbyname('ParentID').AsInteger;
+
+          next;
+        end;
+    finally
+      free;
+    end;
+  for i := ReportQueries.QueryCount-1 downto 0 do
+    if ReportQueries.Queries[i].ParentID>0 then
+      begin
+        NidbData.log(self,'LoadQueries.'+ReportQueries.Queries[i].Name);
+        q := ReportQueries.Find(ReportQueries.Queries[i].ParentID);
+        if assigned(q) then
+          q.AddQuery(ReportQueries.Queries[i]);
+      end;
+  NidbData.log(self,'LoadQueries-OK');
+end;
+
+procedure TReportDM.LoadDefaultVariables(AVariables: TxpMemParamManager);
+var
+  SQL: string;
+  l: TStrings;
+  i: integer;
+begin
+  NidbData.log(self,'LoadDefaultVariables');
+
+  SQL := 'select name,value from options where name in (''GOU_Name'',''Dep_Name'')';
+  with NidbData.GetData(sql) do
+    try
+      while not eof do
+        begin
+          AVariables[fieldbyname('name').asString] := fieldbyname('value').asString;
+          next;
+        end;
+    finally
+      free;
+    end;
+
+end;
+
+procedure TReportDM.LoadLogos(AVariables: TxpMemParamManager);
+var
+  sql: string;
+  img: TJPEGImage;
+  p: TPicture;
+  s: TStream;
+  v: Variant;
+begin
+  NidbData.log(self,'LoadLogos');
+  SQL := 'select name,value from options where name in (''Dep_Logo'',''GOU_Logo'')';
+  with NidbData.GetData(sql) do
+    try
+      while not eof do
+        begin
+          s := CreateBlobStream(FieldByName('value'),bmRead);
+          p:=TPicture.Create;
+          img := TJPEGImage.Create();
+              try
+                img.LoadFromStream(s);
+                p.Graphic:=img;
+                // внутри вызывается Assign, поэтому img больше не нужен
+              finally
+                s.Free();
+                img.Free;
+              end;
+          v := PtrInt(p);
+          AVariables[fieldbyname('name').asString] := PtrInt(p);
+          p := TPicture(PtrInt(v));
+
+          next;
+        end;
+    finally
+      free;
+    end;
+end;
+
+procedure TReportDM.LoadVariables(AVariables, AParam: TxpMemParamManager);
+var
+  sql: string;
+begin
+ NidbData.log(self,'LoadVariables');
+ sql := 'select name,value_string, value_int from tmp_report_variables where var_type=0';
+  with NidbData.GetData(sql) do
+    try
+      while not eof do
+        begin
+          NidbData.log(self,fieldbyname('name').AsString);
+          if not fieldbyname('value_string').IsNull then
+            AVariables[fieldbyname('name').AsString] := fieldbyname('value_string').AsString
+          else if not fieldbyname('value_int').IsNull then
+            AVariables[fieldbyname('name').AsString] := fieldbyname('value_int').AsInteger;
+          Next;
+        end;
+    finally
+      free;
+    end;
+  NidbData.log(self,'LoadParams');
+  sql := 'select name,value_string, value_int from tmp_report_variables where var_type=1';
+  with NidbData.GetData(sql) do
+    try
+      while not eof do
+        begin
+          NidbData.log(self,fieldbyname('name').AsString);
+          if not fieldbyname('value_string').IsNull then
+            AParam[fieldbyname('name').AsString] := fieldbyname('value_string').AsString
+          else if not fieldbyname('value_int').IsNull then
+            AParam[fieldbyname('name').AsString] := fieldbyname('value_int').AsInteger;
+          Next;
+        end;
+    finally
+      free;
+    end;
+  //
+
+  //
+  NidbData.log(self,'LoadVariables-OK');
+end;
+
+procedure TReportDM.OnMasterRecord(Sender: TObject);
+var MasterDS_Index, i, idx: integer;
+    masterDS,detailDS: TfrxDBDataset;
+    master_key_field, detail_key_field, FilterClause: string;
+    DetailDSList: TStringList;
+    q: TReportQuery;
+
+begin
+ try
+   master_key_field := '';
+   detail_key_field := '';
+   FilterClause := '';
+   masterDS := TfrxDBDataset(Sender);
+   q := TReportQuery(masterDS.Tag)  ;
+   master_key_field := q.LinkField;
+   for i := 0 to q.QueryCount-1 do
+     begin
+       detailDS := q.Queries[i].Data;
+       detail_key_field := q.Queries[i].LinkField;
+       FilterClause := GetFilterClause(detail_key_field, master_key_field, 'ID', masterDS);
+       if FilterClause <> '' then
+          begin
+           detailDS.DataSet.Filter := FilterClause;
+           detailDS.DataSet.Filtered := True;
+          end;
+     end;
+
+ except on e: Exception do
+    begin
+         NidbData.logError(self,e,'OnMasterRecord');
+         raise;
+    end;
+
+ end;
+end;
+
+procedure TReportDM.LoadReportTemplate;
+var
+  ReportStream : TMemoryStream;
+  BlobStream   : TStream;
+
+begin
+  NidbData.log(self,'ExportReport.TemplateArh');
+  ReportStream := TMemoryStream.Create;
+    try
+      with NidbData.GetData(format('select TemplateArh from xp_report where xp_rpt_id=%d',[RecordID])) do
+        try
+          BlobStream := CreateBlobStream(FieldByName('TemplateArh'), bmRead);
+          try
+            UnpackReport(BlobStream, ReportStream,AbUnZipper1);
+          finally
+            BlobStream.Free;
+          end;
+
+        finally
+          free;
+        end;
+      if ReportStream.Size > 0 then
+      begin
+        ReportStream.Position := 0;
+        try
+        frxReport.LoadFromStream(ReportStream);
+
+        except on e: Exception do
+          begin
+                  NidbData.logError(self,e,'frxReport.LoadFromStream');
+                  raise;
+          end;
+        end;
+      end;
+    finally
+      ReportStream.Free;
+    end;  // try
+end;
+
+procedure TReportDM.CopyReportVariables(AVariables, AParam: TxpMemParamManager);
+var
+  i: integer;
+  v: variant;
+begin
+  NidbData.log(self,'CopyReportVariables');
+  for I := Low(AVariables.Params) to High(AVariables.Params) do
+      begin
+      if VarIsStr(AVariables.Params[i][1]) then
+        v := maskFRSpecial(VarToStr(AVariables.Params[i][1]))
+      else
+         v:= AVariables.Params[i][1];
+      frxReport.Variables[AVariables.Params[i][0]] := v;
+      end;
+  for I := Low(AParam.Params) to High(AParam.Params) do
+      begin
+      if VarIsStr(AParam.Params[i][1]) then
+        v := maskFRSpecialPreservingEOLs(VarToStr(AParam.Params[i][1]))
+      else
+        v := AParam.Params[i][1];
+      frxReport.Variables[AParam.Params[i][0]] := v;
+      end;
+
+end;
+
+
+
+procedure TReportDM.ExportReport(ExportType: TExportFileType; Data: TStream;
+  OnStage: TLogger);
+var
+  I            : Integer;
+  flt          : TfrxCustomExportFilter;
+  v            : Variant;
+  AVariables, AParam: TxpMemParamManager;
+begin
+ frxReport.EngineOptions.EnableThreadSafe:=true;
+ NidbData.log(self,'ExportReport');
+  ReportQueries := TReportQuery.Create;
+  AVariables := TxpMemParamManager.Create;
+  AParam := TxpMemParamManager.Create;
+  try
+    if assigned(OnStage) then
+      OnStage(self,'список запросов');
+    LoadQueries;
+    LoadDefaultVariables(AVariables);
+    LoadLogos(AVariables);
+    LoadVariables(AVariables,AParam);
+    frxReport.EngineOptions.DestroyForms := False;
+    // Создаём источники данных
+    if assigned(OnStage) then
+      OnStage(self,'подготовка данных');
+
+    CreateDBDataSet(ReportQueries);
+    if assigned(OnStage) then
+      OnStage(self,'загрузка шаблона');
+
+    LoadReportTemplate;
+    CopyReportVariables(AVariables,AParam);
+    TxpFRFunctions.SetReport(NidbData,AVariables);
+    NidbData.log(self,'preparing');
+    if assigned(OnStage) then
+      OnStage(self,'формирование отчета');
+
+    begin
+    try
+      frxReport.PrepareReport(False);
+      frxReport.OnPreview := @frxReportPreview;
+
+    except on e: Exception do
+      begin
+      NidbData.logError(self,e,'frxReport.PrepareReport');
+      raise;
+      end;
+    end;
+
+      case ExportType of
+        ftPDF:  flt := TfrxPDFExport.Create(self);
+        ftRTF:  flt := TfrxODTExport.Create(self);
+        ftXLS:  flt := TfrxODSExport.Create(self);
+      end;
+      try
+        if assigned(OnStage) then
+          OnStage(self,'выгрузка');
+
+        NidbData.log(self,'exporting');
+        flt.ShowDialog := false;
+        flt.Stream := Data;
+        flt.FileName:='';
+        flt.ShowProgress := false;
+        try
+        frxReport.Export(flt);
+
+         except on e: Exception do
+            begin
+            NidbData.logError(self,e,'frxReport.Export');
+            raise;
+            end;
+          end;
+      finally
+        flt.Free;
+      end;
+    end;
+    //FreeContainer;
+  finally
+    ReportQueries.Free;
+    AVariables.Free;
+    AParam.Free;
+  end;
+  NidbData.log(self,'Report complete');
+end;
+
+
+end.
+

tcpclient.pas

@@ -0,0 +1,111 @@
+unit tcpClient;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, tcpthreadhelper, extTypes;
+type
+  { TClientMainThread }
+  TRequestComplete=function(Sender: TMainThread; const mode: byte;
+    const Code:DWORD; const QValue: QWORD; const Answer: string; const Values: TStrings; const iValues: TParamArray; const Data: TStream): boolean of object;
+  TClientMainThread=class(TMainThread)
+    private
+    fHost: string;
+    fData: TStream;
+    fFields: TStrings;
+    fCommand: string;
+    fOnComplete: TRequestComplete;
+    public
+    property Host: string read fHost;
+    property Command: string read fCommand write fCommand;
+    constructor Create(ACommand: string; AFields: TStrings;  ALogger: TLogger;AHost: string; APort: integer; OnReceive:TRequestComplete);
+    destructor Destroy; override;
+    procedure execute; override;
+    procedure ProcessConnect(thread: TConnectionThread); override;
+    procedure ProcessAnswer(const mode: byte; const Code:DWORD; const QValue: QWORD; const Answer: string; const Values: TStrings; const iValues: TParamArray; const Data: TStream);
+  end;
+
+  { TClientThread }
+
+  TClientThread=class(TConnectionThread)
+  public
+    class function Role: string; override;
+    procedure ProcessMessage(const mode: byte; const Code:DWORD; const Param:QWord; const ACommand: string;const Values: TStrings; const intData: TParamArray; const Data: TStream); override;
+  end;
+
+implementation
+constructor TClientMainThread.Create(ACommand: string; AFields: TStrings;
+  ALogger: TLogger; AHost: string; APort: integer; OnReceive: TRequestComplete);
+begin
+  inherited Create(TClientThread,ALogger,APort);
+  FreeOnTerminate:=true;
+  fOnComplete:=onReceive;
+  Connect.OnConnect:=@doConnect;
+  fCommand := ACommand;
+  fFields := TStringList.Create;
+  if assigned(AFields) then
+    fFields.assign(AFields);
+  fHost := AHost;
+end;
+
+destructor TClientMainThread.Destroy;
+begin
+  log(self,'destroy');
+  Connect.Disconnect();
+  fFields.Free;
+  inherited Destroy;
+end;
+
+procedure TClientMainThread.execute;
+begin
+  log(self,'start main thread');
+  Connect.Connect(Host,Port);
+  while not terminated do
+    begin
+    Connect.CallAction;
+    sleep(10);
+    end;
+  Connect.Disconnect();
+  log(self,'terminated');
+end;
+
+procedure TClientMainThread.ProcessConnect(thread: TConnectionThread);
+begin
+  thread.SendMessage(cmdRequest,0,0,self.Command,self.fFields);
+end;
+
+procedure TClientMainThread.ProcessAnswer(const mode: byte; const Code: DWORD;
+  const QValue: QWORD; const Answer: string; const Values: TStrings;
+  const iValues: TParamArray; const Data: TStream);
+begin
+  try
+  if assigned(fOnComplete) then
+    fOnComplete(self,mode,code,qValue,Answer,Values,iValues,Data);
+
+  except on e:Exception do
+    begin
+      log(self,'!!ERROR  ProcessAnswer '+e.message);
+      raise;
+    end;
+  end;
+end;
+
+class function TClientThread.Role: string;
+begin
+  result := 'CLIENT';
+end;
+
+procedure TClientThread.ProcessMessage(const mode: byte; const Code: DWORD;
+  const Param: QWord; const ACommand: string; const Values: TStrings;
+  const intData: TParamArray; const Data: TStream);
+begin
+  log(format('ProcessMessage(%d) Param=%x, Answer=%s ',[code,Param,ACommand]));
+  terminate;
+  Owner.Terminate;
+  (Owner as TClientMainThread).ProcessAnswer(mode,code,Param,ACommand,Values,intData,Data);
+end;
+
+end.
+

tcpserver.pas

@@ -0,0 +1,134 @@
+unit tcpserver;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, tcpthreadhelper, extTypes;
+type
+  { TServerThread }
+
+  TServerThread=class(TConnectionThread)
+    class function Role: string; override;
+    procedure ProcessMessage(const mode: byte; const Code:DWORD; const Param:QWord; const ACommand: string;const Values: TStrings; const intData: TParamArray; const Data: TStream); override;
+  end;
+
+  { TServerMainThread }
+  TCommandReceived=function(Sender: TMainThread;
+    const CommandID:DWORD; const Param:QWord; const ACommand: string; const Fields: TStrings; const iParams: TParamArray;  const Data: TStream;
+    out Code: DWORD; out RetValue: QWord; out Answer: string; out rValues: TStrings; out iValues: TParamArray; out ByteData: TStream ): boolean of object;
+
+  TServerMainThread=class(TMainThread)
+    private
+    fOnReceive: TCommandReceived;
+    fOnIdle: TNotifyEvent;
+    function processReceive(const CommandID:DWORD; const Param:QWord; const ACommand: string; const Fields: TStrings; const iParams: TParamArray;  const Data: TStream;
+    out Code: DWORD; out RetValue: QWord; out Answer: string; out rValues: TStrings; out iValues: TParamArray; out ByteData: TStream): boolean;
+    public
+    property OnIdle: TNotifyEvent read fOnIdle write fOnIdle;
+    procedure execute; override;
+    constructor Create( ALogger: TLogger; APort: integer; OnReceive:TCommandReceived);
+  end;
+
+implementation
+  { TServerMainThread }
+
+function TServerMainThread.processReceive(const CommandID: DWORD;
+  const Param: QWord; const ACommand: string; const Fields: TStrings;
+  const iParams: TParamArray; const Data: TStream; out Code: DWORD; out
+  RetValue: QWord; out Answer: string; out rValues: TStrings; out
+  iValues: TParamArray; out ByteData: TStream): boolean;
+begin
+  log(self,'ProcessReceive '+ACommand);
+  if assigned(fOnReceive) then
+    result := fOnReceive(self,CommandID,Param,ACommand,Fields,IParams,Data,Code,RetValue,Answer,rValues,iValues,ByteData)
+  else
+    begin
+      log(self,'Processor not assigned');
+      result := false;
+      Code := ErrorProcessor;
+      RetValue := 0;
+      Answer := 'Server error';
+      rValues := nil;
+      setLength(iValues,0);
+      ByteData := nil;
+    end;
+end;
+
+procedure TServerMainThread.execute;
+var
+  n: integer;
+begin
+  log(self,'start main thread');
+  Connect.Listen(Port);
+  n := 0;
+  while not terminated do
+    begin
+      try
+      Connect.CallAction;
+
+      except on e: Exception do
+        log(e, '!!ERROR '+e.message);
+      end;
+      sleep(10);
+      inc(n);
+      if n>100 then
+        begin
+          if Assigned(fOnIdle) then fOnIdle(self);
+          n :=0;
+        end;
+      inc(n);
+    end;
+end;
+
+constructor TServerMainThread.Create(ALogger: TLogger; APort: integer;
+  OnReceive: TCommandReceived);
+begin
+  inherited Create(TServerThread,ALogger,APort);
+  fOnReceive := OnReceive;
+  Connect.OnAccept:=@Accept;
+  //FreeOnTerminate:=true;
+end;
+{ TServerThread }
+
+class function TServerThread.Role: string;
+begin
+  result := 'SERVER';
+end;
+
+procedure TServerThread.ProcessMessage(const mode: byte; const Code: DWORD;
+  const Param: QWord; const ACommand: string; const Values: TStrings;
+  const intData: TParamArray; const Data: TStream);
+var
+  s: string;
+  Vals: TStrings;
+  B: TStream;
+  res: DWORD;
+  rVal: QWord;
+  iVals: TParamArray;
+  ok: boolean;
+begin
+  log(format('ProcessMessage(%d) Param=%x, Command %s ',[code,Param,ACommand]));
+  try
+  ok := (Owner as TServerMainThread).ProcessReceive(Code,Param,ACommand,Values,IntData,Data,res,rVal,s,Vals,iVals,B);
+  try
+        if OK then
+          SendMessage(cmdAnswer,res,rVal, s,Vals,iVals,B)
+        else
+          SendMessage(cmdError,res,rVal,s,Vals);
+  finally
+    if Assigned(Vals) then Vals.Free;
+    if Assigned(B) then B.Free;
+  end;
+
+  except on e:Exception do
+    begin
+      log('!!ERROR ProcessMessage '+e.message);
+      raise;
+    end;
+  end;
+end;
+
+end.
+

xpReportUtil.pas

@@ -0,0 +1,127 @@
+unit xpReportUtil;
+
+interface
+
+uses Classes, AbUnzper,AbZipper;
+
+procedure PackReport(SrcStream, DestStream : TStream; Zipper: TAbZipper);
+procedure UnpackReport(SrcStream, DestStream : TStream; UnZipper: TAbUnZipper);
+
+implementation
+
+uses zipper,sysutils, ABUtils, LazUTF8;
+type
+
+	{ TZipTool }
+
+  TZipTool=class
+    private
+				fSrcStream: TStream;
+      fSrcStrean,
+      fDstStream: TStream;
+    public
+      constructor Create(ASourceStream,ADestStream: TStream);
+      Procedure getSource(Sender: TObject; var AStream: TStream);
+      Procedure getDest(Sender : TObject; var AStream : TStream; AItem : TFullZipFileEntry);
+      Procedure closeSource(Sender: TObject; var AStream: TStream);
+      Procedure doneDest(Sender : TObject; var AStream : TStream; AItem : TFullZipFileEntry);
+      Procedure endFile(Sender : TObject; Const Ratio : Double);
+      Procedure progress(Sender : TObject; Const Pct : Double);
+      property SourceStream: TStream read fSrcStream;
+      property DestStream:TStream read fDstStream;
+	end;
+
+procedure UnpackReport(SrcStream, DestStream : TStream; UnZipper: TAbUnZipper);
+var
+  rptCode: TStringList;
+  i: integer;
+  tmp: TStream;
+begin
+  if SrcStream.Size > 0 then
+  begin
+    tmp := TMemoryStream.Create;
+    rptCode := TStringList.Create;
+    try
+      UnZipper.Stream := SrcStream;
+      UnZipper.ArchiveType := atZip;
+      UnZipper.ForceType := true;
+      UnZipper.ExtractToStream('Q.Q',tmp);
+
+      tmp.Seek(0,soFromBeginning);
+      rptCode.LoadFromStream(tmp);
+      // автозамена шрифтов
+      for i := 0 to rptCode.Count-1 do
+        begin
+          {$IFDEF LINUX}
+          rptCode[i] := UTF8StringReplace(rptCode[i],'Font.Name="Times New Roman"','Font.Name="PT Astra Serif"',[]);
+          rptCode[i] := UTF8StringReplace(rptCode[i],'Font.Name="Arial"','Font.Name="Liberation Sans"',[]);
+          rptCode[i] := UTF8StringReplace(rptCode[i],'Rotation="90"','Rotation="90" Wysiwyg="0"',[]);
+          rptCode[i] := UTF8StringReplace(rptCode[i],'Wysiwyg="0" Wysiwyg="0"','Wysiwyg="0"',[]);
+          rptCode[i] := UTF8StringReplace(rptCode[i],'Rotation="90" Wysiwyg="0" Wysiwyg="1"','Rotation="90" Wysiwyg="0"',[]);
+          {$ELSE}
+          rptCode[i] := UTF8StringReplace(rptCode[i],'Font.Name="PT Astra Serif"','Font.Name="Times New Roman"',[]);
+          rptCode[i] := UTF8StringReplace(rptCode[i],'Font.Name="Liberation Sans"','Font.Name="Arial"',[]);
+          {$ENDIF}
+        end;
+      rptCode.SaveToStream(DestStream);
+
+    finally
+      rptCode.Free;
+      tmp.Free;
+    end;
+
+  end;  // if
+
+end;
+
+procedure PackReport(SrcStream, DestStream : TStream; Zipper: TAbZipper);
+begin
+  zipper.FileName := '';
+  zipper.ArchiveType := atZip;
+  zipper.ForceType := true;
+
+
+  zipper.Stream := DestStream;
+  zipper.AddFromStream('Q.Q',SrcStream);
+
+  zipper.Save;
+end;
+
+{ TZipTool }
+
+constructor TZipTool.Create(ASourceStream, ADestStream: TStream);
+begin
+    inherited Create;
+    fSrcStream := ASourceStream;
+    fDstStream := ADestStream;
+end;
+
+procedure TZipTool.getSource(Sender: TObject; var AStream: TStream);
+begin
+  AStream := fSrcStream;
+end;
+
+procedure TZipTool.getDest(Sender: TObject; var AStream: TStream;
+		AItem: TFullZipFileEntry);
+begin
+  AStream := fDstStream;
+end;
+
+procedure TZipTool.closeSource(Sender: TObject; var AStream: TStream);
+begin
+end;
+
+procedure TZipTool.doneDest(Sender: TObject; var AStream: TStream;
+		AItem: TFullZipFileEntry);
+begin
+end;
+
+procedure TZipTool.endFile(Sender: TObject; const Ratio: Double);
+begin
+end;
+
+procedure TZipTool.progress(Sender: TObject; const Pct: Double);
+begin
+end;
+
+end.

xpaccessunit.pas

@@ -0,0 +1,43 @@
+unit xpAccessUnit;
+{$H+}
+interface
+
+  function EncryptText(const AText: String) : String;
+  function MySQLPassword(const AText: Ansistring) : Ansistring;
+implementation
+
+uses
+  SysUtils,
+  Variants, DCPsha1, DCPdes,
+  ConnectionsDmUnit;
+
+
+function DecryptText(const AText: string) : string;
+begin
+  Result := AText;
+end;
+function EncryptText(const AText: String) : String;
+begin
+  Result := String(MySQLPassword(AnsiString(StringReplace(AText, '\', '\\', [rfReplaceAll, rfIgnoreCase]))));
+end;
+
+
+function MySQLPassword(const AText: Ansistring) : Ansistring;
+var
+  Digest: packed array[0..19] of byte;
+  i: integer;
+begin
+  Result := '*';
+  ConnectionsDM.Hash.Init;
+  ConnectionsDM.Hash.UpdateStr(AText);
+  ConnectionsDM.Hash.Final(Digest);
+  ConnectionsDM.Hash.Burn;
+  ConnectionsDM.Hash.Init;
+  ConnectionsDM.Hash.Update(Digest,20);
+  ConnectionsDM.Hash.Final(Digest);
+  ConnectionsDM.Hash.Burn;
+  for i:= 0 to 19 do
+    Result := Result + AnsiString(IntToHex(Digest[i], 2));
+end;
+
+end.

xpmemparammanagerunit.pas

@@ -0,0 +1,141 @@
+unit xpMemParamManagerUnit;
+
+interface
+
+uses
+   Messages, SysUtils, Variants, Classes;
+//  xpConst;
+const
+  sFRBreak = #13#10;
+type
+
+  ParamRow = array[0..1] of Variant;
+  TParamArray = array of ParamRow;
+
+  { TxpMemParamManager }
+
+  TxpMemParamManager = class(TObject)
+  private
+    ParamArray: TParamArray;
+    function GetValue(ParamName: Variant): Variant;
+    procedure SetValue(ParamName: Variant; const Value: Variant);
+
+  public
+    constructor Create;
+    destructor Destroy; override;
+    function IndexOf(const ParamName : string) : Integer;
+    function Count: Integer;
+    function ListAllParamsAndValues: string;
+    procedure Delete(ParamName: Variant);
+    property Params: TParamArray read ParamArray;
+    property Values[ParamName: Variant]: Variant read GetValue write SetValue; default;
+    procedure Assign(OwnerParam: TxpMemParamManager);
+
+  end;
+
+implementation
+uses
+   lazUTF8;
+procedure TxpMemParamManager.Assign(OwnerParam: TxpMemParamManager);
+var
+  i: Integer;
+begin
+  if OwnerParam = nil then
+    Exit;
+  if Length(OwnerParam.ParamArray) > 0 then
+    for i:= Low(OwnerParam.ParamArray) to High(OwnerParam.ParamArray) do
+      Values[OwnerParam.ParamArray[i][0]] := OwnerParam.ParamArray[i][1]
+end;
+
+constructor TxpMemParamManager.Create;
+begin
+  inherited Create;
+  ParamArray := nil;
+end;
+
+destructor TxpMemParamManager.Destroy;
+begin
+  ParamArray := nil;
+  inherited;
+end;
+
+function TxpMemParamManager.GetValue(ParamName: Variant): Variant;
+var
+  i: Integer;
+begin
+  for i:= Low(ParamArray) to High(ParamArray) do
+    if AnsiSameText(ParamArray[i][0], ParamName) then
+    begin
+      Result := ParamArray[i][1];
+      Exit;
+    end;
+  raise Exception.Create('Не найден параметр ' + VarToStr(ParamName));
+end;
+
+function TxpMemParamManager.IndexOf(const ParamName: string): Integer;
+var
+  i : Integer;
+begin
+  Result := -1;
+  for i := Low(ParamArray) to High(ParamArray) do
+  begin
+    if AnsiSameText(ParamArray[i][0], ParamName) then
+    begin
+      Result := i;
+      Exit;
+    end;
+  end;
+end;
+
+function TxpMemParamManager.Count: Integer;
+begin
+  result := High(ParamArray) + 1;
+end;
+
+function TxpMemParamManager.ListAllParamsAndValues: string;
+var
+  i: integer;
+begin
+  Result := '';
+  for i := 0 to (self.Count - 1) do
+    Result := Result + IntToStr(i) + ': '#39 + VarToStr(self.Params[i][0]) + #39' = '#39 + VarToStr(self.Params[i][1]) + #39'.' + sLineBreak;
+end;
+
+procedure TxpMemParamManager.SetValue(ParamName: Variant; const Value: Variant);
+var
+  i,j: Integer;
+  strVal: string;
+  v: variant;
+begin
+  if VarIsStr(Value) then
+    begin
+      v := utf8trim(Value);
+    end
+  else
+    v := Value;
+  for i:= Low(ParamArray) to High(ParamArray) do
+    if AnsiSameText(ParamArray[i][0], ParamName) then
+    begin
+      ParamArray[i][1] := v;
+      Exit;
+    end;
+  SetLength(ParamArray, Length(ParamArray) + 1);
+  ParamArray[High(ParamArray)][0] := ParamName;
+  ParamArray[High(ParamArray)][1] := v;
+end;
+
+
+procedure TxpMemParamManager.Delete(ParamName: Variant);
+var
+  i: Integer;
+begin
+  for i:= Low(ParamArray) to High(ParamArray) do
+    if AnsiSameText(ParamArray[i][0], ParamName) then
+    begin
+      ParamArray[i][0] := '';
+      Exit;
+    end;
+end;
+
+end.
+

xputilunit.pas

@@ -0,0 +1,69 @@
+unit xpUtilUnit;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils;
+function inArrayPos(const value: string; const checkList: array of string; ignoreCase: boolean): integer;
+// проверяет содержится ли строка в массиве
+function inArray(const value: string; const checkList: array of string; ignoreCase: boolean): boolean;
+// находит индекс числа в массиве
+function inArrayPosN(const value: integer; const checkList: array of integer): integer;
+// проверяет содержится ли число в массиве
+function inArrayN(const value: integer; const checkList: array of integer): boolean;
+
+implementation
+uses
+  lazUTF8;
+function inArrayPos(const value: string; const checkList: array of string;
+  ignoreCase: boolean): integer;
+var
+  i: integer;
+  s1,s2: string;
+begin
+  result := -1;
+
+  if ignoreCase  then
+    s1 := UTF8UpperString(value)
+  else
+    s1 := value;
+  for I := Low(checkList) to High(checkList) do
+   begin
+     if ignoreCase  then
+        s2 := UTF8UpperString(checklist[i])
+     else
+        s2 := checklist[i];
+     if SameStr(s1, s2) then
+      exit(I);
+   end;
+end;
+
+
+function inArray(const value: string; const checkList: array of string;
+  ignoreCase: boolean): boolean;
+begin
+  result := inArrayPos(value, checkList, ignoreCase)>=0;
+end;
+
+function inArrayPosN(const value: integer; const checkList: array of integer
+  ): integer;
+var
+  i: integer;
+begin
+  result := -1;
+  for I := Low(checkList) to High(checkList) do
+    if value = checkList[i] then
+      exit(I);
+end;
+
+
+function inArrayN(const value: integer; const checkList: array of integer
+  ): boolean;
+begin
+  result := inArrayPosN(value, checkList)>=0;
+end;
+
+end.
+