Приём текста, передаваемого с помощью метода SendText

{ **** UBPFD *********** by kladovka.net.ru ****
>> Приём и обработка пакетов переданных методом SendText() - с учётом "склеенных" и полученных неполностью пакетов.
Юнит RecvPckt предназначен для приёма текста, передаваемого с помощью метода SendText
объекта Socket:TCustomWinSocket. Данный юнит может использоваться как клиентом так
и сервером для обработки принятого пакета.
Функции юнита предусматривают возможность получения "склеенных" пакетов,
или пакетов, пришедших не полностью.
Тип TBuffer;
FBuffer - хранит в себе принимаемый пакет
FCurrentPacketSize = хранит сведения о полной длине принимаемого пакета.
Описание функций и процедур, необходимых для использования в других юнитах
procedure ClearBuffer(var ABuffer: TBuffer);
Очищает буффер FBuffer и обнуляет значение FCurrentPacketSize;
function ProcessReceivedPacket(var ABuffer: TBuffer; var APacket: string): Boolean;
В данную функцию передаётся полученный от клиента/сервера пакет, через аргумент APacket
Принцип работы этой функции заключается в накоплении получаемого текста в поле
FBuffer объекта ABuffer. В случае когда FBuffer будет содержать полностью весь пакет,
функция возвратит True, иначе возвращает False
Функция ОТПРАВКИ текста:
function SendTextToSocket(Socket: TCustomWinSocket; const Text: string): Integer;
begin
 Result := -1;
 if Text = then exit;
 if Socket.Connected then
 Result := Socket.SendText(IntToStr(Length(Text)) + '#' + Text);
end;
Зависимости: sysutils
Автор: VID, snap@iwt.ru, ICQ:132234868, Махачкала
Copyright: VID
Дата: 30 сентября 2002 г.
********************************************** }
unit RecvPckt;
interface
uses
 SysUtils;
Type
 TReadHeaderResult = record
 FPacketSize: Integer;
 FPacketSizeStr: string;
 FTextStartsAt: Integer;
 end;
 TBuffer = record
 FBuffer: string;
 FHeaderBuffer: string;
 FCurrentPacketSize: Integer;
 end;
 procedure ClearBuffer(var ABuffer: TBuffer);
 function ReadHeader(var ABuffer: TBuffer; var APacket: string): TReadHeaderResult;
 function ProcessReceivedPacket(var ABuffer: TBuffer; var APacket: string): Boolean;
implementation
procedure ClearBuffer(var ABuffer: TBuffer);
begin
 with ABuffer do
 begin
 FBuffer := ;
 FHeaderBuffer := ;
 FCurrentPacketSize := 0;
 end;
end;
function ReadHeader(var ABuffer: TBuffer; var APacket: string): TReadHeaderResult;
var
 X: Integer;
 procedure ClearHeader;
 begin
 ABuffer.FHeaderBuffer := ;
 end;
 function CorrectPacket: Boolean;
 var
 I, L: Integer;
 begin
 X := 0;
 L := Length(APacket);
 for I := 1 to L do
 begin
 if (APacket[I] in ['0'..'9']) then
 Break
 else if (APacket[I] = '#') and (ABuffer.FHeaderBuffer <> ) then
 Break
 else
 X := I;
 end;
 if X > 0 then
 Delete(APacket, 1, X);
 Result := (APacket <> );
 end;
 procedure GetHeader;
 var
 I, L: Integer;
 begin
 L := Length(APacket);
 X := 0;
 for I := 1 to L do
 begin
 X := I;
 if (APacket[I] in ['0'..'9']) then
 begin
 Insert(APacket[I], ABuffer.FHeaderBuffer, Length(ABuffer.FHeaderBuffer)+1);
 end
 else
 Break;
 end;
 end;
 procedure SetResultToNone;
 begin
 with Result do
 begin
 FPacketSize := 0;
 FTextStartsAt := 0;
 FPacketSizeStr := ;
 end;
 end;
begin
 SetResultToNone;
 if APacket = then Exit;
 if ABuffer.FCurrentPacketSize > 0 then
 begin
 with Result do
 begin
 FPacketSize := ABuffer.FCurrentPacketSize;
 FPacketSizeStr := IntToStr(ABuffer.FCurrentPacketSize);
 FTextStartsAt := 1;
 end;
 Exit;
 end;
 if not CorrectPacket then Exit;
 GetHeader();
 if APacket[X] = '#' then
 begin
 Inc(X);
 try
 Result.FPacketSize := StrToInt(ABuffer.FHeaderBuffer);
 except
 end;
 Result.FPacketSizeStr := ABuffer.FHeaderBuffer;
 ClearHeader;
 end
 else if not (APacket[X] in ['0'..'9']) then
 ClearHeader;
 Result.FTextStartsAt := X;
end;
function ProcessReceivedPacket(var ABuffer: TBuffer; var APacket: string): Boolean;
var
 ReadHeaderResult: TReadHeaderResult;
 NeedToCopy, DelSize: Integer;
 S: string;
 function FullPacket: Boolean;
 begin
 with ABuffer do
 Result := (Length(FBuffer) = FCurrentPacketSize);
 end;
begin
 Result := True;
 if APacket = then Exit;
 if ABuffer.FBuffer = then
 begin
 ReadHeaderResult := ReadHeader(ABuffer, APacket);
 ABuffer.FCurrentPacketSize := ReadHeaderResult.FPacketSize;
 S := Copy(APacket, ReadHeaderResult.FTextStartsAt, ReadHeaderResult.FPacketSize);
 DelSize := Length(ReadHeaderResult.FPacketSizeStr) + ReadHeaderResult.FPacketSize + 1;
 end
 else
 begin
 with ABuffer do NeedToCopy := FCurrentPacketSize - Length(FBuffer);
 S := Copy(APacket, 1, NeedToCopy);
 DelSize := NeedToCopy;
 end;
 with ABuffer do
 if FCurrentPacketSize > 0 then
 Insert(S, FBuffer, Length(FBuffer)+1);
 if not FullPacket then Result := False;
 if ABuffer.FHeaderBuffer = then
 Delete(APacket, 1, DelSize)
 else
 begin
 APacket := ;
 Result := False;
 end;
end;
end.
Пример использования:
var
 GBuffer: TBuffer; // Объявляем переменную типа TBuffer. Для каждого клиента на сервере должна быть объявлена отдельная переменная этого типа
procedure TForm1.ServerClientRead(Sender: TObject; Socket: TCustomWinSocket);
var
 S: string;
begin
 S := Socket.ReceiveText;
 repeat
 if ProcessReceivedPacket(GBuffer, S) then
 begin
 if GBuffer.FBuffer <> then
 try
 Recv.Lines.Add(GBuffer.FBuffer);
 // Или же передать GBuffer.FBuffer на исполнение.
 finally
 ClearBuffer(GBuffer);
 end;
 end;
 until S = ;
end
Author: VID
ID: 03566
Category:Связь
Category:Сокеты