Автор: VID
WEB-сайт: http://delphibase.endimus.com

{ **** 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;