buffer-fix
This commit is contained in:
Алексей Заблоцкий
parent
42b89fe6e9
commit
ac9caf456f
@ -24,6 +24,8 @@ type
|
||||
fisDone,fisFinished: boolean;
|
||||
fIsError: boolean;
|
||||
fSubClass: string;
|
||||
function getInt(keyName: string;defaultValue: integer=0): integer;
|
||||
function getString(keyName: string): string;
|
||||
public
|
||||
AccessTime: TDateTime;
|
||||
|
||||
@ -51,17 +53,6 @@ type
|
||||
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
|
||||
@ -116,6 +107,8 @@ type
|
||||
end;
|
||||
|
||||
implementation
|
||||
uses
|
||||
commandcol;
|
||||
{ TBaseConnection }
|
||||
|
||||
procedure TBaseConnection.Init;
|
||||
@ -328,44 +321,19 @@ begin
|
||||
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 }
|
||||
|
||||
function TCommand.getInt(keyName: string; defaultValue: integer): integer;
|
||||
begin
|
||||
result := StrToIntDef(fResult.Keys.Values[keyName],defaultValue);
|
||||
end;
|
||||
|
||||
function TCommand.getString(KeyName: string): string;
|
||||
begin
|
||||
result := fResult.Keys.Values[KeyName];
|
||||
end;
|
||||
|
||||
constructor TCommand.Create(aConnect: TBaseConnection; ASubClass: string);
|
||||
begin
|
||||
fconnect := AConnect;
|
||||
@ -425,6 +393,5 @@ procedure TCommand.Log(ALevel: TLogLevel; msg: string);
|
||||
begin
|
||||
connect.log(ALevel,self, self.CommandID+#09+msg)
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
|
||||
@ -29,11 +29,13 @@ type
|
||||
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;
|
||||
procedure EditTemplate;
|
||||
procedure FillDefaults;
|
||||
end;
|
||||
|
||||
implementation
|
||||
uses
|
||||
cgiDM,reportDMUnit, types, strutils, LazUTF8;
|
||||
cgiDM,reportDMUnit, types, strutils, LazUTF8,allreportsunit,commandcol;
|
||||
{ TReportCommand }
|
||||
|
||||
procedure TReportCommand.CreateVariablesTable;
|
||||
@ -106,6 +108,13 @@ begin
|
||||
end;
|
||||
|
||||
procedure TReportCommand.FillVars;
|
||||
const
|
||||
Q_varlist=
|
||||
'select coalesce(v1.name,v0.name) as name,coalesce(v1.query,v0.query) as query '+
|
||||
'from xp_report_cgi c '+
|
||||
' left join xp_report_variables v0 on v0.name=any(c.variables) and v0.xp_rpt_id=0 and v0.var_type=%1:d '+
|
||||
' left join xp_report_variables v1 on v1.name=any(c.variables) and v1.xp_rpt_id=c.xp_rpt_id and v0.var_type=%1:d '+
|
||||
'where c.xp_rpt_id=%0:d and coalesce(v1.query,v0.query,'''')<>'''' ';
|
||||
var
|
||||
ASQL: string;
|
||||
q: string;
|
||||
@ -115,7 +124,7 @@ var
|
||||
begin
|
||||
log(mtDebug,'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]);
|
||||
ASQL := format(Q_varlist,[ReportID,0]);
|
||||
with connect.Processor.GetData(ASQL) do
|
||||
try
|
||||
while not eof do
|
||||
@ -136,7 +145,7 @@ begin
|
||||
finally
|
||||
free;
|
||||
end;
|
||||
ASQL := format('select name,query from xp_report_variables where xp_rpt_id=%d and var_type=1',[ReportID]);
|
||||
ASQL := format(Q_varlist,[ReportID,1]);
|
||||
with connect.Processor.GetData(ASQL) do
|
||||
try
|
||||
while not eof do
|
||||
@ -184,7 +193,7 @@ begin
|
||||
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(mtInfo,'Построение отчета '+ReportTitle);
|
||||
log(mtInfo,'Построение отчета '+ReportTitle);
|
||||
connect.ReportProcessor.RecordID:=ReportID;
|
||||
fcurrentStage := 'исполняется (подготовка)';
|
||||
try
|
||||
@ -217,7 +226,7 @@ begin
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
fResult := TCommandData.Create(0,fileData.size,ReportTitle+'.pdf',nil,[],fileData);
|
||||
fResult := TCommandData.Create(0,fileData.size,ReportTitle+'.pdf',['type=application/pdf'],[],fileData);
|
||||
fileData.Seek(0,soFromBeginning);
|
||||
result := true;
|
||||
finally
|
||||
@ -246,7 +255,7 @@ begin
|
||||
'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)]);
|
||||
[TNIDBDM.StringAsSQL(ReportName),(ids)]);
|
||||
with Connect.Processor.GetData(asql) do
|
||||
try
|
||||
if not eof then
|
||||
@ -329,8 +338,80 @@ begin
|
||||
result := true;
|
||||
end;
|
||||
|
||||
procedure TReportCommand.EditTemplate;
|
||||
begin
|
||||
CreateVariablesTable;
|
||||
log(mtInfo,'Построение отчета '+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.EditReport(@OnFillVariables);
|
||||
except on e: Exception do
|
||||
begin
|
||||
connect.Processor.LogError(self,e,'ExportReport');
|
||||
fResult := TCommandData.Create(ErrorInternal,0,'Ошибка составления',nil,[],nil);
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TReportCommand.FillDefaults;
|
||||
var
|
||||
asql: string;
|
||||
l,e: TStrings;
|
||||
begin
|
||||
asql := format(
|
||||
'select name, '+
|
||||
'case '+
|
||||
' when type IN (1,2,3,6,17) then ''0'' '+
|
||||
' when type=4 then ''2020-02-02'' '+
|
||||
' when type=5 then ''2020-02-02 20:20:02'' '+
|
||||
' when type=0 then '''' '+
|
||||
'end as value '+
|
||||
'from xp_report_params p '+
|
||||
'where p.xp_rpt_id=%d ',
|
||||
[ReportID]);
|
||||
l := TStringList.Create;
|
||||
try
|
||||
l.add('name='+ReportName);
|
||||
with Connect.Processor.GetData(asql) do
|
||||
try
|
||||
while not eof do
|
||||
begin
|
||||
l.Add(format('%s=%s',[fieldbyname('name').asString,fieldbyname('value').asString]));
|
||||
Next;
|
||||
end;
|
||||
finally
|
||||
free;
|
||||
end;
|
||||
ParseCommand(-1,0,ReportName,l,[],nil,e);
|
||||
finally
|
||||
l.free;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
Initialization
|
||||
TCommandCollection.Register(TReportCommand);
|
||||
end.
|
||||
|
||||
|
||||
64
commandcol.pas
Normal file
64
commandcol.pas
Normal file
@ -0,0 +1,64 @@
|
||||
unit commandcol;
|
||||
|
||||
{$mode ObjFPC}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils,Contnrs,baseconnection;
|
||||
type
|
||||
{ TCommandCollection }
|
||||
TCommandCollection=Class;
|
||||
TCommandCollection=Class(TClassList)
|
||||
private
|
||||
class var fCollection: TCommandCollection;
|
||||
public
|
||||
class procedure Register(ACommand: TCommandClass);
|
||||
class function Find(Action,SubClass: string): TCommandClass;
|
||||
class procedure Init;
|
||||
class procedure Done;
|
||||
end;
|
||||
|
||||
implementation
|
||||
{ TCommandCollection }
|
||||
|
||||
class procedure TCommandCollection.Register(ACommand: TCommandClass);
|
||||
begin
|
||||
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;
|
||||
initialization
|
||||
TCommandCollection.Init;
|
||||
finalization
|
||||
TCommandCollection.Done;
|
||||
|
||||
end.
|
||||
|
||||
@ -45,12 +45,14 @@ type
|
||||
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;
|
||||
property Logger: TEventLog read fLogger write fLogger;
|
||||
procedure Log(ALevel: TLogLevel; Sender: TObject; msg: string);
|
||||
procedure InitBaseCon;
|
||||
procedure Start;
|
||||
procedure Stop;
|
||||
procedure Idle(Sender: TObject);
|
||||
@ -59,6 +61,8 @@ type
|
||||
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;
|
||||
constructor CreateWithLog(ALogger: TEventLog);
|
||||
procedure FillTemplates(RepList: TStrings);
|
||||
procedure EditTemplate(ReportID: integer);
|
||||
end;
|
||||
|
||||
var
|
||||
@ -66,7 +70,7 @@ var
|
||||
|
||||
implementation
|
||||
uses
|
||||
xpUtilUnit, strutils, xpAccessUnit, inifiles;
|
||||
xpUtilUnit, strutils, xpAccessUnit, inifiles,commandcol, cgiReport;
|
||||
{$R *.lfm}
|
||||
|
||||
|
||||
@ -338,6 +342,53 @@ begin
|
||||
inherited Create(nil);
|
||||
end;
|
||||
|
||||
procedure TConnectionsDM.FillTemplates(RepList: TStrings);
|
||||
var
|
||||
asql: string;
|
||||
begin
|
||||
asql :=
|
||||
'select r.xp_rpt_id,r.name, c.cgi_name from xp_report r '+
|
||||
' join xp_report_cgi c on c.xp_rpt_id=r.xp_rpt_id '+
|
||||
'order by r.name ';
|
||||
with MainCon.GetData(asql) do
|
||||
try
|
||||
while not eof do
|
||||
begin
|
||||
RepList.AddObject(format('%s (%s)',[fieldbyname('name').asString, FieldByName('cgi_name').asString]),TObject(ptrint(fieldbyname('xp_rpt_id').asInteger)));
|
||||
next;
|
||||
end;
|
||||
finally
|
||||
free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TConnectionsDM.EditTemplate(ReportID: integer);
|
||||
var
|
||||
asql: string;
|
||||
RName: string;
|
||||
con: TBaseConnection;
|
||||
cc: TCommandClass;
|
||||
cmd: TReportCommand;
|
||||
begin
|
||||
asql := format('select cgi_name from xp_report_cgi where xp_rpt_id=%d',[ReportID]);
|
||||
RName := MainCon.QueryValue(asql);
|
||||
con := NewConnection;
|
||||
try
|
||||
cc := TCommandCollection.Find('report',RName);
|
||||
cmd := cc.Create(con,RName) as TReportCommand;
|
||||
try
|
||||
cmd.ReportID := ReportID;
|
||||
cmd.ReportName:=RName;
|
||||
cmd.FillDefaults;
|
||||
cmd.EditTemplate;
|
||||
finally
|
||||
cmd.free;
|
||||
end;
|
||||
finally
|
||||
con.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TConnectionsDM.ProcessLogin(UserName, UserPassword: string; out UserID: integer): boolean;
|
||||
var
|
||||
ASQL: string;
|
||||
@ -504,13 +555,17 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TConnectionsDM.Start;
|
||||
procedure TConnectionsDM.InitBaseCon;
|
||||
begin
|
||||
MainCon.connection.RemoteHost:=DataHost;
|
||||
MainCon.connection.RemotePort:=DataPort;
|
||||
MainCon.connection.Database:=DataBase;
|
||||
MainCon.OpenConnection;
|
||||
//Input.OnIdle:=@Idle;
|
||||
end;
|
||||
|
||||
procedure TConnectionsDM.Start;
|
||||
begin
|
||||
InitBaseCon;//Input.OnIdle:=@Idle;
|
||||
Input.Start;
|
||||
fRunning:=true;
|
||||
end;
|
||||
@ -534,9 +589,5 @@ begin
|
||||
TBaseConnection(conList[i]).SetIdle;
|
||||
end;
|
||||
|
||||
initialization
|
||||
TCommandCollection.Init;
|
||||
finalization
|
||||
TCommandCollection.Done;
|
||||
end.
|
||||
|
||||
|
||||
68
exttypes.pas
68
exttypes.pas
@ -43,8 +43,10 @@ type
|
||||
fReadReady,fWriteReady: TSimpleEvent;
|
||||
fClosed: boolean;
|
||||
cs: TCriticalSection;
|
||||
fLogger: TLogger;
|
||||
procedure log(msg: string);
|
||||
public
|
||||
constructor Create(BufferSize: integer);
|
||||
constructor Create(ALogger: TLogger; BufferSize: integer);
|
||||
destructor Destroy; override;
|
||||
function Push(const data; datasize: integer): integer;
|
||||
function Pop(var data; datasize: integer): integer;
|
||||
@ -57,6 +59,9 @@ type
|
||||
property ReadReady: TSimpleEvent read fReadReady;
|
||||
property WriteReady: TSimpleEvent read fWriteReady;
|
||||
end;
|
||||
|
||||
{ TCommandData }
|
||||
|
||||
TCommandData=class
|
||||
Code:DWORD;
|
||||
Param:QWord;
|
||||
@ -64,7 +69,8 @@ type
|
||||
Keys: TStrings;
|
||||
iValues: TParamArray;
|
||||
Data: TStream;
|
||||
constructor Create(ACode:DWORD;AParam:QWord; AName: string; AKeys: TStrings; AValues: TParamArray; AData: TStream);
|
||||
constructor Create(ACode:DWORD;AParam:QWord; AName: string; AKeys: TStrings; AValues: TParamArray; AData: TStream); overload;
|
||||
constructor Create(ACode:DWORD;AParam:QWord; AName: string;const AKeys: Array of string; AValues: TParamArray; AData: TStream); overload;
|
||||
destructor Destroy; override;
|
||||
procedure AssignTo(out ACode:DWORD;out AParam:QWord; out AName: string; out AKeys: TStrings; out AValues: TParamArray; out AData: TStream);
|
||||
end;
|
||||
@ -160,10 +166,15 @@ end;
|
||||
|
||||
{ TRoundBuffer }
|
||||
|
||||
procedure TRoundBuffer.log(msg: string);
|
||||
begin
|
||||
{$IFDEF DEBUG} if assigned(fLogger) then fLogger(mtExtra,self,msg); {$ENDIF}
|
||||
end;
|
||||
|
||||
constructor TRoundBuffer.Create(BufferSize: integer);
|
||||
constructor TRoundBuffer.Create(ALogger: TLogger; BufferSize: integer);
|
||||
begin
|
||||
inherited Create;
|
||||
flogger := ALogger;
|
||||
cs := TCriticalSection.Create;
|
||||
SetLength(self.intdata,BufferSize);
|
||||
fSize:=BufferSize;
|
||||
@ -203,6 +214,7 @@ begin
|
||||
fWriteReady.WaitFor(INFINITE);
|
||||
if fClosed then exit;
|
||||
delta := 0;
|
||||
log(format('Push size=%d, R=%d, W=%d ',[fDataSize,ptrRead,ptrWrite]));
|
||||
while not fClosed and (rem>0) and (fDataSize+delta<fSize) do
|
||||
begin
|
||||
intData[i] := p^;
|
||||
@ -212,14 +224,19 @@ begin
|
||||
dec(rem);
|
||||
inc(delta);
|
||||
end;
|
||||
|
||||
cs.Enter;
|
||||
ptrWrite := i;
|
||||
inc(fDataSize,delta);
|
||||
if fDataSize=fSize then
|
||||
begin
|
||||
fWriteReady.ResetEvent;
|
||||
log('buffer full');
|
||||
end;
|
||||
cs.Leave;
|
||||
|
||||
result := datasize-rem;
|
||||
result := delta;
|
||||
log(format('Push %d bytes size=%d',[result,fDataSize]));
|
||||
fReadReady.SetEvent;
|
||||
end;
|
||||
|
||||
@ -233,30 +250,35 @@ begin
|
||||
result := 0;
|
||||
if datasize<=0 then exit;
|
||||
if fClosed then exit;
|
||||
if fDataSize<=0 then
|
||||
fReadReady.WaitFor(INFINITE);
|
||||
if fClosed then exit;
|
||||
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
|
||||
delta := 0;
|
||||
log(format('Pop size=%d, R=%d, W=%d ',[fDataSize,ptrRead,ptrWrite]));
|
||||
while not fClosed and (rem>0) and (fDataSize-delta>0) do
|
||||
begin
|
||||
p^:=intData[i];
|
||||
s := s + inttohex(intData[i],2)+' ';
|
||||
inc(p);
|
||||
i := (i+1) mod fSize;
|
||||
dec(delta);
|
||||
inc(delta);
|
||||
dec(rem);
|
||||
end;
|
||||
cs.Enter;
|
||||
ptrRead := i;
|
||||
fDataSize:=delta;
|
||||
dec(fDataSize,delta);
|
||||
if fDataSize=0 then
|
||||
begin
|
||||
fReadReady.ResetEvent;
|
||||
log('buffer empty');
|
||||
end;
|
||||
cs.Leave;
|
||||
result := datasize-rem;
|
||||
result := delta;
|
||||
log(format('Pop %d bytes size=%d',[result,fDataSize]));
|
||||
fWriteReady.SetEvent;
|
||||
end;
|
||||
|
||||
@ -281,6 +303,7 @@ begin
|
||||
begin
|
||||
result := -1;
|
||||
fReadReady.SetEvent;
|
||||
fWriteReady.SetEvent;
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -384,6 +407,27 @@ begin
|
||||
Data := nil;
|
||||
end;
|
||||
|
||||
constructor TCommandData.Create(ACode: DWORD; AParam: QWord; AName: string;
|
||||
const AKeys: array of string; AValues: TParamArray; AData: TStream);
|
||||
var
|
||||
l: TStrings;
|
||||
i: integer;
|
||||
begin
|
||||
if length(AKeys)=0 then
|
||||
Create(ACode,AParam,AName,nil,AValues,AData)
|
||||
else
|
||||
begin
|
||||
l := TStringList.Create;
|
||||
try
|
||||
for i := low(AKeys) to high(AKeys) do
|
||||
l.add(AKeys[i]);
|
||||
Create(ACode,AParam,AName,l,AValues,AData)
|
||||
finally
|
||||
l.free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TCommandData.Destroy;
|
||||
begin
|
||||
if assigned(Keys) then Keys.Free;
|
||||
|
||||
BIN
lms_cgi.obj
Normal file
BIN
lms_cgi.obj
Normal file
Binary file not shown.
@ -125,6 +125,18 @@
|
||||
<Filename Value="baseconnection.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit>
|
||||
<Unit>
|
||||
<Filename Value="reports\applicantresult.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit>
|
||||
<Unit>
|
||||
<Filename Value="reports\allreportsunit.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit>
|
||||
<Unit>
|
||||
<Filename Value="commandcol.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
@ -135,6 +147,7 @@
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<OtherUnitFiles Value="reports"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Linking>
|
||||
|
||||
@ -10,9 +10,10 @@ uses
|
||||
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
|
||||
sysutils, Forms, abbrevia, lnetbase,commandcol,baseconnection, MainTcpServer, tcpthreadhelper,
|
||||
reportDMUnit, ConnectionsDmUnit, cgiDM, xpAccessUnit, extTypes, tcpserver,
|
||||
tcpClient, cgiReport, cgiCommand, fr_utils, applicantresult,
|
||||
allreportsunit
|
||||
{ you can add units after this };
|
||||
|
||||
{$R *.res}
|
||||
|
||||
@ -1,14 +1,14 @@
|
||||
object CGIServerGUI: TCGIServerGUI
|
||||
Left = 333
|
||||
Height = 309
|
||||
Height = 566
|
||||
Top = 224
|
||||
Width = 870
|
||||
Caption = 'Сервер отчетов LMS'
|
||||
ClientHeight = 309
|
||||
ClientHeight = 566
|
||||
ClientWidth = 870
|
||||
OnCreate = FormCreate
|
||||
OnDestroy = FormDestroy
|
||||
LCLVersion = '2.2.0.4'
|
||||
LCLVersion = '2.2.4.0'
|
||||
object Panel1: TPanel
|
||||
Left = 0
|
||||
Height = 50
|
||||
@ -40,19 +40,19 @@ object CGIServerGUI: TCGIServerGUI
|
||||
end
|
||||
object GroupBox1: TGroupBox
|
||||
Left = 0
|
||||
Height = 259
|
||||
Height = 246
|
||||
Top = 50
|
||||
Width = 368
|
||||
Align = alLeft
|
||||
Caption = 'Запрос'
|
||||
ClientHeight = 240
|
||||
ClientWidth = 366
|
||||
ClientHeight = 226
|
||||
ClientWidth = 364
|
||||
TabOrder = 1
|
||||
object Keys: TMemo
|
||||
Left = 0
|
||||
Height = 210
|
||||
Top = 30
|
||||
Width = 366
|
||||
Height = 203
|
||||
Top = 23
|
||||
Width = 364
|
||||
Align = alClient
|
||||
Lines.Strings = (
|
||||
'user=nnz'
|
||||
@ -62,11 +62,11 @@ object CGIServerGUI: TCGIServerGUI
|
||||
end
|
||||
object edtRequest: TComboBox
|
||||
Left = 0
|
||||
Height = 30
|
||||
Height = 23
|
||||
Top = 0
|
||||
Width = 366
|
||||
Width = 364
|
||||
Align = alTop
|
||||
ItemHeight = 0
|
||||
ItemHeight = 15
|
||||
ItemIndex = 3
|
||||
Items.Strings = (
|
||||
'version'
|
||||
@ -86,46 +86,46 @@ object CGIServerGUI: TCGIServerGUI
|
||||
end
|
||||
object GroupBox2: TGroupBox
|
||||
Left = 373
|
||||
Height = 259
|
||||
Height = 246
|
||||
Top = 50
|
||||
Width = 497
|
||||
Align = alClient
|
||||
Caption = 'Ответ'
|
||||
ClientHeight = 240
|
||||
ClientWidth = 495
|
||||
ClientHeight = 226
|
||||
ClientWidth = 493
|
||||
TabOrder = 2
|
||||
object edtAnswer: TEdit
|
||||
Left = 0
|
||||
Height = 30
|
||||
Height = 23
|
||||
Top = 25
|
||||
Width = 495
|
||||
Width = 493
|
||||
Align = alTop
|
||||
OnDblClick = edtAnswerDblClick
|
||||
TabOrder = 0
|
||||
end
|
||||
object retValues: TMemo
|
||||
Left = 0
|
||||
Height = 75
|
||||
Top = 85
|
||||
Width = 495
|
||||
Height = 105
|
||||
Top = 71
|
||||
Width = 493
|
||||
Align = alClient
|
||||
TabOrder = 1
|
||||
end
|
||||
object intValues: TListBox
|
||||
Left = 0
|
||||
Height = 80
|
||||
Top = 160
|
||||
Width = 495
|
||||
Height = 50
|
||||
Top = 176
|
||||
Width = 493
|
||||
Align = alBottom
|
||||
Columns = 4
|
||||
ItemHeight = 0
|
||||
TabOrder = 2
|
||||
TopIndex = -1
|
||||
end
|
||||
object edtQValue: TEdit
|
||||
Left = 0
|
||||
Height = 30
|
||||
Top = 55
|
||||
Width = 495
|
||||
Height = 23
|
||||
Top = 48
|
||||
Width = 493
|
||||
Align = alTop
|
||||
TabOrder = 3
|
||||
end
|
||||
@ -133,15 +133,54 @@ object CGIServerGUI: TCGIServerGUI
|
||||
Left = 0
|
||||
Height = 25
|
||||
Top = 0
|
||||
Width = 495
|
||||
Width = 493
|
||||
Align = alTop
|
||||
TabOrder = 4
|
||||
end
|
||||
end
|
||||
object Splitter1: TSplitter
|
||||
Left = 368
|
||||
Height = 259
|
||||
Height = 246
|
||||
Top = 50
|
||||
Width = 5
|
||||
end
|
||||
object GroupBox3: TGroupBox
|
||||
Left = 0
|
||||
Height = 270
|
||||
Top = 296
|
||||
Width = 870
|
||||
Align = alBottom
|
||||
Caption = 'Шаблоны'
|
||||
ClientHeight = 250
|
||||
ClientWidth = 866
|
||||
TabOrder = 4
|
||||
object ReportsPanel: TPanel
|
||||
Left = 0
|
||||
Height = 50
|
||||
Top = 200
|
||||
Width = 866
|
||||
Align = alBottom
|
||||
ClientHeight = 50
|
||||
ClientWidth = 866
|
||||
TabOrder = 0
|
||||
object EditTemplate: TButton
|
||||
Left = 760
|
||||
Height = 25
|
||||
Top = 11
|
||||
Width = 100
|
||||
Caption = 'Шаблон'
|
||||
OnClick = EditTemplateClick
|
||||
TabOrder = 0
|
||||
end
|
||||
end
|
||||
object ReportsList: TListBox
|
||||
Left = 0
|
||||
Height = 200
|
||||
Top = 0
|
||||
Width = 866
|
||||
Align = alClient
|
||||
ItemHeight = 0
|
||||
TabOrder = 1
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
@ -17,12 +17,16 @@ type
|
||||
{ TCGIServerGUI }
|
||||
|
||||
TCGIServerGUI = class(TForm)
|
||||
EditTemplate: TButton;
|
||||
edtAnswer: TEdit;
|
||||
edtQValue: TEdit;
|
||||
edtRequest: TComboBox;
|
||||
GroupBox1: TGroupBox;
|
||||
GroupBox2: TGroupBox;
|
||||
GroupBox3: TGroupBox;
|
||||
intValues: TListBox;
|
||||
ReportsList: TListBox;
|
||||
ReportsPanel: TPanel;
|
||||
StatusPanel: TPanel;
|
||||
retValues: TMemo;
|
||||
Keys: TMemo;
|
||||
@ -30,6 +34,7 @@ type
|
||||
Panel1: TPanel;
|
||||
Splitter1: TSplitter;
|
||||
StartButton: TButton;
|
||||
procedure EditTemplateClick(Sender: TObject);
|
||||
procedure edtAnswerDblClick(Sender: TObject);
|
||||
procedure SendButtonClick(Sender: TObject);
|
||||
procedure StartButtonClick(Sender: TObject);
|
||||
@ -66,11 +71,13 @@ uses
|
||||
procedure TCGIServerGUI.FormCreate(Sender: TObject);
|
||||
begin
|
||||
fLogger := TEventLog.Create(self);
|
||||
fLogger.Active:=false;
|
||||
fLogger.LogType:=TLogType.ltFile;
|
||||
fLogger.FileName:=ChangeFileExt(paramstr(0),'.log');
|
||||
flogger.Identification:='LMS-Report-Test';
|
||||
fLogger.Active:=false;
|
||||
fLogger.Active:=true;
|
||||
flogger.Info('TCGIServerGUI.FormCreate');
|
||||
|
||||
Server := TConnectionsDM.CreateWithLog(fLogger);
|
||||
ConnectionsDM := Server;
|
||||
cmdDone := true;
|
||||
@ -98,10 +105,19 @@ begin
|
||||
Keys.Lines.Add('='+edtanswer.text);
|
||||
end;
|
||||
|
||||
procedure TCGIServerGUI.EditTemplateClick(Sender: TObject);
|
||||
var
|
||||
rID: integer;
|
||||
begin
|
||||
rID := PtrInt(ReportsList.Items.Objects[ReportsList.ItemIndex]);
|
||||
Server.EditTemplate(rID);
|
||||
end;
|
||||
|
||||
procedure TCGIServerGUI.StartButtonClick(Sender: TObject);
|
||||
begin
|
||||
|
||||
Server.Start;
|
||||
Server.FillTemplates(ReportsList.Items);
|
||||
started := true;
|
||||
Panel1.Caption := 'запущен';
|
||||
SendButton.Enabled := true;
|
||||
@ -169,7 +185,7 @@ begin
|
||||
if Assigned(Data) then
|
||||
begin
|
||||
Data.seek(0,soFromBeginning);
|
||||
fs := TFileStream.Create(Answer,fmCreate);
|
||||
fs := TFileStream.Create('out/'+Answer,fmCreate);
|
||||
try
|
||||
fs.CopyFrom(Data,Data.size);
|
||||
finally
|
||||
@ -177,7 +193,7 @@ begin
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
Sender.Terminate;
|
||||
Sender.SetComplete;
|
||||
cmdDone := true;
|
||||
end;
|
||||
|
||||
|
||||
@ -91,4 +91,10 @@ object ReportDM: TReportDM
|
||||
Left = 180
|
||||
Top = 86
|
||||
end
|
||||
object AbZipper1: TAbZipper
|
||||
AutoSave = False
|
||||
DOSMode = False
|
||||
Left = 186
|
||||
Top = 155
|
||||
end
|
||||
end
|
||||
|
||||
@ -6,7 +6,7 @@ interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, frxClass, frxExportPDF, frxExportODF,
|
||||
xpMemParamManagerUnit, AbUnzper, frxDBSet, cgiDM,extTypes;
|
||||
xpMemParamManagerUnit, AbUnzper, AbZipper, frxDBSet, cgiDM,extTypes;
|
||||
|
||||
type
|
||||
TExportFileType = (ftPDF,ftRTF,ftXLS);//(ftPDF,ftMail,ftRTF,ftXLS,ftHTML);
|
||||
@ -39,6 +39,7 @@ type
|
||||
|
||||
TReportDM = class(TDataModule)
|
||||
AbUnZipper1: TAbUnZipper;
|
||||
AbZipper1: TAbZipper;
|
||||
frxODSExport1: TfrxODSExport;
|
||||
frxODTExport1: TfrxODTExport;
|
||||
frxPDFExport1: TfrxPDFExport;
|
||||
@ -80,12 +81,13 @@ type
|
||||
procedure LoadVariables(AVariables, AParam : TxpMemParamManager);
|
||||
procedure OnMasterRecord(Sender: TObject);
|
||||
procedure LoadReportTemplate();
|
||||
procedure SaveReportTemplate();
|
||||
procedure CopyReportVariables(AVariables, AParam: TxpMemParamManager);
|
||||
public
|
||||
RecordID: integer;
|
||||
NidbData: TNIDBDM;
|
||||
procedure ExportReport( ExportType: TExportFileType; Data: TStream; OnStage: TLogger; OnVars: TVariableFillProc);
|
||||
|
||||
procedure EditReport(OnVars: TVariableFillProc);
|
||||
end;
|
||||
|
||||
var
|
||||
@ -595,6 +597,28 @@ begin
|
||||
end; // try
|
||||
end;
|
||||
|
||||
procedure TReportDM.SaveReportTemplate;
|
||||
var
|
||||
ReportStream : TMemoryStream;
|
||||
BlobStream : TStream;
|
||||
ASQL: string;
|
||||
begin
|
||||
NidbData.log(mtDebug,self,'ExportReport.TemplateArh');
|
||||
ReportStream := TMemoryStream.Create;
|
||||
BlobStream := TMemoryStream.Create;
|
||||
try
|
||||
frxReport.SaveToStream(ReportStream);
|
||||
ReportStream.seek(0,soFromBeginning);
|
||||
PackReport(ReportStream,BlobStream,AbZipper1);
|
||||
ASQL := format('update xp_report set TemplateArh=%s where xp_rpt_id=%d',[TNIDBDM.StreamAsSQL(BlobStream),RecordID]);
|
||||
NidbData.ExecuteSQL(ASQL);
|
||||
finally
|
||||
ReportStream.Free;
|
||||
BlobStream.Free;
|
||||
end; // try
|
||||
end;
|
||||
|
||||
|
||||
procedure TReportDM.CopyReportVariables(AVariables, AParam: TxpMemParamManager);
|
||||
var
|
||||
i: integer;
|
||||
@ -706,6 +730,53 @@ begin
|
||||
NidbData.log(mtDebug,self,'Report complete');
|
||||
end;
|
||||
|
||||
procedure TReportDM.EditReport(OnVars: TVariableFillProc);
|
||||
var
|
||||
I : Integer;
|
||||
flt : TfrxCustomExportFilter;
|
||||
v : Variant;
|
||||
AVariables, AParam: TxpMemParamManager;
|
||||
begin
|
||||
fOnVars:=OnVars;
|
||||
frxReport.EngineOptions.EnableThreadSafe:=true;
|
||||
NidbData.log(mtDebug,self,'EditReport');
|
||||
ReportQueries := TReportQuery.Create;
|
||||
AVariables := TxpMemParamManager.Create;
|
||||
AParam := TxpMemParamManager.Create;
|
||||
try
|
||||
LoadQueries;
|
||||
LoadDefaultVariables(AVariables);
|
||||
LoadLogos(AVariables);
|
||||
LoadVariables(AVariables,AParam);
|
||||
if assigned(fOnVars) then fOnVars(AVariables);
|
||||
frxReport.EngineOptions.DestroyForms := False;
|
||||
// Создаём источники данных
|
||||
CreateDBDataSet(ReportQueries);
|
||||
LoadReportTemplate;
|
||||
CopyReportVariables(AVariables,AParam);
|
||||
TxpFRFunctions.SetReport(NidbData,AVariables);
|
||||
|
||||
try
|
||||
frxReport.DesignReport;
|
||||
if frxReport.Modified then
|
||||
SaveReportTemplate();
|
||||
except on e: Exception do
|
||||
begin
|
||||
NidbData.logError(self,e,'frxReport.PrepareReport');
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
finally
|
||||
ReportQueries.Free;
|
||||
AVariables.Free;
|
||||
AParam.Free;
|
||||
end;
|
||||
NidbData.log(mtDebug,self,'Report complete');
|
||||
end;
|
||||
|
||||
|
||||
|
||||
end.
|
||||
|
||||
|
||||
16
reports/allreportsunit.pas
Normal file
16
reports/allreportsunit.pas
Normal file
@ -0,0 +1,16 @@
|
||||
unit allreportsunit;
|
||||
|
||||
{$mode ObjFPC}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils,commandcol;
|
||||
|
||||
implementation
|
||||
uses
|
||||
cgiReport,applicantlist,applicantresult;
|
||||
initialization
|
||||
TCommandCollection.Register(TReportCommand);
|
||||
end.
|
||||
|
||||
@ -23,7 +23,7 @@ type
|
||||
|
||||
implementation
|
||||
uses
|
||||
cgiDM,dateutils,baseconnection;
|
||||
cgiDM,dateutils,commandcol;
|
||||
{ TRepApplicantList }
|
||||
|
||||
class function TRepApplicantList.CommandSubClass: string;
|
||||
|
||||
455
reports/applicantresult.pas
Normal file
455
reports/applicantresult.pas
Normal file
@ -0,0 +1,455 @@
|
||||
unit applicantresult;
|
||||
|
||||
{$mode ObjFPC}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, cgiReport,xpMemParamManagerUnit;
|
||||
const
|
||||
ApplicantExtraParamCnt=4;
|
||||
ApplicantExtraFields: array[1..ApplicantExtraParamCnt] of string = ('tabel_mode','olympic_mode','portfolio_mode','techno_mode');
|
||||
type
|
||||
|
||||
{ TRepApplicantList }
|
||||
|
||||
{ TRepApplicantResult }
|
||||
|
||||
TRepApplicantResult=class(TReportCommand)
|
||||
private
|
||||
edtMode: integer;
|
||||
cbStream: integer;
|
||||
idYear: integer;
|
||||
ColNames: array[1..12] of string;
|
||||
ColCount: integer;
|
||||
function MakeCols(): string;
|
||||
function UpdateEnrollStatus(): integer;
|
||||
public
|
||||
class function CommandSubClass: string; override;
|
||||
procedure Prepare; override;
|
||||
procedure OnFillVariables(AVariables: TxpMemParamManager); override;
|
||||
end;
|
||||
|
||||
implementation
|
||||
uses
|
||||
cgiDM,dateutils,commandcol;
|
||||
|
||||
{ TRepApplicantResult }
|
||||
|
||||
function TRepApplicantResult.MakeCols: string;
|
||||
var
|
||||
SQL: string;
|
||||
i,j: integer;
|
||||
exams: string;
|
||||
l: TStrings;
|
||||
begin
|
||||
exams := '';
|
||||
for i := 1 to 6 do
|
||||
exams := exams + format(
|
||||
'UNION SELECT COALESCE(NULLIF(Exam%0:dColName,''''),EnterExam%0:dName) as ExamName, coalesce(d.sorting, %0:d) as sorting '+
|
||||
'FROM applicant_group g '+
|
||||
' LEFT JOIN (SELECT d.school_year, COALESCE(d.stream,0) as stream, l.name as exam_name, d.sorting,d.kurs '+
|
||||
' FROM enroll_disciplines d '+
|
||||
' JOIN lessons l ON l.lid=d.lid '+
|
||||
' WHERE d.school_year=%1:d AND COALESCE(d.stream,0)=%2:d '+
|
||||
' ) d ON d.school_year=g.school_year AND d.stream=COALESCE(g.stream) AND d.exam_name=g.EnterExam%0:dName '+
|
||||
'WHERE g.school_year=%1:d AND (%2:d=COALESCE(g.stream,0)) '+
|
||||
'AND NULLIF(EnterExam%0:dName,'''') IS NOT NULL '+
|
||||
'AND EXISTS (SELECT 1 FROM xp_applicant a WHERE a.applicant_group=g.id AND a.Child_Class=coalesce(d.kurs,a.Child_Class) ) ',
|
||||
[i,idYear,cbStream]);
|
||||
SQL := format(
|
||||
'DROP TABLE IF EXISTS tmpExams; '+
|
||||
'CREATE TEMPORARY TABLE tmpExams AS '+
|
||||
'SELECT trim(t.ExamName) as ExamName, COALESCE(NULLIF(FIND_IN_SET(trim(t.ExamName),''Русский язык,Математика,Иностранный язык''),0),min(t.sorting)+6 ) as sorting FROM ( '+
|
||||
' SELECT '''' as ExamName, 0 as sorting '+
|
||||
' %2:s '+
|
||||
' ) t '+
|
||||
'WHERE t.sorting>0 '+
|
||||
'GROUP BY t.ExamName; ',
|
||||
[idYear,cbStream,Exams]);
|
||||
connect.processor.ExecuteSQL(SQL);
|
||||
|
||||
ColCount := 0;
|
||||
with connect.processor.getData('SELECT ExamName,sorting FROM tmpExams ORDER BY sorting,ExamName ') do
|
||||
try
|
||||
while not eof and (ColCount<8) do
|
||||
begin
|
||||
if (pos('физ',AnsiLowerCase(FieldByName('ExamName').AsString))=0) or (pos('физика',AnsiLowerCase(FieldByName('ExamName').AsString))>0) then
|
||||
begin
|
||||
inc(ColCount);
|
||||
ColNames[ColCount] := FieldByName('ExamName').AsString;
|
||||
end;
|
||||
Next;
|
||||
end;
|
||||
finally
|
||||
Free;
|
||||
end;
|
||||
result := '';
|
||||
for I := 1 to ColCount do
|
||||
begin
|
||||
result := result + 'CASE ';
|
||||
for j := 1 to 6 do
|
||||
result := result + format(
|
||||
' WHEN a1.Col%0:d = %1:s THEN a1.Grade%0:d ',
|
||||
[j,TNIDBDM.StringAsSQL(ColNames[i])]);
|
||||
result := result + format(' ELSE NULL END AS Exam%d, ',[i]);
|
||||
end;
|
||||
for I := ColCount+1 to 12 do
|
||||
begin
|
||||
result := result+ Format('NULL AS Exam%d, ',[i]);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TRepApplicantResult.UpdateEnrollStatus: integer;
|
||||
var
|
||||
SQL: string;
|
||||
separate_enroll: boolean;
|
||||
Z2: string;
|
||||
ColSorter: string;
|
||||
I,j: Integer;
|
||||
SParts: array[1..10] of string;
|
||||
DateFilter: string;
|
||||
FS:TStrings;
|
||||
begin
|
||||
DateFilter := '';
|
||||
if cbStream > 0 then
|
||||
DateFilter := ' AND cast(a1.Date as DATE) BETWEEN %10:s AND %11:s ';
|
||||
|
||||
for i := 1 to 10 do
|
||||
sParts[i] := '';
|
||||
for i := 1 to 8 do
|
||||
begin
|
||||
sParts[1] := sParts[1] + format(
|
||||
'+IF(COALESCE(ep.psycho_mode%0:d,0)>=0,gradevalue((COALESCE(ep.psycho_mode%0:d,0)+1)*a1.EnterTest%0:dGrade,0),0)',[i]);
|
||||
sParts[6] := sParts[6] + format(' and case coalesce(ep.psycho_mode%0:d,0) '+
|
||||
'when -3 then true '+
|
||||
'when -2 then coalesce(a1.EnterTest%0:dGrade,'''')=''да'' '+
|
||||
'when -1 then coalesce(a1.EnterTest%0:dGrade,'''')=''нет'' '+
|
||||
'else ROUND(10000*coalesce(a1.EnterTest%0:dGrade,0))>=ROUND(10000*coalesce(ep.psycho_pass%0:d,ep.psycho_min%0:d,-10)) '+
|
||||
'end ',
|
||||
[i]);
|
||||
sParts[8] := sParts[8] + format(
|
||||
', IF( ep.psycho_mode%0:d=-1 AND coalesce(a1.EnterTest%0:dGrade,'''')<>''нет'',ep.psycho_name%0:d,null) ',[i]);
|
||||
sParts[8] := sParts[8] + format(
|
||||
', IF( ep.psycho_mode%0:d=-2 AND coalesce(a1.EnterTest%0:dGrade,'''')<>''да'',concat(''не пройден тест: ('',ep.psycho_name%0:d,'')''),null) ',[i]);
|
||||
sParts[8] := sParts[8] + format(
|
||||
', IF( ep.psycho_mode%0:d in (0,1,2,3,4,5,6,7) '+
|
||||
' AND ROUND(10000*coalesce(a1.EnterTest%0:dGrade,0))<ROUND(10000*coalesce(ep.psycho_pass%0:d,ep.psycho_min%0:d,-10)),concat(''не пройден тест: ('',ep.psycho_name%0:d,'')''),null) ',[i]);
|
||||
if i <= 6 then
|
||||
begin
|
||||
sParts[2] := sParts[2] + format(
|
||||
' COALESCE(NULLIF(g.Exam%0:dColName,''''),g.EnterExam%0:dName,a1.EnterExam%0:dName) as Col%0:d, ',[i]);
|
||||
sParts[3] := sParts[3] + format(
|
||||
' a1.EnterExam%0:dGrade as Grade%0:d, ',[i]);
|
||||
sParts[4] := sParts[4] + format(
|
||||
' and (coalesce(gradevalue(a1.EnterExam%0:dGrade,1)>= coalesce(g.Pass%0:dGrade,0),false) or NULLIF(a1.EnterExam%0:dName,'''') IS NULL) ',[i]);
|
||||
sParts[5] := sParts[5] + format(
|
||||
' and coalesce(a1.EnterExam%0:dGrade NOT LIKE ''н%%'',true) ',[i]);
|
||||
|
||||
sParts[7] := sParts[7] + format(
|
||||
', IF (NULLIF(a1.EnterExam%0:dName,'''') IS NOT NULL '+
|
||||
' AND (coalesce(gradevalue(a1.EnterExam%0:dGrade,1)< coalesce(g.Pass%0:dGrade,0),false) '+
|
||||
' OR coalesce(a1.EnterExam%0:dGrade LIKE ''незачет%%'',false)),a1.EnterExam%0:dName,null) ',[i]);
|
||||
|
||||
end;
|
||||
end;
|
||||
|
||||
SParts[9] := 'true and (coalesce(gradevalue(a1.EnterExam1Grade,1)>=coalesce(g.Pass1Grade,0),false) '+
|
||||
'or coalesce(gradevalue(a1.EnterExam2Grade,1)>=coalesce(g.Pass2Grade,0),false) '+
|
||||
'or coalesce(gradevalue(a1.EnterExam3Grade,1)>=coalesce(g.Pass3Grade,0),false) '+
|
||||
'or coalesce(gradevalue(a1.EnterExam4Grade,1)>=coalesce(g.Pass4Grade,0),false) '+
|
||||
'or coalesce(gradevalue(a1.EnterExam5Grade,1)>=coalesce(g.Pass5Grade,0),false) '+
|
||||
'or coalesce(gradevalue(a1.EnterExam6Grade,1)>=coalesce(g.Pass6Grade,0),false)) ';
|
||||
|
||||
SQL := format(
|
||||
'DROP TABLE IF EXISTS tmp_rpt_applicant_us; '+
|
||||
'CREATE TEMPORARY TABLE tmp_rpt_applicant_us AS '+
|
||||
'SELECT '+
|
||||
' a.xp_key, '+
|
||||
' a.s_year_id, '+
|
||||
' a.trajectory, '+
|
||||
' subj.Subject, '+
|
||||
' CONCAT_WS('' '',UPPER(a.Child_LastName),a.Child_FirstName,a.Child_MidName) AS FIO, '+
|
||||
' a.Child_Birth, '+
|
||||
' a.Child_Class, '+
|
||||
' CASE WHEN a.testready<>0 and coalesce(a.scr_fail,0) = 0 THEN ''годен'' ELSE ''не годен'' END AS isready, '+
|
||||
' COALESCE(a.coeff,1) as coeff, '+
|
||||
' a.sex, '+
|
||||
' COALESCE(NULLIF(a2.Privilege,''''),''нет'') as Privilege , '+
|
||||
' a2.Priv_Count, a2.priv_super, a2.Priv_M > 0 and priv_with_exam and a2.TestPassed and a.testready as priv_m, '+
|
||||
' a.scr_fail, '+
|
||||
' a2.Grade_RUS, '+
|
||||
' a2.Grade_MATH, '+
|
||||
' a2.Grade_INO, '+
|
||||
' a2.Grade_PHYS, '+
|
||||
' CASE WHEN COALESCE(ep.psychomode,0)=0 THEN '+
|
||||
' ROUND(a2.psycho_grade,2) '+
|
||||
' ELSE CASE WHEN a.Psychologist<>0 THEN ''Зачет'' ELSE ''Незачет'' END '+
|
||||
' END as Psycho, '+
|
||||
|
||||
' a.applicant_status_id NOT IN (5,8) '+
|
||||
' AND COALESCE(a.scr_fail,0)=0 '+
|
||||
' AND ( a2.ExamPassed AND a2.TestPassed '+
|
||||
' AND (COALESCE(ep.psychomode,0)=0 AND ROUND(10000*a2.Psycho_grade)>=ROUND(10000*coalesce(ep.psycho_pass,0)) OR a.Psychologist<>0 AND ep.psychomode<>0) '+
|
||||
' OR a2.Priv_super<>0 OR (a2.priv_m > 0 and priv_with_exam AND a2.TestPassed and a.testready)) '+
|
||||
'as ExamOK, '+
|
||||
' calc_applicant_ball(a.xp_key) AS Ball, '+
|
||||
' calc_applicant_ball_priv_m(a.xp_key) as Ball_m, '+
|
||||
' CASE '+
|
||||
' WHEN a.absent <> 0 THEN CASE a.Sex WHEN ''женский'' THEN ''не явилась'' ELSE ''не явился'' END '+
|
||||
' WHEN a.scr_fail <> 0 THEN a.screening '+
|
||||
' WHEN a.applicant_status_id = 5 THEN ''Отказано'' '+
|
||||
' WHEN a.applicant_status_id = 8 THEN ''Отказ от обучения'' '+
|
||||
' WHEN a2.priv_super>0 THEN '''' '+
|
||||
' WHEN a2.priv_m > 0 THEN TRIM(CONCAT(IF(COALESCE(ep.psychomode,0)=0 AND ROUND(10000*a2.Psycho_grade)<ROUND(10000*coalesce(ep.psycho_pass,0)) ' +
|
||||
' OR coalesce(a.Psychologist,0)=0 AND ep.psychomode<>0,''Не рекомендуется к обучению по результатам психологического отбора'', ''''), ' +
|
||||
' CASE WHEN LOCATE(''физическая культура'', a2.FailedExams) > 0 THEN '' Не сданы: физическая культура'' ELSE '''' END)) '+
|
||||
' WHEN nd.errors<>'''' THEN nd.errors '+
|
||||
' WHEN NOT a2.TestPassed or NOT a2.ExamPassed '+
|
||||
' or COALESCE(ep.psychomode,0)=0 AND ROUND(10000*a2.Psycho_grade)<ROUND(10000*coalesce(ep.psycho_pass,0)) OR coalesce(a.Psychologist,0)=0 AND ep.psychomode<>0 '+
|
||||
' THEN CONCAT_WS('',\n '','+
|
||||
' IF (COALESCE(ep.psychomode,0)=0 AND ROUND(10000*a2.Psycho_grade)<ROUND(10000*coalesce(ep.psycho_pass,0)) OR coalesce(a.Psychologist,0)=0 AND ep.psychomode<>0,''Не рекомендуется к обучению по результатам психологического отбора'',NULL), '+
|
||||
' IF(NOT a2.TestPassed AND a2.Priv_super=0, a2.FailedTests,NULL), '+
|
||||
' IF(NOT a2.ExamPassed AND a2.Priv_super=0, CONCAT(''Не сданы: \n'',a2.FailedExams),NULL)'+
|
||||
' ) '+
|
||||
' END AS Prim, '+
|
||||
' a2.FailedExams, a2.FailedTests, a2.ExamPassed,a2.TestPassed, '+
|
||||
' CASE WHEN a.absent<>0 THEN 1 ELSE 0 END as absent, '+
|
||||
' a2.col1,a2.col2,a2.col3,a2.col4,a2.col5,a2.col6, '+
|
||||
' a2.grade1,a2.grade2,a2.grade3,a2.grade4,a2.grade5,a2.grade6 '+
|
||||
'FROM ( '+
|
||||
' SELECT a1.xp_key, '+
|
||||
' GROUP_CONCAT(distinct CASE '+
|
||||
' WHEN np.code = ''Л'' THEN ''Указ Президента РФ от 09.05.2022 г. №268 п.3/ч.1.'' '+
|
||||
' WHEN np.code = ''Л1'' THEN ''Указ Президента РФ от 09.05.2022 г. №268 п.3/ч.2.'' '+
|
||||
' WHEN np.code = ''М'' THEN ''Федеральный закон от 29 декабря 2022 года «641-ФЗ, статья 86, часть 6.1'' '+
|
||||
' WHEN np.code IS NOT NULL THEN priv.PrivilegeCode '+
|
||||
' ELSE priv.PrivilegeName END order by priv.PrivilegeCode SEPARATOR '', '') AS Privilege, '+
|
||||
' COUNT(priv.PrivilegeCode) AS Priv_Count, '+
|
||||
' SUM(if(np.code in ( ''Л''),1, 0) ) AS Priv_super, '+
|
||||
' SUM(if(np.code in (''М''),1,0)) as Priv_M, '+
|
||||
' get_applicant_grade(a1.xp_key,''%%русский%%'','''') AS Grade_RUS, '+
|
||||
' get_applicant_grade(a1.xp_key,''%%математика%%'','''') AS Grade_MATH, '+
|
||||
' get_applicant_grade(a1.xp_key,''%%язык%%'',''%%русский%%'') AS Grade_INO, '+
|
||||
' get_applicant_grade(a1.xp_key,''%%физ%%'',''физика'') AS Grade_PHYS, '+
|
||||
' %3:s '+
|
||||
' %4:s '+
|
||||
' (0.0 %2:s )/COALESCE(ep.psycho_denom,5) as Psycho_grade, '+
|
||||
' (TRUE %5:s %6:s) as ExamPassed, '+
|
||||
' (TRUE %7:s ) as TestPassed, '+
|
||||
' %12:s as priv_with_exam, '+
|
||||
|
||||
' CONCAT_WS('', '' %8:s ) as FailedExams, '+
|
||||
' CONCAT_WS('', '' %9:s ) as FailedTests '+
|
||||
' FROM xp_applicant a1 '+
|
||||
' LEFT JOIN xp_applicant_file_privilege priv ON priv.mid=a1.xp_key AND priv.PrivilegeCode <> ''-'' '+
|
||||
' LEFT JOIN c_privilege np ON np.code=priv.PrivilegeCode '+
|
||||
' JOIN applicant_group g ON g.id=a1.applicant_group '+
|
||||
' LEFT JOIN enroll_params ep ON ep.school_year=a1.s_year_id '+
|
||||
' WHERE a1.s_year_id=%0:d AND a1.Child_Class>0 AND a1.testready <> 0 AND applicant_status_id <> 4 '+
|
||||
' AND (%1:d=COALESCE(a1.stream,0)) '+
|
||||
DateFilter +
|
||||
' GROUP BY a1.xp_key '+
|
||||
') a2 '+
|
||||
' JOIN xp_applicant a ON a.xp_key = a2.xp_key '+
|
||||
' LEFT JOIN enroll_params ep ON ep.school_year=a.s_year_id '+
|
||||
' LEFT JOIN tmp_rpt_problems nd ON nd.xp_key=a.xp_key '+
|
||||
' LEFT JOIN xp_subjects subj ON subj.Subject = a.Subject; ',
|
||||
[idyear,cbStream,
|
||||
sParts[1],
|
||||
sParts[2],
|
||||
sParts[3],
|
||||
sParts[4],
|
||||
sParts[5],
|
||||
sParts[6],
|
||||
sParts[7],
|
||||
sParts[8],
|
||||
TNIDBDM.StringAsSQL(Arguments.Keys.Values['fromdate']),
|
||||
TNIDBDM.StringAsSQL(Arguments.Keys.Values['todate']),
|
||||
sParts[9]]);
|
||||
// FS:= TstringList.create;
|
||||
// fs.Add(sql);
|
||||
// fs.SaveToFile('sqlappldebug.sql');
|
||||
//xpInformation(sql);
|
||||
connect.processor.ExecuteSQL(SQL);
|
||||
|
||||
colSorter := MakeCols();
|
||||
SQL := format(
|
||||
'DROP TABLE IF EXISTS tmp_rpt_applicant; '+
|
||||
'CREATE TEMPORARY TABLE tmp_rpt_applicant AS '+
|
||||
' SELECT a1.*, e.places, e.places_male, e.places_female, '+
|
||||
ColSorter+
|
||||
'CASE '+
|
||||
' WHEN COALESCE(a1.absent,0)=0 THEN ' +
|
||||
' CASE ' +
|
||||
' WHEN a1.undefined<>'''' THEN 5 '+
|
||||
' WHEN NOT ExamOK AND priv_super=0 THEN 3 '+
|
||||
' WHEN (a1.row<=a1.place_limit) THEN 0 '+
|
||||
|
||||
' ELSE 3 ' +
|
||||
' END ' +
|
||||
' ELSE 4 ' +
|
||||
'END as GroupID ' +
|
||||
' FROM ( '+
|
||||
' SELECT t.*, '+
|
||||
' CASE '+
|
||||
' WHEN @kurs=t.Child_Class AND @gender=t.gender AND @track=t.track THEN @row := @row+1 '+
|
||||
' ELSE @row := 1 '+
|
||||
' END as row, '+
|
||||
' @kurs := t.Child_Class, @gender := t.gender, @track := t.track '+
|
||||
' FROM '+
|
||||
' (SELECT @row:=-1 as row, @kurs:=-1 as i_kurs, @gender:=-1 as i_gender, @track:=-1 as i_track ) init, '+
|
||||
' (SELECT '+
|
||||
' CASE '+
|
||||
' WHEN et.places>0 THEN et.places '+
|
||||
' WHEN e.places_female>0 AND a.Sex=''женский'' THEN e.places_female '+
|
||||
' WHEN e.places_male>0 AND a.Sex=''мужской'' THEN e.places_male '+
|
||||
' ELSE e.places '+
|
||||
' END as place_limit, '+
|
||||
' CASE '+
|
||||
' WHEN a.sex=''женский'' AND e.places_female>0 THEN 2 '+
|
||||
' WHEN a.Sex=''мужской'' AND e.places_male>0 THEN 1 '+
|
||||
' ELSE 0 '+
|
||||
' END as gender, '+
|
||||
' CASE '+
|
||||
' WHEN et.trajectory>0 THEN a.trajectory '+
|
||||
' ELSE 0 '+
|
||||
' END as track, '+
|
||||
' a.*,nd.errors as undefined '+
|
||||
' from tmp_rpt_applicant_us a '+
|
||||
' join xp_enroll e ON e.school_year=%0:d and e.kurs=a.child_class AND e.trajectory=0 AND e.places>0 '+
|
||||
' and (e.places_female>0 and a.Sex=''женский'' OR e.places_male>0 and a.Sex=''мужской'' OR e.places_female IS NULL AND e.places_male IS NULL) '+
|
||||
' LEFT JOIN xp_enroll et ON et.school_year=%0:d AND et.kurs=a.Child_Class AND et.trajectory=a.trajectory '+
|
||||
' LEFT JOIN tmp_rpt_problems nd ON nd.xp_key=a.xp_key '+
|
||||
' WHERE 1=1 '+
|
||||
' AND (et.trajectory>0 OR NOT EXISTS (SELECT 1 FROM xp_enroll WHERE school_year=a.s_year_id AND kurs=a.Child_Class AND trajectory>0)) '+
|
||||
' ORDER BY a.Child_Class,COALESCE(a.scr_fail,0), absent,IF(nd.errors<>'''',1,0),gender,'+
|
||||
' track,priv_super desc,a.priv_m desc, case when a.priv_m > 0 then a.Ball_m else 0 end desc,ExamOK DESC, ball desc ,case a.Priv_Count when 0 then 1 else 0 end, a.fio '+
|
||||
' ) t '+
|
||||
{
|
||||
' SELECT IF(Child_Class<>@class OR use_sex AND sex <> @sex,@i:=1,@i:=@i+1) as Row, '+
|
||||
' (@class:=Child_Class) as ClassCopy,(@sex:=sex) as SexCopy, a.* '+
|
||||
' FROM (SELECT u.*,(e.places_male IS NOT NULL OR e.places_female IS NOT NULL) as use_sex,nd.errors as undefined '+
|
||||
' FROM tmp_rpt_applicant_us u '+
|
||||
' LEFT JOIN xp_enroll e ON e.kurs=u.Child_Class AND e.school_year=u.s_year_id '+
|
||||
' LEFT JOIN tmp_rpt_problems nd ON nd.xp_key=u.xp_key '+
|
||||
' ORDER BY Child_Class,absent,ExamOK DESC,IF(nd.errors<>'''',1,0), '+
|
||||
' CASE WHEN e.places_male IS NOT NULL OR e.places_female IS NOT NULL THEN Sex ELSE 0 END, '+
|
||||
' coalesce(Ball,0) DESC, CASE COALESCE(Priv_Count,0) WHEN 0 THEN 0 ELSE 1 END DESC, fio) a, '+
|
||||
' (select @i:=0,@class:=null,@sex:=null) as z '+ }
|
||||
' ) a1 '+
|
||||
//' LEFT JOIN tmp_rpt_problems nd ON nd.xp_key=a1.xp_key '+
|
||||
' LEFT JOIN xp_enroll e ON e.kurs=a1.Child_Class AND e.school_year=%0:d AND e.trajectory=0; '{+
|
||||
' LEFT JOIN tmpExams e1 ON e1.ExamName = a1.Col1 '+
|
||||
' LEFT JOIN tmpExams e2 ON e2.ExamName = a1.Col2 '+
|
||||
' LEFT JOIN tmpExams e3 ON e3.ExamName = a1.Col3 '+
|
||||
' LEFT JOIN tmpExams e4 ON e4.ExamName = a1.Col4 '+
|
||||
' LEFT JOIN tmpExams e5 ON e5.ExamName = a1.Col5 '+
|
||||
' LEFT JOIN tmpExams e6 ON e6.ExamName = a1.Col6 '},
|
||||
[idYear]);
|
||||
//xpInformation(sql);
|
||||
connect.processor.ExecuteSQL(SQL);
|
||||
|
||||
SQL :=
|
||||
'UPDATE xp_applicant a '+
|
||||
' JOIN tmp_rpt_applicant r ON r.xp_key = a.xp_key '+
|
||||
'SET a.passed = null, a.ball = null; ';
|
||||
connect.processor.ExecuteSQL(SQL);
|
||||
SQL :=
|
||||
'UPDATE xp_applicant a '+
|
||||
' JOIN tmp_rpt_applicant r ON r.xp_key = a.xp_key '+
|
||||
'SET a.passed = r.GroupID IN (0,1,2), a.ball = r.ball; ';
|
||||
connect.processor.ExecuteSQL(SQL);
|
||||
|
||||
result := colcount;
|
||||
end;
|
||||
|
||||
|
||||
class function TRepApplicantResult.CommandSubClass: string;
|
||||
begin
|
||||
Result:='applicant_results';
|
||||
end;
|
||||
|
||||
procedure TRepApplicantResult.Prepare;
|
||||
var
|
||||
SQL: string;
|
||||
begin
|
||||
inherited Prepare;
|
||||
idYear := getInt('year');
|
||||
cbStream := getInt('stream');
|
||||
UpdateEnrollStatus();
|
||||
SQL := format(
|
||||
'DROP TABLE IF EXISTS tmp_members; '+
|
||||
'CREATE TEMPORARY TABLE tmp_members AS '+
|
||||
' SELECT xp_f_get_mid_fio(m.mid,0) as member FROM enroll_comitet c '+
|
||||
' JOIN enroll_comitet_members m ON m.enroll_comitet = c.id '+
|
||||
'WHERE c.school_year=%0:d AND coalesce(c.stream,0)=%1:d ORDER BY 1; ' ,
|
||||
[idYear,cbStream]);
|
||||
connect.processor.ExecuteSQL(SQL);
|
||||
end;
|
||||
|
||||
procedure TRepApplicantResult.OnFillVariables(AVariables: TxpMemParamManager);
|
||||
var
|
||||
i: integer;
|
||||
ColSorter: string;
|
||||
SQL: string;
|
||||
extra_params: array [1..ApplicantExtraParamCnt] of boolean;
|
||||
Z2: string;
|
||||
separate_enroll: boolean;
|
||||
|
||||
begin
|
||||
ColSorter:='';
|
||||
for I := 1 to ColCount do
|
||||
AVariables['Grade'+inttostr(i)] := (ColNames[i]);
|
||||
for I := ColCount+1 to 12 do
|
||||
begin
|
||||
ColSorter := ColSorter+ Format('NULL AS Exam%d, ',[i]);
|
||||
AVariables['Grade'+inttostr(i)] := ('');
|
||||
end;
|
||||
for i := 1 to ApplicantExtraParamCnt do
|
||||
begin
|
||||
extra_params[i] := connect.processor.QueryIntValue(format('SELECT coalesce(%s,0) FROM enroll_params WHERE school_year=%d',[ApplicantExtraFields[i], idYear]))=1;
|
||||
if extra_params[i] then
|
||||
AVariables['ball_extra_'+inttostr(i)] := 1
|
||||
else
|
||||
AVariables['ball_extra_'+inttostr(i)] := 0;
|
||||
end;
|
||||
if (connect.processor.QueryIntValue('SELECT COUNT(*) as cnt FROM tmp_rpt_problems')>0) then
|
||||
AVariables['rpt_ready'] := 'ПРЕДВАРИТЕЛЬНЫЕ'#13#10'результаты'
|
||||
else
|
||||
AVariables['rpt_ready'] := ('Результаты');
|
||||
SQL := format(
|
||||
'SELECT xp_f_get_mid_fio(c.chairman,0) as chairman , xp_f_get_mid_fio(c.deputy,0) as deputy, xp_f_get_mid_fio(c.deputy2,0) as deputy2, xp_f_get_mid_fio(c.secretary,0) as secretary '+
|
||||
'FROM enroll_comitet c WHERE c.school_year = %0:d AND coalesce(c.stream,0)=%1:d; ',
|
||||
[idYear,cbStream]);
|
||||
with connect.Processor.getData(SQL) do
|
||||
try
|
||||
if Not eof then
|
||||
begin
|
||||
AVariables['Председатель'] := (FieldByName('Chairman').AsString);
|
||||
AVariables['Заместитель'] := (FieldByName('Deputy').AsString);
|
||||
Z2 := FieldByName('Deputy2').AsString;
|
||||
AVariables['Секретарь'] := (FieldByName('Secretary').AsString);
|
||||
end
|
||||
else
|
||||
begin
|
||||
AVariables['Председатель'] := ('');
|
||||
AVariables['Заместитель'] := ('');
|
||||
Z2 := '';
|
||||
AVariables['Секретарь'] := ('');
|
||||
end;
|
||||
AVariables['Заместитель2'] := (Z2);
|
||||
if Z2<>'' then AVariables['zam2'] := 1 else AVariables['zam2'] := 0;
|
||||
finally
|
||||
Free;
|
||||
end;
|
||||
//Variables['Year'] := YearOf(Date);
|
||||
AVariables['Year'] := connect.processor.QueryValue('SELECT YEAR(begdate) FROM school_year WHERE xp_key = ' + inttostr(idyear));
|
||||
|
||||
end;
|
||||
Initialization
|
||||
TCommandCollection.Register(TRepApplicantResult);
|
||||
|
||||
end.
|
||||
|
||||
@ -48,7 +48,8 @@ implementation
|
||||
|
||||
procedure TClientMainThread.SynchAnswer;
|
||||
begin
|
||||
fOnComplete(self,fmode,fResult.code,fResult.Param,fResult.Name,fResult.Keys,fResult.iValues,fResult.Data);
|
||||
if assigned(fOnComplete) then
|
||||
fOnComplete(self,fmode,fResult.code,fResult.Param,fResult.Name,fResult.Keys,fResult.iValues,fResult.Data);
|
||||
end;
|
||||
|
||||
constructor TClientMainThread.Create(ACommand: string; AFields: TStrings;
|
||||
@ -73,16 +74,18 @@ begin
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
|
||||
procedure TClientMainThread.execute;
|
||||
begin
|
||||
doStart;
|
||||
log(mtExtra, self,'start main thread');
|
||||
Connect.Connect(Host,Port);
|
||||
while not terminated do
|
||||
while not terminated and not Complete do
|
||||
begin
|
||||
Connect.CallAction;
|
||||
sleep(10);
|
||||
end;
|
||||
TerminateClients;
|
||||
Connect.Disconnect();
|
||||
log(mtExtra, self,'terminated');
|
||||
end;
|
||||
|
||||
@ -64,7 +64,7 @@ begin
|
||||
log(mtExtra,self,'start main thread');
|
||||
Connect.Listen(Port);
|
||||
n := 0;
|
||||
while not terminated do
|
||||
while not terminated and not Complete do
|
||||
begin
|
||||
try
|
||||
Connect.CallAction;
|
||||
@ -81,6 +81,7 @@ begin
|
||||
end;
|
||||
inc(n);
|
||||
end;
|
||||
TerminateClients;
|
||||
end;
|
||||
|
||||
constructor TServerMainThread.Create(ALogger: TLogger; APort: integer;
|
||||
|
||||
@ -86,11 +86,15 @@ type
|
||||
flogger: TLogger;
|
||||
fThreadClass: TConnectionThreadClass;
|
||||
fStarted:boolean;
|
||||
fComplete: boolean;
|
||||
|
||||
function getThread(index: TLSocket): TConnectionThread;
|
||||
procedure TerminateClients;
|
||||
|
||||
protected
|
||||
procedure Log(ALevel: TLogLevel; Sender:TObject; msg: string);
|
||||
procedure doStart; virtual;
|
||||
procedure TerminateClients;
|
||||
property Complete: boolean read fComplete;
|
||||
public
|
||||
property Port: integer read fPort;
|
||||
property Connect: TLTCP read fCon;
|
||||
@ -106,6 +110,8 @@ type
|
||||
procedure NetError(const msg: string; aSocket: TLSocket);
|
||||
constructor Create(AThreadClass: TConnectionThreadClass; ALogger: TLogger; APort: integer);
|
||||
destructor Destroy; override;
|
||||
procedure SetComplete;
|
||||
|
||||
end;
|
||||
|
||||
|
||||
@ -127,11 +133,11 @@ begin
|
||||
if TConnectionThread(fclients[i]).Socket=index then
|
||||
begin
|
||||
result := TConnectionThread(fclients[i]);
|
||||
log(mtDebug,self,format('getThread(%d) %s',[index.Handle,guidToString(result.ID)]));
|
||||
log(mtExtra,self,format('getThread(%d) %s',[index.Handle,guidToString(result.ID)]));
|
||||
exit;
|
||||
end;
|
||||
result := fThreadClass.Create(self,index);
|
||||
log(mtDebug,self,format('new Thread(%d) %s',[index.Handle,guidToString(result.ID)]));
|
||||
log(mtExtra,self,format('new Thread(%d) %s',[index.Handle,guidToString(result.ID)]));
|
||||
fclients.Add(Result);
|
||||
|
||||
end;
|
||||
@ -141,13 +147,13 @@ var
|
||||
i: integer;
|
||||
clt: TConnectionThread;
|
||||
begin
|
||||
log(mtDebug,Self,'Terminate Clients');
|
||||
log(mtExtra,Self,'Terminate Clients');
|
||||
for i := fclients.Count-1 downto 0 do
|
||||
begin
|
||||
sleep(0);
|
||||
clt := TConnectionThread(fclients[i]);
|
||||
try
|
||||
log(mtDebug,self,GuidToString(clt.ID));
|
||||
log(mtExtra,self,GuidToString(clt.ID));
|
||||
clt.Terminate;
|
||||
clt.WaitFor;
|
||||
clt.free;
|
||||
@ -170,6 +176,7 @@ end;
|
||||
procedure TMainThread.doStart;
|
||||
begin
|
||||
fStarted := true;
|
||||
fComplete:=false;
|
||||
end;
|
||||
|
||||
procedure TMainThread.RemoveClient(clt: TConnectionThread);
|
||||
@ -182,7 +189,7 @@ procedure TMainThread.dataReady(aSocket: TLSocket);
|
||||
var
|
||||
clt: TConnectionThread;
|
||||
begin
|
||||
log(mtDebug,self,'dataReady');
|
||||
log(mtExtra,self,'dataReady');
|
||||
if Terminated then exit;
|
||||
|
||||
clt := Client[aSocket];
|
||||
@ -207,10 +214,10 @@ procedure TMainThread.Accept(aSocket: TLSocket);
|
||||
var
|
||||
clt: TConnectionThread;
|
||||
begin
|
||||
log(mtDebug,self,'connect');
|
||||
log(mtExtra,self,'connect');
|
||||
if Terminated then exit;
|
||||
clt := Client[aSocket];
|
||||
log(mtDebug,self,format('connected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
|
||||
log(mtExtra,self,format('connected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
|
||||
|
||||
ProcessAccept(clt);
|
||||
clt.start;
|
||||
@ -221,11 +228,11 @@ var
|
||||
clt: TConnectionThread;
|
||||
begin
|
||||
if terminated then exit;
|
||||
log(mtDebug,self,'disconnect');
|
||||
log(mtExtra,self,'disconnect');
|
||||
try
|
||||
clt := Client[aSocket];
|
||||
if clt.terminated then exit;
|
||||
log(mtDebug,self,format('disconnected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
|
||||
log(mtExtra,self,format('disconnected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
|
||||
clt.Terminate;
|
||||
fclients.remove(clt);
|
||||
|
||||
@ -241,10 +248,10 @@ procedure TMainThread.doConnect(aSocket: TLSocket);
|
||||
var
|
||||
clt: TConnectionThread;
|
||||
begin
|
||||
log(mtDebug,self,'doConnect');
|
||||
log(mtExtra,self,'doConnect');
|
||||
if Terminated then exit;
|
||||
clt := Client[aSocket];
|
||||
log(mtDebug,self,format('connected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
|
||||
log(mtExtra,self,format('connected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle]));
|
||||
ProcessConnect(clt);
|
||||
clt.Start;
|
||||
end;
|
||||
@ -252,8 +259,7 @@ end;
|
||||
procedure TMainThread.TerminatedSet;
|
||||
begin
|
||||
inherited TerminatedSet();
|
||||
if fStarted then
|
||||
TerminateClients;
|
||||
|
||||
end;
|
||||
|
||||
|
||||
@ -281,7 +287,7 @@ begin
|
||||
Connect.OnDisconnect:=@doDisconnect;
|
||||
Connect.OnReceive:=@dataReady;
|
||||
Connect.Timeout:=100;
|
||||
log(mtDebug,self,'create main thread');
|
||||
log(mtExtra,self,'create main thread');
|
||||
end;
|
||||
|
||||
destructor TMainThread.Destroy;
|
||||
@ -291,6 +297,11 @@ begin
|
||||
Inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TMainThread.SetComplete;
|
||||
begin
|
||||
fComplete:=true;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
{ TConnectionThread }
|
||||
@ -592,7 +603,7 @@ var
|
||||
begin
|
||||
log(mtExtra,'Send buffer '+inttostr(len));
|
||||
try
|
||||
rem := len+Sizeof(integer)+Sizeof(QWord);
|
||||
rem := len+Sizeof(dword)+Sizeof(QWord);
|
||||
p := GetMem(rem);
|
||||
try
|
||||
t := p;
|
||||
@ -631,13 +642,25 @@ var
|
||||
part_id: QWORD;
|
||||
begin
|
||||
result := false;
|
||||
if Terminated then exit;
|
||||
if Terminated then
|
||||
begin
|
||||
log(mtExtra,'ReceiveBuffer terminated');
|
||||
exit;
|
||||
end;
|
||||
try
|
||||
Cache.Read(part_id);
|
||||
if Part_id<>PacketStart then exit;
|
||||
if Part_id<>PacketStart then
|
||||
begin
|
||||
log(mtError,'ReceiveBuffer PacketStart '+inttohex(part_id,16));
|
||||
exit;
|
||||
end;
|
||||
Cache.Read(len);
|
||||
if len=0 then exit;
|
||||
setlength(Buffer,len);
|
||||
if len=0 then
|
||||
begin
|
||||
log(mtError,'ReceiveBuffer Length=0');
|
||||
exit;
|
||||
end;
|
||||
rem := len;
|
||||
p := PByte(Buffer);
|
||||
repeat
|
||||
@ -740,6 +763,8 @@ procedure TConnectionThread.SendMessage(const mode: byte;
|
||||
const CommandID: DWORD; const QParam: QWord; const AValue: string;
|
||||
const AKeys: TStrings; const IntData: TParamArray; const AData: TStream);
|
||||
begin
|
||||
|
||||
try
|
||||
if assigned(AKeys) and assigned(AData) and (length(IntData)>0) then
|
||||
begin
|
||||
SendHeader(7,mode,CommandID,QParam,AValue);
|
||||
@ -782,6 +807,13 @@ begin
|
||||
end
|
||||
else
|
||||
SendHeader(0,mode,CommandID,QParam,AValue);
|
||||
|
||||
except on E:exception do
|
||||
begin
|
||||
log(mtError,format('send error(%s) %s',[e.classname,e.message]));
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
@ -796,6 +828,7 @@ var
|
||||
footer: dWORD;
|
||||
begin
|
||||
try
|
||||
log(mtExtra,'Send Stream '+inttostr(Data.Size));
|
||||
setLength(Buffer,1+Data.Size+8);
|
||||
pos := 0;
|
||||
AddToBuffer(part,Buffer,pos);
|
||||
@ -815,6 +848,7 @@ var
|
||||
pos: integer;
|
||||
footer: dWORD;
|
||||
begin
|
||||
log(mtExtra,'Send Buffer '+inttostr(length(Data)));
|
||||
try
|
||||
setLength(Buffer,length(Data)+4+1);
|
||||
pos := 0;
|
||||
@ -837,6 +871,7 @@ var
|
||||
len,i: integer;
|
||||
begin
|
||||
try
|
||||
log(mtExtra,'Send Strings');
|
||||
LogStrings(mtExtra,fOwner.flogger,self,'KEYS',Data);
|
||||
len := 1+4+8*Data.Count;
|
||||
for i:=0 to Data.Count-1 do
|
||||
@ -869,6 +904,7 @@ var
|
||||
Buffer: TBuffer;
|
||||
begin
|
||||
len := length(Data);
|
||||
log(mtExtra,'Send ParamArray '+inttostr(length(Data)));
|
||||
InitBuffer(Sizeof(byte)+(len+1)*SizeOf(DWORD),Buffer,pos);
|
||||
AddToBuffer(part,Buffer,pos);
|
||||
AddToBuffer(len,Buffer,pos);
|
||||
@ -923,6 +959,9 @@ begin
|
||||
ReadFromBuffer(b,Buffer,pos);
|
||||
if b<>1 then raise EFormatException.Create('');
|
||||
ReadFromBuffer(Keys,Buffer,pos);
|
||||
LogStrings(mtExtra,fOwner.flogger,self,'Values',Keys);
|
||||
if not ReceiveBuffer(Buffer,len) then exit;
|
||||
pos := 0;
|
||||
ReadFromBuffer(b,Buffer,pos);
|
||||
if b<>2 then raise EFormatException.Create('');
|
||||
ReadFromBuffer(Data,Buffer,pos);
|
||||
@ -933,6 +972,8 @@ begin
|
||||
ReadFromBuffer(b,Buffer,pos);
|
||||
if b<>1 then raise EFormatException.Create('');
|
||||
ReadFromBuffer(intData,Buffer,pos);
|
||||
if not ReceiveBuffer(Buffer,len) then exit;
|
||||
pos := 0;
|
||||
ReadFromBuffer(b,Buffer,pos);
|
||||
if b<>2 then raise EFormatException.Create('');
|
||||
ReadFromBuffer(Data,Buffer,pos);
|
||||
@ -943,6 +984,8 @@ begin
|
||||
ReadFromBuffer(b,Buffer,pos);
|
||||
if b<>1 then raise EFormatException.Create('');
|
||||
ReadFromBuffer(Keys,Buffer,pos);
|
||||
if not ReceiveBuffer(Buffer,len) then exit;
|
||||
pos := 0;
|
||||
ReadFromBuffer(b,Buffer,pos);
|
||||
if b<>2 then raise EFormatException.Create('');
|
||||
ReadFromBuffer(intData,Buffer,pos);
|
||||
@ -953,9 +996,13 @@ begin
|
||||
ReadFromBuffer(b,Buffer,pos);
|
||||
if b<>1 then raise EFormatException.Create('');
|
||||
ReadFromBuffer(Keys,Buffer,pos);
|
||||
if not ReceiveBuffer(Buffer,len) then exit;
|
||||
pos := 0;
|
||||
ReadFromBuffer(b,Buffer,pos);
|
||||
if b<>2 then raise EFormatException.Create('');
|
||||
ReadFromBuffer(intData,Buffer,pos);
|
||||
if not ReceiveBuffer(Buffer,len) then exit;
|
||||
pos := 0;
|
||||
ReadFromBuffer(b,Buffer,pos);
|
||||
if b<>3 then raise EFormatException.Create('');
|
||||
ReadFromBuffer(Data,Buffer,pos);
|
||||
@ -977,7 +1024,7 @@ var
|
||||
begin
|
||||
inherited Create(true);
|
||||
//FreeOnTerminate:=true;
|
||||
fCache := TRoundBuffer.Create(10000);
|
||||
fCache := TRoundBuffer.Create(@AOwner.log, 1024*1024);
|
||||
fSocket := ASocket;
|
||||
fOwner := AOwner;
|
||||
CreateGuid(ID);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user