alexey.zablotskiy/LMS-2_ReportAPI
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

buffer-fix

Browse Source
This commit is contained in:
Алексей Заблоцкий 2023-10-24 11:00:40 +03:00
parent 42b89fe6e9
commit ac9caf456f
18 changed files with 1010 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
baseconnection.pas
View File

@ -24,6 +24,8 @@ type
fisDone,fisFinished: boolean; fisDone,fisFinished: boolean;
fIsError: boolean; fIsError: boolean;
fSubClass: string; fSubClass: string;
function getInt(keyName: string;defaultValue: integer=0): integer;
function getString(keyName: string): string;
public public
AccessTime: TDateTime; AccessTime: TDateTime;
@ -51,17 +53,6 @@ type
end; end;
TCommandClass=class of TCommand; 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) TBaseConnection=class(TThread)
private private
@ -116,6 +107,8 @@ type
end; end;
implementation implementation
uses
commandcol;
{ TBaseConnection } { TBaseConnection }
procedure TBaseConnection.Init; procedure TBaseConnection.Init;
@ -328,44 +321,19 @@ begin
end; 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 } { 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); constructor TCommand.Create(aConnect: TBaseConnection; ASubClass: string);
begin begin
fconnect := AConnect; fconnect := AConnect;
@ -425,6 +393,5 @@ procedure TCommand.Log(ALevel: TLogLevel; msg: string);
begin begin
connect.log(ALevel,self, self.CommandID+#09+msg) connect.log(ALevel,self, self.CommandID+#09+msg)
end; end;
end. end.

97
cgireport.pas
View File

@ -29,11 +29,13 @@ type
function Run: boolean; override; function Run: boolean; override;
function ParseArguments(Args: TStrings; out Errors: TStrings): 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; function ProcessOptionValues(ParamName: string; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean; override;
procedure EditTemplate;
procedure FillDefaults;
end; end;
implementation implementation
uses uses
cgiDM,reportDMUnit, types, strutils, LazUTF8; cgiDM,reportDMUnit, types, strutils, LazUTF8,allreportsunit,commandcol;
{ TReportCommand } { TReportCommand }
procedure TReportCommand.CreateVariablesTable; procedure TReportCommand.CreateVariablesTable;
@ -106,6 +108,13 @@ begin
end; end;
procedure TReportCommand.FillVars; 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 var
ASQL: string; ASQL: string;
q: string; q: string;
@ -115,7 +124,7 @@ var
begin begin
log(mtDebug,'FillVars'); log(mtDebug,'FillVars');
script := format('insert into tmp_report_variables(name,value_string,var_type) values(''UserName'',%s,0); ',[TNIDBDM.StringAsSQL(self.Connect.User)]); 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 with connect.Processor.GetData(ASQL) do
try try
while not eof do while not eof do
@ -136,7 +145,7 @@ begin
finally finally
free; free;
end; 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 with connect.Processor.GetData(ASQL) do
try try
while not eof do while not eof do
@ -184,7 +193,7 @@ begin
end; 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)])); 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; CreateVariablesTable;
log(mtInfo,'Построение отчета '+ReportTitle); log(mtInfo,'Построение отчета '+ReportTitle);
connect.ReportProcessor.RecordID:=ReportID; connect.ReportProcessor.RecordID:=ReportID;
fcurrentStage := 'исполняется (подготовка)'; fcurrentStage := 'исполняется (подготовка)';
try try
@ -217,7 +226,7 @@ begin
exit; exit;
end; end;
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); fileData.Seek(0,soFromBeginning);
result := true; result := true;
finally 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) '+ '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) '+ 'where c.cgi_name=%s and p.name not in (%s) '+
'order by fill_order,p.name ', 'order by fill_order,p.name ',
[TNIDBDM.StringAsSQL(ReportName),TNIDBDM.StringAsSQL(ids)]); [TNIDBDM.StringAsSQL(ReportName),(ids)]);
with Connect.Processor.GetData(asql) do with Connect.Processor.GetData(asql) do
try try
if not eof then if not eof then
@ -329,8 +338,80 @@ begin
result := true; result := true;
end; 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. end.

64
commandcol.pas Normal file
View 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.

65
connectionsdmunit.pas
View File

@ -45,12 +45,14 @@ type
function ProcessReports(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; function ProcessOptionValues(ReportName,ParamName: string; ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean;
procedure LoadConfig; procedure LoadConfig;
public public
property DataHost: string read fDataHost; property DataHost: string read fDataHost;
property DataPort: integer read fDataPort; property DataPort: integer read fDataPort;
property DataBase: string read fDataBase; property DataBase: string read fDataBase;
property Logger: TEventLog read fLogger write fLogger; property Logger: TEventLog read fLogger write fLogger;
procedure Log(ALevel: TLogLevel; Sender: TObject; msg: string); procedure Log(ALevel: TLogLevel; Sender: TObject; msg: string);
procedure InitBaseCon;
procedure Start; procedure Start;
procedure Stop; procedure Stop;
procedure Idle(Sender: TObject); 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; 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; out Code: DWORD; out RetValue: QWord; out Answer: string; out rValues: TStrings; out iValues: TParamArray; out ByteData: TStream ): boolean;
constructor CreateWithLog(ALogger: TEventLog); constructor CreateWithLog(ALogger: TEventLog);
procedure FillTemplates(RepList: TStrings);
procedure EditTemplate(ReportID: integer);
end; end;
var var
@ -66,7 +70,7 @@ var
implementation implementation
uses uses
xpUtilUnit, strutils, xpAccessUnit, inifiles; xpUtilUnit, strutils, xpAccessUnit, inifiles,commandcol, cgiReport;
{$R *.lfm} {$R *.lfm}
@ -338,6 +342,53 @@ begin
inherited Create(nil); inherited Create(nil);
end; 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; function TConnectionsDM.ProcessLogin(UserName, UserPassword: string; out UserID: integer): boolean;
var var
ASQL: string; ASQL: string;
@ -504,13 +555,17 @@ begin
end; end;
end; end;
procedure TConnectionsDM.Start; procedure TConnectionsDM.InitBaseCon;
begin begin
MainCon.connection.RemoteHost:=DataHost; MainCon.connection.RemoteHost:=DataHost;
MainCon.connection.RemotePort:=DataPort; MainCon.connection.RemotePort:=DataPort;
MainCon.connection.Database:=DataBase; MainCon.connection.Database:=DataBase;
MainCon.OpenConnection; MainCon.OpenConnection;
//Input.OnIdle:=@Idle; end;
procedure TConnectionsDM.Start;
begin
InitBaseCon;//Input.OnIdle:=@Idle;
Input.Start; Input.Start;
fRunning:=true; fRunning:=true;
end; end;
@ -534,9 +589,5 @@ begin
TBaseConnection(conList[i]).SetIdle; TBaseConnection(conList[i]).SetIdle;
end; end;
initialization
TCommandCollection.Init;
finalization
TCommandCollection.Done;
end. end.

68
exttypes.pas
View File

@ -43,8 +43,10 @@ type
fReadReady,fWriteReady: TSimpleEvent; fReadReady,fWriteReady: TSimpleEvent;
fClosed: boolean; fClosed: boolean;
cs: TCriticalSection; cs: TCriticalSection;
fLogger: TLogger;
procedure log(msg: string);
public public
constructor Create(BufferSize: integer); constructor Create(ALogger: TLogger; BufferSize: integer);
destructor Destroy; override; destructor Destroy; override;
function Push(const data; datasize: integer): integer; function Push(const data; datasize: integer): integer;
function Pop(var data; datasize: integer): integer; function Pop(var data; datasize: integer): integer;
@ -57,6 +59,9 @@ type
property ReadReady: TSimpleEvent read fReadReady; property ReadReady: TSimpleEvent read fReadReady;
property WriteReady: TSimpleEvent read fWriteReady; property WriteReady: TSimpleEvent read fWriteReady;
end; end;
{ TCommandData }
TCommandData=class TCommandData=class
Code:DWORD; Code:DWORD;
Param:QWord; Param:QWord;
@ -64,7 +69,8 @@ type
Keys: TStrings; Keys: TStrings;
iValues: TParamArray; iValues: TParamArray;
Data: TStream; 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; destructor Destroy; override;
procedure AssignTo(out ACode:DWORD;out AParam:QWord; out AName: string; out AKeys: TStrings; out AValues: TParamArray; out AData: TStream); procedure AssignTo(out ACode:DWORD;out AParam:QWord; out AName: string; out AKeys: TStrings; out AValues: TParamArray; out AData: TStream);
end; end;
@ -160,10 +166,15 @@ end;
{ TRoundBuffer } { 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 begin
inherited Create; inherited Create;
flogger := ALogger;
cs := TCriticalSection.Create; cs := TCriticalSection.Create;
SetLength(self.intdata,BufferSize); SetLength(self.intdata,BufferSize);
fSize:=BufferSize; fSize:=BufferSize;
@ -203,6 +214,7 @@ begin
fWriteReady.WaitFor(INFINITE); fWriteReady.WaitFor(INFINITE);
if fClosed then exit; if fClosed then exit;
delta := 0; 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 while not fClosed and (rem>0) and (fDataSize+delta<fSize) do
begin begin
intData[i] := p^; intData[i] := p^;
@ -212,14 +224,19 @@ begin
dec(rem); dec(rem);
inc(delta); inc(delta);
end; end;
cs.Enter; cs.Enter;
ptrWrite := i; ptrWrite := i;
inc(fDataSize,delta); inc(fDataSize,delta);
if fDataSize=fSize then if fDataSize=fSize then
begin
fWriteReady.ResetEvent; fWriteReady.ResetEvent;
log('buffer full');
end;
cs.Leave; cs.Leave;
result := datasize-rem; result := delta;
log(format('Push %d bytes size=%d',[result,fDataSize]));
fReadReady.SetEvent; fReadReady.SetEvent;
end; end;
@ -233,30 +250,35 @@ begin
result := 0; result := 0;
if datasize<=0 then exit; if datasize<=0 then exit;
if fClosed then exit; if fClosed then exit;
if fDataSize<=0 then fReadReady.WaitFor(INFINITE);
fReadReady.WaitFor(INFINITE); if fClosed then
if fClosed then exit; exit;
p := @data; p := @data;
i := ptrRead; i := ptrRead;
rem := dataSize; rem := dataSize;
s := ''; s := '';
delta := fDataSize; delta := 0;
while not fClosed and (rem>0) and (delta>0) do log(format('Pop size=%d, R=%d, W=%d ',[fDataSize,ptrRead,ptrWrite]));
while not fClosed and (rem>0) and (fDataSize-delta>0) do
begin begin
p^:=intData[i]; p^:=intData[i];
s := s + inttohex(intData[i],2)+' '; s := s + inttohex(intData[i],2)+' ';
inc(p); inc(p);
i := (i+1) mod fSize; i := (i+1) mod fSize;
dec(delta); inc(delta);
dec(rem); dec(rem);
end; end;
cs.Enter; cs.Enter;
ptrRead := i; ptrRead := i;
fDataSize:=delta; dec(fDataSize,delta);
if fDataSize=0 then if fDataSize=0 then
begin
fReadReady.ResetEvent; fReadReady.ResetEvent;
log('buffer empty');
end;
cs.Leave; cs.Leave;
result := datasize-rem; result := delta;
log(format('Pop %d bytes size=%d',[result,fDataSize]));
fWriteReady.SetEvent; fWriteReady.SetEvent;
end; end;
@ -281,6 +303,7 @@ begin
begin begin
result := -1; result := -1;
fReadReady.SetEvent; fReadReady.SetEvent;
fWriteReady.SetEvent;
end; end;
end; end;
@ -384,6 +407,27 @@ begin
Data := nil; Data := nil;
end; 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; destructor TCommandData.Destroy;
begin begin
if assigned(Keys) then Keys.Free; if assigned(Keys) then Keys.Free;

BIN
lms_cgi.obj Normal file
View File

Binary file not shown.

13
lmsreport.lpi
View File

@ -125,6 +125,18 @@
<Filename Value="baseconnection.pas"/> <Filename Value="baseconnection.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
</Unit> </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> </Units>
</ProjectOptions> </ProjectOptions>
<CompilerOptions> <CompilerOptions>
@ -135,6 +147,7 @@
</Target> </Target>
<SearchPaths> <SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/> <IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="reports"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths> </SearchPaths>
<Linking> <Linking>

7
lmsreport.lpr
View File

@ -10,9 +10,10 @@ uses
athreads, athreads,
{$ENDIF} {$ENDIF}
Interfaces, // this includes the LCL widgetset Interfaces, // this includes the LCL widgetset
sysutils,Forms, abbrevia, lnetbase, MainTcpServer, tcpthreadhelper, reportDMUnit, sysutils, Forms, abbrevia, lnetbase,commandcol,baseconnection, MainTcpServer, tcpthreadhelper,
ConnectionsDmUnit, cgiDM, xpAccessUnit, extTypes, tcpserver, tcpClient, reportDMUnit, ConnectionsDmUnit, cgiDM, xpAccessUnit, extTypes, tcpserver,
cgiReport, cgiCommand, fr_utils, baseconnection tcpClient, cgiReport, cgiCommand, fr_utils, applicantresult,
allreportsunit
{ you can add units after this }; { you can add units after this };
{$R *.res} {$R *.res}

97
maintcpserver.lfm
View File

@ -1,14 +1,14 @@
object CGIServerGUI: TCGIServerGUI object CGIServerGUI: TCGIServerGUI
Left = 333 Left = 333
Height = 309 Height = 566
Top = 224 Top = 224
Width = 870 Width = 870
Caption = 'Сервер отчетов LMS' Caption = 'Сервер отчетов LMS'
ClientHeight = 309 ClientHeight = 566
ClientWidth = 870 ClientWidth = 870
OnCreate = FormCreate OnCreate = FormCreate
OnDestroy = FormDestroy OnDestroy = FormDestroy
LCLVersion = '2.2.0.4' LCLVersion = '2.2.4.0'
object Panel1: TPanel object Panel1: TPanel
Left = 0 Left = 0
Height = 50 Height = 50
@ -40,19 +40,19 @@ object CGIServerGUI: TCGIServerGUI
end end
object GroupBox1: TGroupBox object GroupBox1: TGroupBox
Left = 0 Left = 0
Height = 259 Height = 246
Top = 50 Top = 50
Width = 368 Width = 368
Align = alLeft Align = alLeft
Caption = 'Запрос' Caption = 'Запрос'
ClientHeight = 240 ClientHeight = 226
ClientWidth = 366 ClientWidth = 364
TabOrder = 1 TabOrder = 1
object Keys: TMemo object Keys: TMemo
Left = 0 Left = 0
Height = 210 Height = 203
Top = 30 Top = 23
Width = 366 Width = 364
Align = alClient Align = alClient
Lines.Strings = ( Lines.Strings = (
'user=nnz' 'user=nnz'
@ -62,11 +62,11 @@ object CGIServerGUI: TCGIServerGUI
end end
object edtRequest: TComboBox object edtRequest: TComboBox
Left = 0 Left = 0
Height = 30 Height = 23
Top = 0 Top = 0
Width = 366 Width = 364
Align = alTop Align = alTop
ItemHeight = 0 ItemHeight = 15
ItemIndex = 3 ItemIndex = 3
Items.Strings = ( Items.Strings = (
'version' 'version'
@ -86,46 +86,46 @@ object CGIServerGUI: TCGIServerGUI
end end
object GroupBox2: TGroupBox object GroupBox2: TGroupBox
Left = 373 Left = 373
Height = 259 Height = 246
Top = 50 Top = 50
Width = 497 Width = 497
Align = alClient Align = alClient
Caption = 'Ответ' Caption = 'Ответ'
ClientHeight = 240 ClientHeight = 226
ClientWidth = 495 ClientWidth = 493
TabOrder = 2 TabOrder = 2
object edtAnswer: TEdit object edtAnswer: TEdit
Left = 0 Left = 0
Height = 30 Height = 23
Top = 25 Top = 25
Width = 495 Width = 493
Align = alTop Align = alTop
OnDblClick = edtAnswerDblClick OnDblClick = edtAnswerDblClick
TabOrder = 0 TabOrder = 0
end end
object retValues: TMemo object retValues: TMemo
Left = 0 Left = 0
Height = 75 Height = 105
Top = 85 Top = 71
Width = 495 Width = 493
Align = alClient Align = alClient
TabOrder = 1 TabOrder = 1
end end
object intValues: TListBox object intValues: TListBox
Left = 0 Left = 0
Height = 80 Height = 50
Top = 160 Top = 176
Width = 495 Width = 493
Align = alBottom Align = alBottom
Columns = 4
ItemHeight = 0 ItemHeight = 0
TabOrder = 2 TabOrder = 2
TopIndex = -1
end end
object edtQValue: TEdit object edtQValue: TEdit
Left = 0 Left = 0
Height = 30 Height = 23
Top = 55 Top = 48
Width = 495 Width = 493
Align = alTop Align = alTop
TabOrder = 3 TabOrder = 3
end end
@ -133,15 +133,54 @@ object CGIServerGUI: TCGIServerGUI
Left = 0 Left = 0
Height = 25 Height = 25
Top = 0 Top = 0
Width = 495 Width = 493
Align = alTop Align = alTop
TabOrder = 4 TabOrder = 4
end end
end end
object Splitter1: TSplitter object Splitter1: TSplitter
Left = 368 Left = 368
Height = 259 Height = 246
Top = 50 Top = 50
Width = 5 Width = 5
end 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 end

22
maintcpserver.pas
View File

@ -17,12 +17,16 @@ type
{ TCGIServerGUI } { TCGIServerGUI }
TCGIServerGUI = class(TForm) TCGIServerGUI = class(TForm)
EditTemplate: TButton;
edtAnswer: TEdit; edtAnswer: TEdit;
edtQValue: TEdit; edtQValue: TEdit;
edtRequest: TComboBox; edtRequest: TComboBox;
GroupBox1: TGroupBox; GroupBox1: TGroupBox;
GroupBox2: TGroupBox; GroupBox2: TGroupBox;
GroupBox3: TGroupBox;
intValues: TListBox; intValues: TListBox;
ReportsList: TListBox;
ReportsPanel: TPanel;
StatusPanel: TPanel; StatusPanel: TPanel;
retValues: TMemo; retValues: TMemo;
Keys: TMemo; Keys: TMemo;
@ -30,6 +34,7 @@ type
Panel1: TPanel; Panel1: TPanel;
Splitter1: TSplitter; Splitter1: TSplitter;
StartButton: TButton; StartButton: TButton;
procedure EditTemplateClick(Sender: TObject);
procedure edtAnswerDblClick(Sender: TObject); procedure edtAnswerDblClick(Sender: TObject);
procedure SendButtonClick(Sender: TObject); procedure SendButtonClick(Sender: TObject);
procedure StartButtonClick(Sender: TObject); procedure StartButtonClick(Sender: TObject);
@ -66,11 +71,13 @@ uses
procedure TCGIServerGUI.FormCreate(Sender: TObject); procedure TCGIServerGUI.FormCreate(Sender: TObject);
begin begin
fLogger := TEventLog.Create(self); fLogger := TEventLog.Create(self);
fLogger.Active:=false;
fLogger.LogType:=TLogType.ltFile; fLogger.LogType:=TLogType.ltFile;
fLogger.FileName:=ChangeFileExt(paramstr(0),'.log'); fLogger.FileName:=ChangeFileExt(paramstr(0),'.log');
flogger.Identification:='LMS-Report-Test'; flogger.Identification:='LMS-Report-Test';
fLogger.Active:=false;
fLogger.Active:=true; fLogger.Active:=true;
flogger.Info('TCGIServerGUI.FormCreate');
Server := TConnectionsDM.CreateWithLog(fLogger); Server := TConnectionsDM.CreateWithLog(fLogger);
ConnectionsDM := Server; ConnectionsDM := Server;
cmdDone := true; cmdDone := true;
@ -98,10 +105,19 @@ begin
Keys.Lines.Add('='+edtanswer.text); Keys.Lines.Add('='+edtanswer.text);
end; 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); procedure TCGIServerGUI.StartButtonClick(Sender: TObject);
begin begin
Server.Start; Server.Start;
Server.FillTemplates(ReportsList.Items);
started := true; started := true;
Panel1.Caption := 'запущен'; Panel1.Caption := 'запущен';
SendButton.Enabled := true; SendButton.Enabled := true;
@ -169,7 +185,7 @@ begin
if Assigned(Data) then if Assigned(Data) then
begin begin
Data.seek(0,soFromBeginning); Data.seek(0,soFromBeginning);
fs := TFileStream.Create(Answer,fmCreate); fs := TFileStream.Create('out/'+Answer,fmCreate);
try try
fs.CopyFrom(Data,Data.size); fs.CopyFrom(Data,Data.size);
finally finally
@ -177,7 +193,7 @@ begin
end; end;
end; end;
finally finally
Sender.Terminate; Sender.SetComplete;
cmdDone := true; cmdDone := true;
end; end;

6
reportdmunit.lfm
View File

@ -91,4 +91,10 @@ object ReportDM: TReportDM
Left = 180 Left = 180
Top = 86 Top = 86
end end
object AbZipper1: TAbZipper
AutoSave = False
DOSMode = False
Left = 186
Top = 155
end
end end

75
reportdmunit.pas
View File

@ -6,7 +6,7 @@ interface
uses uses
Classes, SysUtils, frxClass, frxExportPDF, frxExportODF, Classes, SysUtils, frxClass, frxExportPDF, frxExportODF,
xpMemParamManagerUnit, AbUnzper, frxDBSet, cgiDM,extTypes; xpMemParamManagerUnit, AbUnzper, AbZipper, frxDBSet, cgiDM,extTypes;
type type
TExportFileType = (ftPDF,ftRTF,ftXLS);//(ftPDF,ftMail,ftRTF,ftXLS,ftHTML); TExportFileType = (ftPDF,ftRTF,ftXLS);//(ftPDF,ftMail,ftRTF,ftXLS,ftHTML);
@ -39,6 +39,7 @@ type
TReportDM = class(TDataModule) TReportDM = class(TDataModule)
AbUnZipper1: TAbUnZipper; AbUnZipper1: TAbUnZipper;
AbZipper1: TAbZipper;
frxODSExport1: TfrxODSExport; frxODSExport1: TfrxODSExport;
frxODTExport1: TfrxODTExport; frxODTExport1: TfrxODTExport;
frxPDFExport1: TfrxPDFExport; frxPDFExport1: TfrxPDFExport;
@ -80,12 +81,13 @@ type
procedure LoadVariables(AVariables, AParam : TxpMemParamManager); procedure LoadVariables(AVariables, AParam : TxpMemParamManager);
procedure OnMasterRecord(Sender: TObject); procedure OnMasterRecord(Sender: TObject);
procedure LoadReportTemplate(); procedure LoadReportTemplate();
procedure SaveReportTemplate();
procedure CopyReportVariables(AVariables, AParam: TxpMemParamManager); procedure CopyReportVariables(AVariables, AParam: TxpMemParamManager);
public public
RecordID: integer; RecordID: integer;
NidbData: TNIDBDM; NidbData: TNIDBDM;
procedure ExportReport( ExportType: TExportFileType; Data: TStream; OnStage: TLogger; OnVars: TVariableFillProc); procedure ExportReport( ExportType: TExportFileType; Data: TStream; OnStage: TLogger; OnVars: TVariableFillProc);
procedure EditReport(OnVars: TVariableFillProc);
end; end;
var var
@ -595,6 +597,28 @@ begin
end; // try end; // try
end; 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); procedure TReportDM.CopyReportVariables(AVariables, AParam: TxpMemParamManager);
var var
i: integer; i: integer;
@ -706,6 +730,53 @@ begin
NidbData.log(mtDebug,self,'Report complete'); NidbData.log(mtDebug,self,'Report complete');
end; 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. end.

16
reports/allreportsunit.pas Normal file
View 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.

2
reports/applicantlist.pas
View File

@ -23,7 +23,7 @@ type
implementation implementation
uses uses
cgiDM,dateutils,baseconnection; cgiDM,dateutils,commandcol;
{ TRepApplicantList } { TRepApplicantList }
class function TRepApplicantList.CommandSubClass: string; class function TRepApplicantList.CommandSubClass: string;

455
reports/applicantresult.pas Normal file
View 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.

7
tcpclient.pas
View File

@ -48,7 +48,8 @@ implementation
procedure TClientMainThread.SynchAnswer; procedure TClientMainThread.SynchAnswer;
begin 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; end;
constructor TClientMainThread.Create(ACommand: string; AFields: TStrings; constructor TClientMainThread.Create(ACommand: string; AFields: TStrings;
@ -73,16 +74,18 @@ begin
inherited Destroy; inherited Destroy;
end; end;
procedure TClientMainThread.execute; procedure TClientMainThread.execute;
begin begin
doStart; doStart;
log(mtExtra, self,'start main thread'); log(mtExtra, self,'start main thread');
Connect.Connect(Host,Port); Connect.Connect(Host,Port);
while not terminated do while not terminated and not Complete do
begin begin
Connect.CallAction; Connect.CallAction;
sleep(10); sleep(10);
end; end;
TerminateClients;
Connect.Disconnect(); Connect.Disconnect();
log(mtExtra, self,'terminated'); log(mtExtra, self,'terminated');
end; end;

3
tcpserver.pas
View File

@ -64,7 +64,7 @@ begin
log(mtExtra,self,'start main thread'); log(mtExtra,self,'start main thread');
Connect.Listen(Port); Connect.Listen(Port);
n := 0; n := 0;
while not terminated do while not terminated and not Complete do
begin begin
try try
Connect.CallAction; Connect.CallAction;
@ -81,6 +81,7 @@ begin
end; end;
inc(n); inc(n);
end; end;
TerminateClients;
end; end;
constructor TServerMainThread.Create(ALogger: TLogger; APort: integer; constructor TServerMainThread.Create(ALogger: TLogger; APort: integer;

87
tcpthreadhelper.pas
View File

@ -86,11 +86,15 @@ type
flogger: TLogger; flogger: TLogger;
fThreadClass: TConnectionThreadClass; fThreadClass: TConnectionThreadClass;
fStarted:boolean; fStarted:boolean;
fComplete: boolean;
function getThread(index: TLSocket): TConnectionThread; function getThread(index: TLSocket): TConnectionThread;
procedure TerminateClients;
protected protected
procedure Log(ALevel: TLogLevel; Sender:TObject; msg: string); procedure Log(ALevel: TLogLevel; Sender:TObject; msg: string);
procedure doStart; virtual; procedure doStart; virtual;
procedure TerminateClients;
property Complete: boolean read fComplete;
public public
property Port: integer read fPort; property Port: integer read fPort;
property Connect: TLTCP read fCon; property Connect: TLTCP read fCon;
@ -106,6 +110,8 @@ type
procedure NetError(const msg: string; aSocket: TLSocket); procedure NetError(const msg: string; aSocket: TLSocket);
constructor Create(AThreadClass: TConnectionThreadClass; ALogger: TLogger; APort: integer); constructor Create(AThreadClass: TConnectionThreadClass; ALogger: TLogger; APort: integer);
destructor Destroy; override; destructor Destroy; override;
procedure SetComplete;
end; end;
@ -127,11 +133,11 @@ begin
if TConnectionThread(fclients[i]).Socket=index then if TConnectionThread(fclients[i]).Socket=index then
begin begin
result := TConnectionThread(fclients[i]); 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; exit;
end; end;
result := fThreadClass.Create(self,index); 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); fclients.Add(Result);
end; end;
@ -141,13 +147,13 @@ var
i: integer; i: integer;
clt: TConnectionThread; clt: TConnectionThread;
begin begin
log(mtDebug,Self,'Terminate Clients'); log(mtExtra,Self,'Terminate Clients');
for i := fclients.Count-1 downto 0 do for i := fclients.Count-1 downto 0 do
begin begin
sleep(0); sleep(0);
clt := TConnectionThread(fclients[i]); clt := TConnectionThread(fclients[i]);
try try
log(mtDebug,self,GuidToString(clt.ID)); log(mtExtra,self,GuidToString(clt.ID));
clt.Terminate; clt.Terminate;
clt.WaitFor; clt.WaitFor;
clt.free; clt.free;
@ -170,6 +176,7 @@ end;
procedure TMainThread.doStart; procedure TMainThread.doStart;
begin begin
fStarted := true; fStarted := true;
fComplete:=false;
end; end;
procedure TMainThread.RemoveClient(clt: TConnectionThread); procedure TMainThread.RemoveClient(clt: TConnectionThread);
@ -182,7 +189,7 @@ procedure TMainThread.dataReady(aSocket: TLSocket);
var var
clt: TConnectionThread; clt: TConnectionThread;
begin begin
log(mtDebug,self,'dataReady'); log(mtExtra,self,'dataReady');
if Terminated then exit; if Terminated then exit;
clt := Client[aSocket]; clt := Client[aSocket];
@ -207,10 +214,10 @@ procedure TMainThread.Accept(aSocket: TLSocket);
var var
clt: TConnectionThread; clt: TConnectionThread;
begin begin
log(mtDebug,self,'connect'); log(mtExtra,self,'connect');
if Terminated then exit; if Terminated then exit;
clt := Client[aSocket]; 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); ProcessAccept(clt);
clt.start; clt.start;
@ -221,11 +228,11 @@ var
clt: TConnectionThread; clt: TConnectionThread;
begin begin
if terminated then exit; if terminated then exit;
log(mtDebug,self,'disconnect'); log(mtExtra,self,'disconnect');
try try
clt := Client[aSocket]; clt := Client[aSocket];
if clt.terminated then exit; 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; clt.Terminate;
fclients.remove(clt); fclients.remove(clt);
@ -241,10 +248,10 @@ procedure TMainThread.doConnect(aSocket: TLSocket);
var var
clt: TConnectionThread; clt: TConnectionThread;
begin begin
log(mtDebug,self,'doConnect'); log(mtExtra,self,'doConnect');
if Terminated then exit; if Terminated then exit;
clt := Client[aSocket]; 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); ProcessConnect(clt);
clt.Start; clt.Start;
end; end;
@ -252,8 +259,7 @@ end;
procedure TMainThread.TerminatedSet; procedure TMainThread.TerminatedSet;
begin begin
inherited TerminatedSet(); inherited TerminatedSet();
if fStarted then
TerminateClients;
end; end;
@ -281,7 +287,7 @@ begin
Connect.OnDisconnect:=@doDisconnect; Connect.OnDisconnect:=@doDisconnect;
Connect.OnReceive:=@dataReady; Connect.OnReceive:=@dataReady;
Connect.Timeout:=100; Connect.Timeout:=100;
log(mtDebug,self,'create main thread'); log(mtExtra,self,'create main thread');
end; end;
destructor TMainThread.Destroy; destructor TMainThread.Destroy;
@ -291,6 +297,11 @@ begin
Inherited Destroy; Inherited Destroy;
end; end;
procedure TMainThread.SetComplete;
begin
fComplete:=true;
end;
{ TConnectionThread } { TConnectionThread }
@ -592,7 +603,7 @@ var
begin begin
log(mtExtra,'Send buffer '+inttostr(len)); log(mtExtra,'Send buffer '+inttostr(len));
try try
rem := len+Sizeof(integer)+Sizeof(QWord); rem := len+Sizeof(dword)+Sizeof(QWord);
p := GetMem(rem); p := GetMem(rem);
try try
t := p; t := p;
@ -631,13 +642,25 @@ var
part_id: QWORD; part_id: QWORD;
begin begin
result := false; result := false;
if Terminated then exit; if Terminated then
begin
log(mtExtra,'ReceiveBuffer terminated');
exit;
end;
try try
Cache.Read(part_id); 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); Cache.Read(len);
if len=0 then exit;
setlength(Buffer,len); setlength(Buffer,len);
if len=0 then
begin
log(mtError,'ReceiveBuffer Length=0');
exit;
end;
rem := len; rem := len;
p := PByte(Buffer); p := PByte(Buffer);
repeat repeat
@ -740,6 +763,8 @@ procedure TConnectionThread.SendMessage(const mode: byte;
const CommandID: DWORD; const QParam: QWord; const AValue: string; const CommandID: DWORD; const QParam: QWord; const AValue: string;
const AKeys: TStrings; const IntData: TParamArray; const AData: TStream); const AKeys: TStrings; const IntData: TParamArray; const AData: TStream);
begin begin
try
if assigned(AKeys) and assigned(AData) and (length(IntData)>0) then if assigned(AKeys) and assigned(AData) and (length(IntData)>0) then
begin begin
SendHeader(7,mode,CommandID,QParam,AValue); SendHeader(7,mode,CommandID,QParam,AValue);
@ -782,6 +807,13 @@ begin
end end
else else
SendHeader(0,mode,CommandID,QParam,AValue); 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; end;
@ -796,6 +828,7 @@ var
footer: dWORD; footer: dWORD;
begin begin
try try
log(mtExtra,'Send Stream '+inttostr(Data.Size));
setLength(Buffer,1+Data.Size+8); setLength(Buffer,1+Data.Size+8);
pos := 0; pos := 0;
AddToBuffer(part,Buffer,pos); AddToBuffer(part,Buffer,pos);
@ -815,6 +848,7 @@ var
pos: integer; pos: integer;
footer: dWORD; footer: dWORD;
begin begin
log(mtExtra,'Send Buffer '+inttostr(length(Data)));
try try
setLength(Buffer,length(Data)+4+1); setLength(Buffer,length(Data)+4+1);
pos := 0; pos := 0;
@ -837,6 +871,7 @@ var
len,i: integer; len,i: integer;
begin begin
try try
log(mtExtra,'Send Strings');
LogStrings(mtExtra,fOwner.flogger,self,'KEYS',Data); LogStrings(mtExtra,fOwner.flogger,self,'KEYS',Data);
len := 1+4+8*Data.Count; len := 1+4+8*Data.Count;
for i:=0 to Data.Count-1 do for i:=0 to Data.Count-1 do
@ -869,6 +904,7 @@ var
Buffer: TBuffer; Buffer: TBuffer;
begin begin
len := length(Data); len := length(Data);
log(mtExtra,'Send ParamArray '+inttostr(length(Data)));
InitBuffer(Sizeof(byte)+(len+1)*SizeOf(DWORD),Buffer,pos); InitBuffer(Sizeof(byte)+(len+1)*SizeOf(DWORD),Buffer,pos);
AddToBuffer(part,Buffer,pos); AddToBuffer(part,Buffer,pos);
AddToBuffer(len,Buffer,pos); AddToBuffer(len,Buffer,pos);
@ -923,6 +959,9 @@ begin
ReadFromBuffer(b,Buffer,pos); ReadFromBuffer(b,Buffer,pos);
if b<>1 then raise EFormatException.Create(''); if b<>1 then raise EFormatException.Create('');
ReadFromBuffer(Keys,Buffer,pos); ReadFromBuffer(Keys,Buffer,pos);
LogStrings(mtExtra,fOwner.flogger,self,'Values',Keys);
if not ReceiveBuffer(Buffer,len) then exit;
pos := 0;
ReadFromBuffer(b,Buffer,pos); ReadFromBuffer(b,Buffer,pos);
if b<>2 then raise EFormatException.Create(''); if b<>2 then raise EFormatException.Create('');
ReadFromBuffer(Data,Buffer,pos); ReadFromBuffer(Data,Buffer,pos);
@ -933,6 +972,8 @@ begin
ReadFromBuffer(b,Buffer,pos); ReadFromBuffer(b,Buffer,pos);
if b<>1 then raise EFormatException.Create(''); if b<>1 then raise EFormatException.Create('');
ReadFromBuffer(intData,Buffer,pos); ReadFromBuffer(intData,Buffer,pos);
if not ReceiveBuffer(Buffer,len) then exit;
pos := 0;
ReadFromBuffer(b,Buffer,pos); ReadFromBuffer(b,Buffer,pos);
if b<>2 then raise EFormatException.Create(''); if b<>2 then raise EFormatException.Create('');
ReadFromBuffer(Data,Buffer,pos); ReadFromBuffer(Data,Buffer,pos);
@ -943,6 +984,8 @@ begin
ReadFromBuffer(b,Buffer,pos); ReadFromBuffer(b,Buffer,pos);
if b<>1 then raise EFormatException.Create(''); if b<>1 then raise EFormatException.Create('');
ReadFromBuffer(Keys,Buffer,pos); ReadFromBuffer(Keys,Buffer,pos);
if not ReceiveBuffer(Buffer,len) then exit;
pos := 0;
ReadFromBuffer(b,Buffer,pos); ReadFromBuffer(b,Buffer,pos);
if b<>2 then raise EFormatException.Create(''); if b<>2 then raise EFormatException.Create('');
ReadFromBuffer(intData,Buffer,pos); ReadFromBuffer(intData,Buffer,pos);
@ -953,9 +996,13 @@ begin
ReadFromBuffer(b,Buffer,pos); ReadFromBuffer(b,Buffer,pos);
if b<>1 then raise EFormatException.Create(''); if b<>1 then raise EFormatException.Create('');
ReadFromBuffer(Keys,Buffer,pos); ReadFromBuffer(Keys,Buffer,pos);
if not ReceiveBuffer(Buffer,len) then exit;
pos := 0;
ReadFromBuffer(b,Buffer,pos); ReadFromBuffer(b,Buffer,pos);
if b<>2 then raise EFormatException.Create(''); if b<>2 then raise EFormatException.Create('');
ReadFromBuffer(intData,Buffer,pos); ReadFromBuffer(intData,Buffer,pos);
if not ReceiveBuffer(Buffer,len) then exit;
pos := 0;
ReadFromBuffer(b,Buffer,pos); ReadFromBuffer(b,Buffer,pos);
if b<>3 then raise EFormatException.Create(''); if b<>3 then raise EFormatException.Create('');
ReadFromBuffer(Data,Buffer,pos); ReadFromBuffer(Data,Buffer,pos);
@ -977,7 +1024,7 @@ var
begin begin
inherited Create(true); inherited Create(true);
//FreeOnTerminate:=true; //FreeOnTerminate:=true;
fCache := TRoundBuffer.Create(10000); fCache := TRoundBuffer.Create(@AOwner.log, 1024*1024);
fSocket := ASocket; fSocket := ASocket;
fOwner := AOwner; fOwner := AOwner;
CreateGuid(ID); CreateGuid(ID);