diff --git a/.gitignore b/.gitignore index 61043be..a8e6c49 100644 --- a/.gitignore +++ b/.gitignore @@ -26,7 +26,7 @@ backup/ *.bak lib/ - +out/ # Application bundle for Mac OS *.app/ diff --git a/baseconnection.pas b/baseconnection.pas new file mode 100644 index 0000000..32d9798 --- /dev/null +++ b/baseconnection.pas @@ -0,0 +1,422 @@ +unit baseconnection; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils, extTypes, Contnrs, cgiDM,reportDMUnit; +type + { TBaseConnection } + TBaseConnection=class; + + { TCommand } + + TCommand=class + protected + fData, + fResult: TCommandData; + fCommandID: string; + fStatus: integer; + fcurrentStage: string; + fconnect: TBaseConnection; + TimeOut: single; + fisDone,fisFinished: boolean; + fIsError: boolean; + fSubClass: string; + public + AccessTime: TDateTime; + + property Arguments: TCommandData read fData; + property Results: TCommandData read fResult; + property CommandID: string read fCommandID; + property Status: integer read fStatus; + property isDone: boolean read fIsDone; + property Error: boolean read fIsError; + property isFinished: boolean read fIsFinished; + property CurrentStage: string read fCurrentStage; + property Connect: TBaseConnection read fConnect; + constructor Create(aConnect: TBaseConnection; ASubClass: string); + destructor Destroy; override; + procedure doRun; + procedure Done; + function Run: boolean; virtual; abstract; + class function CommandName: string; virtual; abstract; + class function CommandSubClass: string; virtual; abstract; + function CheckArgs(out Errors: TStrings): boolean; virtual; abstract; + function ParseCommand(ACode: DWORD; iParam: QWORD; ACommand: string; Args: TStrings; intArgs: TParamArray; CmdData: TStream; out Errors: TStrings): boolean; + function ParseArguments(Args: TStrings; out Errors: TStrings): boolean; virtual; abstract; + procedure Log(msg: string); + function ProcessOptionValues(ParamName: string; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean; virtual; abstract; + end; + TCommandClass=class of TCommand; + + { TCommandCollection } + TCommandCollection=Class; + TCommandCollection=Class(TClassList) + private + class var fCollection: TCommandCollection; + public + class procedure Register(ACommand: TCommandClass); + class function Find(Action,SubClass: string): TCommandClass; + class procedure Init; + class procedure Done; + end; + + TBaseConnection=class(TThread) + private + fOwner:TObject; + fLogger: TLogger; + fConnectionID: string; + fTimeout: integer; + fProcessor: TNIDBDM; + fReportProcessor: TReportDM; + Commands: TStrings; + DoneCommands: TList; + fCreated, + fCommandReceived, + fCommandCompleted: TDateTime; + nCommandComplete: integer; + nCommandReceived: integer; + nCommandReady: integer; + nErrors: integer; + + procedure CleanDone; + public + Host: string; + port: integer; + DataBase: string; + User: string; + UserID: integer; + LastAccess: TDateTime; + procedure Log(sender: TObject; msg: string); + property Created: TDateTime read fCreated; + property LastReceive: TDateTime read fCommandReceived; + property LastComplete: TDateTime read fCommandCompleted; + property CountReceived: integer read nCommandReceived; + property CountCompleted: integer read nCommandComplete; + property CountReady: integer read nCommandReady; + property CountErrors: integer read nErrors; + property Owner: TObject read fOwner; + property ConnectionID: string read fConnectionID; + property Processor: TNIDBDM read fProcessor; + property ReportProcessor: TReportDM read fReportProcessor; + procedure Init; + constructor Create(AOwner: TObject;ATimeOut: integer; aLogger: TLogger); + destructor Destroy; override; + // CommandID,Param,ACommand,Fields,iParam.Data + function AddCommand(ACode: DWORD; iParam: QWORD; ACommandClass,ACommandName: string; Arguments: TStrings; intArgs: TParamArray; CmdData: TStream; out ID: string; out retCode:DWORD; out Errors: TStrings): boolean; + function RunCommand(ACommand: TCommand): boolean; + function FindCommand(IDCommand: string): TCommand; + procedure Idle; + procedure Execute; override; + function ProcessOptionValues(ReportName,ParamName: string; ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean; + class function newID: string; + end; + +implementation +{ TBaseConnection } + +procedure TBaseConnection.Init; +begin + Processor.connection.RemoteHost:=Host; + Processor.connection.RemotePort:=Port; + Processor.connection.Database:=DataBase; + Processor.OpenConnection; +end; + + +constructor TBaseConnection.Create(AOwner: TObject; ATimeOut: integer; + aLogger: TLogger); +begin + inherited Create(true); + fTimeout:=ATimeOut; + fOwner := AOwner; + flogger := ALogger; + fProcessor:=TNIDBDM.Create(nil); + fProcessor.logger:=aLogger; + fReportProcessor:=TReportDM.Create(nil); + fReportProcessor.NidbData := fProcessor; + Commands:=TStringList.Create; + DoneCommands:=TList.Create; + fCreated := now(); + fCommandReceived := 0; + fCommandCompleted := 0; + nCommandComplete:=0; + nCommandReceived:=0; + nCommandReady:=0; + nErrors:=0; + fConnectionID:=newID; + +end; + +destructor TBaseConnection.Destroy; +begin + log(self,'Destroy'); + Processor.Free; + Commands.Free; + DoneCommands.Free; + inherited; +end; + +function TBaseConnection.AddCommand(ACode: DWORD; iParam: QWORD; ACommandClass, + ACommandName: string; Arguments: TStrings; intArgs: TParamArray; + CmdData: TStream; out ID: string; out retCode: DWORD; out Errors: TStrings + ): boolean; +var + cc: TCommandClass; + cmd: TCommand; +begin + log(self,'AddCommand '+ACommandClass+ ' '+ACommandName); + fCommandReceived:=Now(); + cc := TCommandCollection.Find(ACommandClass,ACommandName); + if assigned(cc) then + begin + cmd := cc.Create(self,ACommandName); + cmd.AccessTime:=NOW(); + result := cmd.ParseCommand(ACode,iParam,ACommandName,Arguments,intArgs,CmdData, Errors); + if result then + begin + Commands.AddObject(ACommandName,cmd); + ID := cmd.CommandID; + retCode := Commands.Count; + end + else + begin + ID := 'неверные параметры запроса'; + retCode := ErrorArguments; + inc(nErrors); + cmd.fIsError:=true; + cmd.Done; + DoneCommands.Add(cmd); + end; + inc(nCommandReceived); + + + + end + else + inc(nErrors); +end; + +function TBaseConnection.RunCommand(ACommand: TCommand): boolean; +begin + ACommand.doRun(); + log(Self,'complete '+ACommand.CommandID); + fCommandCompleted:=Now(); + inc(nCommandReady); +end; + +function TBaseConnection.FindCommand(IDCommand: string): TCommand; +var + i: integer; +begin + for i := 0 to Commands.Count-1 do + if (Commands.Objects[i] as TCommand).CommandID=IDCommand then + begin + result := Commands.Objects[i] as TCommand; + result.AccessTime:=now(); + exit; + end; + for i := DoneCommands.Count-1 downto 0 do + if TCommand(DoneCommands[i]).CommandID=IDCommand then + begin + result := TCommand(DoneCommands[i]); + result.AccessTime:=now(); + exit; + end; + result := nil; +end; + +procedure TBaseConnection.Idle; +var + d: TDateTime; +begin + d := Created; + if LastAccess>d then d := LastAccess; + if (now()-d)*24*60>fTimeout then + begin + log(self,'TIMEOUT'); + terminate; + end + else + fProcessor.ExecuteSQL('SELECT 1'); +end; + +procedure TBaseConnection.CleanDone; +var + i: integer; + cmd: TCommand; +begin + for i := DoneCommands.Count-1 downto 0 do + begin + cmd := TCommand(DoneCommands[i]); + if cmd.isDone or (now()-cmd.AccessTime > cmd.TimeOut) then + begin + cmd.free; + DoneCommands.Delete(i); + Dec(nCommandReady); + + end; + end; +end; + +procedure TBaseConnection.Log(sender: TObject; msg: string); +begin + if assigned(fLogger) then + flogger(sender,msg); +end; + +procedure TBaseConnection.Execute; +var + cmd: TCommand; +begin + log(self,'started'); + while not terminated do + begin + while Commands.Count>0 do + begin + cmd := Commands.Objects[0] as TCommand; + log(self,format('run(%s) %s %s ',[cmd.CommandID,cmd.CommandName, cmd.CommandSubClass])); + try + RunCommand(cmd); + finally + Commands.Delete(0); + DoneCommands.Add(cmd); + end; + end; + CleanDone; + sleep(100); + end; + log(self,'finished'); +end; + +function TBaseConnection.ProcessOptionValues(ReportName, ParamName: string; + ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out + OptionValues: TStrings): boolean; +var + c: TCommand; + tmp: TStrings; +begin + with TCommandCollection.Find('report',Reportname).Create(self,ReportName) do + try + ParseCommand(0,0,ReportName,ParamValues,[],nil,tmp); + if assigned(tmp) then FreeAndNil(tmp); + result := ProcessOptionValues(ParamName,answer,RetValue,OptionValues); + finally + free + end; +end; + +class function TBaseConnection.newID: string; +var + g: TGUID; + i: integer; +begin + createguid(g); + result := inttohex(g.D1,8)+inttohex(g.D2,4)+inttohex(g.D3,4); + for i := 0 to 7 do + result := result + inttohex(g.D4[i],2); +end; + + +{ TCommandCollection } + +class procedure TCommandCollection.Register(ACommand: TCommandClass); +begin + fCollection.Add(ACommand); +end; + +class function TCommandCollection.Find(Action, SubClass: string): TCommandClass; +var + i: integer; +begin + for i := 0 to fCollection.Count-1 do + if fCollection.Items[i].InheritsFrom(TCommand) and SameText(Action, TCommandClass(fCollection.Items[i]).CommandName) and SameText(SubClass, TCommandClass(fCollection.Items[i]).CommandSubClass) then + begin + result := TCommandClass(fCollection.Items[i]) ; + exit; + end; + for i := 0 to fCollection.Count-1 do + if fCollection.Items[i].InheritsFrom(TCommand) and SameText(Action, TCommandClass(fCollection.Items[i]).CommandName) and SameText('', TCommandClass(fCollection.Items[i]).CommandSubClass) then + begin + result := TCommandClass(fCollection.Items[i]) ; + exit; + end; + result := nil; +end; + +class procedure TCommandCollection.Init; +begin + fCollection := TCommandCollection.Create; +end; + +class procedure TCommandCollection.Done; +begin + fCollection.Free; +end; + +{ TCommand } + +constructor TCommand.Create(aConnect: TBaseConnection; ASubClass: string); +begin + fconnect := AConnect; + fSubClass := ASubClass; + fStatus:=StatusWaiting; + fcurrentStage := 'в очереди'; + TimeOut:=1/24/4; + fCommandID:=TBaseConnection.newID; +end; + +destructor TCommand.Destroy; +begin + if assigned(fData) then fData.Free; + if assigned(fResult) then fResult.free; + inherited Destroy; +end; + +procedure TCommand.doRun; +begin + fStatus:=StatusProcessing; + fcurrentStage := 'исполняется'; + try + if Run then + begin + fStatus:=StatusComplete; + fcurrentStage := 'завершена'; + end + else + begin + fStatus := StatusError; + fcurrentStage := 'завершена c ошибкой'; + end; + + except on e: Exception do + begin + fStatus:=StatusError; + fcurrentStage := 'error'; + Results.Name:=e.Message; + end; + end; +end; + +procedure TCommand.Done; +begin + fisDone:=true; +end; + +function TCommand.ParseCommand(ACode: DWORD; iParam: QWORD; ACommand: string; + Args: TStrings; intArgs: TParamArray; CmdData: TStream; out Errors: TStrings + ): boolean; +begin + self.fData := TCommandData.Create(ACode,iParam,ACommand,Args,intArgs,cmdData); + result := ParseArguments(fData.Keys,Errors); +end; + +procedure TCommand.Log(msg: string); +begin + connect.log(self, self.CommandID+#09+msg) +end; + +end. + diff --git a/cgi_daemon.lfm b/cgi_daemon.lfm new file mode 100644 index 0000000..48f798d --- /dev/null +++ b/cgi_daemon.lfm @@ -0,0 +1,8 @@ +object LMSReportCGI: TLMSReportCGI + OldCreateOrder = False + OnStart = DataModuleStart + Height = 150 + HorizontalOffset = 840 + VerticalOffset = 384 + Width = 445 +end diff --git a/cgi_daemon.pas b/cgi_daemon.pas new file mode 100644 index 0000000..9b9d2b5 --- /dev/null +++ b/cgi_daemon.pas @@ -0,0 +1,67 @@ +unit cgi_daemon; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, DaemonApp; + +type + TLMSReportCGI=class; + { TDaemonThread } + + TDaemonThread=class(TThread) + fOwner: TLMSReportCGI; + procedure Execute;override; + constructor Create(AOwner: TLMSReportCGI); + end; + + { TLMSReportCGI } + + TLMSReportCGI = class(TDaemon) + procedure DataModuleStart(Sender: TCustomDaemon; var OK: Boolean); + private + workThread: TDaemonThread; + public + + end; + +var + LMSReportCGI: TLMSReportCGI; + +implementation + +procedure RegisterDaemon; +begin + RegisterDaemonClass(TLMSReportCGI) +end; + +{$R *.lfm} + +{ TLMSReportCGI } + +procedure TLMSReportCGI.DataModuleStart(Sender: TCustomDaemon; var OK: Boolean); +begin + workThread := TDaemonThread(self); + workThread.Start; +end; + +{ TDaemonThread } + +procedure TDaemonThread.Execute; +begin + +end; + +constructor TDaemonThread.Create(AOwner: TLMSReportCGI); +begin + inherited Create(true); + fOwner:=AOwner; +end; + + +initialization + RegisterDaemon; +end. + diff --git a/cgi_mapper.lfm b/cgi_mapper.lfm new file mode 100644 index 0000000..4a1f5eb --- /dev/null +++ b/cgi_mapper.lfm @@ -0,0 +1,20 @@ +object DaemonMapper1: TDaemonMapper1 + DaemonDefs = < + item + DaemonClassName = 'TLMSReportCGI' + Name = 'lmsRepCGI' + Description = 'Служба создания отчетовв LMS 2' + DisplayName = 'LMS2 (отчеты)' + Options = [doAllowStop, doAllowPause] + WinBindings.Dependencies = <> + WinBindings.StartType = stBoot + WinBindings.WaitHint = 0 + WinBindings.IDTag = 0 + WinBindings.ServiceType = stWin32 + WinBindings.ErrorSeverity = esIgnore + WinBindings.AcceptedCodes = [] + LogStatusReport = False + end> + Left = 1065 + Top = 332 +end diff --git a/cgi_mapper.pas b/cgi_mapper.pas new file mode 100644 index 0000000..03bff21 --- /dev/null +++ b/cgi_mapper.pas @@ -0,0 +1,34 @@ +unit cgi_mapper; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, DaemonApp; + +type + TDaemonMapper1 = class(TDaemonMapper) + private + + public + + end; + +var + DaemonMapper1: TDaemonMapper1; + +implementation + +procedure RegisterMapper; +begin + RegisterDaemonMapper(TDaemonMapper1) +end; + +{$R *.lfm} + + +initialization + RegisterMapper; +end. + diff --git a/cgicommand.pas b/cgicommand.pas new file mode 100644 index 0000000..b08bb43 --- /dev/null +++ b/cgicommand.pas @@ -0,0 +1,13 @@ +unit cgiCommand; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils; + +implementation + +end. + diff --git a/cgidm.lfm b/cgidm.lfm new file mode 100644 index 0000000..adfe6a6 --- /dev/null +++ b/cgidm.lfm @@ -0,0 +1,38 @@ +object NIDBDM: TNIDBDM + OnCreate = DataModuleCreate + OnDestroy = DataModuleDestroy + OldCreateOrder = False + Height = 150 + HorizontalOffset = 417 + VerticalOffset = 131 + Width = 150 + object nnzQuery1: TnnzQuery + FieldDefs = <> + ReadOnly = True + FilterOptions = [] + Left = 25 + Top = 36 + end + object frxReport1: TfrxReport + Version = '2023.1' + DotMatrixReport = False + IniFile = '\Software\Fast Reports' + PreviewOptions.Buttons = [pbPrint, pbLoad, pbSave, pbExport, pbZoom, pbFind, pbOutline, pbPageSetup, pbTools, pbEdit, pbNavigator, pbExportQuick, pbCopy, pbSelection] + PreviewOptions.Zoom = 1 + PrintOptions.Printer = 'Default' + PrintOptions.PrintOnSheet = 0 + ReportOptions.CreateDate = 45099.7272582292 + ReportOptions.LastChange = 45099.7272582292 + ScriptLanguage = 'PascalScript' + ScriptText.Strings = ( + 'begin' + '' + 'end.' + ) + Left = 64 + Top = 92 + Datasets = <> + Variables = <> + Style = <> + end +end diff --git a/cgidm.pas b/cgidm.pas new file mode 100644 index 0000000..2869fec --- /dev/null +++ b/cgidm.pas @@ -0,0 +1,363 @@ +unit cgiDM; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils, nnz_data_components, frxClass, nnzDBClient,DB,extTypes; + +type + + { TNIDBDM } + + TNIDBDM = class(TDataModule) + frxReport1: TfrxReport; + nnzQuery1: TnnzQuery; + procedure DataModuleCreate(Sender: TObject); + procedure DataModuleDestroy(Sender: TObject); + private + fcon: TnnzConnection; + fMid: integer; + fLogin: string; + fID: TGUID; + fLastConnectTime: TDateTime; + flogger: TLogger; + class function DeleteLastChar(const St: String; const CharCount: integer=1): String; + public + class function FloatAsSQL(Value: Double): String; + class function PeriodAsSQL(BegDate, EndDate: TDateTime): string; + class function DateAsSQL(Date: TDateTime): String; + class function DateTimeAsSQL(Stamp: TDateTime): String; + class function CurrencyAsSQL(Value: Currency): string; + class function VariantAsSQL(const Value: Variant): String; + class function BooleanAsSQL(Value: Boolean): String; + class function StringAsSQL(const St: String): String; + class function StringAsJSON(const St: String): String; + class function StreamAsSQL(s: TStream): String; + class function BytesAsSQL(const data: array of byte; dataSize: integer): string; + class function IntArrayAsSQL(const data: array of integer): string; + class procedure UpdateWithArguments(var code: string; const Arguments: TStrings); + property logger: TLogger read flogger write flogger; + property connection: TnnzConnection read fCon; + function QueryValue(ASQL: string; Default: string=''): string; + function QueryIntValue(ASQL: string): integer; + function GetData(ASQL: string): TDataSet; + function CheckUser(const login,password: string; out UserID: integer): boolean; + procedure OpenConnection; + procedure log(Sender: TObject; msg: string); + procedure LogError(Sender: TObject; e: Exception; msg: string); + procedure ExecuteSQL(ASQL: string); + end; + +var + NIDBDM: TNIDBDM; + +implementation +uses + variants,LazUTF8; +{$R *.lfm} + +{ TNIDBDM } + +procedure TNIDBDM.DataModuleCreate(Sender: TObject); +begin + log(self,'connecting'); + fcon := TnnzConnection.Create(self); + + +end; + +procedure TNIDBDM.DataModuleDestroy(Sender: TObject); +begin + log(sender,'destroy'); + fcon.Connected:=false; + fcon.free; +end; + +class function TNIDBDM.DeleteLastChar(const St: String; + const CharCount: integer): String; +begin + Result := utf8Copy(St, 1, utf8Length(St) - CharCount); +end; + +class function TNIDBDM.FloatAsSQL(Value: Double): String; +var + fs: TFormatSettings; +begin + fs.DecimalSeparator := '.'; + Result := FloatToStr(Value, fs); +end; + + +class function TNIDBDM.PeriodAsSQL(BegDate, EndDate: TDateTime): string; +begin + if (BegDate <= 2) and (EndDate <= 2) then + Result := '>=''1900-01-01''' + else + Result := 'BETWEEN ' + DateAsSQL(BegDate) + ' AND ' + DateAsSQL(EndDate); +end; + + +class function TNIDBDM.DateAsSQL(Date: TDateTime): String; +begin + if FormatSettings.ShortMonthNames[1] <> 'JAN' then + begin + FormatSettings.ShortMonthNames[1] := 'JAN'; + // без этого дурит MSSQL7/MSSQL2000, который не понимает + FormatSettings.ShortMonthNames[2] := 'FEB'; // дату в формате '13 окт 1999' + FormatSettings.ShortMonthNames[3] := 'MAR'; + FormatSettings.ShortMonthNames[4] := 'APR'; + FormatSettings.ShortMonthNames[5] := 'MAY'; + FormatSettings.ShortMonthNames[6] := 'JUN'; + FormatSettings.ShortMonthNames[7] := 'JUL'; + FormatSettings.ShortMonthNames[8] := 'AUG'; + FormatSettings.ShortMonthNames[9] := 'SEP'; + FormatSettings.ShortMonthNames[10] := 'OCT'; + FormatSettings.ShortMonthNames[11] := 'NOV'; + FormatSettings.ShortMonthNames[12] := 'DEC'; + end; + if Date < 2 then + Date := 2; // приводим к 1 января 1900 - это ноль для SMALLDATETIME + Result := QuotedStr(FormatDateTime('yyyy-mm-dd', Date)); +end; +class function TNIDBDM.DateTimeAsSQL(Stamp: TDateTime): String; +begin + // Result := FloatToStr(Real(Stamp) - 2); старый вариант - ldm + Result := ''; + DateTimeToString(Result, 'hh:nn:ss', Stamp); + Result := DeleteLastChar(DateAsSQL(Stamp)) + ' ' + Result + ''''; +end; + +class function TNIDBDM.CurrencyAsSQL(Value: Currency): string; +begin + Result := StringAsSQL(CurrToStr(Value)); +end; + +class function TNIDBDM.VariantAsSQL(const Value: Variant): String; +var + Stream: TStringStream; +begin + case VarType(Value) of + varNull: + Result := 'NULL'; + varEmpty: + Result := 'NULL'; + varSmallInt, varInteger, varShortInt, varByte, varWord, varLongWord, + varInt64, varUInt64: + Result := VarToStr(Value); + varSingle, varCurrency: + Result := CurrencyAsSQL(Value); + varDouble: + Result := FloatAsSQL(Value); + varDate: + Result := DateAsSQL(Value); + varOleStr: + begin + Stream := TStringStream.Create(Value); + try + Result := StreamAsSQL(Stream); + finally + Stream.Free; + end; + end; + varBoolean: + Result := BooleanAsSQL(Value); + varString, varUString: + Result := StringAsSQL(Value); + else + raise Exception.Create('VariantAsSQL: Неверный тип ' + VarToStr(Value)); + end; +end; + +class function TNIDBDM.BooleanAsSQL(Value: Boolean): String; +begin + if value then result := 'true' else result := 'false'; +end; + + +class function TNIDBDM.StreamAsSQL(s: TStream): String; +var + i: Integer; + b: Byte; +begin + result := 'null'; + if s.size=0 then exit; + //Result := '0x'; //MySQL + Result := 'E''\\x'; //PostgreSQL + s.Position := 0; + for i := 1 to s.Size do + begin + s.Read(b, 1); + Result := Result + IntToHex(b, 2); + end; + result := result +''''; +end; + +class function TNIDBDM.BytesAsSQL(const data: array of byte; + dataSize: integer): string; +var + i: integer; + b: byte; +begin + result := 'null'; + if datasize=0 then exit; + Result := 'E''\\x'; //PostgreSQL + for i := 0 to dataSize-1 do + begin + b := data[i]; + Result := Result + IntToHex(b, 2); + end; + result := result +''''; +end; + + +class function TNIDBDM.IntArrayAsSQL(const data: array of integer): string; +var + i: integer; +begin + if length(data)=0 then + result := 'ARRAY[]::integer[]' + else + begin + result := inttostr(data[low(data)]); + for i := low(data)+1 to high(data) do + result := result +','+inttostr(data[i]); + result := format('ARRAY[%s]::integer[]',[result]); + end; +end; + +class procedure TNIDBDM.UpdateWithArguments(var code: string; + const Arguments: TStrings); +var + i: integer; + s,v: string; +begin + for i := 0 to Arguments.Count-1 do + begin + s := Arguments.Names[i]; + v := Arguments.Values[s]; + Code := StringReplace(Code,'{s#'+s+'}', TNidbDM.StringAsSQL(v),[rfReplaceAll]); + Code := StringReplace(Code,'{d#'+s+'}',TNidbDM.StringAsSQL(v),[rfReplaceAll]); + Code := StringReplace(Code,'{#'+s+'}',v,[rfReplaceAll]); + end; +end; + + + + +class function TNIDBDM.StringAsSQL(const St: String): String; +var + len,i: Cardinal; + c: Char; + hasSpecial: boolean; +begin +// Result := QuotedStr(StringReplace(St, '\', '\\', +// [rfReplaceAll, rfIgnoreCase])); + Result:=''; + len:=Length(St); + hasSpecial := false; + for i:=1 to len do begin + c:=St[i]; + hasSpecial := hasSpecial or (c in [#0,'''','"','\',#8,#10,#13,#9,#26]); + case(c) of + #0: Result:=Result+'\0'; + '''','"','\': Result:=Result+'\'+c; + #8: Result:=Result+'\b'; + #10: Result:=Result+'\n'; + #13: Result:=Result+'\r'; + #9: Result:=Result+'\t'; + #26: Result:=Result+'\Z'; + else + Result:=Result+c; + end; + end; + Result:=''''+Result+''''; + if hasSpecial then Result :='E'+Result; + +end; + +class function TNIDBDM.StringAsJSON(const St: String): String; +begin + result := st; + result := UTF8StringReplace(result,'\','\\',[rfReplaceAll]); + result := UTF8StringReplace(result,'"','\"',[rfReplaceAll]); +end; + + +function TNIDBDM.QueryValue(ASQL: string; Default: string): string; +begin + log(self,'QueryValue'#13#10+ASQL); + with TnnzQuery.Create(self) do + try + Connection := fcon; + SQL.Text:=ASQL; + Open; + if not eof and not Fields[0].IsNull then result := Fields[0].AsString else result := Default; + finally + free; + end; +end; + +function TNIDBDM.QueryIntValue(ASQL: string): integer; +begin + log(self,'QueryIntValue'#13#10+ASQL); + with TnnzQuery.Create(self) do + try + Connection := fcon; + SQL.Text:=ASQL; + Open; + if not eof then result := Fields[0].AsInteger else result := 0; + finally + free; + end; +end; + + +function TNIDBDM.GetData(ASQL: string): TDataSet; +begin + log(self,'getData '#13#10+ASQL); + result := TnnzQuery.Create(self); + with result as TnnzQuery do + begin + Connection := fcon; + SQL.Text:=ASQL; + Open; + + end; +end; + +function TNIDBDM.CheckUser(const login, password: string; out UserID: integer + ): boolean; +begin + log(self,'CheckUser'); + UserID := QueryIntValue(format('Select coalesce((select min(p.mid) from people p where login=%s and password=%s),0) ',[StringAsSQL(login),StringAsSQl(password)])); + result := UserID>0; +end; + +procedure TNIDBDM.OpenConnection; +begin + log(self,'OpenConnection'); + fcon.Connected:=true; + fcon.Identify; +end; + +procedure TNIDBDM.log(Sender: TObject; msg: string); +begin + if assigned(flogger) then + flogger(Sender,msg); +end; + +procedure TNIDBDM.LogError(Sender: TObject; e: Exception; msg: string); +begin + log(Sender,'!!ERROT at '+msg+#13#10+e.ClassName+#13#10+e.message); +end; + +procedure TNIDBDM.ExecuteSQL(ASQL: string); +begin + log(self,'ExecuteSQL '+ASQL); + connection.ExecuteSQL(ASQL); +end; + +end. + diff --git a/cgireport.pas b/cgireport.pas new file mode 100644 index 0000000..ac99e17 --- /dev/null +++ b/cgireport.pas @@ -0,0 +1,329 @@ +unit cgiReport; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils, baseconnection; +type + { TReportCommand } + + TReportCommand=class(TCommand) + private + procedure CreateVariablesTable; + procedure UpdateCodeWithArguments(var code: string); + procedure SetStage(Sender:TObject; stageName: string); + public + ReportID: integer; + ReportName: string; + ReportTitle: string; + ReportCode: string; + Varcode: string; + class function CommandName: string; override; + class function CommandSubClass: string; override; + procedure Prepare; virtual; + procedure PrepareVars; virtual; + procedure FillVars; + function Run: boolean; override; + function ParseArguments(Args: TStrings; out Errors: TStrings): boolean; override; + function ProcessOptionValues(ParamName: string; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean; override; + end; + +implementation +uses + cgiDM,extTypes,reportDMUnit, types, strutils, LazUTF8; +{ TReportCommand } + +procedure TReportCommand.CreateVariablesTable; +begin + connect.Processor.ExecuteSQL( + 'drop table if exists tmp_report_variables; '+ + 'create temporary table tmp_report_variables ( '+ + 'name character varying,'+ + 'value_string character varying, '+ + 'value_int integer, '+ + 'var_type integer '+ + '); ' + ); +end; + +procedure TReportCommand.UpdateCodeWithArguments(var code: string); +begin + TNIDBDM.UpdateWithArguments(code,Arguments.Keys); + Code := StringReplace(Code,'{#user}',inttostr(self.Connect.UserID),[rfReplaceAll]); +end; + +procedure TReportCommand.SetStage(Sender: TObject; stageName: string); +begin + fcurrentStage:=format('выполняется (%s)',[stageName]); +end; + +class function TReportCommand.CommandName: string; +begin + result := 'report'; +end; + +class function TReportCommand.CommandSubClass: string; +begin + result := ''; +end; + +procedure TReportCommand.Prepare; +var + ASQL: string; + v: string; + d: TStringDynArray; + i: integer; +begin + ReportCode := connect.Processor.QueryValue(format('select report_routine from xp_report_cgi where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)])); + UpdateCodeWithArguments(ReportCode); + if reportcode<>'' then + connect.Processor.ExecuteSQL(format('select %s;',[ReportCode])); + ASQL := format( 'select array_to_string(extra_routines,'';'') as v from xp_report_cgi where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)]); + v := connect.Processor.QueryValue(ASQL); + if v>'' then + begin + d := SplitString(v,';'); + for i := low(d) to high(d) do + begin + v := d[i]; + UpdateCodeWithArguments(v); + if v<>'' then + connect.Processor.ExecuteSQL(v); + end; + end; +end; + +procedure TReportCommand.PrepareVars; +begin + VarCode := connect.Processor.QueryValue(format('select report_routine_vars from xp_report_cgi where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)])); + UpdateCodeWithArguments(VarCode); + if VarCode<>'' then + connect.Processor.ExecuteSQL(format('select %s;',[VarCode])); +end; + +procedure TReportCommand.FillVars; +var + ASQL: string; + q: string; + script: string; + vs: string; + vi: integer; +begin + log('FillVars'); + script := format('insert into tmp_report_variables(name,value_string,var_type) values(''UserName'',%s,0); ',[TNIDBDM.StringAsSQL(self.Connect.User)]); + ASQL := format('select name,query from xp_report_variables where xp_rpt_id=%d and var_type=0',[ReportID]); + with connect.Processor.GetData(ASQL) do + try + while not eof do + begin + log(FieldByName('name').asString); + q := FieldByName('query').AsString; + UpdateCodeWithArguments(q); + try + vs := connect.Processor.QueryValue(q); + + except + vs := ''; + end; + script := script + format(#13#10'insert into tmp_report_variables(name,value_string,var_type) values (%s,%s,0); ', + [TNIDBDM.StringAsSQL(fieldByName('name').asString),TNidbDM.StringAsSQL(vs)]); + Next; + end; + finally + free; + end; + ASQL := format('select name,query from xp_report_variables where xp_rpt_id=%d and var_type=1',[ReportID]); + with connect.Processor.GetData(ASQL) do + try + while not eof do + begin + log(FieldByName('name').asString); + q := FieldByName('query').AsString; + UpdateCodeWithArguments(q); + try + vi := connect.Processor.QueryIntValue(q); + + except + vi := 0; + end; + script := script + format('insert into tmp_report_variables(name,value_int,var_type) values (%s,%d,1); '#13#10, + [TNIDBDM.StringAsSQL(fieldByName('name').asString),vi]); + Next; + end; + finally + free; + end; + if script<>'' then + connect.Processor.ExecuteSQL(script); +end; + +function TReportCommand.Run: boolean; +var + i: integer; + s: string; + fileData: TStream; +begin + result := false; + fcurrentStage := 'исполняется (инициализация)'; + fileData := TMemoryStream.Create; + try + ReportID := connect.Processor.QueryIntValue(format('select xp_rpt_id from xp_report_cgi where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)])); + if ReportID<=0 then + begin + fResult := TCommandData.Create(ErrorArguments,0,'Отчет не найден',nil,[],nil); + exit; + end; + ReportTitle := connect.Processor.QueryValue(format('select r.name from xp_report_cgi g join xp_report r on r.xp_rpt_id=g.xp_rpt_id where cgi_name=%s',[TNidbDM.StringAsSQL(ReportName)])); + CreateVariablesTable; + log(ReportTitle); + connect.ReportProcessor.RecordID:=ReportID; + fcurrentStage := 'исполняется (подготовка)'; + try + Prepare; + except on e: Exception do + begin + connect.Processor.LogError(self,e,'prepare'); + fResult := TCommandData.Create(ErrorInternal,0,'Ошибка составления',nil,[],nil); + exit; + end; + end; + fcurrentStage := 'исполняется (настройка)'; + try + FillVars; + PrepareVars; + except on e: Exception do + begin + connect.Processor.LogError(self,e,'vars'); + fResult := TCommandData.Create(ErrorInternal,0,'Ошибка составления',nil,[],nil); + exit; + end; + end; + fcurrentStage := 'исполняется ()'; + try + connect.ReportProcessor.ExportReport(ftPDF,fileData,@SetStage); + except on e: Exception do + begin + connect.Processor.LogError(self,e,'ExportReport'); + fResult := TCommandData.Create(ErrorInternal,0,'Ошибка составления',nil,[],nil); + exit; + end; + end; + fResult := TCommandData.Create(0,fileData.size,ReportTitle+'.pdf',nil,[],fileData); + fileData.Seek(0,soFromBeginning); + result := true; + finally + fileData.Free; + end; +end; + +function TReportCommand.ParseArguments(Args: TStrings; out Errors: TStrings + ): boolean; +var + asql: string; + ids: string; + i: integer; +begin + result := false; + ids := ''; + for i := 0 to Arguments.Keys.Count-1 do + if ids='' then + ids := TNIDBDM.StringAsSQL(Arguments.Keys.Names[i]) + else + ids := ids + ','+ TNIDBDM.StringAsSQL(Arguments.Keys.Names[i]); + ReportName := Arguments.Keys.Values['name']; + + asql := format( + 'select p.name from xp_report_cgi c '+ + 'join xp_report_params p on p.xp_rpt_id=c.xp_rpt_id and coalesce(p.required,true) '+ + 'where c.cgi_name=%s and p.name not in (%s) '+ + 'order by fill_order,p.name ', + [TNIDBDM.StringAsSQL(ReportName),TNIDBDM.StringAsSQL(ids)]); + with Connect.Processor.GetData(asql) do + try + if not eof then + begin + Errors := TStringList.Create; + while not eof do + begin + Errors.add(format('"%s"',[TNIDBDM.StringAsJSON(FieldByName('name').AsString)])); + next; + end; + end + else + result := true; + finally + free; + end; + +end; + +function TReportCommand.ProcessOptionValues(ParamName: string; out + Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean; +var + ASQL: string; + code,s,k,v: string; + i,p: integer; + d: TStringDynArray; +begin + result := false; + ASQL := format( + 'select source from xp_report_params p '+ + ' join xp_report_cgi c on c.xp_rpt_id=p.xp_rpt_id '+ + 'where c.cgi_name=%s and p.name=%s and p.type in (0,1,2,17) ', + [TNIDBDM.StringAsSQL(fSubClass), TNIDBDM.StringAsSQL(ParamName)]); + code := connect.Processor.QueryValue(ASQL); + if code='' then exit; + if code[1]='(' then + begin + OptionValues := TStringList.Create; + code := copy(code,2,length(code)-2); + d := splitstring(code,','); + for i := low(d) to high(d) do + begin + s:= d[i]; + p:=pos(':',s); + if p>1 then + begin + k := copy(s,1,p-1); + v := copy(s,p+1,length(s)); + OptionValues.add(format('{"id":"%s","value":"%s"}',[TNIDBDM.StringAsJSON(k),TNIDBDM.StringAsJSON(v)])); + end + else + OptionValues.add(format('"%s"',[TNIDBDM.StringAsJSON(s)])); + end; + end + else + begin + UpdateCodeWithArguments(code); + if pos('{',code)>0 then + begin + result := false; + Answer := 'недостаточно данных'; + exit; + end; + ASQL := code; + OptionValues := TStringList.Create; + if ASQL<>'' then + with connect.Processor.GetData(ASQL) do + try + while not eof do + begin + OptionValues.Add(format('{"id":"%d","value":"%s"}', + [Fields[0].AsInteger, TNIDBDM.StringAsJSON(Fields[1].AsString)])); + next; + end; + finally + free; + end; + + end; + result := true; +end; + + +Initialization + TCommandCollection.Register(TReportCommand); +end. + diff --git a/connectionsdmunit.lfm b/connectionsdmunit.lfm new file mode 100644 index 0000000..682f05b --- /dev/null +++ b/connectionsdmunit.lfm @@ -0,0 +1,32 @@ +object ConnectionsDM: TConnectionsDM + OnCreate = DataModuleCreate + OnDestroy = DataModuleDestroy + OldCreateOrder = False + Height = 150 + HorizontalOffset = 677 + VerticalOffset = 301 + Width = 533 + object Process1: TProcess + Active = False + Options = [] + Priority = ppNormal + StartupOptions = [] + ShowWindow = swoNone + WindowColumns = 0 + WindowHeight = 0 + WindowLeft = 0 + WindowRows = 0 + WindowTop = 0 + WindowWidth = 0 + FillAttribute = 0 + Left = 63 + Top = 37 + end + object Hash: TDCP_sha1 + Id = 2 + Algorithm = 'SHA1' + HashSize = 160 + Left = 240 + Top = 60 + end +end diff --git a/connectionsdmunit.pas b/connectionsdmunit.pas new file mode 100644 index 0000000..7320f03 --- /dev/null +++ b/connectionsdmunit.pas @@ -0,0 +1,538 @@ +unit ConnectionsDmUnit; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, Contnrs, SysUtils, types, process, cgiDM, reportDMUnit, LNet, + lnetbase,tcpserver, tcpthreadhelper, DCPsha1, extTypes,syncobjs, baseconnection; + +type + + { TCommand } + + + + + + { TConnectionsDM } + + TConnectionsDM = class(TDataModule) + Hash: TDCP_sha1; + Process1: TProcess; + procedure DataModuleCreate(Sender: TObject); + procedure DataModuleDestroy(Sender: TObject); + private + fLogFolder: string; + MainCon: TNIDBDM; + conlist: TList; + Input: TServerMainThread; + fDataHost: string; + fDataPort: integer; + fDataBase: string; + fServicePort: integer; + + fTimeOut: integer; + LogLock: TCriticalSection; + fRunning: boolean; + function getConnection(ID: string): TBaseConnection; + function NewConnection: TBaseConnection; + procedure Remove(ID: string); + procedure ClearConnections; + procedure ClearTerminated; + procedure ConnectNew(aSocket: TLSocket); + function ProcessLogin(UserName,UserPassword: string; out UserID: integer):boolean; + function ProcessArguments(ReportName: string; out RetValue: QWORD;out ReportTitle: string; out rValues: TStrings): boolean; + function ProcessReports(out rValues: TStrings): boolean; + function ProcessOptionValues(ReportName,ParamName: string; ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out OptionValues: TStrings): boolean; + procedure LoadConfig; + public + property DataHost: string read fDataHost; + property DataPort: integer read fDataPort; + property DataBase: string read fDataBase; + procedure Log(Sender: TObject; msg: string); + procedure Start; + procedure Idle(Sender: TObject); + property Running: boolean read fRunning; + function ProcessRequest(Sender: TMainThread; + const CommandID:DWORD; const Param:QWord; const ACommand: string; const Fields: TStrings; const iParams: TParamArray; const Data: TStream; + out Code: DWORD; out RetValue: QWord; out Answer: string; out rValues: TStrings; out iValues: TParamArray; out ByteData: TStream ): boolean; + + end; + +var + ConnectionsDM: TConnectionsDM; + +implementation +uses + xpUtilUnit, strutils, xpAccessUnit, inifiles; +{$R *.lfm} + + + + +{ TConnectionsDM } + +procedure TConnectionsDM.DataModuleCreate(Sender: TObject); +begin + MainCon := TNIDBDM.Create(nil); + MainCon.logger:=@log; + LogLock := TCriticalSection.Create; + conList := TList.Create; + LoadConfig; + fRunning := false; + input := TServerMainThread.Create(@log,fServicePort,@ProcessRequest); +end; + +procedure TConnectionsDM.DataModuleDestroy(Sender: TObject); +begin + log(Sender,'Destroy'); + ClearConnections; + + if fRunning then + begin + Input.Terminate; + Input.WaitFor; + end; + Input.Free; + MainCon.Free; + LogLock.Free; + conList.Free; + +end; + +function TConnectionsDM.getConnection(ID: string): TBaseConnection; +var + i: integer; +begin + for i := 0 to conList.Count-1 do + if TBaseConnection(conlist[i]).ConnectionID=ID then + begin + result := TBaseConnection(conlist[i]); + result.LastAccess := NOW(); + exit; + end; + result := nil; +end; + +function TConnectionsDM.NewConnection: TBaseConnection; +var + g: TGUID; + s: string; + i: integer; +begin + result := TBaseConnection.Create(self,fTimeOut,@Log); + conlist.add(result); + result.Host:=DataHost; + result.port:=DataPort; + result.DataBase:=DataBase; + log(self, 'New '+result.ConnectionID); + result.Init; + +end; + +procedure TConnectionsDM.Remove(ID: string); +var + i: integer; +begin + + for i := conList.Count-1 downto 0 do + if TBaseConnection(conlist[i]).ConnectionID=ID then + begin + log(self,'terminate '+ID); + TBaseConnection(conlist[i]).terminate; + exit; + end; +end; + + +procedure TConnectionsDM.ClearConnections; +var + i: integer; + con: TBaseConnection; +begin + log(self,'ClearConnections'); + for i := 0 to conList.Count-1 do + begin + con := TBaseConnection(conlist[i]); + con.terminate; + con.WaitFor; + con.Free; + end; + conList.Clear; +end; + +procedure TConnectionsDM.ClearTerminated; +var + i: integer; + con: TBaseConnection; +begin + for i := conlist.Count-1 downto 0 do + begin + con := TBaseConnection(conlist[i]); + if con.Finished then + begin + log(self,'Destroy terminated '+con.ConnectionID); + con.free; + conlist.delete(i); + end; + end; +end; + +procedure TConnectionsDM.ConnectNew(aSocket: TLSocket); +begin +// aSocket +end; + +function TConnectionsDM.ProcessRequest(Sender: TMainThread; + const CommandID: DWORD; const Param: QWord; const ACommand: string; + const Fields: TStrings; const iParams: TParamArray; const Data: TStream; out + Code: DWORD; out RetValue: QWord; out Answer: string; out rValues: TStrings; + out iValues: TParamArray; out ByteData: TStream): boolean; +var + UserID: integer; + con: TBaseConnection; + userName,conID,cmdID: string; + cmd: TCommand; +begin + log(Self,'Process Request '+ACommand); + ClearTerminated; + result := false; + RetValue := 0; + Code := 0; + rValues := nil; + ByteData := nil; + setLength(iValues,0); + if ACommand='stop' then + begin + ClearConnections; + Input.Terminate; + fRunning:=false; + result := true; + exit; + end; + if ACommand='version' then + begin + result := true; + Answer := extTypes.version; + exit; + end; + if ACommand='arguments' then + begin + result := ProcessArguments(Fields.Values['name'],RetValue,Answer,rValues); + if not result then + begin + Code := ErrorArguments; + end; + exit; + end; + if ACommand='reports' then + begin + result := ProcessReports(rValues); + exit; + end; + if ACommand='login' then + begin + UserName :=Fields.Values['user']; + if ProcessLogin(UserName,EncryptText(Fields.Values['password']),UserID) then + begin + con := NewConnection; + con.User:=UserName; + con.UserID := UserID; + Answer := con.ConnectionID; + con.Start; + result := true; + end + else + begin + Answer := 'Invalid password'; + code := ErrorLogin; + end; + exit; + end; + conID := fields.Values['connect']; + con := getConnection(conID); + + if not assigned(con) or (con.Finished) then + begin + Answer := 'invalid connectionID'; + code := ErrorConnect; + exit; + end; + if ACommand='test' then + begin + result := true; + answer := 'OK'; + exit; + end; + if ACommand='logout' then + begin + result := true; + Answer := 'OK'; + Remove(con.ConnectionID); + exit; + end; + if ACommand='connectStatus' then + begin + result := true; + SetLength(iValues,7); + iValues[0] := round(con.Created*24*60*60*100); + iValues[1] := round(con.LastReceive*24*60*60*100); + iValues[2] := round(con.LastComplete*24*60*60*100); + iValues[3] := con.CountReceived; + iValues[4] := con.CountCompleted; + iValues[5] := con.CountReady; + iValues[6] := con.CountErrors; + Answer := 'OK'; + exit; + end; + if (ACommand='option_values') then + begin + result := con.ProcessOptionValues(fields.Values['report'],fields.Values['name'],fields,Answer,RetValue,rValues); + exit; + end; + + if (ACommand='status') or (ACommand='result') then + begin + cmdID := fields.Values['operation']; + cmd := con.FindCommand(cmdID); + if not assigned(cmd) then + begin + Answer := 'command not found'; + Code := ErrorCommand; + exit; + end; + if ACommand='status' then + begin + Answer := cmd.currentStage; + code := cmd.Status; + if (code=StatusComplete) and assigned(cmd.Results.Data) then + RetValue:=cmd.Results.Data.Size + else + RetValue := 0; + result := true; + exit; + end; + if ACommand='result' then + begin + if cmd.Status=StatusComplete then + begin + cmd.Results.AssignTo(Code,RetValue,Answer,rValues,iValues,ByteData); + cmd.Done; + result := true; + end + else + begin + Code := ErrorComplete; + Answer:='command not complete'; + end; + exit; + end; + + end; + result := con.AddCommand(CommandID,Param,ACommand,Fields.Values['name'],Fields,iValues,Data,Answer,Code, rValues); + +end; + +function TConnectionsDM.ProcessLogin(UserName, UserPassword: string; out UserID: integer): boolean; +var + ASQL: string; +begin + Result := MainCon.CheckUser(UserName,UserPassword,UserID); +end; + +function TConnectionsDM.ProcessArguments(ReportName: string; out + RetValue: QWORD; out ReportTitle: string; out rValues: TStrings): boolean; +var + ASQL: string; +begin + result := false; + rValues := TStringList.Create; + ASQL := format( + 'select r.xp_rpt_id,r.name as reportname,p.name as paramname, '+ + 'case p.type '+ + ' when 0 then ''A'' '+ + ' when 1 then ''ID'' '+ + ' when 2 then ''N'' '+ + ' when 3 then ''F'' '+ + ' when 4 then ''D'' '+ + ' when 5 then ''T'' '+ + ' when 6 then ''B'' '+ + ' when 17 then ''IDS'' '+ + 'end as type, '+ + + 'case coalesce(p.required,false) or p.def_val is null '+ + 'when true then ''!'' '+ + 'else p.def_val '+ + 'end as def_val, '+ + 'string_agg(''"'' || p.argument || ''"'','';'') as arguments, '+ + 'p.description '+ + 'from xp_report_cgi c '+ + ' join xp_report r on r.xp_rpt_id=c.xp_rpt_id '+ + ' left join ( '+ + ' select xp_rpt_id, type,name, required,def_val,description,fill_order, unnest(coalesce(arguments,array[null])) as argument '+ + ' from xp_report_params '+ + ')p on p.xp_rpt_id=r.xp_rpt_id '+ + 'where c.cgi_name=%0:s '+ + 'group by r.xp_rpt_id,r.name, p.name,p.type,p.required, p.def_val,p.description, p.fill_order '+ + 'order by p.fill_order, p.name ', + [TNIDBDM.StringAsSQL(ReportName)]); + with MainCon.GetData(ASQL) do + try + while not eof do + begin + ReportTitle := fieldByName('reportname').AsString; + rValues.Add(format('{"name":"%s","type":"%s","default":"%s","arguments":[%s],"description":"%s"}', + [fieldbyname('paramname').asString, fieldbyname('type').asString,fieldbyname('def_val').asString,fieldbyname('arguments').asString, TNIDBDM.StringAsJSON(fieldbyname('description').asString)])); + result := true; + next; + end; + finally + free; + end; + +end; + +function TConnectionsDM.ProcessReports(out rValues: TStrings): boolean; +var + ASQL: string; +begin + rValues := TStringList.Create; + ASQL := + 'select c.cgi_name,r.name as rep_name '+ + 'from xp_report_cgi c '+ + ' join xp_report r on r.xp_rpt_id=c.xp_rpt_id '+ + 'order by 2 '; + with MainCon.GetData(ASQL) do + try + while not eof do + begin + rValues.Add(format('{"name":"%s","title":"%s"}',[fieldbyname('cgi_name').asString, TNIDBDM.StringAsJSON(fieldbyname('rep_name').asString)])); + result := true; + next; + end; + finally + free; + end; + result := true; +end; + +function TConnectionsDM.ProcessOptionValues(ReportName, ParamName: string; + ParamValues: TStrings; out Answer: string; out RetValue: QWORD; out + OptionValues: TStrings): boolean; +var + ASQL: string; + code: string; + i: integer; +begin + ASQL := format( + 'select source from xp_report_params p '+ + ' join xp_report_cgi c on c.xp_rpt_id=p.xp_rpt_id '+ + 'where c.cgi_name=%s and p.name=%s and p.type= in (1,17) ', + [TNIDBDM.StringAsSQL(ReportName), TNIDBDM.StringAsSQL(ParamName)]); + code := MainCon.QueryValue(ASQL); + TNIDBDM.UpdateWithArguments(code,ParamValues); + if pos('{',code)>0 then + begin + result := false; + Answer := 'недостаточно данных'; + exit; + end; + ASQL := code; + OptionValues := TStringList.Create; + if ASQL<>'' then + with MainCon.GetData(ASQL) do + try + while not eof do + begin + OptionValues.Add(format('{"id":"%d","value":"%s"}', + [Fields[0].AsInteger, TNIDBDM.StringAsJSON(Fields[1].AsString)])); + next; + end; + finally + free; + end; + result := true; +end; + + +procedure TConnectionsDM.LoadConfig; +var + ini: TIniFile; + inifile: string; +begin + inifile := ChangeFileExt(ParamStr(0),'.ini'); + ini := TIniFile.Create(inifile); + try + fDataHost := ini.ReadString('DATA','host','localhost'); + fDataPort := ini.ReadInteger('DATA','port',7079); + fDataBase:= ini.ReadString('DATA','database',''); + fServicePort := ini.ReadInteger('PARAMS','port',6543); + flogFolder:=ini.ReadString('PARAMS','log',''); + fTimeOut:=ini.ReadInteger('PARAMS','timeout',CONNECT_TIMEOUT); + finally + ini.free; + end; +end; + +procedure TConnectionsDM.Log(Sender: TObject; msg: string); +var + f: TextFile; +begin + + try + if fLogFolder='' then exit; + LogLock.Enter; + try + AssignFile(f, fLogFolder); + if fileexists(fLogFolder) then + append(f) + else + rewrite(f); + if Sender is TComponent then + writeln(f,DateTimeToStr(NOW()),#09,Sender.ClassName,'-',(Sender as TComponent).Name, #09, Msg) + else if Assigned(Sender) then + writeln(f,DateTimeToStr(NOW()),#09,Sender.ClassName, #09, Msg) + else + writeln(f,DateTimeToStr(NOW()),#09, #09, Msg); + closeFile(f); + + finally + logLock.Leave; + end; + + except on e: Exception do + raise; + end; +end; + +procedure TConnectionsDM.Start; +begin + log(self,'Start'); + MainCon.connection.RemoteHost:=DataHost; + MainCon.connection.RemotePort:=DataPort; + MainCon.connection.Database:=DataBase; + MainCon.OpenConnection; + Input.OnIdle:=@Idle; + Input.Start; + fRunning:=true; +end; + + +procedure TConnectionsDM.Idle(Sender: TObject); +var + i: integer; +begin + MainCon.ExecuteSQL('select 1'); + for i := conlist.Count-1 downto 0 do + if not TBaseConnection(conList[i]).Finished then + TBaseConnection(conList[i]).Idle; +end; + +initialization + TCommandCollection.Init; +finalization + TCommandCollection.Done; +end. + diff --git a/exttypes.pas b/exttypes.pas new file mode 100644 index 0000000..bcefcaf --- /dev/null +++ b/exttypes.pas @@ -0,0 +1,422 @@ +unit extTypes; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils, LNet, syncobjs; +const + version='0.0.0.1'; + cmdRequest=1; + cmdAnswer=2; + cmdError=3; + StatusWaiting=1; + StatusProcessing=2; + StatusComplete=3; + StatusError=4; + PacketStart:qword=$1F2E3D4C5B6A7908; + ErrorProcessor=1; + ErrorLogin=2; + ErrorConnect=3; + ErrorCommand=4; + ErrorComplete=5; + ErrorArguments=6; + ErrorInternal=$100; + CONNECT_TIMEOUT=15; + +type + TBuffer=Array of Byte; + TParamArray=Array of QWORD; + TLogger=procedure(Sender: TObject; Msg: String) of object; + EFormatException=class(Exception); + { TConnectionThread } + + { TRoundBuffer } + + TRoundBuffer=class + private + intdata: TBuffer; + ptrRead,ptrWrite: integer; + fSize,fDataSize: integer; + fReadReady,fWriteReady: TSimpleEvent; + fClosed: boolean; + cs: TCriticalSection; + public + constructor Create(BufferSize: integer); + destructor Destroy; override; + function Push(const data; datasize: integer): integer; + function Pop(var data; datasize: integer): integer; + function ReadFromSocket(ASocket:TLSocket): integer; + procedure Read(out Value: byte); overload; + procedure Read(out Value: word); overload; + procedure Read(out Value: dword); overload; + procedure Read(out Value: qword); overload; + procedure Close; + property ReadReady: TSimpleEvent read fReadReady; + property WriteReady: TSimpleEvent read fWriteReady; + end; + TCommandData=class + Code:DWORD; + Param:QWord; + Name: string; + Keys: TStrings; + iValues: TParamArray; + Data: TStream; + constructor Create(ACode:DWORD;AParam:QWord; AName: string; AKeys: TStrings; AValues: TParamArray; AData: TStream); + destructor Destroy; override; + procedure AssignTo(out ACode:DWORD;out AParam:QWord; out AName: string; out AKeys: TStrings; out AValues: TParamArray; out AData: TStream); + end; +procedure CopyBytes(var Dest: PByte; const Data: byte); overload; +procedure CopyBytes(var Dest: PByte; const Data: word); overload; +procedure CopyBytes(var Dest: PByte; const Data: dword); overload; +procedure CopyBytes(var Dest: PByte; const Data: qword); overload; +procedure CopyBytes(var Dest: PByte; const Data: TBuffer); overload; +procedure CopyParamArray(const Source: TParamArray; out Dest: TParamArray); +procedure LogStrings(logger: TLogger;Sender: TObject;Name: string; Data: TStrings); +implementation +procedure CopyParamArray(const Source: TParamArray; out Dest: TParamArray); +var + i: integer; +begin + setlength(Dest,length(Source)); + if length(Source)>0 then + for i := low(Source) to High(Source) do + Dest[i] := Source[i]; +end; + +procedure LogStrings(logger: TLogger; Sender: TObject; Name: string; + Data: TStrings); +var + i: integer; +begin + if assigned(logger) and assigned(Data) then + begin + logger(Sender,Name); + for i := 0 to Data.Count-1 do + logger(Sender,' '+Data[i]); + end; +end; + +procedure CopyBytes(var Dest: PByte; const Data: byte); +begin + dest^ := Data; + inc(dest); +end; + +procedure CopyBytes(var Dest: PByte; const Data: word); +var + i: integer; + l: word; +begin + l := Data; + for i:=0 to sizeof(word)-1 do + begin + Dest^ := l and $FF; + l := l shr 8; + inc(Dest); + end; +end; + +procedure CopyBytes(var Dest: PByte; const Data: dword); +var + i: integer; + l: dword; +begin + l := Data; + for i:=0 to sizeof(dword)-1 do + begin + Dest^ := l and $FF; + l := l shr 8; + inc(Dest); + end; +end; + +procedure CopyBytes(var Dest: PByte; const Data: qword); +var + i: integer; + l: qword; +begin + l := Data; + for i:=0 to sizeof(qword)-1 do + begin + Dest^ := l and $FF; + l := l shr 8; + inc(Dest); + end; +end; + +procedure CopyBytes(var Dest: PByte; const Data: TBuffer); +var + i: integer; +begin + for i := low(Data) to high(Data) do + begin + Dest^ := Data[i]; + inc(Dest); + end; +end; + + { TRoundBuffer } + + +constructor TRoundBuffer.Create(BufferSize: integer); +begin + inherited Create; + cs := TCriticalSection.Create; + SetLength(self.intdata,BufferSize); + fSize:=BufferSize; + fDataSize := 0; + self.ptrRead:=0; + self.ptrWrite:=0; + fReadReady := TSimpleEvent.Create; + fWriteReady := TSimpleEvent.Create; + fWriteReady.SetEvent; + fClosed:=false; +end; + +destructor TRoundBuffer.Destroy; +begin + cs.free; + fReadReady.Free; + fWriteReady.Free; + setLength(self.intdata,0); + inherited Destroy; +end; + +function TRoundBuffer.Push(const data; datasize: integer): integer; +var + i,delta: integer; + p:PByte; + rem: integer; + s: string; +begin + result := 0; + if dataSize<=0 then exit; + if fClosed then exit; + p := @data; + i := ptrWrite; + rem := dataSize; + s := ''; + if fDataSize=fSize then + fWriteReady.WaitFor(INFINITE); + if fClosed then exit; + delta := 0; + while not fClosed and (rem>0) and (fDataSize+delta0) and (delta>0) do + begin + p^:=intData[i]; + s := s + inttohex(intData[i],2)+' '; + inc(p); + i := (i+1) mod fSize; + dec(delta); + dec(rem); + end; + cs.Enter; + ptrRead := i; + fDataSize:=delta; + if fDataSize=0 then + fReadReady.ResetEvent; + cs.Leave; + result := datasize-rem; + fWriteReady.SetEvent; +end; + +function TRoundBuffer.ReadFromSocket(ASocket: TLSocket): integer; +var + p: PByte; + s: integer; +begin + if fClosed then exit; + s := fSize-fDataSize; + if s>0 then + begin + p := GetMem(s); + try + s := ASocket.Get(p^,s); + result := Push(p^,s); + finally + FreeMem(p); + end; + end + else + begin + result := -1; + fReadReady.SetEvent; + end; +end; + +procedure TRoundBuffer.Read(out Value: byte); +begin + Pop(value,sizeof(byte)); +end; + +procedure TRoundBuffer.Read(out Value: word); +var + rem,l : integer; + p: PByte; + lBytes: array[0..1] of byte; +begin + Value := 0; + rem := 2; + p := PByte(lBytes); + repeat + l := pop(p^,rem); + dec(rem,l); + inc(p,l); + if l=0 then sleep(100); + until rem=0; + for l := 1 downto 0 do + Value := (Value shl 8) or lBytes[l]; +end; + +procedure TRoundBuffer.Read(out Value: dword); +var + rem,l : integer; + p: PByte; + lBytes: array[0..3] of byte; +begin + Value := 0; + rem := 4; + p := PByte(lBytes); + repeat + l := pop(p^,rem); + dec(rem,l); + inc(p,l); + if l=0 then sleep(100); + until rem=0; + for l := 3 downto 0 do + Value := (Value shl 8) or lBytes[l]; +end; + +procedure TRoundBuffer.Read(out Value: qword); +var + rem,l : integer; + p: PByte; + lBytes: array[0..7] of byte; +begin + Value := 0; + rem := 8; + p := PByte(lBytes); + repeat + l := pop(p^,rem); + dec(rem,l); + inc(p,l); + if l=0 then + sleep(10); + until (rem=0) or fClosed; + for l := 7 downto 0 do + Value := (Value shl 8) or lBytes[l]; +end; + +procedure TRoundBuffer.Close; +begin + fClosed := true; + fReadReady.SetEvent; + fWriteReady.SetEvent; +end; + +{ TCommandData } + +constructor TCommandData.Create(ACode: DWORD; AParam: QWord; AName: string; + AKeys: TStrings; AValues: TParamArray; AData: TStream); +var + i: integer; +begin + Code := Acode; + Param := AParam; + Name := AName; + if assigned(AKeys) then + begin + Keys := TStringList.Create; + Keys.Assign(AKeys); + end + else + Keys := nil; + setLength(iValues,length(AValues)); + for i := low(iValues) to high(iValues) do + iValues[i] := AValues[i]; + if assigned(AData) then + begin + Data := TMemoryStream.Create; + AData.seek(0,soFromBeginning); + Data.CopyFrom(AData,AData.Size); + end + else + Data := nil; +end; + +destructor TCommandData.Destroy; +begin + if assigned(Keys) then Keys.Free; + if assigned(Data) then Data.Free; + setLength(iValues,0); + inherited Destroy; +end; + +procedure TCommandData.AssignTo(out ACode: DWORD; out AParam: QWord; out + AName: string; out AKeys: TStrings; out AValues: TParamArray; out + AData: TStream); +var + i: integer; +begin + ACode := Code; + AParam := Param; + AName := Name; + if assigned(Keys) then + begin + AKeys := TStringList.Create; + AKeys.Assign(Keys); + end + else + AKeys := nil; + if assigned(Data) then + begin + AData := TMemoryStream.Create; + Data.Seek(0,soFromBeginning); + AData.CopyFrom(Data,Data.Size); + end + else + AData := nil; + CopyParamArray(iValues,AValues); +end; + +end. + diff --git a/fr_utils.pas b/fr_utils.pas new file mode 100644 index 0000000..fb260e5 --- /dev/null +++ b/fr_utils.pas @@ -0,0 +1,91 @@ +unit fr_utils; + +{$mode ObjFPC}{$H+} + +interface + +uses + SysUtils, Classes, fs_iinterpreter, xpMemParamManagerUnit, controls, frxClass, cgiDM; +type + + { TxpFRFunctions } + + TxpFRFunctions = class(TfsRTTIModule) + private + class var fData: TNIDBDM; + class var fVars: TxpMemParamManager; + function CallMethod(Instance: TObject; AClassType: TClass; const AMethodName: String; var Params: Variant): Variant; + function _(const szMsgId: string): string; + public + constructor Create(AScript: TfsScript); override; + class procedure SetReport(Adata: TNIDBDM; AVariables: TxpMemParamManager); + end; + +implementation + +uses + //gnugettext, + numberinwords; +function TxpFRFunctions._(const szMsgId: string): string; +begin + Result := szMsgId; + if Assigned(fData) then + begin + result := fData.QueryValue(format('select interpretation from xp_vocabulary where term=%s',[TNidbDM.StringAsSQL(szMsgId)]),szMsgId); + end; +end; +constructor TxpFRFunctions.Create(AScript: TfsScript); +begin + inherited Create(AScript); + with AScript do + begin + AddMethod('function _(str:string):string', @CallMethod, 'LMS функции', 'Функция _()'); + AddMethod('function Log(str:string):integer', @CallMethod, 'LMS функции', 'Функция LOG()'); + AddMethod('function Variable(str:string):string', @CallMethod, 'LMS функции', 'Функция Variable()'); + AddMethod('function AnsiLowerCase(str:string):string', @CallMethod, 'LMS функции', 'Функция AnsiLowerCase()'); + + AddMethod('function ЧислоСловами(number:integer;gender:integer;declension:integer):string', @CallMethod, 'LMS функции', 'Функция ЧислоСловами(число, род (0=М,1=Ж,2=С), падеж (0=И,5=П))'); + AddMethod('function НомерСловами(number:integer;gender:integer;declension:integer):string', @CallMethod, 'LMS функции', 'Функция НомерСловами(число, род (0=М,1=Ж,2=С), падеж (0=И,5=П))'); + + AddMethod('function Нагрузка(reqname: string; paramNumber: integer):string', @CallMethod, 'LMS функции', 'Функция Нагрузка(параметр нагрузки, номер поля (1=не менее,2=не более))'); + AddMethod('procedure Логотип(ControlName: string; ImageName: string)',@CallMethod,'LMS функции','Отображение логотипа'); + end; +end; + +class procedure TxpFRFunctions.SetReport(Adata: TNIDBDM; + AVariables: TxpMemParamManager); +begin + fData := AData; + fVars := AVariables; +end; + +function TxpFRFunctions.CallMethod(Instance: TObject; AClassType: TClass; + const AMethodName: String; var Params: Variant): Variant; +begin + if AMethodName = '_' then Result := _(Params[0]) + else + if AnsiSameText(AMethodName,'Log') then begin + {$IFDEF DEBUG} cxlogger.TLogSystem.Loggers['fastreport'].writelog(Params[0],Params[1]); {$ENDIF} + result := true; + end + else + if AnsiSameText(AMethodName,'Variable') then + begin + if fVars<>nil then + Result := fVars[(Params[0])] + else + Result := ''; + end + else + if AnsiSameText(AMethodName, 'AnsiLowerCase') then Result := AnsiLowerCase(Params[0]) + else + if AnsiSameText(AMethodName, 'ЧислоСловами') then Result := number999(Params[0],Params[1],Params[2]) + else + if AnsiSameText(AMethodName, 'НомерСловами') then Result := number999_ord(Params[0],Params[1],Params[2]) +end; + + + +initialization + fsRTTIModules.Add(TxpFRFunctions); +end. diff --git a/lms_cgi.lpi b/lms_cgi.lpi new file mode 100644 index 0000000..691c5a8 --- /dev/null +++ b/lms_cgi.lpi @@ -0,0 +1,108 @@ + + + + + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes> + <Item Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + </RunParams> + <RequiredPackages> + <Item> + <PackageName Value="lnetbase"/> + </Item> + <Item> + <PackageName Value="DataPortLasarus"/> + </Item> + <Item> + <PackageName Value="Abbrevia"/> + </Item> + <Item> + <PackageName Value="frxe_lazarus"/> + </Item> + <Item> + <PackageName Value="dcpcrypt"/> + </Item> + <Item> + <PackageName Value="fr_lazarus"/> + </Item> + <Item> + <PackageName Value="nnzdata"/> + </Item> + <Item> + <PackageName Value="WebLaz"/> + </Item> + <Item> + <PackageName Value="FCL"/> + </Item> + </RequiredPackages> + <Units> + <Unit> + <Filename Value="lms_cgi.lpr"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="tcpthreadhelper.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="tcpclient.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="tcpClient"/> + </Unit> + <Unit> + <Filename Value="exttypes.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="extTypes"/> + </Unit> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="U:\Apache\Apache24\cgi-bin"/> + </SearchPaths> + <Other> + <CustomOptions Value="-dDEBUG +-dLOG +-dCGI"/> + <OtherDefines Count="3"> + <Define0 Value="DEBUG"/> + <Define1 Value="LOG"/> + <Define2 Value="CGI"/> + </OtherDefines> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions> + <Item> + <Name Value="EAbort"/> + </Item> + <Item> + <Name Value="ECodetoolError"/> + </Item> + <Item> + <Name Value="EFOpenError"/> + </Item> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/lms_cgi.lpr b/lms_cgi.lpr new file mode 100644 index 0000000..08b8089 --- /dev/null +++ b/lms_cgi.lpr @@ -0,0 +1,166 @@ +program lms_cgi; + +{$mode objfpc}{$H+} + +uses + Interfaces, Classes, SysUtils, inifiles, httpDefs, fpweb, custweb, custcgi, + cxlogger, abbrevia, lnetbase, tcpClient, tcpthreadhelper, extTypes; + +Type + + { TMyCGIHandler } + + TMyCGIHandler = Class(TCgiHandler) + Private + fAnswer: string; + fMode: byte; + fCode: DWORD; + fParam: QWORD; + fValues: TStrings; + fData: TStream; + function answerReady(Sender: TMainThread; const mode: byte; + const Code:DWORD; const QValue: QWORD; const Answer: string; const Values: TStrings; const iValues: TParamArray; const Data: TStream): boolean; + Public + Procedure HandleRequest(ARequest : Trequest; AResponse : TResponse); override; + procedure log(Sender: TObject; msg: string); + end; + + + { TMyCGIApp } + + TMyCGIApp = Class(TCustomCGIApplication) + private + flogFolder: string; + fHost: string; + fPort: integer; + procedure LoadConfig; + Protected + function InitializeWebHandler: TWebHandler; override; + public + property Host: string read fHost; + property Port: integer read fPort; + property LogFolder: string read fLogFolder; + end; + +const + aTypes: array[0..3] of string=('"UNKNOWN"','"REQUEST"','"ANSWER"','"ERROR"'); + +function TMyCGIHandler.answerReady(Sender: TMainThread; const mode: byte; + const Code: DWORD; const QValue: QWORD; const Answer: string; + const Values: TStrings; const iValues: TParamArray; const Data: TStream + ): boolean; +begin + log(self,'AnswerReady'); + fAnswer:=Answer; + fMode:=mode; + fCode:=code; + fParam:=QValue; + if assigned(Values) then + begin + fValues:=TStringList.Create; + fValues.assign(Values); + end; + if assigned(Data) then + begin + fData := TMemoryStream.Create; + Data.seek(0,soFromBeginning); + fData.CopyFrom(Data,Data.Size); + end; + Sender.Terminate; +end; + +procedure TMyCGIHandler.HandleRequest(ARequest: Trequest; AResponse: TResponse); +var + clt: TClientMainThread; + i: integer; + k,v: string; + allfields: TStrings; +begin + log(self,'HandleRequest'); + LogStrings(@log,self,'QueryFields',Arequest.QueryFields); + allfields := TStringList.Create; + try + allfields.AddStrings(ARequest.QueryFields); + allfields.AddStrings(ARequest.ContentFields); + clt := TClientMainThread.Create(ARequest.QueryFields.Values['action'],allfields,@Log,(Owner as TMyCGIApp).Host,(Owner as TMyCGIApp).Port,@answerReady); + clt.start; + clt.waitFor; + + finally + allfields.free; + end; + log(self,'Data READY'); + if not assigned(fData) then + begin + AResponse.ContentType := 'application/json'; + AResponse.Contents.add('{'); + AResponse.Contents.add('"type":'+aTypes[fMode]+','); + AResponse.Contents.add('"code":'+inttostr(fCode)+','); + AResponse.Contents.add('"value":'+inttostr(fParam)+','); + AResponse.Contents.add('"name":"'+(fAnswer)+'",'); + if assigned(fValues) then + begin + AResponse.Contents.add('"values":['); + for i := 0 to fValues.Count-1 do + begin + AResponse.Contents.Add(fValues[i]+','); + end; + AResponse.Contents.add(']'); + fValues.Free; + end; + AResponse.Contents.add('}'); + end + else + begin + AResponse.FreeContentStream := true; + AResponse.ContentType:='application/pdf'; + fData.Seek(0,soFromBeginning); + AResponse.ContentStream := fData; + end; + log(self,'Sending'); + AResponse.SendContent; + log(self,'Sent'); +end; + +procedure TMyCGIHandler.log(Sender: TObject; msg: string); +var + f: TextFile; +begin + if (Owner as TMyCGIApp).LogFolder='' then exit; + assignfile(f, (Owner as TMyCGIApp).LogFolder); + if fileexists((Owner as TMyCGIApp).LogFolder) then append(f) else rewrite(f); + writeln(f,msg); + closefile(f); +end; + +procedure TMyCGIApp.LoadConfig; +var + ini: TIniFile; +begin + ini := TIniFile.Create(ChangeFileExt(ParamStr(0),'.ini')); + try + fHost := ini.ReadString('PARAMS','host','localhost'); + fPort := ini.ReadInteger('PARAMS','port',6543); + flogFolder:=ini.ReadString('PARAMS','log',''); + finally + ini.free; + end; +end; + +function TMyCGIApp.InitializeWebHandler: TWebHandler; +begin + LoadConfig; + Result:=TMyCgiHandler.Create(self); +end; + + + +begin + with TMyCGIApp.create(nil) do + try + Initialize; + Run; + finally + Free; + end; +end. diff --git a/lmsreport.ico b/lmsreport.ico new file mode 100644 index 0000000..10c5fc1 Binary files /dev/null and b/lmsreport.ico differ diff --git a/lmsreport.ini b/lmsreport.ini new file mode 100644 index 0000000..152728e --- /dev/null +++ b/lmsreport.ini @@ -0,0 +1,7 @@ +[DATA] +host=10.120.7.20 +port=7079 +database=lms +[PARAMS] +port=6543 +log=D:\PROJECTS\LAZARUS\LMS\out\server.log \ No newline at end of file diff --git a/lmsreport.lpi b/lmsreport.lpi new file mode 100644 index 0000000..012abcb --- /dev/null +++ b/lmsreport.lpi @@ -0,0 +1,161 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="12"/> + <PathDelim Value="\"/> + <General> + <SessionStorage Value="InProjectDir"/> + <Title Value="lmsreport"/> + <Scaled Value="True"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <XPManifest> + <DpiAware Value="True"/> + </XPManifest> + <Icon Value="0"/> + </General> + <BuildModes> + <Item Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + </RunParams> + <RequiredPackages> + <Item> + <PackageName Value="Abbrevia"/> + </Item> + <Item> + <PackageName Value="frxe_lazarus"/> + </Item> + <Item> + <PackageName Value="fr_lazarus"/> + </Item> + <Item> + <PackageName Value="dcpcrypt"/> + </Item> + <Item> + <PackageName Value="nnzdata"/> + </Item> + <Item> + <PackageName Value="lnetbase"/> + </Item> + <Item> + <PackageName Value="LCL"/> + </Item> + </RequiredPackages> + <Units> + <Unit> + <Filename Value="lmsreport.lpr"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="maintcpserver.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="CGIServerGUI"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="MainTcpServer"/> + </Unit> + <Unit> + <Filename Value="tcpthreadhelper.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="connectionsdmunit.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="ConnectionsDM"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="DataModule"/> + <UnitName Value="ConnectionsDmUnit"/> + </Unit> + <Unit> + <Filename Value="reportdmunit.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="ReportDM"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="DataModule"/> + <UnitName Value="reportDMUnit"/> + </Unit> + <Unit> + <Filename Value="cgidm.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="NIDBDM"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="DataModule"/> + <UnitName Value="cgiDM"/> + </Unit> + <Unit> + <Filename Value="xpaccessunit.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="xpAccessUnit"/> + </Unit> + <Unit> + <Filename Value="exttypes.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="extTypes"/> + </Unit> + <Unit> + <Filename Value="tcpserver.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="tcpclient.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="tcpClient"/> + </Unit> + <Unit> + <Filename Value="cgireport.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="cgiReport"/> + </Unit> + <Unit> + <Filename Value="cgicommand.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="cgiCommand"/> + </Unit> + <Unit> + <Filename Value="fr_utils.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="baseconnection.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="lmsreport"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions> + <Item> + <Name Value="EAbort"/> + </Item> + <Item> + <Name Value="ECodetoolError"/> + </Item> + <Item> + <Name Value="EFOpenError"/> + </Item> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/lmsreport.lpr b/lmsreport.lpr new file mode 100644 index 0000000..50d0e95 --- /dev/null +++ b/lmsreport.lpr @@ -0,0 +1,38 @@ +program lmsreport; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX} + cthreads, + {$ENDIF} + {$IFDEF HASAMIGA} + athreads, + {$ENDIF} + Interfaces, // this includes the LCL widgetset + sysutils,Forms, abbrevia, lnetbase, MainTcpServer, tcpthreadhelper, reportDMUnit, + ConnectionsDmUnit, cgiDM, xpAccessUnit, extTypes, tcpserver, tcpClient, +cgiReport, cgiCommand, fr_utils, baseconnection + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource:=True; + Application.Scaled:=True; + Application.Initialize; + if paramstr(1)='console' then + begin + Application.CreateForm(TCGIServerGUI, CGIServerGUI); + Application.Run; + end + else + begin + Application.CreateForm(TConnectionsDM,ConnectionsDM); + ConnectionsDM.start; + while ConnectionsDM.running do + sleep(1000); + + end; +end. + diff --git a/maintcpserver.lfm b/maintcpserver.lfm new file mode 100644 index 0000000..8e4c06d --- /dev/null +++ b/maintcpserver.lfm @@ -0,0 +1,146 @@ +object CGIServerGUI: TCGIServerGUI + Left = 333 + Height = 309 + Top = 224 + Width = 870 + Caption = 'Сервер отчетов LMS' + ClientHeight = 309 + ClientWidth = 870 + OnCreate = FormCreate + OnDestroy = FormDestroy + LCLVersion = '2.2.4.0' + object Panel1: TPanel + Left = 0 + Height = 50 + Top = 0 + Width = 870 + Align = alTop + Caption = 'остановлен' + ClientHeight = 50 + ClientWidth = 870 + TabOrder = 0 + object SendButton: TButton + Left = 96 + Height = 25 + Top = 14 + Width = 75 + Caption = 'Запрос' + OnClick = SendButtonClick + TabOrder = 0 + end + object StartButton: TButton + Left = 8 + Height = 25 + Top = 14 + Width = 75 + Caption = 'Запуск' + OnClick = StartButtonClick + TabOrder = 1 + end + end + object GroupBox1: TGroupBox + Left = 0 + Height = 259 + Top = 50 + Width = 368 + Align = alLeft + Caption = 'Запрос' + ClientHeight = 239 + ClientWidth = 364 + TabOrder = 1 + object Keys: TMemo + Left = 0 + Height = 216 + Top = 23 + Width = 364 + Align = alClient + Lines.Strings = ( + 'user=nnz' + 'password=Sochi-2020' + ) + TabOrder = 0 + end + object edtRequest: TComboBox + Left = 0 + Height = 23 + Top = 0 + Width = 364 + Align = alTop + ItemHeight = 15 + ItemIndex = 3 + Items.Strings = ( + 'version' + 'reports' + 'arguments' + 'login' + 'test' + 'logout' + 'option_values' + 'report' + 'status' + 'result' + ) + TabOrder = 1 + Text = 'login' + end + end + object GroupBox2: TGroupBox + Left = 373 + Height = 259 + Top = 50 + Width = 497 + Align = alClient + Caption = 'Ответ' + ClientHeight = 239 + ClientWidth = 493 + TabOrder = 2 + object edtAnswer: TEdit + Left = 0 + Height = 23 + Top = 25 + Width = 493 + Align = alTop + OnDblClick = edtAnswerDblClick + TabOrder = 0 + end + object retValues: TMemo + Left = 0 + Height = 88 + Top = 71 + Width = 493 + Align = alClient + TabOrder = 1 + end + object intValues: TListBox + Left = 0 + Height = 80 + Top = 159 + Width = 493 + Align = alBottom + ItemHeight = 0 + TabOrder = 2 + end + object edtQValue: TEdit + Left = 0 + Height = 23 + Top = 48 + Width = 493 + Align = alTop + TabOrder = 3 + end + object StatusPanel: TPanel + Left = 0 + Height = 25 + Top = 0 + Width = 493 + Align = alTop + TabOrder = 4 + end + end + object Splitter1: TSplitter + Left = 368 + Height = 259 + Top = 50 + Width = 5 + end +end diff --git a/maintcpserver.pas b/maintcpserver.pas new file mode 100644 index 0000000..72ca0f7 --- /dev/null +++ b/maintcpserver.pas @@ -0,0 +1,182 @@ +unit MainTcpServer; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls, + tcpClient,tcpServer, tcpthreadhelper, + ConnectionsDmUnit, syncobjs, extTypes; + +type + + { TClientThread } + + + { TCGIServerGUI } + + TCGIServerGUI = class(TForm) + edtAnswer: TEdit; + edtQValue: TEdit; + edtRequest: TComboBox; + GroupBox1: TGroupBox; + GroupBox2: TGroupBox; + intValues: TListBox; + StatusPanel: TPanel; + retValues: TMemo; + Keys: TMemo; + SendButton: TButton; + Panel1: TPanel; + Splitter1: TSplitter; + StartButton: TButton; + procedure edtAnswerDblClick(Sender: TObject); + procedure SendButtonClick(Sender: TObject); + procedure StartButtonClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + private + + Server: TConnectionsDM; + Client: TClientMainThread; + cmdDone: boolean; + started: boolean; + procedure LogQuery(const qtype: integer; const command: string; const aKeys: TStrings; const code: DWORD; const Param: QWORD; const data: TParamArray); + function onAnswer(Sender: TMainThread; const mode: byte; + const Code:DWORD; const QValue: QWORD; const Answer: string; const Values: TStrings; const iValues: TParamArray; const Data: TStream): boolean; + public + + end; + + { TConnectionThread } + + +var + CGIServerGUI: TCGIServerGUI; + +implementation + +{$R *.lfm} +uses + types,strUtils; + + +{ TCGIServerGUI } + +procedure TCGIServerGUI.FormCreate(Sender: TObject); +begin + Server := TConnectionsDM.Create(self); + ConnectionsDM := Server; + cmdDone := true; + started := false; + SendButton.Enabled := false; +end; + +procedure TCGIServerGUI.SendButtonClick(Sender: TObject); +begin + if not started then exit; + client := TClientMainThread.Create(edtRequest.Text,Keys.Lines,@Server.log,'localhost',6543,@onAnswer); + LogQuery(0,edtRequest.Text,Keys.Lines,0,0,[]); + cmdDone := false; + edtAnswer.Text := ''; + edtQValue.Text := ''; + StatusPanel.Caption := 'Ожидание'; + retValues.Clear; + client.Start; + +end; + +procedure TCGIServerGUI.edtAnswerDblClick(Sender: TObject); +begin + Keys.Lines.Add('='+edtanswer.text); +end; + +procedure TCGIServerGUI.StartButtonClick(Sender: TObject); +begin + + Server.Start; + started := true; + Panel1.Caption := 'запущен'; + SendButton.Enabled := true; +end; + +procedure TCGIServerGUI.FormDestroy(Sender: TObject); +begin + Server.Free; +end; + +procedure TCGIServerGUI.LogQuery(const qtype: integer; const command: string; + const aKeys: TStrings; const code: DWORD; const Param: QWORD; + const data: TParamArray); +var + f: textfile; + logfile: string; + i: integer; +begin + logfile := ExtractFilePath(paramstr(0))+'out/query.log'; + assignfile(f,logfile); + if fileexists(logfile) then + append(f) + else + rewrite(f); + case qType of + 0: writeln(f,DateTimeToStr(now()),#09,'REQUEST'); + 1: writeln(f,DateTimeToStr(now()),#09,'RESULT'); + end; + writeln(f,#09,command); + if qType=1 then + writeln(f,#09,format('code=%d, value=0x%x',[code,Param])); + if assigned(aKeys) then + for i := 0 to akeys.Count-1 do + writeln(f,#09,#09,aKeys[i]); + + closefile(f); +end; + + + +function TCGIServerGUI.onAnswer(Sender: TMainThread; const mode: byte; + const Code: DWORD; const QValue: QWORD; const Answer: string; + const Values: TStrings; const iValues: TParamArray; const Data: TStream + ): boolean; +var + i: integer; + fs: TFileStream; +begin + try + LogQuery(1,Answer,Values,code,QValue,iValues); + edtAnswer.Text := Answer; + case mode of + cmdAnswer: StatusPanel.Caption := format('OK(%d)',[code]); + cmdError: StatusPanel.Caption := format('ERROR(%d)',[code]); + end; + edtQValue.Text:=IntToHex(QValue,16); + if assigned(Values) then + retValues.Lines.Assign(Values) + else + retValues.Clear; + intValues.Clear; + for i := low(iValues) to high(iValues) do + intValues.AddItem(inttostr(ivalues[i]),TObject(PtrInt(iValues[i]))); + if Assigned(Data) then + begin + Data.seek(0,soFromBeginning); + fs := TFileStream.Create(Answer,fmCreate); + try + fs.CopyFrom(Data,Data.size); + finally + fs.free; + end; + end; + finally + Sender.Terminate; + cmdDone := true; + end; + +end; + + + + +end. + diff --git a/numberinwords.pas b/numberinwords.pas new file mode 100644 index 0000000..8acc46a --- /dev/null +++ b/numberinwords.pas @@ -0,0 +1,464 @@ +unit numberinwords; + +interface +function number999(number: integer; gender: integer; declension: integer): string; +function number999_ord(number: integer; gender: integer; declension: integer): string; +implementation +function number900(centi: integer; declension: integer): string; +begin + case centi of + 0:; + 1: case declension of + 0: Result := 'сто'; + 1: Result := 'ста'; + 2: Result := 'ста'; + 3: Result := 'сто'; + 4: Result := 'ста'; + 5: Result := 'ста'; + end; + 2: case declension of + 0: Result := 'двести'; + 1: Result := 'двухсот'; + 2: Result := 'двумстам'; + 3: Result := 'двести'; + 4: Result := 'двумястами'; + 5: Result := 'двухстах'; + end; + 3: case declension of + 0: Result := 'триста'; + 1: Result := 'трехсот'; + 2: Result := 'тремстам'; + 3: Result := 'триста'; + 4: Result := 'тремястами'; + 5: Result := 'трехстах'; + end; + 4: case declension of + 0: Result := 'четыреста'; + 1: Result := 'четырехсот'; + 2: Result := 'четыремстам'; + 3: Result := 'четыреста'; + 4: Result := 'четырьмястами'; + 5: Result := 'четырехстах'; + end; + 5: case declension of + 0: Result := 'пятьсот'; + 1: Result := 'пятисот'; + 2: Result := 'пятистам'; + 3: Result := 'пятьсот'; + 4: Result := 'пятьюстами'; + 5: Result := 'пятистах'; + end; + 6: case declension of + 0: Result := 'шестьсот'; + 1: Result := 'шестисот'; + 2: Result := 'шестистам'; + 3: Result := 'шестьсот'; + 4: Result := 'шестьюстами'; + 5: Result := 'шестистах'; + end; + 7: case declension of + 0: Result := 'семьсот'; + 1: Result := 'семисот'; + 2: Result := 'семистам'; + 3: Result := 'семьсот'; + 4: Result := 'семьюстами'; + 5: Result := 'семистах'; + end; + 8: case declension of + 0: Result := 'восемьсот'; + 1: Result := 'восьмисот'; + 2: Result := 'восьмистам'; + 3: Result := 'восемьсот'; + 4: Result := 'восемьюстами'; + 5: Result := 'восьмистах'; + end; + 9: case declension of + 0: Result := 'девятьсот'; + 1: Result := 'девятисот'; + 2: Result := 'девятистам'; + 3: Result := 'девятьсот'; + 4: Result := 'девятьюстами'; + 5: Result := 'девятистах'; + end; + end; +end; +function Adjective1(gender,declension: integer): string; +begin + case declension of + 0: case gender of + 0: result := 'ый'; + 1: result := 'ая'; + 2: result := 'ое'; + end; + 1: case gender of + 0: result := 'ого'; + 1: result := 'ой'; + 2: result := 'ого'; + end; + 2: case gender of + 0: result := 'ому'; + 1: result := 'ой'; + 2: result := 'ому'; + end; + 3: case gender of + 0: result := 'ый'; + 1: result := 'ую'; + 2: result := 'ое'; + end; + 4: case gender of + 0: result := 'ым'; + 1: result := 'ой'; + 2: result := 'ым'; + end; + 5: case gender of + 0: result := 'ом'; + 1: result := 'ой'; + 2: result := 'ом'; + end; + end; +end; +function Adjective2(gender,declension: integer): string; +begin + if (gender=0) and (declension in [0,3]) then result := 'ой' + else result := Adjective1(gender,declension); +end; +function Adjective3(gender,declension: integer): string; +begin + case declension of + 0: case gender of + 0: result := 'ий'; + 1: result := 'яя'; + 2: result := 'ье'; + end; + 1: case gender of + 0: result := 'ьего'; + 1: result := 'ей'; + 2: result := 'ьего'; + end; + 2: case gender of + 0: result := 'ьему'; + 1: result := 'ей'; + 2: result := 'ьему'; + end; + 3: case gender of + 0: result := 'ий'; + 1: result := 'ью'; + 2: result := 'ье'; + end; + 4: case gender of + 0: result := 'ьим'; + 1: result := 'ьей'; + 2: result := 'ьим'; + end; + 5: case gender of + 0: result := 'ьем'; + 1: result := 'ьей'; + 2: result := 'ьем'; + end; + end; +end; + +function number900_ord(centi: integer; gender: integer; declension: integer): string; +begin + case centi of + 0:; + 1: result := 'сот'+Adjective1( gender, declension); + 2: result := 'двухсот'+Adjective1( gender, declension); + 3: result := 'трехсот'+Adjective1( gender, declension); + 4: result := 'четырехсот'+Adjective1( gender, declension); + 5: result := 'пятисот'+Adjective1( gender, declension); + 6: result := 'шестисот'+Adjective1( gender, declension); + 7: result := 'семисот'+Adjective1( gender, declension); + 8: result := 'восьмисот'+Adjective1( gender, declension); + 9: result := 'девятисот'+Adjective1( gender, declension); + end; +end; + +function number90(decades: integer; declension: integer): string; +begin + case decades of + 0,1:; + 2: case declension of + 0: Result := 'двадцать'; + 1: Result := 'двадцати'; + 2: Result := 'двадцати'; + 3: Result := 'двадцать'; + 4: Result := 'двадцатью'; + 5: Result := 'двадцати'; + end; + 3: case declension of + 0: Result := 'тридцать'; + 1: Result := 'тридцати'; + 2: Result := 'тридцати'; + 3: Result := 'тридцать'; + 4: Result := 'тридцатью'; + 5: Result := 'тридцати'; + end; + 4: case declension of + 0: Result := 'сорок'; + 1: Result := 'сорока'; + 2: Result := 'сорока'; + 3: Result := 'сорок'; + 4: Result := 'сорока'; + 5: Result := 'сорока'; + end; + 5: case declension of + 0: Result := 'пятьдесят'; + 1: Result := 'пятидесяти'; + 2: Result := 'пятидесяти'; + 3: Result := 'пятьдесят'; + 4: Result := 'пятьюдесятью'; + 5: Result := 'пятидесяти'; + end; + 6: case declension of + 0: Result := 'шестьдесят'; + 1: Result := 'шестидесяти'; + 2: Result := 'шестидесяти'; + 3: Result := 'шестьдесят'; + 4: Result := 'шестьюдесятью'; + 5: Result := 'шестидесяти'; + end; + 7: case declension of + 0: Result := 'семьдесят'; + 1: Result := 'семидесяти'; + 2: Result := 'семидесяти'; + 3: Result := 'семьдесят'; + 4: Result := 'семьюдесятью'; + 5: Result := 'семидесяти'; + end; + 8: case declension of + 0: Result := 'восемьдесят'; + 1: Result := 'восьмидесяти'; + 2: Result := 'восьмидесяти'; + 3: Result := 'восемьдесят'; + 4: Result := 'восьмьюдесятью'; + 5: Result := 'восьмидесяти'; + end; + 9: case declension of + 0: Result := 'девяносто'; + 1: Result := 'девяноста'; + 2: Result := 'девяноста'; + 3: Result := 'девяносто'; + 4: Result := 'девяноста'; + 5: Result := 'девяноста'; + end; + end; +end; +function number90_ord(decades: integer; gender: integer; declension: integer): string; +begin + case decades of + 0,1:; + 2: Result := 'двадцат' + Adjective1(gender,declension); + 3: Result := 'тридцат' + Adjective1(gender,declension); + 4: Result := 'сороков' + Adjective2(gender,declension); + 5: Result := 'пятидесят' + Adjective1(gender,declension); + 6: Result := 'шестидесят' + Adjective1(gender,declension); + 7: Result := 'седидесят' + Adjective1(gender,declension); + 8: Result := 'восьмидесят' + Adjective1(gender,declension); + 9: Result := 'девяност' + Adjective1(gender,declension); + end; +end; +function number19(number: integer; declension: integer): string; +var + p1,p2: string; +begin + case declension of + 0: p2 := 'надцать'; + 1: p2 := 'надцати'; + 2: p2 := 'надцати'; + 3: p2 := 'надцать'; + 4: p2 := 'надцатью'; + 5: p2 := 'надцати'; + end; + case number of + 11: p1 := 'один'; + 12: p1 := 'две'; + 13: p1 := 'три'; + 14: p1 := 'четыр'; + 15: p1 := 'пят'; + 16: p1 := 'шест'; + 17: p1 := 'семь'; + 18: p1 := 'восемь'; + 19: p1 := 'девят'; + end; + Result := p1 + p2; +end; +function number19_ord(number: integer; gender: integer; declension: integer): string; +var + p1: string; +begin + case number of + 11: p1 := 'один'; + 12: p1 := 'две'; + 13: p1 := 'три'; + 14: p1 := 'четыр'; + 15: p1 := 'пят'; + 16: p1 := 'шест'; + 17: p1 := 'семь'; + 18: p1 := 'восемь'; + 19: p1 := 'девят'; + end; + Result := Result +'надцат'+Adjective1(gender,declension) +end; +function number9(number: integer; gender: integer; declension: integer): string; +begin + case number of + 0:; + 1: case declension of + 0: case gender of + 0: Result := 'один'; + 1: Result := 'одна'; + 2: Result := 'одно'; + end; + 1: case gender of + 0: Result := 'одного'; + 1: Result := 'одной'; + 2: Result := 'одного'; + end; + 2: case gender of + 0: Result := 'одному'; + 1: Result := 'одной'; + 2: Result := 'одному'; + end; + 3: case gender of + 0: Result := 'один'; + 1: Result := 'одну'; + 2: Result := 'одно'; + end; + 4: case gender of + 0: Result := 'одним'; + 1: Result := 'одной'; + 2: Result := 'одним'; + end; + 5: case gender of + 0: Result := 'одном'; + 1: Result := 'одной'; + 2: Result := 'одном'; + end; + end; + 2: case declension of + 0: case gender of + 0,2: Result := 'два'; + 1: Result := 'две'; + end; + 1: Result := 'двух'; + 2: Result := 'двум'; + 3: Result := 'двух'; + 4: Result := 'двумя'; + 5: Result := 'двух'; + end; + 3: case declension of + 0: Result := 'три'; + 1: Result := 'трех'; + 2: Result := 'трем'; + 3: Result := 'три'; + 4: Result := 'тремя'; + 5: Result := 'трех'; + end; + 4: case declension of + 0: Result := 'четыре'; + 1: Result := 'четырех'; + 2: Result := 'четырем'; + 3: Result := 'четыре'; + 4: Result := 'четырьмя'; + 5: Result := 'четырех'; + end; + 5: case declension of + 0: Result := 'пять'; + 1: Result := 'пяти'; + 2: Result := 'пяти'; + 3: Result := 'пять'; + 4: Result := 'пятью'; + 5: Result := 'пяти'; + end; + 6: case declension of + 0: Result := 'шесть'; + 1: Result := 'шести'; + 2: Result := 'шести'; + 3: Result := 'шесть'; + 4: Result := 'шестью'; + 5: Result := 'шести'; + end; + 7: case declension of + 0: Result := 'семь'; + 1: Result := 'семи'; + 2: Result := 'семи'; + 3: Result := 'семь'; + 4: Result := 'семью'; + 5: Result := 'семи'; + end; + 8: case declension of + 0: Result := 'восемь'; + 1: Result := 'восьми'; + 2: Result := 'восьми'; + 3: Result := 'восемь'; + 4: Result := 'восемью'; + 5: Result := 'восьми'; + end; + 9: case declension of + 0: Result := 'девять'; + 1: Result := 'девяти'; + 2: Result := 'девяти'; + 3: Result := 'девять'; + 4: Result := 'девятью'; + 5: Result := 'девяти'; + end; + + end; +end; +function number9_ord(number: integer; gender: integer; declension: integer): string; +begin + case number of + 1: result := 'перв' + Adjective1(gender,declension); + 2: result := 'втор' + Adjective2(gender,declension); + 3: result := 'трет' + Adjective3(gender,declension); + 4: result := 'четверт' + Adjective1(gender,declension); + 5: result := 'пят' + Adjective1(gender,declension); + 6: result := 'шест' + Adjective2(gender,declension); + 7: result := 'седьм' + Adjective2(gender,declension); + 8: result := 'восьм' + Adjective2(gender,declension); + 9: result := 'девят' + Adjective1(gender,declension); + end; +end; +function number999(number: integer; gender: integer; declension: integer): string; +begin + result := number900(number div 100, declension); + number := number mod 100; + case number of + 0..9: result := result + ' ' + number9(number,gender,declension); + 11..19: result := result + ' ' + number19(number,declension); + else begin + result := result +' '+ number90(number div 10,declension); + number := number mod 10; + result := result +' '+ number9(number,gender,declension); + end; + end; +end; + +function number999_ord(number: integer; gender: integer; declension: integer): string; +var + top,rem: integer; +begin + top := number div 100; + rem := number mod 100; + if rem = 0 then + begin + result := number900_ord(top,gender,declension); + exit; + end; + result := number900(top,0); + top := rem; + rem := top mod 10; + case top of + 1..9: result := result + ' ' + number9_ord(top,gender,declension); + 11..19: result := result + ' ' + number19_ord(top,gender,declension); + else begin + if rem = 0 then + result := result +' '+ number90_ord(top div 10,gender,declension) + else + result := result +' '+ number90(top div 10, 0) + ' ' + number9_ord(rem,gender,declension); + end; + end; + +end; +end. diff --git a/reportdmunit.lfm b/reportdmunit.lfm new file mode 100644 index 0000000..0965e17 --- /dev/null +++ b/reportdmunit.lfm @@ -0,0 +1,94 @@ +object ReportDM: TReportDM + OldCreateOrder = False + Height = 213 + HorizontalOffset = 694 + VerticalOffset = 317 + Width = 330 + object frxReport: TfrxReport + Version = '2023.1' + DotMatrixReport = False + EngineOptions.SilentMode = True + EngineOptions.NewSilentMode = simSilent + IniFile = '\Software\Fast Reports' + PreviewOptions.Buttons = [pbPrint, pbLoad, pbSave, pbExport, pbZoom, pbFind, pbOutline, pbPageSetup, pbTools, pbEdit, pbNavigator, pbExportQuick, pbCopy, pbSelection] + PreviewOptions.Zoom = 1 + PrintOptions.Printer = 'Default' + PrintOptions.PrintOnSheet = 0 + ReportOptions.CreateDate = 45166.790207419 + ReportOptions.LastChange = 45166.790207419 + ScriptLanguage = 'PascalScript' + ScriptText.Strings = ( + 'begin' + '' + 'end.' + ) + OnLoadTemplate = frxReportLoadTemplate + OnLoadDetailTemplate = frxReportLoadDetailTemplate + Left = 176 + Top = 24 + Datasets = <> + Variables = <> + Style = <> + end + object frxPDFExport1: TfrxPDFExport + UseFileCache = True + ShowProgress = True + OverwritePrompt = False + DataOnly = False + EmbedFontsIfProtected = False + InteractiveFormsFontSubset = 'A-Z,a-z,0-9,#43-#47 ' + OpenAfterExport = False + PrintOptimized = False + Outline = False + Background = False + HTMLTags = True + Quality = 95 + Author = 'FastReport' + Subject = 'FastReport PDF export' + Creator = 'FastReport' + ProtectionFlags = [ePrint, eModify, eCopy, eAnnot] + HideToolbar = False + HideMenubar = False + HideWindowUI = False + FitWindow = False + CenterWindow = False + PrintScaling = False + PdfA = False + PDFStandard = psNone + PDFVersion = pv17 + Left = 55 + Top = 97 + end + object frxODSExport1: TfrxODSExport + UseFileCache = True + ShowProgress = True + OverwritePrompt = False + DataOnly = False + PictureType = gpPNG + OpenAfterExport = False + Background = True + Creator = 'FastReport' + Language = 'en' + SuppressPageHeadersFooters = False + Left = 47 + Top = 24 + end + object frxODTExport1: TfrxODTExport + UseFileCache = True + ShowProgress = True + OverwritePrompt = False + DataOnly = False + PictureType = gpPNG + OpenAfterExport = False + Background = True + Creator = 'FastReport' + Language = 'en' + SuppressPageHeadersFooters = False + Left = 108 + Top = 61 + end + object AbUnZipper1: TAbUnZipper + Left = 180 + Top = 86 + end +end diff --git a/reportdmunit.pas b/reportdmunit.pas new file mode 100644 index 0000000..b8771cd --- /dev/null +++ b/reportdmunit.pas @@ -0,0 +1,693 @@ +unit reportDMUnit; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils, frxClass, frxExportPDF, frxExportODF, + xpMemParamManagerUnit, AbUnzper, frxDBSet, cgiDM,extTypes; + +type + TExportFileType = (ftPDF,ftRTF,ftXLS);//(ftPDF,ftMail,ftRTF,ftXLS,ftHTML); + { TReportDM } + TReportQuery=class; + + { TReportQuery } + + TReportQuery=class + private + fQueries: TList; + fOwner: TReportQuery; + fData: TNIDBDM; + function getQuery(index: integer): TReportQuery; + function getQueryCount: integer; + public + Name,SQL,LinkField,Description: string; + ID,ParentID: integer; + Data: TfrxDBDataset; + property Queries[index: integer]:TReportQuery read getQuery; + property QueryCount: integer read getQueryCount; + property MasterQuery: TReportQuery read fOwner; + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure AddQuery(q: TReportQuery); + procedure RemoveQuery(q: TReportQuery); + function Find(QueryID: integer): TReportQuery; + end; + + TReportDM = class(TDataModule) + AbUnZipper1: TAbUnZipper; + frxODSExport1: TfrxODSExport; + frxODTExport1: TfrxODTExport; + frxPDFExport1: TfrxPDFExport; + frxReport: TfrxReport; + function frxReportLoadDetailTemplate(Report: TfrxReport; + const TemplateName: String; const AHyperlink: TfrxHyperlink): Boolean; + procedure frxReportLoadTemplate(Report: TfrxReport; + const TemplateName: String); + private + TempTableAlreadyCreated : Boolean; + ComponentContainer : TList; + MasterDataSets: TStringList; // Список Master-датасетов (TfrxDBDataset) - не забыть создать/удалить как ComponentContainer. Возможно, не нужен??? + DetailDataSets: TStringList; // Список Detail-датасетов. В Objects - TStringList (id query + Detail-датасет(TfrxDBDataset)) + ReportVariables: TxpMemParamManager; + ReportQueries: TReportQuery; + procedure CreateDBDataSet(Query:TReportQuery; EditReport: Boolean = False); + procedure CreateSignaturesDataSet(EditReport: Boolean = False); + procedure CreateLogosDataSet(EditReport: Boolean = False); + procedure BuildPodpis(AVariables : TxpMemParamManager); + // Возвращает имя Master-датасета по id Detail-а (пустую строку если датасет не имеет Master-а) + function GetMasterDSName(qryID: integer): string; + // Возвращает имя ключевого поля (для Master-датасета - ключевое поле, для Detail-датасета - поле внешнего ключа) + function GetLinkFieldName(qryID: integer): string; + // Возвращает строку для фильтрации Detail-датасета. Параметры: + // - detail_key_fields, master_key_fields - строки, описывающие поля связи master и detail - датасета, + // - Link_type - тип связи ("ID" - по id, "BETWEEN" - по диапазону дат, "LIKE" - по подстроке и т.п. - сейчас пока только по id) + // - MasterDataSet - Master-датасет. + function GetFilterClause(detail_key_fields, master_key_fields, Link_type: string; MasterDataSet: TfrxDBDataset): string; + procedure PrepareBuildInfo(AVariables : TxpMemParamManager); + function GetVariable(AVariables: TxpMemParamManager; VarName: string; DefaultValue: string): string; + class function maskFRSpecial(value: string): string; + class function maskFRSpecialPreservingEOLs(value: string): string; + procedure frxReportPreview(Sender: TObject); + procedure LoadQueries; + procedure LoadDefaultVariables(AVariables : TxpMemParamManager); + procedure LoadLogos(AVariables : TxpMemParamManager); + procedure LoadVariables(AVariables, AParam : TxpMemParamManager); + procedure OnMasterRecord(Sender: TObject); + procedure LoadReportTemplate(); + procedure CopyReportVariables(AVariables, AParam: TxpMemParamManager); + public + RecordID: integer; + NidbData: TNIDBDM; + procedure ExportReport( ExportType: TExportFileType; Data: TStream; OnStage: TLogger); + end; + +var + ReportDM: TReportDM; + +implementation +uses + xpReportUtil, Variants,DB,lazUTF8, xpUtilUnit,nnz_data_components,frxCross, Graphics, fr_utils; +{$R *.lfm} + +{ TReportQuery } + +function TReportQuery.getQuery(index: integer): TReportQuery; +begin + result :=TReportQuery(fQueries[index]); +end; + +function TReportQuery.getQueryCount: integer; +begin + result := fQueries.Count; +end; + +constructor TReportQuery.Create; +begin + fQueries := TList.Create; + fOwner := nil; + ID := 0; + ParentID := 0; +end; + +destructor TReportQuery.Destroy; +begin + Clear; + fQueries.Free; + if assigned(Data) then + FreeAndNil(Data); + inherited Destroy; +end; + +procedure TReportQuery.Clear; +var + i: integer; +begin + for i := 0 to fQueries.Count-1 do + TReportQuery(fQueries[i]).Free; + fQueries.Clear; +end; + +procedure TReportQuery.AddQuery(q: TReportQuery); +var + p: TReportQuery; +begin + p := self; + while assigned(p) do + begin + if p=q then exit; + p := p.MasterQuery; + end; + if assigned(q.MasterQuery) then + q.MasterQuery.RemoveQuery(q); + fQueries.Add(q); + q.fOwner := self; +end; + +procedure TReportQuery.RemoveQuery(q: TReportQuery); +begin + fQueries.Remove(q); +end; + +function TReportQuery.Find(QueryID: integer): TReportQuery; +var + i: integer; +begin + result := nil; + if self.ID=QueryID then result := self + else + for i := 0 to QueryCount-1 do + begin + Result := Queries[i].Find(QueryID); + if assigned(Result) then + exit; + end; + +end; + +{ TReportDM } + +procedure TReportDM.frxReportLoadTemplate(Report: TfrxReport; + const TemplateName: String); +begin + NidbData.log(self,'LoadTemplate '+TemplateName); +end; + +function TReportDM.frxReportLoadDetailTemplate(Report: TfrxReport; + const TemplateName: String; const AHyperlink: TfrxHyperlink): Boolean; +begin + NidbData.log(self,'LoadDetailTemplate '+TemplateName); +end; + +procedure TReportDM.CreateDBDataSet(Query: TReportQuery; EditReport: Boolean); +var + i: integer; + DBQuery: TnnzQuery; + ds: TfrxDBDataset; +begin + if Query.ID>0 then + begin + NidbData.log(self,'CreateDBDataSet '+Query.Name); + ds := TfrxDBDataset.Create(Self); + Query.Data := ds; + ds.Tag := PtrInt(Query); + // Master/Detail + if Query.ParentID=0 then + begin // Если это мастер-датасет, добавить его в список и присвоить ему события + Query.Data.OnFirst := @OnMasterRecord; + Query.Data.OnNext := @OnMasterRecord; + end; + Query.Data.Name := Query.Name; + + + DBQuery := TnnzQuery.Create(Self); + DBQuery.Connection := NidbData.connection; + DBQuery.SQL.Text := Query.SQL; + try + DBQuery.Open; + except on E: Exception do + begin + NidbData.logError(self,e,Query.SQL); + raise Exception.Create(Format('%s::"%s"'#13#10' '#13#10'%s',[e.ClassName,e.Message,Query.SQL])); + end; + end; + Query.Data.DataSet := DBQuery; + + end; + for i := 0 to Query.QueryCount-1 do + begin + CreateDBDataSet(query.Queries[i],EditReport); + end; +end; + +procedure TReportDM.CreateSignaturesDataSet(EditReport: Boolean); +begin + +end; + +procedure TReportDM.CreateLogosDataSet(EditReport: Boolean); +begin + +end; + +procedure TReportDM.BuildPodpis(AVariables: TxpMemParamManager); +begin + +end; + +function TReportDM.GetMasterDSName(qryID: integer): string; +begin + +end; + +function TReportDM.GetLinkFieldName(qryID: integer): string; +begin + +end; + +function TReportDM.GetFilterClause(detail_key_fields, master_key_fields, + Link_type: string; MasterDataSet: TfrxDBDataset): string; +begin + +end; + +procedure TReportDM.PrepareBuildInfo(AVariables: TxpMemParamManager); +begin + +end; + +function TReportDM.GetVariable(AVariables: TxpMemParamManager; VarName: string; + DefaultValue: string): string; +begin + +end; + +class function TReportDM.maskFRSpecial(value: string): string; +var + i: integer; + isSpace: boolean; + uchar: string; +begin + isSpace := false; + result := ''; + value := UTF8Trim(value); + for i := 1 to UTF8Length(value) do + begin + uchar := UTF8Copy(value,i,1); + if uchar <= ' ' then // убиваем и заменяем одинарным пробелом все последовательности непечатаемых символов, включая перенос строки + begin + if not isSpace then + result := result + ' '; + + isSpace := true; + end + else + begin + if uchar = #39 then // одиночная кавычка, апостроф (') + result := result + #39#39 + else + result := result + uchar; + + isSpace := false; + end; + + end; + + result := #39 + result + #39; // 'result' +// result :=QuotedStr(''); +end; +class function TReportDM.maskFRSpecialPreservingEOLs(value: string): string; +var + i: integer; + isSpace, isEOL: boolean; + uchar: string; +begin + isSpace := false; + isEOL := false; + result := ''; + value := UTF8Trim(value); + for i := 1 to UTF8length(value) do + begin + uchar := UTF8Copy(value,i,1); + if inArray(uChar,[#13,#10],false) then // любые последовательности переноса строк, в т.ч. от макоси (#13) и линукса (#10), меняем одним #13#10 + begin + if not isEOL then + result := result + sFRBreak; + isEOL := true; + isSpace := false; + end + else if (uchar <= ' ') then // заменяем одинарным пробелом все последовательности пробелов и непечатаемых символов, КРОМЕ переносов строк + begin + if not isSpace then + result := result + ' '; + + isSpace := true; + isEOL := false; + end + else + begin + if uchar = #39 then // одиночная кавычка, апостроф (') + result := result + #39#39 + else + result := result + UTF8Copy(value,i,1); + + isSpace := false; + isEOL := false; + end; + + end; + + if (utf8pos(#13, result) = 0) then // в строке result нет символа CR; нужно забрать всё в одинарные кавычки, и FR их не покажет + result := #39 + result + #39; +// result := QuotedStr(''); +end; + +procedure TReportDM.frxReportPreview(Sender: TObject); +var + Report: TfrxReport; +begin + inherited; + try + Report := Sender as TfrxReport; + Report.PreviewForm.BringToFront; + except + end; +end; + +procedure TReportDM.LoadQueries; +var + SQL: string; + q: TReportquery; + i: integer; +begin + NidbData.log(self,'LoadQueries'); + SQL := format( + 'select q.xp_rpt_q_id,qp.xp_rpt_q_id as ParentID,q.Link_field, '+ + ' q.Name,'+ + ' q.Description, q.SQL '+ + 'FROM xp_report_query q '+ + ' left join xp_report_query qp ON q.Parent_q_id=qp.xp_rpt_q_id AND qp.xp_rpt_id=q.xp_rpt_id '+ + 'WHERE q.xp_rpt_id = %0:d '+ + 'ORDER BY qp.xp_rpt_q_id is not null, q.Name ', + [integer(RecordID)]); + with NidbData.GetData(SQL) do + try + while not eof do + begin + q := TReportQuery.Create; + ReportQueries.AddQuery(q); + q.Name:=fieldbyname('Name').AsString; + q.SQL:=fieldbyname('SQL').AsString; + q.LinkField:=fieldbyname('Link_field').AsString; + q.Description:=fieldbyname('Description').AsString; + q.ID:=fieldbyname('xp_rpt_q_id').AsInteger; + q.ParentID:=fieldbyname('ParentID').AsInteger; + + next; + end; + finally + free; + end; + for i := ReportQueries.QueryCount-1 downto 0 do + if ReportQueries.Queries[i].ParentID>0 then + begin + NidbData.log(self,'LoadQueries.'+ReportQueries.Queries[i].Name); + q := ReportQueries.Find(ReportQueries.Queries[i].ParentID); + if assigned(q) then + q.AddQuery(ReportQueries.Queries[i]); + end; + NidbData.log(self,'LoadQueries-OK'); +end; + +procedure TReportDM.LoadDefaultVariables(AVariables: TxpMemParamManager); +var + SQL: string; + l: TStrings; + i: integer; +begin + NidbData.log(self,'LoadDefaultVariables'); + + SQL := 'select name,value from options where name in (''GOU_Name'',''Dep_Name'')'; + with NidbData.GetData(sql) do + try + while not eof do + begin + AVariables[fieldbyname('name').asString] := fieldbyname('value').asString; + next; + end; + finally + free; + end; + +end; + +procedure TReportDM.LoadLogos(AVariables: TxpMemParamManager); +var + sql: string; + img: TJPEGImage; + p: TPicture; + s: TStream; + v: Variant; +begin + NidbData.log(self,'LoadLogos'); + SQL := 'select name,value from options where name in (''Dep_Logo'',''GOU_Logo'')'; + with NidbData.GetData(sql) do + try + while not eof do + begin + s := CreateBlobStream(FieldByName('value'),bmRead); + p:=TPicture.Create; + img := TJPEGImage.Create(); + try + img.LoadFromStream(s); + p.Graphic:=img; + // внутри вызывается Assign, поэтому img больше не нужен + finally + s.Free(); + img.Free; + end; + v := PtrInt(p); + AVariables[fieldbyname('name').asString] := PtrInt(p); + p := TPicture(PtrInt(v)); + + next; + end; + finally + free; + end; +end; + +procedure TReportDM.LoadVariables(AVariables, AParam: TxpMemParamManager); +var + sql: string; +begin + NidbData.log(self,'LoadVariables'); + sql := 'select name,value_string, value_int from tmp_report_variables where var_type=0'; + with NidbData.GetData(sql) do + try + while not eof do + begin + NidbData.log(self,fieldbyname('name').AsString); + if not fieldbyname('value_string').IsNull then + AVariables[fieldbyname('name').AsString] := fieldbyname('value_string').AsString + else if not fieldbyname('value_int').IsNull then + AVariables[fieldbyname('name').AsString] := fieldbyname('value_int').AsInteger; + Next; + end; + finally + free; + end; + NidbData.log(self,'LoadParams'); + sql := 'select name,value_string, value_int from tmp_report_variables where var_type=1'; + with NidbData.GetData(sql) do + try + while not eof do + begin + NidbData.log(self,fieldbyname('name').AsString); + if not fieldbyname('value_string').IsNull then + AParam[fieldbyname('name').AsString] := fieldbyname('value_string').AsString + else if not fieldbyname('value_int').IsNull then + AParam[fieldbyname('name').AsString] := fieldbyname('value_int').AsInteger; + Next; + end; + finally + free; + end; + // + + // + NidbData.log(self,'LoadVariables-OK'); +end; + +procedure TReportDM.OnMasterRecord(Sender: TObject); +var MasterDS_Index, i, idx: integer; + masterDS,detailDS: TfrxDBDataset; + master_key_field, detail_key_field, FilterClause: string; + DetailDSList: TStringList; + q: TReportQuery; + +begin + try + master_key_field := ''; + detail_key_field := ''; + FilterClause := ''; + masterDS := TfrxDBDataset(Sender); + q := TReportQuery(masterDS.Tag) ; + master_key_field := q.LinkField; + for i := 0 to q.QueryCount-1 do + begin + detailDS := q.Queries[i].Data; + detail_key_field := q.Queries[i].LinkField; + FilterClause := GetFilterClause(detail_key_field, master_key_field, 'ID', masterDS); + if FilterClause <> '' then + begin + detailDS.DataSet.Filter := FilterClause; + detailDS.DataSet.Filtered := True; + end; + end; + + except on e: Exception do + begin + NidbData.logError(self,e,'OnMasterRecord'); + raise; + end; + + end; +end; + +procedure TReportDM.LoadReportTemplate; +var + ReportStream : TMemoryStream; + BlobStream : TStream; + +begin + NidbData.log(self,'ExportReport.TemplateArh'); + ReportStream := TMemoryStream.Create; + try + with NidbData.GetData(format('select TemplateArh from xp_report where xp_rpt_id=%d',[RecordID])) do + try + BlobStream := CreateBlobStream(FieldByName('TemplateArh'), bmRead); + try + UnpackReport(BlobStream, ReportStream,AbUnZipper1); + finally + BlobStream.Free; + end; + + finally + free; + end; + if ReportStream.Size > 0 then + begin + ReportStream.Position := 0; + try + frxReport.LoadFromStream(ReportStream); + + except on e: Exception do + begin + NidbData.logError(self,e,'frxReport.LoadFromStream'); + raise; + end; + end; + end; + finally + ReportStream.Free; + end; // try +end; + +procedure TReportDM.CopyReportVariables(AVariables, AParam: TxpMemParamManager); +var + i: integer; + v: variant; +begin + NidbData.log(self,'CopyReportVariables'); + for I := Low(AVariables.Params) to High(AVariables.Params) do + begin + if VarIsStr(AVariables.Params[i][1]) then + v := maskFRSpecial(VarToStr(AVariables.Params[i][1])) + else + v:= AVariables.Params[i][1]; + frxReport.Variables[AVariables.Params[i][0]] := v; + end; + for I := Low(AParam.Params) to High(AParam.Params) do + begin + if VarIsStr(AParam.Params[i][1]) then + v := maskFRSpecialPreservingEOLs(VarToStr(AParam.Params[i][1])) + else + v := AParam.Params[i][1]; + frxReport.Variables[AParam.Params[i][0]] := v; + end; + +end; + + + +procedure TReportDM.ExportReport(ExportType: TExportFileType; Data: TStream; + OnStage: TLogger); +var + I : Integer; + flt : TfrxCustomExportFilter; + v : Variant; + AVariables, AParam: TxpMemParamManager; +begin + frxReport.EngineOptions.EnableThreadSafe:=true; + NidbData.log(self,'ExportReport'); + ReportQueries := TReportQuery.Create; + AVariables := TxpMemParamManager.Create; + AParam := TxpMemParamManager.Create; + try + if assigned(OnStage) then + OnStage(self,'список запросов'); + LoadQueries; + LoadDefaultVariables(AVariables); + LoadLogos(AVariables); + LoadVariables(AVariables,AParam); + frxReport.EngineOptions.DestroyForms := False; + // Создаём источники данных + if assigned(OnStage) then + OnStage(self,'подготовка данных'); + + CreateDBDataSet(ReportQueries); + if assigned(OnStage) then + OnStage(self,'загрузка шаблона'); + + LoadReportTemplate; + CopyReportVariables(AVariables,AParam); + TxpFRFunctions.SetReport(NidbData,AVariables); + NidbData.log(self,'preparing'); + if assigned(OnStage) then + OnStage(self,'формирование отчета'); + + begin + try + frxReport.PrepareReport(False); + frxReport.OnPreview := @frxReportPreview; + + except on e: Exception do + begin + NidbData.logError(self,e,'frxReport.PrepareReport'); + raise; + end; + end; + + case ExportType of + ftPDF: flt := TfrxPDFExport.Create(self); + ftRTF: flt := TfrxODTExport.Create(self); + ftXLS: flt := TfrxODSExport.Create(self); + end; + try + if assigned(OnStage) then + OnStage(self,'выгрузка'); + + NidbData.log(self,'exporting'); + flt.ShowDialog := false; + flt.Stream := Data; + flt.FileName:=''; + flt.ShowProgress := false; + try + frxReport.Export(flt); + + except on e: Exception do + begin + NidbData.logError(self,e,'frxReport.Export'); + raise; + end; + end; + finally + flt.Free; + end; + end; + //FreeContainer; + finally + ReportQueries.Free; + AVariables.Free; + AParam.Free; + end; + NidbData.log(self,'Report complete'); +end; + + +end. + diff --git a/tcpclient.pas b/tcpclient.pas new file mode 100644 index 0000000..6a43057 --- /dev/null +++ b/tcpclient.pas @@ -0,0 +1,111 @@ +unit tcpClient; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils, tcpthreadhelper, extTypes; +type + { TClientMainThread } + TRequestComplete=function(Sender: TMainThread; const mode: byte; + const Code:DWORD; const QValue: QWORD; const Answer: string; const Values: TStrings; const iValues: TParamArray; const Data: TStream): boolean of object; + TClientMainThread=class(TMainThread) + private + fHost: string; + fData: TStream; + fFields: TStrings; + fCommand: string; + fOnComplete: TRequestComplete; + public + property Host: string read fHost; + property Command: string read fCommand write fCommand; + constructor Create(ACommand: string; AFields: TStrings; ALogger: TLogger;AHost: string; APort: integer; OnReceive:TRequestComplete); + destructor Destroy; override; + procedure execute; override; + procedure ProcessConnect(thread: TConnectionThread); override; + procedure ProcessAnswer(const mode: byte; const Code:DWORD; const QValue: QWORD; const Answer: string; const Values: TStrings; const iValues: TParamArray; const Data: TStream); + end; + + { TClientThread } + + TClientThread=class(TConnectionThread) + public + class function Role: string; override; + procedure ProcessMessage(const mode: byte; const Code:DWORD; const Param:QWord; const ACommand: string;const Values: TStrings; const intData: TParamArray; const Data: TStream); override; + end; + +implementation +constructor TClientMainThread.Create(ACommand: string; AFields: TStrings; + ALogger: TLogger; AHost: string; APort: integer; OnReceive: TRequestComplete); +begin + inherited Create(TClientThread,ALogger,APort); + FreeOnTerminate:=true; + fOnComplete:=onReceive; + Connect.OnConnect:=@doConnect; + fCommand := ACommand; + fFields := TStringList.Create; + if assigned(AFields) then + fFields.assign(AFields); + fHost := AHost; +end; + +destructor TClientMainThread.Destroy; +begin + log(self,'destroy'); + Connect.Disconnect(); + fFields.Free; + inherited Destroy; +end; + +procedure TClientMainThread.execute; +begin + log(self,'start main thread'); + Connect.Connect(Host,Port); + while not terminated do + begin + Connect.CallAction; + sleep(10); + end; + Connect.Disconnect(); + log(self,'terminated'); +end; + +procedure TClientMainThread.ProcessConnect(thread: TConnectionThread); +begin + thread.SendMessage(cmdRequest,0,0,self.Command,self.fFields); +end; + +procedure TClientMainThread.ProcessAnswer(const mode: byte; const Code: DWORD; + const QValue: QWORD; const Answer: string; const Values: TStrings; + const iValues: TParamArray; const Data: TStream); +begin + try + if assigned(fOnComplete) then + fOnComplete(self,mode,code,qValue,Answer,Values,iValues,Data); + + except on e:Exception do + begin + log(self,'!!ERROR ProcessAnswer '+e.message); + raise; + end; + end; +end; + +class function TClientThread.Role: string; +begin + result := 'CLIENT'; +end; + +procedure TClientThread.ProcessMessage(const mode: byte; const Code: DWORD; + const Param: QWord; const ACommand: string; const Values: TStrings; + const intData: TParamArray; const Data: TStream); +begin + log(format('ProcessMessage(%d) Param=%x, Answer=%s ',[code,Param,ACommand])); + terminate; + Owner.Terminate; + (Owner as TClientMainThread).ProcessAnswer(mode,code,Param,ACommand,Values,intData,Data); +end; + +end. + diff --git a/tcpserver.pas b/tcpserver.pas new file mode 100644 index 0000000..e712835 --- /dev/null +++ b/tcpserver.pas @@ -0,0 +1,134 @@ +unit tcpserver; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils, tcpthreadhelper, extTypes; +type + { TServerThread } + + TServerThread=class(TConnectionThread) + class function Role: string; override; + procedure ProcessMessage(const mode: byte; const Code:DWORD; const Param:QWord; const ACommand: string;const Values: TStrings; const intData: TParamArray; const Data: TStream); override; + end; + + { TServerMainThread } + TCommandReceived=function(Sender: TMainThread; + const CommandID:DWORD; const Param:QWord; const ACommand: string; const Fields: TStrings; const iParams: TParamArray; const Data: TStream; + out Code: DWORD; out RetValue: QWord; out Answer: string; out rValues: TStrings; out iValues: TParamArray; out ByteData: TStream ): boolean of object; + + TServerMainThread=class(TMainThread) + private + fOnReceive: TCommandReceived; + fOnIdle: TNotifyEvent; + function processReceive(const CommandID:DWORD; const Param:QWord; const ACommand: string; const Fields: TStrings; const iParams: TParamArray; const Data: TStream; + out Code: DWORD; out RetValue: QWord; out Answer: string; out rValues: TStrings; out iValues: TParamArray; out ByteData: TStream): boolean; + public + property OnIdle: TNotifyEvent read fOnIdle write fOnIdle; + procedure execute; override; + constructor Create( ALogger: TLogger; APort: integer; OnReceive:TCommandReceived); + end; + +implementation + { TServerMainThread } + +function TServerMainThread.processReceive(const CommandID: DWORD; + const Param: QWord; const ACommand: string; const Fields: TStrings; + const iParams: TParamArray; const Data: TStream; out Code: DWORD; out + RetValue: QWord; out Answer: string; out rValues: TStrings; out + iValues: TParamArray; out ByteData: TStream): boolean; +begin + log(self,'ProcessReceive '+ACommand); + if assigned(fOnReceive) then + result := fOnReceive(self,CommandID,Param,ACommand,Fields,IParams,Data,Code,RetValue,Answer,rValues,iValues,ByteData) + else + begin + log(self,'Processor not assigned'); + result := false; + Code := ErrorProcessor; + RetValue := 0; + Answer := 'Server error'; + rValues := nil; + setLength(iValues,0); + ByteData := nil; + end; +end; + +procedure TServerMainThread.execute; +var + n: integer; +begin + log(self,'start main thread'); + Connect.Listen(Port); + n := 0; + while not terminated do + begin + try + Connect.CallAction; + + except on e: Exception do + log(e, '!!ERROR '+e.message); + end; + sleep(10); + inc(n); + if n>100 then + begin + if Assigned(fOnIdle) then fOnIdle(self); + n :=0; + end; + inc(n); + end; +end; + +constructor TServerMainThread.Create(ALogger: TLogger; APort: integer; + OnReceive: TCommandReceived); +begin + inherited Create(TServerThread,ALogger,APort); + fOnReceive := OnReceive; + Connect.OnAccept:=@Accept; + //FreeOnTerminate:=true; +end; +{ TServerThread } + +class function TServerThread.Role: string; +begin + result := 'SERVER'; +end; + +procedure TServerThread.ProcessMessage(const mode: byte; const Code: DWORD; + const Param: QWord; const ACommand: string; const Values: TStrings; + const intData: TParamArray; const Data: TStream); +var + s: string; + Vals: TStrings; + B: TStream; + res: DWORD; + rVal: QWord; + iVals: TParamArray; + ok: boolean; +begin + log(format('ProcessMessage(%d) Param=%x, Command %s ',[code,Param,ACommand])); + try + ok := (Owner as TServerMainThread).ProcessReceive(Code,Param,ACommand,Values,IntData,Data,res,rVal,s,Vals,iVals,B); + try + if OK then + SendMessage(cmdAnswer,res,rVal, s,Vals,iVals,B) + else + SendMessage(cmdError,res,rVal,s,Vals); + finally + if Assigned(Vals) then Vals.Free; + if Assigned(B) then B.Free; + end; + + except on e:Exception do + begin + log('!!ERROR ProcessMessage '+e.message); + raise; + end; + end; +end; + +end. + diff --git a/tcpthreadhelper.pas b/tcpthreadhelper.pas new file mode 100644 index 0000000..626aba7 --- /dev/null +++ b/tcpthreadhelper.pas @@ -0,0 +1,1047 @@ +unit tcpthreadhelper; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils,lNet,lnetbase, syncobjs, extTypes; + +type + + TMainThread=class; + TConnectionThread=class; + + { TConnectionThread } + + TConnectionThread=class(TThread) + private + fSocket: TLSocket; + fCache: TRoundBuffer; + fOwner: TMainThread; + class function BufferToString(const Buffer: TBuffer; const len: integer): string; + class procedure AddToBuffer(const Value: byte; var Buffer: TBuffer; var pos: integer); overLoad; + class procedure AddToBuffer(const Value: word; var Buffer: TBuffer; var pos: integer); overLoad; + class procedure AddToBuffer(const Value: dword; var Buffer: TBuffer; var pos: integer); overLoad; + class procedure AddToBuffer(const Value: QWord; var Buffer: TBuffer; var pos: integer); overLoad; + class procedure AddToBuffer(const Value: string; var Buffer: TBuffer; var pos: integer); overLoad; + class procedure AddToBuffer(const Value: TGUID; var Buffer: TBuffer; var pos: integer); overLoad; + class procedure AddToBuffer(const Value: TBuffer; var Buffer: TBuffer; var pos: integer); overLoad; + class procedure AddToBuffer(const Value: TStream; var Buffer: TBuffer; var pos: integer); overLoad; + class procedure AddToBuffer(const Value: TParamArray; var Buffer: TBuffer; var pos: integer); overLoad; + + class procedure ReadFromBuffer(var Value: byte; const Buffer: TBuffer; var pos: integer); overLoad; + class procedure ReadFromBuffer(var Value: word; const Buffer: TBuffer; var pos: integer); overLoad; + class procedure ReadFromBuffer(var Value: dword; const Buffer: TBuffer; var pos: integer); overLoad; + class procedure ReadFromBuffer(var Value: QWord; const Buffer: TBuffer; var pos: integer); overLoad; + class procedure ReadFromBuffer(var Value: string; const Buffer: TBuffer; var pos: integer); overLoad; + class procedure ReadFromBuffer(var Value: TGUID; const Buffer: TBuffer; var pos: integer); overLoad; + class procedure ReadFromBuffer(var Value: TBuffer; const Buffer: TBuffer; var pos: integer); overLoad; + class procedure ReadFromBuffer(out Value: TStream; const Buffer: TBuffer; var pos: integer); overLoad; + class procedure ReadFromBuffer(out Value: TStrings; const Buffer: TBuffer; var pos: integer); overLoad; + class procedure ReadFromBuffer(out Value: TParamArray; const Buffer: TBuffer; var pos: integer); overLoad; + class procedure InitBuffer(buffSize: dword; out Buffer: TBuffer; out pos: integer); + public + ID: TGUID; + recNo: qword; + property Owner: TMainThread read fOwner; + property Socket:TLSocket read fSocket; + property Cache: TRoundBuffer read fCache; + procedure log(msg: string); + procedure ProcessMessage(const mode: byte;const Code:DWORD; const Param:QWord; const ACommand: string;const Values: TStrings; const intData: TParamArray; const Data: TStream); virtual; abstract; + class function Role: string; virtual; abstract; + procedure SendBuffer(const Buffer: TBuffer; Len: dword); + function ReceiveBuffer(var Buffer: TBuffer; out Len: dword): boolean; + + procedure SendHeader(packetType,state: byte; Code:DWORD; QP:QWORD;SP:string); + function ReceiveHeader(out packetType,state: byte;out Sender:TGUID; out num:QWORD; out Code:DWORD;out QP:QWORD;out SP:string): boolean; + + procedure SendData(part: byte; const Data: TStream); overload; + procedure SendData(part: byte; const Data: TBuffer); overload; + procedure SendData(part: byte; const Data: TStrings); overload; + procedure SendData(part: byte; const Data: TParamArray); overload; + + procedure SendMessage(const mode: byte; const Status: DWORD; const QParam: QWord; const sParam: string); overload; + procedure SendMessage(const mode: byte; const Status: DWORD; const QParam: QWord;const AValue: string; const AKeys: TStrings); overload; + procedure SendMessage(const mode: byte; const CommandID: DWORD;const QParam: QWord; const AValue: string; const AKeys: TStrings;const IntData: TParamArray; const AData: TStream); overload; + + + + function ReceiveMessage(out mode: byte;out Sender: TGUID; out rNum: QWord;out CommandID: DWORD; out QParam:QWord; out Value: string; out intData: TParamArray; out Keys: TStrings; out Data: TStream): boolean; virtual; + + constructor Create(Aowner: TMainThread; ASocket:TLSocket); + destructor Destroy; override; + procedure Execute;override; + procedure TerminatedSet; override; + end; + TConnectionThreadClass = class of TConnectionThread; + + { TMainThread } + + TMainThread=class(TThread) + private + fCon: TLTCP; + fPort: integer; + fclients: TList; + flogger: TLogger; + fThreadClass: TConnectionThreadClass; + function getThread(index: TLSocket): TConnectionThread; + procedure TerminateClients; + protected + procedure Log(Sender:TObject; msg: string); + public + property Port: integer read fPort; + property Connect: TLTCP read fCon; + property Client[index: TLSocket]: TConnectionThread read getThread; + procedure RemoveClient(clt:TConnectionThread); + procedure dataReady(aSocket: TLSocket); + procedure ProcessConnect(thread: TConnectionThread); virtual; + procedure ProcessAccept(thread: TConnectionThread); virtual; + procedure Accept(aSocket: TLSocket); + procedure doDisconnect(aSocket: TLSocket); + procedure doConnect(aSocket: TLSocket); + procedure doTerminate;override; + procedure NetError(const msg: string; aSocket: TLSocket); + constructor Create(AThreadClass: TConnectionThreadClass; ALogger: TLogger; APort: integer); + destructor Destroy; override; + end; + + + { TClientRequest } + + +implementation +uses + lCommon; + + + +function TMainThread.getThread(index: TLSocket): TConnectionThread; +var + clt: TConnectionThread; + i: integer; +begin + for i := 0 to fclients.Count-1 do + if TConnectionThread(fclients[i]).Socket=index then + begin + result := TConnectionThread(fclients[i]); + log(self,format('getThread(%d) %s',[index.Handle,guidToString(result.ID)])); + exit; + end; + result := fThreadClass.Create(self,index); + log(self,format('new Thread(%d) %s',[index.Handle,guidToString(result.ID)])); + fclients.Add(Result); + +end; + +procedure TMainThread.TerminateClients; +var + i: integer; + clt: TConnectionThread; +begin + log(Self,'Terminate Clients'); + for i := fclients.Count-1 downto 0 do + begin + sleep(0); + clt := TConnectionThread(fclients[i]); + try + log(self,GuidToString(clt.ID)); + clt.Terminate; + clt.WaitFor; + clt.Free; + + except on e: Exception do + begin + log(self, '!!ERROR Destroy ' + e.Message); + end; + end; + end; + fClients.Clear; + +end; + +procedure TMainThread.Log(Sender: TObject; msg: string); +begin + if assigned(fLogger) then + fLogger(Sender,Msg); +end; + +procedure TMainThread.RemoveClient(clt: TConnectionThread); +begin + fclients.Remove(clt); +end; + + +procedure TMainThread.dataReady(aSocket: TLSocket); +var + clt: TConnectionThread; +begin + log(self,'dataReady'); + if Terminated then exit; + + clt := Client[aSocket]; + clt.Cache.WriteReady.WaitFor(INFINITE); + while clt.Cache.ReadFromSocket(aSocket)<>0 do + begin + sleep(0); + end; +end; + +procedure TMainThread.ProcessConnect(thread: TConnectionThread); +begin + +end; + +procedure TMainThread.ProcessAccept(thread: TConnectionThread); +begin + +end; + +procedure TMainThread.Accept(aSocket: TLSocket); +var + clt: TConnectionThread; +begin + log(self,'connect'); + if Terminated then exit; + clt := Client[aSocket]; + log(self,format('connected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle])); + + ProcessAccept(clt); + clt.start; +end; + +procedure TMainThread.doDisconnect(aSocket: TLSocket); +var + clt: TConnectionThread; +begin + if terminated then exit; + log(self,'disconnect'); + try + clt := Client[aSocket]; + if clt.terminated then exit; + log(self,format('disconnected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle])); + clt.Terminate; + clt.WaitFor; + clt.free; + fclients.remove(clt); + + except on e: Exception do + begin + log(self,'!!ERROR doDisconnect '+e.Message); + raise; + end; + end; +end; + +procedure TMainThread.doConnect(aSocket: TLSocket); +var + clt: TConnectionThread; +begin + log(self,'doConnect'); + if Terminated then exit; + clt := Client[aSocket]; + log(self,format('connected %s on %d ',[GUIDToString(clt.ID), aSocket.Handle])); + ProcessConnect(clt); + clt.Start; +end; + +procedure TMainThread.doTerminate; +begin + inherited doTerminate(); + TerminateClients; +end; + + + + +procedure TMainThread.NetError(const msg: string; aSocket: TLSocket); +begin + if assigned(aSocket) then + log(self,'!!NETERROR on '+inttostr(aSocket.Handle)+#09+msg) + else + log(self,'!!NETERROR '+msg); +end; + +constructor TMainThread.Create(AThreadClass: TConnectionThreadClass; + ALogger: TLogger; APort: integer); +begin + inherited Create(true); + fThreadClass:=AThreadClass; + fCon := TLTcp.Create(nil); + fclients := TList.Create; + fLogger := ALogger; + fPort := APort; + + Connect.OnDisconnect:=@doDisconnect; + Connect.OnReceive:=@dataReady; + Connect.Timeout:=100; + log(self,'create main thread'); +end; + +destructor TMainThread.Destroy; +begin + fClients.Free; + fCon.Free; + Inherited Destroy; +end; + + + +{ TConnectionThread } + + + + +class function TConnectionThread.BufferToString(const Buffer: TBuffer; + const len: integer): string; +var + i: integer; +begin + result := ''; + for i := 1 to len do + begin + result := result + IntToHex(Buffer[i-1],2)+' '; + if (i mod 64)=0 then + result := result +#13#10; + end; + +end; + +class procedure TConnectionThread.AddToBuffer(const Value: byte; + var Buffer: TBuffer; var pos: integer); +begin + Buffer[pos] := Value; + inc(pos); +end; + +class procedure TConnectionThread.AddToBuffer(const Value: word; + var Buffer: TBuffer; var pos: integer); +var + i: integer; + b: byte; +begin + for i := 0 to 1 do + begin + b := (Value shr (8*i)) and $FF; + Buffer[pos] := b; + inc(pos); + end; +end; + + +class procedure TConnectionThread.AddToBuffer(const Value: dword; + var Buffer: TBuffer; var pos: integer); +var + i: integer; + b: byte; +begin + for i := 0 to 3 do + begin + b := (Value shr (8*i)) and $FF; + Buffer[pos] := b; + inc(pos); + end; +end; + +class procedure TConnectionThread.AddToBuffer(const Value: QWord; + var Buffer: TBuffer; var pos: integer); +var + i: integer; + b: Byte; +begin + for i := 0 to 7 do + begin + b := (Value shr (8*i)) and $FF; + Buffer[pos] := b; + inc(pos); + end; +end; + +class procedure TConnectionThread.AddToBuffer(const Value: string; + var Buffer: TBuffer; var pos: integer); +var + len,i: DWORD; + p: PChar; + b: byte; +begin + len := Length(Value); + AddToBuffer(Len,Buffer,pos); + p := PChar(Value); + for i := 1 to len do + begin + b :=byte(p^); + AddToBuffer(b,Buffer,pos); + inc(p); + end; +end; + +class procedure TConnectionThread.AddToBuffer(const Value: TGUID; + var Buffer: TBuffer; var pos: integer); +var + i: integer; +begin + AddToBuffer(Value.D1,Buffer,pos); + AddToBuffer(Value.D2,Buffer,pos); + AddToBuffer(Value.D3,Buffer,pos); + for i := 0 to 7 do + AddToBuffer(Value.D4[i],Buffer,pos); +end; + +class procedure TConnectionThread.AddToBuffer(const Value: TBuffer; + var Buffer: TBuffer; var pos: integer); +var + len: DWORD; + i: integer; +begin + len := length(Value); + AddToBuffer(len,Buffer,pos); + for i := 0 to len-1 do + AddToBuffer(Value[i],Buffer,pos); +end; + +class procedure TConnectionThread.AddToBuffer(const Value: TStream; + var Buffer: TBuffer; var pos: integer); +var + len: QWORD; + i: integer; + b: byte; +begin + len := Value.Size; + AddToBuffer(len,Buffer,pos); + Value.seek(0,soFromBeginning); + for i := 0 to len-1 do + begin + Value.Read(b,1); + AddToBuffer(b,Buffer,pos); + end; +end; + +class procedure TConnectionThread.AddToBuffer(const Value: TParamArray; + var Buffer: TBuffer; var pos: integer); +var + l,i: DWORD; +begin + l := Length(Value); + AddToBuffer(l,Buffer,pos); + for i := low(Value) to high(Value) do + AddToBuffer(Value[i],Buffer,pos); +end; + +class procedure TConnectionThread.ReadFromBuffer(var Value: byte; + const Buffer: TBuffer; var pos: integer); +begin + Value := Buffer[pos]; + inc(pos); +end; + +class procedure TConnectionThread.ReadFromBuffer(var Value: word; + const Buffer: TBuffer; var pos: integer); +var + i: integer; +begin + Value := 0; + for i := 0 to 1 do + begin + Value := Value or (Buffer[pos] shl (8*i)); + inc(pos); + end; +end; + +class procedure TConnectionThread.ReadFromBuffer(var Value: dword; + const Buffer: TBuffer; var pos: integer); +var + i: integer; +begin + Value := 0; + for i := 0 to 3 do + begin + Value := Value or (Buffer[pos] shl (8*i)); + inc(pos); + end; +end; + +class procedure TConnectionThread.ReadFromBuffer(var Value: QWord; + const Buffer: TBuffer; var pos: integer); +var + i: integer; +begin + Value := 0; + for i := 0 to 7 do + begin + Value := Value or (Buffer[pos] shl (8*i)); + inc(pos); + end; +end; + + +class procedure TConnectionThread.ReadFromBuffer(var Value: string; + const Buffer: TBuffer; var pos: integer); +var + len: DWORD; + i: integer; + p: PChar; +begin + ReadFromBuffer(Len,Buffer,pos); + Value := StringOfChar(' ',len); + for i := 1 to len do + begin + Value[i] := chr(Buffer[pos]); + inc(pos); + end; +end; + +class procedure TConnectionThread.ReadFromBuffer(var Value: TGUID; + const Buffer: TBuffer; var pos: integer); +var + i: integer; +begin + ReadFromBuffer(Value.D1,Buffer,pos); + ReadFromBuffer(Value.D2,Buffer,pos); + ReadFromBuffer(Value.D3,Buffer,pos); + for i := 0 to 7 do + ReadFromBuffer(Value.D4[i],Buffer,pos); +end; + +class procedure TConnectionThread.ReadFromBuffer(var Value: TBuffer; + const Buffer: TBuffer; var pos: integer); +var + len: DWORD; + i: integer; +begin + ReadFromBuffer(len,Buffer,pos); + setLength(Value,len); + for i := 0 to len-1 do + ReadFromBuffer(Value[i],Buffer,pos); +end; + +class procedure TConnectionThread.ReadFromBuffer(out Value: TStream; + const Buffer: TBuffer; var pos: integer); +var + len: QWORD; + i: integer; + b: byte; +begin + Value := TMemoryStream.Create; + ReadFromBuffer(len,Buffer,pos); + if len=0 then exit; + for i := 0 to len-1 do + begin + ReadFromBuffer(b,Buffer,pos); + Value.Write(b,1); + end; + Value.seek(0,soFromBeginning); +end; + +class procedure TConnectionThread.ReadFromBuffer(out Value: TStrings; + const Buffer: TBuffer; var pos: integer); +var + i,w,d: dword; + s: string; +begin + Value := TStringList.Create; + ReadFromBuffer(w,Buffer,pos); + if w=0 then exit; + for i := 0 to w-1 do + begin + ReadFromBuffer(s,Buffer,pos); + ReadFromBuffer(d,Buffer,pos); + Value.AddObject(s, TObject(PtrInt(d))); + end; +end; + +class procedure TConnectionThread.ReadFromBuffer(out Value: TParamArray; + const Buffer: TBuffer; var pos: integer); +var + l,i: DWORD; +begin + ReadFromBuffer(l,Buffer,pos); + SetLength(Value,l); + if l=0 then exit; + for i := 0 to l-1 do + ReadFromBuffer(Value[i],Buffer,pos); +end; + +class procedure TConnectionThread.InitBuffer(buffSize: dword; out + Buffer: TBuffer; out pos: integer); +begin + SetLength(Buffer,buffSize); + pos := 0; +end; + + +procedure TConnectionThread.log(msg: string); +begin + if assigned(fOwner) then + fOwner.log(self,Role+#09+ GuidToString(ID)+#09+msg); +end; + + + +procedure TConnectionThread.SendBuffer(const Buffer: TBuffer; Len: dword); +var + p,t: PByte; + l,rem,i: integer; + part_id,tmp: QWORD; + b2: array[0..7] of byte; +begin + log('Send buffer '+inttostr(len)); + try + rem := len+Sizeof(integer)+Sizeof(QWord); + p := GetMem(rem); + try + t := p; + CopyBytes(t,PacketStart); + CopyBytes(t,len); + CopyBytes(t,Buffer); + t := p; + repeat + l := Socket.send(t^,rem); + dec(rem,l); + inc(t,l); + if l=0 then + sleep(100); + until terminated or (rem<=0); + + finally + //log(format('%p',[p])); + freeMem(p); + end; + except on e:Exception do + begin + log('!!ERROR SendBuffer '+e.message); + raise; + end; + end; + +end; + +function TConnectionThread.ReceiveBuffer(var Buffer: TBuffer; out Len: dword + ): boolean; +var + p: PByte; + i,l,rem: integer; + lbytes: array[0..3] of byte; + b2: array[0..7] of byte; + part_id: QWORD; +begin + result := false; + if Terminated then exit; + try + Cache.Read(part_id); + if Part_id<>PacketStart then exit; + Cache.Read(len); + if len=0 then exit; + setlength(Buffer,len); + rem := len; + p := PByte(Buffer); + repeat + l := Cache.pop(p^,rem); + dec(rem,l); + inc(p,l); + if Terminated then exit; + until terminated or (rem<=0) ; + log('Receive buffer '+inttostr(len)); + result := true; + except on e:Exception do + begin + log('!!ERROR ReceiveBuffer '+e.message); + raise; + end; + end; +end; + + +procedure TConnectionThread.SendHeader(packetType, state: byte; Code: DWORD; + QP: QWORD; SP: string); +var + Buffer: TBuffer; + pos: integer; +begin + try + log(format('SendHeader(%d) Code=%d, Param=%x, Command=%s',[packettype,Code,QP,SP])); + InitBuffer(sizeof(BYTE)*(Length(SP)+2)+16+2*sizeof(QWord)+sizeof(DWORD)*2,Buffer,pos); + AddToBuffer(packetType,Buffer,pos); + AddToBuffer(state,Buffer,pos); + AddToBuffer(ID,Buffer,pos); + AddToBuffer(recNo,Buffer,pos); + AddToBuffer(Code,Buffer,pos); + AddToBuffer(QP,Buffer,pos); + AddToBuffer(SP,Buffer,pos); + SendBuffer(Buffer,pos); + + except on e:Exception do + begin + log('!!ERROR SendHeader '+e.message); + raise; + end; + end; +end; + +function TConnectionThread.ReceiveHeader(out packetType, state: byte; out + Sender: TGUID; out num: QWORD; out Code: DWORD; out QP: QWORD; out SP: string + ): boolean; +var + Buffer: TBuffer; + len: dword; + pos: integer; +begin + result := false; + if Terminated then exit; + try + if not ReceiveBuffer(Buffer,len) then exit; + pos := 0; + ReadFromBuffer(packetType,Buffer,pos); + ReadFromBuffer(State,Buffer,pos); + ReadFromBuffer(Sender,Buffer,pos); + ReadFromBuffer(num,Buffer,pos); + ReadFromBuffer(Code,Buffer,pos); + ReadFromBuffer(QP,Buffer,pos); + ReadFromBuffer(SP,Buffer,pos); + log(format('ReceiveHeader(%d) Code=%d, Param=%x, Command=%s',[packettype,Code,QP,SP])); + result := true; + + except on e:Exception do + begin + log('!!ERROR ReceiveHeader '+e.message); + raise; + end; + end; +end; + + + +procedure TConnectionThread.SendMessage(const mode: byte; + const Status: DWORD; const QParam: QWord; const sParam: string); +begin + SendHeader(0,mode,Status,QParam,sParam); +end; + +procedure TConnectionThread.SendMessage(const mode: byte; + const Status: DWORD; const QParam: QWord; const AValue: string; + const AKeys: TStrings); +begin + if assigned(AKeys) then + begin + SendHeader(1,mode,Status,QParam,AValue); + SendData(1,AKeys); + end + else + SendHeader(0,mode,Status,QParam,AValue); +end; + + +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 + if assigned(AKeys) and assigned(AData) and (length(IntData)>0) then + begin + SendHeader(7,mode,CommandID,QParam,AValue); + SendData(1,AKeys); + SendData(2,IntData); + SendData(3,AData); + end + else if (length(IntData)>0) and assigned(AKeys) then + begin + SendHeader(6,mode,CommandID,QParam,AValue); + SendData(1,AKeys); + SendData(2,IntData); + end + else if (length(IntData)>0) and assigned(AData) then + begin + SendHeader(5,mode,CommandID,QParam,AValue); + SendData(1,IntData); + SendData(2,AData); + end + else if assigned(AKeys) and assigned(AData) then + begin + SendHeader(4,mode,CommandID,QParam,AValue); + SendData(1,AKeys); + SendData(2,AData); + end + else if length(IntData)>0 then + begin + SendHeader(3,mode,CommandID,QParam,AValue); + SendData(1,IntData); + end + else if assigned(AData) then + begin + SendHeader(2,mode,CommandID,QParam,AValue); + SendData(2,AData); + end + else if assigned(AKeys) then + begin + SendHeader(1,mode,CommandID,QParam,AValue); + SendData(1,AKeys); + end + else + SendHeader(0,mode,CommandID,QParam,AValue); +end; + + + + + + +procedure TConnectionThread.SendData(part: byte; const Data: TStream); +var + Buffer: TBuffer; + pos: integer; + footer: dWORD; +begin + try + setLength(Buffer,1+Data.Size+8); + pos := 0; + AddToBuffer(part,Buffer,pos); + AddToBuffer(Data,Buffer,pos); + SendBuffer(Buffer,pos); + + except on e:Exception do + begin + raise; + end; + end; +end; + +procedure TConnectionThread.SendData(part: byte; const Data: TBuffer); +var + Buffer: TBuffer; + pos: integer; + footer: dWORD; +begin + try + setLength(Buffer,length(Data)+4+1); + pos := 0; + AddToBuffer(part,Buffer,pos); + AddToBuffer(Data,Buffer,pos); + SendBuffer(Buffer,pos); + + except on e:Exception do + begin + raise; + end; + end; +end; + +procedure TConnectionThread.SendData(part: byte; const Data: TStrings); +var + Buffer: TBuffer; + pos: integer; + w,footer: dWORD; + len,i: integer; +begin + try + LogStrings(fOwner.flogger,self,'KEYS',Data); + len := 1+4+8*Data.Count; + for i:=0 to Data.Count-1 do + inc(len,length(Data[i])); + setLength(Buffer,len); + pos := 0; + AddToBuffer(part,Buffer,pos); + w := Data.Count; + AddToBuffer(w,Buffer,pos); + for i := 0 to Data.Count-1 do + begin + AddToBuffer(Data[i],Buffer,pos); + w := ptrInt(Pointer(Data.Objects[i])) and $FFFFFFFF; + AddToBuffer(w,Buffer,pos); + end; + SendBuffer(Buffer,pos); + + except on e:Exception do + begin + raise; + end; + end; +end; + +procedure TConnectionThread.SendData(part: byte; + const Data: TParamArray); +var + i,pos: integer; + len: DWORD; + Buffer: TBuffer; +begin + len := length(Data); + InitBuffer(Sizeof(byte)+(len+1)*SizeOf(DWORD),Buffer,pos); + AddToBuffer(part,Buffer,pos); + AddToBuffer(len,Buffer,pos); + for i := low(Data) to High(Data) do + AddToBuffer(Data[i],Buffer,pos); + SendBuffer(Buffer,pos); +end; + + +function TConnectionThread.ReceiveMessage(out mode: byte; out Sender: TGUID; + out rNum: QWord; out CommandID: DWORD; out QParam: QWord; out Value: string; + out intData: TParamArray; out Keys: TStrings; out Data: TStream): boolean; +var + Buffer: TBuffer; + Len: dword; + pos: integer; + s: string; + b,b1: byte; +begin + result := false; + if Terminated then exit; + try + log('ReceiveMessage'); + if not ReceiveHeader(b,mode,Sender,rNum,CommandID,QParam,Value) then exit; + if Terminated then exit; + case b of + 1: begin + if not ReceiveBuffer(Buffer,len) then exit; + pos := 0; + ReadFromBuffer(b,Buffer,pos); + if b<>1 then raise EFormatException.Create(''); + ReadFromBuffer(Keys,Buffer,pos); + LogStrings(fOwner.flogger,self,'KEYS',Keys); + end; + 2: begin + if not ReceiveBuffer(Buffer,len) then exit; + pos := 0; + ReadFromBuffer(b,Buffer,pos); + if b<>1 then raise EFormatException.Create(''); + ReadFromBuffer(Data,Buffer,pos); + end; + 3: begin + if not ReceiveBuffer(Buffer,len) then exit; + pos := 0; + ReadFromBuffer(b,Buffer,pos); + if b<>1 then raise EFormatException.Create(''); + ReadFromBuffer(intData,Buffer,pos); + end; + 4: begin + if not ReceiveBuffer(Buffer,len) then exit; + pos := 0; + ReadFromBuffer(b,Buffer,pos); + if b<>1 then raise EFormatException.Create(''); + ReadFromBuffer(Keys,Buffer,pos); + ReadFromBuffer(b,Buffer,pos); + if b<>2 then raise EFormatException.Create(''); + ReadFromBuffer(Data,Buffer,pos); + end; + 5: begin + if not ReceiveBuffer(Buffer,len) then exit; + pos := 0; + ReadFromBuffer(b,Buffer,pos); + if b<>1 then raise EFormatException.Create(''); + ReadFromBuffer(intData,Buffer,pos); + ReadFromBuffer(b,Buffer,pos); + if b<>2 then raise EFormatException.Create(''); + ReadFromBuffer(Data,Buffer,pos); + end; + 6: begin + if not ReceiveBuffer(Buffer,len) then exit; + pos := 0; + ReadFromBuffer(b,Buffer,pos); + if b<>1 then raise EFormatException.Create(''); + ReadFromBuffer(Keys,Buffer,pos); + ReadFromBuffer(b,Buffer,pos); + if b<>2 then raise EFormatException.Create(''); + ReadFromBuffer(intData,Buffer,pos); + end; + 7: begin + if not ReceiveBuffer(Buffer,len) then exit; + pos := 0; + ReadFromBuffer(b,Buffer,pos); + if b<>1 then raise EFormatException.Create(''); + ReadFromBuffer(Keys,Buffer,pos); + ReadFromBuffer(b,Buffer,pos); + if b<>2 then raise EFormatException.Create(''); + ReadFromBuffer(intData,Buffer,pos); + ReadFromBuffer(b,Buffer,pos); + if b<>3 then raise EFormatException.Create(''); + ReadFromBuffer(Data,Buffer,pos); + end; + end; + result := true; + + except on e:Exception do + begin + log('!!ERROR ReceiveMessage '+e.message); + raise; + end; + end; +end; + +constructor TConnectionThread.Create(Aowner: TMainThread; ASocket: TLSocket); +var + i,d1,d2 : integer; +begin + inherited Create(true); + fCache := TRoundBuffer.Create(10000); + fSocket := ASocket; + fOwner := AOwner; + CreateGuid(ID); + recNo := 0; + log('Create'); +end; + +destructor TConnectionThread.Destroy; +begin + log('Destroy'); + fCache.Free; + fOwner.removeClient(self); + log('Destroy2'); + inherited Destroy; +end; + +procedure TConnectionThread.Execute; +var + Sender: TGUID; + num,Param: QWORD; + CommandID: DWORD; + Value: string; + intData: TParamArray; + Keys: TStrings; + Data: TStream; + mode: byte; +begin + log('start thread'); + while not terminated do + begin + if cache.ReadReady.WaitFor(1000)<>wrSignaled then begin sleep(10);continue;end; + log('received'); + if terminated then break; + if not Socket.Connected then break; + Keys := nil; + Data := nil; + try + if ReceiveMessage(mode,Sender,num,CommandID,Param,Value,intData,Keys,Data) then + ProcessMessage(mode,CommandID,Param,Value,Keys,intData,Data); + + finally + if assigned(Keys) then Keys.Free; + if assigned(Data) then Data.Free; + setLength(intData,0); + end; + end; + Cache.Close; + Socket.Disconnect(); + log('terminated'); +end; + +procedure TConnectionThread.TerminatedSet; +begin + log('terminate required'); + Cache.Close; +end; + +{ TClientThread } + + + +const + HexChars='0123456789abcdef'; + + + + + + + + + +end. + diff --git a/xpReportUtil.pas b/xpReportUtil.pas new file mode 100644 index 0000000..2e97c0e --- /dev/null +++ b/xpReportUtil.pas @@ -0,0 +1,127 @@ +unit xpReportUtil; + +interface + +uses Classes, AbUnzper,AbZipper; + +procedure PackReport(SrcStream, DestStream : TStream; Zipper: TAbZipper); +procedure UnpackReport(SrcStream, DestStream : TStream; UnZipper: TAbUnZipper); + +implementation + +uses zipper,sysutils, ABUtils, LazUTF8; +type + + { TZipTool } + + TZipTool=class + private + fSrcStream: TStream; + fSrcStrean, + fDstStream: TStream; + public + constructor Create(ASourceStream,ADestStream: TStream); + Procedure getSource(Sender: TObject; var AStream: TStream); + Procedure getDest(Sender : TObject; var AStream : TStream; AItem : TFullZipFileEntry); + Procedure closeSource(Sender: TObject; var AStream: TStream); + Procedure doneDest(Sender : TObject; var AStream : TStream; AItem : TFullZipFileEntry); + Procedure endFile(Sender : TObject; Const Ratio : Double); + Procedure progress(Sender : TObject; Const Pct : Double); + property SourceStream: TStream read fSrcStream; + property DestStream:TStream read fDstStream; + end; + +procedure UnpackReport(SrcStream, DestStream : TStream; UnZipper: TAbUnZipper); +var + rptCode: TStringList; + i: integer; + tmp: TStream; +begin + if SrcStream.Size > 0 then + begin + tmp := TMemoryStream.Create; + rptCode := TStringList.Create; + try + UnZipper.Stream := SrcStream; + UnZipper.ArchiveType := atZip; + UnZipper.ForceType := true; + UnZipper.ExtractToStream('Q.Q',tmp); + + tmp.Seek(0,soFromBeginning); + rptCode.LoadFromStream(tmp); + // автозамена шрифтов + for i := 0 to rptCode.Count-1 do + begin + {$IFDEF LINUX} + rptCode[i] := UTF8StringReplace(rptCode[i],'Font.Name="Times New Roman"','Font.Name="PT Astra Serif"',[]); + rptCode[i] := UTF8StringReplace(rptCode[i],'Font.Name="Arial"','Font.Name="Liberation Sans"',[]); + rptCode[i] := UTF8StringReplace(rptCode[i],'Rotation="90"','Rotation="90" Wysiwyg="0"',[]); + rptCode[i] := UTF8StringReplace(rptCode[i],'Wysiwyg="0" Wysiwyg="0"','Wysiwyg="0"',[]); + rptCode[i] := UTF8StringReplace(rptCode[i],'Rotation="90" Wysiwyg="0" Wysiwyg="1"','Rotation="90" Wysiwyg="0"',[]); + {$ELSE} + rptCode[i] := UTF8StringReplace(rptCode[i],'Font.Name="PT Astra Serif"','Font.Name="Times New Roman"',[]); + rptCode[i] := UTF8StringReplace(rptCode[i],'Font.Name="Liberation Sans"','Font.Name="Arial"',[]); + {$ENDIF} + end; + rptCode.SaveToStream(DestStream); + + finally + rptCode.Free; + tmp.Free; + end; + + end; // if + +end; + +procedure PackReport(SrcStream, DestStream : TStream; Zipper: TAbZipper); +begin + zipper.FileName := ''; + zipper.ArchiveType := atZip; + zipper.ForceType := true; + + + zipper.Stream := DestStream; + zipper.AddFromStream('Q.Q',SrcStream); + + zipper.Save; +end; + +{ TZipTool } + +constructor TZipTool.Create(ASourceStream, ADestStream: TStream); +begin + inherited Create; + fSrcStream := ASourceStream; + fDstStream := ADestStream; +end; + +procedure TZipTool.getSource(Sender: TObject; var AStream: TStream); +begin + AStream := fSrcStream; +end; + +procedure TZipTool.getDest(Sender: TObject; var AStream: TStream; + AItem: TFullZipFileEntry); +begin + AStream := fDstStream; +end; + +procedure TZipTool.closeSource(Sender: TObject; var AStream: TStream); +begin +end; + +procedure TZipTool.doneDest(Sender: TObject; var AStream: TStream; + AItem: TFullZipFileEntry); +begin +end; + +procedure TZipTool.endFile(Sender: TObject; const Ratio: Double); +begin +end; + +procedure TZipTool.progress(Sender: TObject; const Pct: Double); +begin +end; + +end. diff --git a/xpaccessunit.pas b/xpaccessunit.pas new file mode 100644 index 0000000..afa8722 --- /dev/null +++ b/xpaccessunit.pas @@ -0,0 +1,43 @@ +unit xpAccessUnit; +{$H+} +interface + + function EncryptText(const AText: String) : String; + function MySQLPassword(const AText: Ansistring) : Ansistring; +implementation + +uses + SysUtils, + Variants, DCPsha1, DCPdes, + ConnectionsDmUnit; + + +function DecryptText(const AText: string) : string; +begin + Result := AText; +end; +function EncryptText(const AText: String) : String; +begin + Result := String(MySQLPassword(AnsiString(StringReplace(AText, '\', '\\', [rfReplaceAll, rfIgnoreCase])))); +end; + + +function MySQLPassword(const AText: Ansistring) : Ansistring; +var + Digest: packed array[0..19] of byte; + i: integer; +begin + Result := '*'; + ConnectionsDM.Hash.Init; + ConnectionsDM.Hash.UpdateStr(AText); + ConnectionsDM.Hash.Final(Digest); + ConnectionsDM.Hash.Burn; + ConnectionsDM.Hash.Init; + ConnectionsDM.Hash.Update(Digest,20); + ConnectionsDM.Hash.Final(Digest); + ConnectionsDM.Hash.Burn; + for i:= 0 to 19 do + Result := Result + AnsiString(IntToHex(Digest[i], 2)); +end; + +end. diff --git a/xpmemparammanagerunit.pas b/xpmemparammanagerunit.pas new file mode 100644 index 0000000..2805b25 --- /dev/null +++ b/xpmemparammanagerunit.pas @@ -0,0 +1,141 @@ +unit xpMemParamManagerUnit; + +interface + +uses + Messages, SysUtils, Variants, Classes; +// xpConst; +const + sFRBreak = #13#10; +type + + ParamRow = array[0..1] of Variant; + TParamArray = array of ParamRow; + + { TxpMemParamManager } + + TxpMemParamManager = class(TObject) + private + ParamArray: TParamArray; + function GetValue(ParamName: Variant): Variant; + procedure SetValue(ParamName: Variant; const Value: Variant); + + public + constructor Create; + destructor Destroy; override; + function IndexOf(const ParamName : string) : Integer; + function Count: Integer; + function ListAllParamsAndValues: string; + procedure Delete(ParamName: Variant); + property Params: TParamArray read ParamArray; + property Values[ParamName: Variant]: Variant read GetValue write SetValue; default; + procedure Assign(OwnerParam: TxpMemParamManager); + + end; + +implementation +uses + lazUTF8; +procedure TxpMemParamManager.Assign(OwnerParam: TxpMemParamManager); +var + i: Integer; +begin + if OwnerParam = nil then + Exit; + if Length(OwnerParam.ParamArray) > 0 then + for i:= Low(OwnerParam.ParamArray) to High(OwnerParam.ParamArray) do + Values[OwnerParam.ParamArray[i][0]] := OwnerParam.ParamArray[i][1] +end; + +constructor TxpMemParamManager.Create; +begin + inherited Create; + ParamArray := nil; +end; + +destructor TxpMemParamManager.Destroy; +begin + ParamArray := nil; + inherited; +end; + +function TxpMemParamManager.GetValue(ParamName: Variant): Variant; +var + i: Integer; +begin + for i:= Low(ParamArray) to High(ParamArray) do + if AnsiSameText(ParamArray[i][0], ParamName) then + begin + Result := ParamArray[i][1]; + Exit; + end; + raise Exception.Create('Не найден параметр ' + VarToStr(ParamName)); +end; + +function TxpMemParamManager.IndexOf(const ParamName: string): Integer; +var + i : Integer; +begin + Result := -1; + for i := Low(ParamArray) to High(ParamArray) do + begin + if AnsiSameText(ParamArray[i][0], ParamName) then + begin + Result := i; + Exit; + end; + end; +end; + +function TxpMemParamManager.Count: Integer; +begin + result := High(ParamArray) + 1; +end; + +function TxpMemParamManager.ListAllParamsAndValues: string; +var + i: integer; +begin + Result := ''; + for i := 0 to (self.Count - 1) do + Result := Result + IntToStr(i) + ': '#39 + VarToStr(self.Params[i][0]) + #39' = '#39 + VarToStr(self.Params[i][1]) + #39'.' + sLineBreak; +end; + +procedure TxpMemParamManager.SetValue(ParamName: Variant; const Value: Variant); +var + i,j: Integer; + strVal: string; + v: variant; +begin + if VarIsStr(Value) then + begin + v := utf8trim(Value); + end + else + v := Value; + for i:= Low(ParamArray) to High(ParamArray) do + if AnsiSameText(ParamArray[i][0], ParamName) then + begin + ParamArray[i][1] := v; + Exit; + end; + SetLength(ParamArray, Length(ParamArray) + 1); + ParamArray[High(ParamArray)][0] := ParamName; + ParamArray[High(ParamArray)][1] := v; +end; + + +procedure TxpMemParamManager.Delete(ParamName: Variant); +var + i: Integer; +begin + for i:= Low(ParamArray) to High(ParamArray) do + if AnsiSameText(ParamArray[i][0], ParamName) then + begin + ParamArray[i][0] := ''; + Exit; + end; +end; + +end. + diff --git a/xputilunit.pas b/xputilunit.pas new file mode 100644 index 0000000..c605e32 --- /dev/null +++ b/xputilunit.pas @@ -0,0 +1,69 @@ +unit xpUtilUnit; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils; +function inArrayPos(const value: string; const checkList: array of string; ignoreCase: boolean): integer; +// проверяет содержится ли строка в массиве +function inArray(const value: string; const checkList: array of string; ignoreCase: boolean): boolean; +// находит индекс числа в массиве +function inArrayPosN(const value: integer; const checkList: array of integer): integer; +// проверяет содержится ли число в массиве +function inArrayN(const value: integer; const checkList: array of integer): boolean; + +implementation +uses + lazUTF8; +function inArrayPos(const value: string; const checkList: array of string; + ignoreCase: boolean): integer; +var + i: integer; + s1,s2: string; +begin + result := -1; + + if ignoreCase then + s1 := UTF8UpperString(value) + else + s1 := value; + for I := Low(checkList) to High(checkList) do + begin + if ignoreCase then + s2 := UTF8UpperString(checklist[i]) + else + s2 := checklist[i]; + if SameStr(s1, s2) then + exit(I); + end; +end; + + +function inArray(const value: string; const checkList: array of string; + ignoreCase: boolean): boolean; +begin + result := inArrayPos(value, checkList, ignoreCase)>=0; +end; + +function inArrayPosN(const value: integer; const checkList: array of integer + ): integer; +var + i: integer; +begin + result := -1; + for I := Low(checkList) to High(checkList) do + if value = checkList[i] then + exit(I); +end; + + +function inArrayN(const value: integer; const checkList: array of integer + ): boolean; +begin + result := inArrayPosN(value, checkList)>=0; +end; + +end. +