Washington Post: Приложение тормозит при передачи большого текста

← →
VID (2002-09-24 16:10) [0]

const PE = #13;
EL = "";

Функции и процедуры описаны в иерарх порядке от самой(вверху) нижней до самой верхней (внизу текста)

{Доп. юнит приложение - неосновной, непотоковый}

Function GetPasswordKeys - получение всего лишь трёх числе, ничего особенного
Function b64Encode - шифрование текста по алгоритму Base64
Function b64Decode - дешифрование текста по алгоритму Base64

Function Encrypt2(InString:String; _Password:String):String;
Var PasswordKeys:TPasswordKeys;
S:String;
begin
//Функция шифровки текста
If _Password = "" then begin Result := InString; Exit;end;

try
PasswordKeys:=GetPasswordKeys(_Password);
S := Encrypt(InString, PasswordKeys.StartKey , PasswordKeys.MultiKey, PasswordKeys.AddKey);
Result := B64Encode(S);
except Result := InString; end;
end;

Function Decrypt2(InString:String; _Password:String):String;
Var PasswordKeys:TPasswordKeys;
S:String;
begin
//Функция дешифровки текста
If _Password = "" then begin Result := InString; Exit;end;

try
PasswordKeys:=GetPasswordKeys(_Password);
S := B64Decode(InString);
Result := Decrypt(S, PasswordKeys.StartKey , PasswordKeys.MultiKey, PasswordKeys.AddKey);
except Result := InString; end;
end;

Function CreatePacket(_Text, _ContactUsers, _MessageMode, _Command, _Sender:String; _MessageColor:TColor; MustEncrypt:Boolean; CryptPas:String):String;
Var St:TStringList;
TS, Mcolor,TextLength:String;
begin
IF Length(Trim(_Text))=0 then _Text := EL;
IF Length(Trim(_ContactUsers))=0 then _ContactUsers := EL;
IF Length(Trim(_MessageMode))=0 then _MessageMode := EL;
IF Length(Trim(_Command))=0 then _Command := EL;
IF Length(Trim(_Sender))=0 then _Sender := EL;

St:=TStringList.Create;

TS := GetTime; //Получение времени в строковом виде
MColor := IntToStr(_MessageColor);

IF MustEncrypt then
begin
//Шифрация полей пакета. _Text и содержит Очень большой текс
_Text := encrypt2(_text, CryptPas);
_ContactUsers := encrypt2(_contactUsers, Cryptpas);
_MessageMode := encrypt2(_MessageMode, CryptPas);
_Command := encrypt2 (_Command, Cryptpas);
TS := Encrypt2(TS, CryptPas);
MColor := Encrypt2(Mcolor, Cryptpas);
end;

TextLength := IntToStr(Length(_Text));
ST.ADD(_TEXT);
ST.ADD(_ContactUsers);
ST.ADD(_MessageMode);
ST.ADD(_Command);
ST.ADD(_Sender);
ST.ADD(TS);
ST.ADD(Mcolor);
ST.Add(BoolToStr(MustEncrypt));
IF SendCheckSum then ST.ADD(TextLength) else ST.Add("-1");
Result := St.CommaText+PE+PE;//Коммутация пакета в ед. строку

ST.FREE;
end;

← →
VID (2002-09-24 16:11) [1]

{Доп. потоковый юнит приложения - отправка текста сокету клиента подключённого к серверу}
unit SendPacket_Unit;

interface

uses
Classes, Tools,ScktComp, sysUtils, graphics, Dialogs, windows;

type
TSendPacket_THRD = class(TThread)
private
FText, FContactUsers, FMessageMode, FCommand, FSender:String;
FMessageColor:TColor;
FMustEncrypt:Boolean;
FInitProc, FTermProc:TStandartProcedure;

Login, CryptPas:String;
IsCheckCommandDisabled : Boolean;

PacketList:TStringList;
CurPacket:String;

public
FSocket:TCustomWinSocket;
Constructor CreateWithArgs (AText, AContactUsers, AMessageMode, ACommand, ASender:String; AMessageColor:TColor; ASocket:TCustomWinSocket; AMustEncrypt:Boolean; AInitProc, ATermProc:TStandartProcedure);
Procedure AddPacket(AText, AContactUsers, AMessageMode, ACommand, ASender:String; AMessageColor:TColor; AMustEncrypt:Boolean);
protected
procedure Execute; override;
Procedure TermEvent(Sender:TObject);
Procedure GetLogin;
Procedure GetCryptPas;
Procedure GetIsCheckCommandDisabled;
Procedure FreeAll;
Procedure AddLog;
end;

implementation

USES ThreadManager, Main, ServerSets;

Procedure TSendPacket_THRD.TermEvent(Sender:TObject);
begin
try
ThreadTerminateEvent(Self, FTermProc);
except end;
end;

Constructor TSendPacket_THRD.CreateWithArgs (AText, AContactUsers, AMessageMode, ACommand, ASender:String; AMessageColor:TColor; ASocket:TCustomWinSocket; AMustEncrypt:Boolean; AInitProc, ATermProc:TStandartProcedure);
Var I:Integer;
Sp_Thrd:TSendPacket_THRD;
begin
FText:=AText;
FContactUsers := AContactUsers;
FMessageMode:=AMessageMode;
FCommand:=ACommand;
FSender := ASender;
FMessageColor := AMessageColor;
FSocket := ASocket;
FMustEncrypt := AMustEncrypt;
FInitProc:=AInitProc;
FTermProc:=ATermProc;

I:=-1;
REPEAT
I:=I+1;
try
IF ThreadList.Objects[I] IS TSendPacket_THRD then
begin
SP_THRD := (ThreadList.Objects[I] as TSendPacket_THRD);
IF SocketExists(FSocket) then
begin
IF SP_THRD.FSocket = FSocket then
begin
SP_THRD.AddPacket(FText, FContactUsers, FMessageMode, FCommand, FSender, FMessageColor, FMustEncrypt);
Exit;
end;
end
else Exit;
end;
except I:=ThreadList.Count - 1; end;
Until (I>=ThreadList.Count - 1);

Priority := tpNormal;
FreeOnTerminate := True;
OnTerminate := TermEvent;
Create(False);
ThreadInitEvent(self, FInitProc);
end;

Procedure TSendPacket_THRD.GetLogin;
begin
try
Login := Form1.GetLoginBySocketHandle(FSocket.SocketHandle);
except Login:=""end;
end;

Procedure TSendPacket_THRD.GetCryptPas;
begin
try
CryptPas := Form1.GetUserPassword(Login);
except CryptPas:="";end;
end;

Procedure TSendPacket_THRD.GETIsCheckCommandDisabled;
begin
try
IsCheckCommandDisabled:=Form1.CheckCommandDisabled(FCommand, Login);
except IsCheckCommandDisabled := False; end;
end;

Procedure TSendPacket_THRD.AddPacket(AText, AContactUsers, AMessageMode, ACommand, ASender:String; AMessageColor:TColor; AMustEncrypt:Boolean);
begin
IF not SocketExists(FSocket) then
begin
Terminate;
Exit;
end;

IF InSpecList(THISLOGIN, IntToStr(FSocket.SocketHandle), CIPList)=-1 then
begin
Terminate;
Exit;
end;

FCommand:=ACommand;

Synchronize(GetLogin);
Synchronize(GetIsCheckCommandDisabled);
IF IsCheckCommandDisabled then
begin
Terminate;
Exit;
end;
Synchronize(GetCryptPas);
IF FMustEncrypt then IF CryptPas="" then
begin
Terminate;
Exit;
end;

CurPacket := CreatePacket(AText, AContactUsers, AMessageMode, ACommand, ASender, AMessageColor, AMustEncrypt, CryptPas);
//Создание пакета и его шифрация. Под созданием понимается коммутация всех полей пакета, в единый текст, для отправки по каналу стандарта TCP/IP.

PacketList.Add(CurPacket);
end;

Procedure TSendPacket_THRD.FreeAll;
begin
try
PacketList.Free;
except end;
end;

Procedure TSendPacket_THRD.AddLog;
Var Recv:String;
begin
try
IF form1.IsConsole(FSocket) then Recv := "ADMIN" else Recv := FSocket.RemoteAddress;
except end;
end;

procedure TSendPacket_THRD.Execute;
begin
PacketList := TStringList.Create;
AddPacket(FText, FContactUsers, FMessageMode, FCommand, FSender, FMessageColor, FMustEncrypt);
REPEAT
IF PacketList.Count>0 then
begin
try
CurPacket := PacketList[0];
UniqueString(CurPacket);
PacketList.Delete(0);
FSocket.SendText(CurPacket);
//Отправка пакета клиенту
IF ShowInOut then Synchronize(AddLog);
except Terminate end;
end else Sleep(1000);
Until Terminated;
FreeAll;
end;

end.

← →
VID (2002-09-24 16:12) [2]

{Основной юнит приложения}
Procedure Tform1.SendPacketToClient(_Text, _ContactUsers, _MessageMode, _Command, _Sender:String; _MessageColor:TColor; Socket:TCustomWinSocket; MustEncrypt:Boolean);
begin

SendPacket_THRD := TSendPacket_THRD.CreateWithArgs(_Text, _ContactUsers, _MessageMode, _Command, _Sender, _MessageColor, Socket, MustEncrypt, TIEvent, TTEvent);
//Передача пакета в поток, для последующей шифрации пакета и отправки клиенту

end;

{Доп. юнит приложения - потоковый: ВЫРЕЗКИ...}

Procedure TArchiveGetting_THRD.SendPacket;
begin
try
Form1.SendPacketToClient(LST.CommaText, EL, EL, GetChatArchive, EL, 0, FSocket, True);
except end;
//Отправка пакета в проц. в осн. модуле.
//После вызова этой проц и до исполнения первой строки когда процедуры Form1.SendPacketToClient наблюдается макс торможение.
//LST.CommaText содержит тот самый БОЛЬШОЙ ТЕКСТ ~400кб
end;
...
Procedure TArchiveGetting_THRD.Execute;
begin
...
Synchronize(SendPacket);//Отправка пакета в проц. в собственном модуле
...
end;

Вот и всё :)

← →
Alx2 (2002-09-24 16:50) [3]

unit SendPacket_Unit; interface uses Classes, Tools,ScktComp, sysUtils, graphics, Dialogs, windows; type TSendPacket_THRD = class(TThread) private FText, FContactUsers, FMessageMode, FCommand, FSender:String; FMessageColor:TColor; FMustEncrypt:Boolean; FInitProc, FTermProc:TStandartProcedure; Login, CryptPas:String; IsCheckCommandDisabled : Boolean; PacketList:TStringList; CurPacket:String; public FSocket:TCustomWinSocket; Constructor CreateWithArgs (AText, AContactUsers, AMessageMode, ACommand, ASender:String; AMessageColor:TColor; ASocket:TCustomWinSocket; AMustEncrypt:Boolean; AInitProc, ATermProc:TStandartProcedure); Procedure AddPacket(AText, AContactUsers, AMessageMode, ACommand, ASender:String; AMessageColor:TColor; AMustEncrypt:Boolean); protected procedure Execute; override; Procedure TermEvent(Sender:TObject); Procedure GetLogin; Procedure GetCryptPas; Procedure GetIsCheckCommandDisabled; Procedure FreeAll; Procedure AddLog; end; implementation USES ThreadManager, Main, ServerSets; Procedure TSendPacket_THRD.TermEvent(Sender:TObject); begin try ThreadTerminateEvent(Self, FTermProc); except end; end; Constructor TSendPacket_THRD.CreateWithArgs (AText, AContactUsers, AMessageMode, ACommand, ASender:String; AMessageColor:TColor; ASocket:TCustomWinSocket; AMustEncrypt:Boolean; AInitProc, ATermProc:TStandartProcedure); Var I:Integer; Sp_Thrd:TSendPacket_THRD; begin FText:=AText; FContactUsers := AContactUsers; FMessageMode:=AMessageMode; FCommand:=ACommand; FSender := ASender; FMessageColor := AMessageColor; FSocket := ASocket; FMustEncrypt := AMustEncrypt; FInitProc:=AInitProc; FTermProc:=ATermProc; I:=-1; REPEAT I:=I+1; try IF ThreadList.Objects[I] IS TSendPacket_THRD then begin SP_THRD := (ThreadList.Objects[I] as TSendPacket_THRD); IF SocketExists(FSocket) then begin IF SP_THRD.FSocket = FSocket then begin SP_THRD.AddPacket(FText, FContactUsers, FMessageMode, FCommand, FSender, FMessageColor, FMustEncrypt); Exit; end; end else Exit; end; except I:=ThreadList.Count - 1; end; Until (I>=ThreadList.Count - 1); Priority := tpNormal; FreeOnTerminate := True; OnTerminate := TermEvent; Create(False); ThreadInitEvent(self, FInitProc); end; Procedure TSendPacket_THRD.GetLogin; begin try Login := Form1.GetLoginBySocketHandle(FSocket.SocketHandle); except Login:=""end; end; Procedure TSendPacket_THRD.GetCryptPas; begin try CryptPas := Form1.GetUserPassword(Login); except CryptPas:="";end; end; Procedure TSendPacket_THRD.GETIsCheckCommandDisabled; begin try IsCheckCommandDisabled:=Form1.CheckCommandDisabled(FCommand, Login); except IsCheckCommandDisabled := False; end; end; Procedure TSendPacket_THRD.AddPacket(AText, AContactUsers, AMessageMode, ACommand, ASender:String; AMessageColor:TColor; AMustEncrypt:Boolean); begin IF not SocketExists(FSocket) then begin Terminate; Exit; end; IF InSpecList(THISLOGIN, IntToStr(FSocket.SocketHandle), CIPList)=-1 then begin Terminate; Exit; end; FCommand:=ACommand; Synchronize(GetLogin); Synchronize(GetIsCheckCommandDisabled); IF IsCheckCommandDisabled then begin Terminate; Exit; end; Synchronize(GetCryptPas); IF FMustEncrypt then IF CryptPas="" then begin Terminate; Exit; end; CurPacket := CreatePacket(AText, AContactUsers, AMessageMode, ACommand, ASender, AMessageColor, AMustEncrypt, CryptPas); //Создание пакета и его шифрация. Под созданием понимается коммутация всех полей пакета, в единый текст, для отправки по каналу стандарта TCP/IP. PacketList.Add(CurPacket); end; Procedure TSendPacket_THRD.FreeAll; begin try PacketList.Free; except end; end; Procedure TSendPacket_THRD.AddLog; Var Recv:String; begin try IF form1.IsConsole(FSocket) then Recv := "ADMIN" else Recv := FSocket.RemoteAddress; except end; end; procedure TSendPacket_THRD.Execute; begin PacketList := TStringList.Create; AddPacket(FText, FContactUsers, FMessageMode, FCommand, FSender, FMessageColor, FMustEncrypt); REPEAT IF PacketList.Count>0 then begin try CurPacket := PacketList[0]; UniqueString(CurPacket); PacketList.Delete(0); FSocket.SendText(CurPacket); //Отправка пакета клиенту IF ShowInOut then Synchronize(AddLog); except Terminate end; end else Sleep(1000); Until Terminated; FreeAll; end; end.

Washington Post: Приложение тормозит при передачи большого текста Найти похожие ветки