Первая версия
This commit is contained in:
Алексей Заблоцкий
parent
d64060cffb
commit
d6ad951e55
2
.gitignore
vendored
2
.gitignore
vendored
@ -26,7 +26,7 @@
|
||||
backup/
|
||||
*.bak
|
||||
lib/
|
||||
|
||||
out/
|
||||
# Application bundle for Mac OS
|
||||
*.app/
|
||||
|
||||
|
||||
422
baseconnection.pas
Normal file
422
baseconnection.pas
Normal file
@ -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.
|
||||
|
||||
8
cgi_daemon.lfm
Normal file
8
cgi_daemon.lfm
Normal file
@ -0,0 +1,8 @@
|
||||
object LMSReportCGI: TLMSReportCGI
|
||||
OldCreateOrder = False
|
||||
OnStart = DataModuleStart
|
||||
Height = 150
|
||||
HorizontalOffset = 840
|
||||
VerticalOffset = 384
|
||||
Width = 445
|
||||
end
|
||||
67
cgi_daemon.pas
Normal file
67
cgi_daemon.pas
Normal file
@ -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.
|
||||
|
||||
20
cgi_mapper.lfm
Normal file
20
cgi_mapper.lfm
Normal file
@ -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
|
||||
34
cgi_mapper.pas
Normal file
34
cgi_mapper.pas
Normal file
@ -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.
|
||||
|
||||
13
cgicommand.pas
Normal file
13
cgicommand.pas
Normal file
@ -0,0 +1,13 @@
|
||||
unit cgiCommand;
|
||||
|
||||
{$mode ObjFPC}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils;
|
||||
|
||||
implementation
|
||||
|
||||
end.
|
||||
|
||||
38
cgidm.lfm
Normal file
38
cgidm.lfm
Normal file
@ -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
|
||||
363
cgidm.pas
Normal file
363
cgidm.pas
Normal file
@ -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.
|
||||
|
||||
329
cgireport.pas
Normal file
329
cgireport.pas
Normal file
@ -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.
|
||||
|
||||
32
connectionsdmunit.lfm
Normal file
32
connectionsdmunit.lfm
Normal file
@ -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
|
||||
538
connectionsdmunit.pas
Normal file
538
connectionsdmunit.pas
Normal file
@ -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.
|
||||
|
||||
422
exttypes.pas
Normal file
422
exttypes.pas
Normal file
@ -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.
|
||||
|
||||
91
fr_utils.pas
Normal file
91
fr_utils.pas
Normal file
@ -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.
|
||||
108
lms_cgi.lpi
Normal file
108
lms_cgi.lpi
Normal file
@ -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>
|
||||
166
lms_cgi.lpr
Normal file
166
lms_cgi.lpr
Normal file
@ -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.
|
||||
BIN
lmsreport.ico
Normal file
BIN
lmsreport.ico
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 130 KiB |
7
lmsreport.ini
Normal file
7
lmsreport.ini
Normal file
@ -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
|
||||
161
lmsreport.lpi
Normal file
161
lmsreport.lpi
Normal file
@ -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>
|
||||
38
lmsreport.lpr
Normal file
38
lmsreport.lpr
Normal file
@ -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.
|
||||
|
||||
146
maintcpserver.lfm
Normal file
146
maintcpserver.lfm
Normal file
@ -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
|
||||
182
maintcpserver.pas
Normal file
182
maintcpserver.pas
Normal file
@ -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.
|
||||
|
||||
464
numberinwords.pas
Normal file
464
numberinwords.pas
Normal file
@ -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.
|
||||
94
reportdmunit.lfm
Normal file
94
reportdmunit.lfm
Normal file
@ -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
|
||||
693
reportdmunit.pas
Normal file
693
reportdmunit.pas
Normal file
@ -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.
|
||||
|
||||
111
tcpclient.pas
Normal file
111
tcpclient.pas
Normal file
@ -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.
|
||||
|
||||
134
tcpserver.pas
Normal file
134
tcpserver.pas
Normal file
@ -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.
|
||||
|
||||
1047
tcpthreadhelper.pas
Normal file
1047
tcpthreadhelper.pas
Normal file
File diff suppressed because it is too large
Load Diff
127
xpReportUtil.pas
Normal file
127
xpReportUtil.pas
Normal file
@ -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.
|
||||
43
xpaccessunit.pas
Normal file
43
xpaccessunit.pas
Normal file
@ -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.
|
||||
141
xpmemparammanagerunit.pas
Normal file
141
xpmemparammanagerunit.pas
Normal file
@ -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.
|
||||
|
||||
69
xputilunit.pas
Normal file
69
xputilunit.pas
Normal file
@ -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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user