cltcpclient.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

procedure TclTcpClient.DoVerifyServer(ACertificate: TclCertificate;
  const AStatusText: string; AStatusCode: Integer; var AVerified: Boolean);
begin
  if Assigned(OnVerifyServer) then
  begin
    OnVerifyServer(Self, ACertificate, AStatusText, AStatusCode, AVerified);
  end;
end;

procedure TclTcpClient.VerifyServer(Sender: TObject; ACertificate: TclCertificate;
  const AStatusText: string; AStatusCode: Integer; var AVerified: Boolean);
begin
  DoVerifyServer(ACertificate, AStatusText, AStatusCode, AVerified);
end;

procedure TclTcpClient.SetCertificateFlags(const Value: TclCertificateFlags);
begin
  if (FCertificateFlags <> Value) then
  begin
    FCertificateFlags := Value;
    Changed();
  end;
end;

procedure TclTcpClient.SetTLSFlags(const Value: TclTlsFlags);
begin
  if (FTLSFlags <> Value) then
  begin
    FTLSFlags := Value;
    Changed();
  end;
end;

function TclTcpClient.GetIsTls: Boolean;
begin
  Result := (Connection.NetworkStream is TclTlsNetworkStream);
end;

{ TclTcpCommandClient }

procedure TclTcpCommandClient.SendCommand(const ACommand: string);
var
  cmd: string;
begin
  CheckConnected();
  cmd := ACommand + #13#10;
  Connection.InitProgress(0, 0);
  Connection.WriteString(cmd);
  DoSendCommand(cmd);
end;

function TclTcpCommandClient.ReceiveResponse(AddToLastString: Boolean): Boolean;
var
  stream: TStream;
begin
  stream := TMemoryStream.Create();
  try
    Connection.ReadData(stream);
    stream.Position := 0;
    Result := AddTextStream(Response, stream, AddToLastString);
  finally
    stream.Free();
  end;
end;

function TclTcpCommandClient.IsOkResponse(AResponseCode: Integer; const AOkResponses: array of Integer): Boolean;
var
  i: Integer;
begin
  Result := False;
  i := Low(AOkResponses);
  while (i <= High(AOkResponses)) and (AOkResponses[i] <> 0) do
  begin
    if (AOkResponses[i] = AResponseCode) then
    begin
      Result := True;
      Break;
    end;
    Inc(i);
  end;
end;

procedure TclTcpCommandClient.WaitingResponse(const AOkResponses: array of Integer);
begin
  Response.Clear();
  InternalWaitingResponse(0, AOkResponses);
  DoReceiveResponse(Response);
end;

procedure TclTcpCommandClient.InternalSendCommandSync(const ACommand: string;
  const AOkResponses: array of Integer);
begin
  SendCommand(ACommand);
  WaitingResponse(AOkResponses);
end;

procedure TclTcpCommandClient.SendCommandSync(const ACommand: string;
  const AOkResponses: array of Integer);
begin
  FInProgress := True;
  try
    InternalSendCommandSync(ACommand, AOkResponses);
  finally
    FInProgress := False;
  end;
end;

procedure TclTcpCommandClient.SendCommandSync(const ACommand: string;
  const AOkResponses: array of Integer; const Args: array of const);
begin
  SendCommandSync(Format(ACommand, Args), AOkResponses);
end;

procedure TclTcpCommandClient.SetPassword(const Value: string);
begin
  if (FPassword <> Value) then
  begin
    FPassword := Value;
    Changed();
  end;
end;

procedure TclTcpCommandClient.SetUserName(const Value: string);
begin
  if (FUserName <> Value) then
  begin
    FUserName := Value;
    Changed();
  end;
end;

constructor TclTcpCommandClient.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FResponse := TStringList.Create();
end;

function TclTcpCommandClient.GetResponseCode(const AResponse: string): Integer;
begin
  Result := SOCKET_WAIT_RESPONSE;
end;

procedure TclTcpCommandClient.InternalClose;
begin
  try
    if Active and not FInProgress then
    begin
      CloseSession();
    end;
  finally
    inherited InternalClose();
  end;
end;

procedure TclTcpCommandClient.InternalOpen;
begin
  inherited InternalOpen();
  OpenSession();
end;

procedure TclTcpCommandClient.SendMultipleLines(ALines: TStrings);
const
  cDot = '.';
  cCRLF = #13#10;

  procedure WriteLine(AStream: TStream; const ALine: string);
  begin
    AStream.Write(PChar(ALine)^, Length(ALine));
  end;

  function GetTotalBytes(ALines: TStrings): Int64;
  var
    i: Integer;
  begin
    Result := 0;
    for i := 0 to ALines.Count - 1 do
    begin
      if (Length(ALines[i]) + Length(cCRLF) + 1 > BatchSize) then
      begin
        RaiseSocketError(cLineSizeInvalid, -1);
      end;
      Result := Result + Length(ALines[i]) + Length(cCRLF);
    end;
  end;
var
  i: Integer;
  stream: TStream;
  line: string;
begin
  if (BatchSize < 1) then
  begin
    RaiseSocketError(cBatchSizeInvalid, -1);
  end;

  stream := TMemoryStream.Create();
  Connection.OnProgress := DoDataProgress;
  FInProgress := True;
  try
    i := 0;
    line := '';
    Connection.InitProgress(0, GetTotalBytes(ALines));

    while (i < ALines.Count) do
    begin
      line := ALines[i];
      if ((stream.Size + 3 + Length(line)) <= BatchSize) then
      begin
        if (Length(line) > 0) then
        begin
          if (line[1] = '.') then
          begin
            WriteLine(stream, cDot);
          end;
          WriteLine(stream, line);
        end;
        WriteLine(stream, cCRLF);
      end else
      begin
        stream.Position := 0;
        Connection.WriteData(stream);
        stream.Position := 0;
        stream.Size := 0;

        Continue;
      end;
      Inc(i);
    end;

    if (stream.Size > 0) then
    begin
      stream.Position := 0;
      Connection.WriteData(stream);
    end;
  finally
    FInProgress := False;
    Connection.OnProgress := nil;
    stream.Free();
  end;
end;

procedure TclTcpCommandClient.DoReceiveResponse(AList: TStrings);
begin
  if Assigned(OnReceiveResponse) then
  begin
    OnReceiveResponse(Self, AList);
  end;
end;

procedure TclTcpCommandClient.DoSendCommand(const AText: string);
begin
  if Assigned(OnSendCommand) then
  begin
    OnSendCommand(Self, AText);
  end;
end;

procedure TclTcpCommandClient.DoProgress(ABytesProceed, ATotalBytes: Int64);
begin
  if Assigned(OnProgress) then
  begin
    OnProgress(Self, ABytesProceed, ATotalBytes);
  end;
  if Assigned(OnProgress64) then
  begin
    OnProgress64(Self, ABytesProceed, ATotalBytes);
  end;
end;

procedure TclTcpCommandClient.DoDestroy;
begin
  FResponse.Free();
  inherited DoDestroy();
end;

procedure TclTcpCommandClient.WaitMultipleLines(ATotalBytes: Int64);

  function CheckForDotTerminator: Boolean;
  begin
    Result := (Response.Count > 0) and (Response[Response.Count - 1] = '.');
  end;

  procedure RemoveResponseLine;
  begin
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'WaitMultipleLines, RemoveResponseLine');{$ENDIF}
    if (Response.Count > 0) then
    begin
      Response.Delete(0);
    end;
  end;

  procedure RemoveDotTerminatorLine;
  begin
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'WaitMultipleLines, RemoveDotTerminatorLine');{$ENDIF}
    Assert(Response.Count > 0);
    Response.Delete(Response.Count - 1);
  end;

  procedure ReplaceLeadingDotTerminator;
  var
    i: Integer;
  begin
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'WaitMultipleLines, ReplaceLeadingDotTerminator');{$ENDIF}
    for i := 0 to Response.Count - 1 do
    begin
      if (system.Pos('..', Response[i]) = 1) then
      begin
        Response[i] := system.Copy(Response[i], 2, Length(Response[i]));
      end;
    end;
  end;

begin
  Connection.OnProgress := DoDataProgress;
  FInProgress := True;
  try
    if (ATotalBytes > 0) then
    begin
      Connection.InitProgress(GetStringsSize(Response), ATotalBytes);
    end else
    begin
      Connection.InitProgress(0, 0);
    end;

    RemoveResponseLine();
    if not CheckForDotTerminator then
    begin
      InternalWaitingResponse(0, [SOCKET_DOT_RESPONSE]);
    end;
    ReplaceLeadingDotTerminator();
    RemoveDotTerminatorLine();
  finally
    FInProgress := False;
    Connection.OnProgress := nil;
  end;
  if (ATotalBytes > 0) then
  begin
    DoProgress(ATotalBytes, ATotalBytes);
  end;
end;

procedure TclTcpCommandClient.DoDataProgress(Sender: TObject; ABytesProceed, ATotalBytes: Int64);
begin
  if (ABytesProceed <= ATotalBytes) then
  begin
    DoProgress(ABytesProceed, ATotalBytes);
  end;
end;

function TclTcpCommandClient.ParseResponse(AStartFrom: Integer; const AOkResponses: array of Integer): Integer;
var
  i, tempCode: Integer;
begin
  Result := -1;
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'ParseResponse');{$ENDIF}
  for i := AStartFrom to Response.Count - 1 do
  begin
    tempCode := GetResponseCode(Response[i]);
    if (tempCode <> SOCKET_WAIT_RESPONSE) then
    begin
      FLastResponseCode := tempCode;
      if IsOkResponse(LastResponseCode, AOkResponses) then
      begin
        Result := i;
        Exit;
      end;
    end;
  end;
{$IFDEF LOGGER}
  finally
    if(Result > -1) then
    begin
      clPutLogMessage(Self, edLeave, 'ParseResponse %d, %s', nil, [Result, Response[Result]]);
    end else
    begin
      clPutLogMessage(Self, edLeave, 'ParseResponse %d', nil, [Result]);
    end;
  end;
{$ENDIF}
end;

function TclTcpCommandClient.InternalWaitingResponse(AStartFrom: Integer;
  const AOkResponses: array of Integer): Integer;
var
  keepLastString: Boolean;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'InternalWaitingResponse');{$ENDIF}
  Result := -1;
  keepLastString := False;
  repeat
    keepLastString := ReceiveResponse(keepLastString);

    if keepLastString then
    begin
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'InternalWaitingResponse inside if(keepLastString)then');{$ENDIF}
      Continue;
    end;

    FLastResponseCode := SOCKET_WAIT_RESPONSE;

    if (Response.Count = AStartFrom) and (Length(AOkResponses) = 0) then
    begin
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'InternalWaitingResponse inside if(Response.Count = AStartFrom)');{$ENDIF}
      Break;
    end;

    Result := ParseResponse(AStartFrom, AOkResponses);
    if Result > -1 then
    begin
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'InternalWaitingResponse inside if(Result > -1)');{$ENDIF}
      Break;
    end;

    if not ((Length(AOkResponses) = 1) and (AOkResponses[Low(AOkResponses)] = SOCKET_DOT_RESPONSE))
      and (LastResponseCode <> SOCKET_WAIT_RESPONSE) then
    begin
      RaiseSocketError(Trim(Response.Text), LastResponseCode);
    end;
  until False;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'InternalWaitingResponse'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'InternalWaitingResponse', E); raise; end; end;{$ENDIF}
end;

procedure TclTcpCommandClient.SendSilentCommand(const ACommand: string;
  const AOkResponses: array of Integer; const Args: array of const);
begin
  try
    SendCommandSync(ACommand, AOkResponses, Args);
  except
    on EclSocketError do ;
  end;
end;

procedure TclTcpCommandClient.SendSilentCommand(const ACommand: string;
  const AOkResponses: array of Integer);
begin
  try
    SendCommandSync(ACommand, AOkResponses);
  except
    on EclSocketError do ;
  end;
end;

end.