Приём и обработка пакетов переданных методом SendText - с учётом склеенных и полученных неполностью пакетов

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Приём и обработка пакетов переданных методом 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; Text:String):Integer;
Var S:String;
begin
Result := -1;
IF Text = '' then exit;
IF Socket.Connected then
begin
S:=IntToStr(Length(Text));
Result := Socket.SendText(S+'#'+Text);
end;
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
;

type

  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

  ABuffer.FBuffer := '';
  ABuffer.FHeaderBuffer := '';
  ABuffer.FCurrentPacketSize := 0;
end
;

function
 ReadHeader(var
 ABuffer: TBuffer; var
 APacket: string
):
  TReadHeaderResult;
var

  X, HBuffLen: 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

      if
 (APacket[I] in
 ['0'..'9']) then

        BREAK
      else
 if
 (APacket[I] = '#') and
 (ABuffer.FHeaderBuffer <> '') then

        BREAK
      else

        X := I;
    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

        HBuffLen := Length(ABuffer.FHeaderBuffer);
        if
 HBuffLen > 0 then

          Inc(HBuffLen);
        Insert(APacket[I], ABuffer.FHeaderBuffer, HBuffLen);
      end

      else

        Break;
    end
;
  end
;

  procedure
 SetResultToNone;
  begin

    Result.FPacketSize := 0;
    Result.FTextStartsAt := 0;
    Result.FPacketSizeStr := '';
  end
;

begin

  SetResultToNone;
  if
 APacket = '' then

    Exit;
  if
 ABuffer.FCurrentPacketSize > 0 then

  begin

    Result.FPacketSize := ABuffer.FCurrentPacketSize;
    Result.FPacketSizeStr := IntToStr(ABuffer.FCurrentPacketSize);
    Result.FTextStartsAt := 1;
    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
;
  BuffLen: Integer;

  function
 FullPacket: Boolean;
  begin

    Result := Length(ABuffer.FBuffer) = ABuffer.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

    NeedToCopy := ABuffer.FCurrentPacketSize - Length(ABuffer.FBuffer);
    S := Copy(APacket, 1, NeedToCopy);
    DelSize := NeedToCopy;
  end
;
  if
 ABuffer.FCurrentPacketSize > 0 then

  begin

    BuffLen := Length(ABuffer.FBuffer);
    if
 BuffLen > 0 then

      Inc(BuffLen);
    Insert(S, ABuffer.FBuffer, BuffLen);
  end
;

  if
 not
 FullPacket then

    Result := False;
  if
 ABuffer.FHeaderBuffer = '' then

    DELETE(APacket, 1, DelSize)
  else

  begin

    APacket := '';
    Result := False;
  end
;
end
;

end
.

Пример использования:

// Объявляем переменную типа TBuffer. Для каждого клиента на
// сервере должна быть объявлена отдельная переменная этого типа
var

  GBuffer: 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

        Recv.Lines.Add(GBuffer.FBuffer);
      //или же передать GBuffer.FBuffer на исполнение.
      ClearBuffer(GBuffer);
    end
;
  until
 S = '';
end
;

Другое по теме:

• CrtSock - модуль для работы с сокетами в Delphi32
• TServerSocket и TClientSocket без scktsrvr.exe отказываются работать
• Асинхронная ошибка