//TODO: Elim read/write methods - they are duped
                               

{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  12000: IdTCPConnection.pas
{
    Rev 1.45    11/4/2003 10:28:34 PM  DSiders
  Removed exceptions moved to IdException.pas.
}
{
{   Rev 1.44    2003.10.18 9:33:28 PM  czhower
{ Boatload of bug fixes to command handlers.
}
{
    Rev 1.43    10/15/2003 7:32:48 PM  DSiders
  Added a resource string for the exception raised in
  TIdTCPConnection.CreateIOHandler.
}
{
{   Rev 1.42    2003.10.14 1:27:02 PM  czhower
{ Uupdates + Intercept support
}
{
{   Rev 1.41    10/10/2003 11:00:36 PM  BGooijen
{ Added GetReplyClass
}
{
{   Rev 1.40    2003.10.02 8:29:40 PM  czhower
{ Added IdReply back
}
{
{   Rev 1.39    2003.10.02 8:08:52 PM  czhower
{ Removed unneeded unit in uses.
}
{
{   Rev 1.38    2003.10.01 9:11:28 PM  czhower
{ .Net
}
{
{   Rev 1.37    2003.10.01 5:05:18 PM  czhower
{ .Net
}
{
{   Rev 1.36    2003.10.01 2:30:42 PM  czhower
{ .Net
}
{
{   Rev 1.35    2003.10.01 11:16:38 AM  czhower
{ .Net
}
{
{   Rev 1.34    2003.09.30 1:23:06 PM  czhower
{ Stack split for DotNet
}
{
{   Rev 1.33    2003.09.18 7:12:42 PM  czhower
{ AV Fix in SetIOHandler
}
{
{   Rev 1.32    2003.09.18 5:18:00 PM  czhower
{ Implemented OnWork
}
{
{   Rev 1.31    2003.06.30 6:17:48 PM  czhower
{ Moved socket property to public. Dont know how/why it got protected.
}
{
{   Rev 1.30    2003.06.30 5:41:56 PM  czhower
{ -Fixed AV that occurred sometimes when sockets were closed with chains
{ -Consolidated code that was marked by a todo for merging as it no longer
{ needed to be separate
{ -Removed some older code that was no longer necessary
{
{ Passes bubble tests.
}
{
{   Rev 1.29    2003.06.05 10:08:52 AM  czhower
{ Extended reply mechanisms to the exception handling. Only base and RFC
{ completed, handing off to J Peter.
}
{
{   Rev 1.28    6/4/2003 03:54:42 PM  JPMugaas
{ Now should compile.
}
{
{   Rev 1.27    2003.06.04 8:10:00 PM  czhower
{ Modified CheckResponse string version to allow ''
}
{
{   Rev 1.26    2003.06.04 12:02:30 PM  czhower
{ Additions for text code and command handling.
}
{
{   Rev 1.25    2003.06.03 3:44:26 PM  czhower
{ Removed unused variable.
}
{
{   Rev 1.24    2003.05.30 10:25:58 PM  czhower
{ Implemented IsEndMarker
}
{
{   Rev 1.23    5/26/2003 04:29:52 PM  JPMugaas
{ Removed GenerateReply and ParseReply.  Those are now obsolete duplicate
{ functions in the new design.
}
{
{   Rev 1.22    5/26/2003 12:19:56 PM  JPMugaas
}
{
{   Rev 1.21    2003.05.26 11:38:20 AM  czhower
}
{
{   Rev 1.20    5/25/2003 03:34:54 AM  JPMugaas
}
{
{   Rev 1.19    5/25/2003 03:16:22 AM  JPMugaas
}
{
{   Rev 1.18    5/20/2003 02:40:10 PM  JPMugaas
}
{
    Rev 1.17    5/20/2003 12:43:50 AM  BGooijen
  changeable reply types
}
{
    Rev 1.16    4/4/2003 8:10:14 PM  BGooijen
  procedure CreateIOHandler is now public
}
{
    Rev 1.15    3/27/2003 3:17:32 PM  BGooijen
  Removed MaxLineLength, MaxLineAction, SendBufferSize, RecvBufferSize,
  ReadLnSplit, ReadLnTimedOut
}
{
    Rev 1.14    3/19/2003 1:04:16 PM  BGooijen
  changed procedure CreateIOHandler a little (default parameter, and other
  behavour when parameter = nil (constructs default now))
}
{
    Rev 1.13    3/5/2003 11:07:18 PM  BGooijen
  removed intercept from this file
}
{
{   Rev 1.12    2003.02.25 7:28:02 PM  czhower
{ Fixed WriteRFCReply
}
{
{   Rev 1.11    2003.02.25 1:36:20 AM  czhower
}
{
{   Rev 1.10    2/13/2003 02:14:44 PM  JPMugaas
{ Now calls ReadLn in GetInternelResponse so a space is not dropped.  Dropping
{ a space throws off some things in FTP such as the FEAT reply.
}
{
{   Rev 1.9    2003.01.18 12:29:52 PM  czhower
}
{
{   Rev 1.8    1-17-2003 22:22:08  BGooijen
{ new design
}
{
{   Rev 1.7    12-16-2002 20:44:38  BGooijen
{ Added procedure CreateIOHandler(....)
}
{
{   Rev 1.6    12-15-2002 23:32:32  BGooijen
{ Added RecvBufferSize
}
{
{   Rev 1.5    12-14-2002 22:16:32  BGooijen
{ improved method to detect timeouts in ReadLn.
}
{
{   Rev 1.4    12/6/2002 02:11:46 PM  JPMugaas
{ Protected Port and Host properties added to TCPClient because those are
{ needed by protocol implementations.  Socket property added to TCPConnection.
}
{
{   Rev 1.3    6/12/2002 11:00:16 AM  SGrobety
}
{
{   Rev 1.0    21/11/2002 12:36:48 PM  SGrobety    Version: Indy 10
}
{
{   Rev 1.2    11/15/2002 01:26:42 PM  JPMugaas
{ Restored Trim to ReadLnWait and changed GetInternelResponse to use ReadLn
{ instead of ReadLn wait.
}
{
{   Rev 1.1    11/14/2002 06:44:54 PM  JPMugaas
{ Removed Trim from ReadLnWait.  It was breaking the new RFC Reply parsing code
{ by removing the space at the beggining of a line.
}
{
{   Rev 1.0    11/13/2002 09:00:30 AM  JPMugaas
}
unit IdTCPConnection;

interface

{
2002-06 -Andrew P.Rybin
  -WriteStream optimization and new "friendly" interface, InputLn fix (CrLf only if AEcho)
2002-04-12 - Andrew P.Rybin
  - ReadLn bugfix and optimization
2002-01-20 - Chad Z. Hower a.k.a Kudzu
  -WriteBuffer change was not correct. Removed. Need info on original problem to fix properly.
  -Modified ReadLnWait
2002-01-19 - Grahame Grieve
  - Fix to WriteBuffer to accept -1 from the stack.
  Also fixed to clean up FWriteBuffer if connection lost.
2002-01-19 - Chad Z. Hower a.k.a Kudzu
  -Fix to ReadLn
2002-01-16 - Andrew P.Rybin
  -ReadStream optimization, TIdManagedBuffer new
2002-01-03 - Chad Z. Hower a.k.a Kudzu
  -Added MaxLineAction
  -Added ReadLnSplit
2001-12-27 - Chad Z. Hower a.k.a Kudzu
  -Changes and bug fixes to InputLn
  -Modifed how buffering works
    -Added property InputBuffer
    -Moved some things to TIdBuffer
  -Modified ReadLn
  -Added LineCount to Capture
2001-12-25 - Andrew P.Rybin
  -MaxLineLength,ReadLn,InputLn and Merry Christmas!
Original Author and Maintainer:
  -Chad Z. Hower a.k.a Kudzu
}

uses
  Classes,
  IdException, IdComponent, IdCoreGlobal, IdSocketHandle, IdIOHandler, IdReply,
  IdIOHandlerSocket, IdIOHandlerStack;


type
  TIdTCPConnection = class(TIdComponent)
  protected
                                                                                               
    // to just TStream so we can replace it easily
    FGreeting: TIdReply;
    FFreeIOHandlerOnDisconnect: Boolean;
    FIOHandler: TIdIOHandler;
    FLastCmdResult: TIdReply;
    FOnDisconnected: TNotifyEvent;
    FSocket: TIdIOHandlerSocket;
    FReplyClass: TIdReplyClass;
    //
    procedure DoOnDisconnected; virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetIOHandler(AValue: TIdIOHandler); virtual;
    procedure WorkBeginEvent(ASender: TObject; AWorkMode: TWorkMode;
     AWorkCountMax: Integer);
    procedure WorkEndEvent(ASender: TObject; AWorkMode: TWorkMode);
    procedure WorkEvent(ASender: TObject; AWorkMode: TWorkMode;
     AWorkCount: Integer);
    function GetReplyClass:TIdReplyClass; virtual;
  public
    procedure CreateIOHandler(ABaseType:TIdIOHandlerClass=nil);
    procedure CheckForGracefulDisconnect(
     ARaiseExceptionIfDisconnected: Boolean = True); virtual;
    //
    function CheckResponse(AResponse: SmallInt;
     const AAllowedResponses: array of SmallInt): SmallInt; overload; virtual;
    function CheckResponse(AResponse: string;
      AAllowedResponse: string): string; overload; virtual;
    //
    function Connected: Boolean; virtual;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Disconnect; virtual;
    // GetInternalResponse is not in IOHandler as some protocols may need to
    // override it. It could be still moved and proxied from here, but at this
    // point it is here.
    procedure GetInternalResponse; virtual;
    // Reads response using GetInternalResponse which each reply type can define
    // the behaviour. Then checks against expected Code.
    //
    // Seperate one for singles as one of the older Delphi compilers cannot
    // match a single number into an array. IIRC newer ones do.
    function GetResponse(AAllowedResponse: SmallInt): SmallInt; overload;
    function GetResponse(const AAllowedResponses: array of SmallInt): SmallInt;
     overload; virtual;
    // No array type for strings as ones that use strings are usually bastard
    // protocols like POP3/IMAP which dont include proper substatus anyways.
    //
    // If a case can be made for some other condition this may be expanded
    // in the future
    function GetResponse(AAllowedResponse: string): string;
     overload; virtual;
    //
    property Greeting: TIdReply read FGreeting write FGreeting;
    // RaiseExceptionForCmdResult - Overload necesary as a exception as a default param doesnt work
    procedure RaiseExceptionForLastCmdResult; overload; virtual;
    procedure RaiseExceptionForLastCmdResult(AException: TClassIdException);
     overload; virtual;
    // These are extended GetResponses, so see the comments for GetResponse
    function SendCmd(AOut: string; AResponse: SmallInt = -1)
     : SmallInt; overload;
    function SendCmd(AOut: string; const AResponse: array of SmallInt)
     : SmallInt; overload; virtual;
    function SendCmd(AOut: string; AResponse: string): string;
     overload;
    //
    procedure WriteHeader(AHeader: TStrings);
    procedure WriteRFCStrings(AStrings: TStrings);
    //
    property LastCmdResult: TIdReply read FLastCmdResult;
    property FreeIOHandlerOnDisconnect:boolean read FFreeIOHandlerOnDisconnect write FFreeIOHandlerOnDisconnect;
    property Socket: TIdIOHandlerSocket read FSocket;
  published
    property IOHandler: TIdIOHandler read FIOHandler write SetIOHandler;
    // Events
    property OnDisconnected: TNotifyEvent read FOnDisconnected write FOnDisconnected;
    property OnWork;
    property OnWorkBegin;
    property OnWorkEnd;
  end;


implementation

uses
  IdAntiFreezeBase, IdCoreResourceStrings, IdStackConsts, IdReplyRFC,
  SysUtils;

function TIdTCPConnection.GetReplyClass:TIdReplyClass;
begin
  result := TIdReplyRFC;
end;

procedure TIdTCPConnection.CreateIOHandler(ABaseType:TIdIOHandlerClass=nil);
begin
  if Connected then
    raise EIdException.create(RSIOHandlerCannotChange);
  if Assigned(IOHandler) then begin
    if FFreeIOHandlerOnDisconnect then begin
      IOHandler.free;
      FFreeIOHandlerOnDisconnect:=false;
    end;
  end;
  if Assigned(ABaseType) then begin
    IOHandler := TIdIOHandler.MakeIOHandler(ABaseType);
  end else begin
    IOHandler := TIdIOHandler.MakeDefaultIOHandler;
  end;
  FFreeIOHandlerOnDisconnect:=true;
end;

function TIdTCPConnection.Connected: Boolean;
begin
  Result := IOHandler <> nil;
  if Result then begin
    Result := IOHandler.Connected;
  end;
end;

constructor TIdTCPConnection.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FReplyClass := GetReplyClass;
  FGreeting := FReplyClass.Create(nil, nil);
  FLastCmdResult := FReplyClass.Create(nil, nil);
end;

destructor TIdTCPConnection.Destroy;
begin
  // DisconnectSocket closes IOHandler etc. Dont call Disconnect - Disconnect may be override and
  // try to read/write to the socket.
  if Assigned(IOHandler) then begin
    IOHandler.Close;
  end;

  // Because DisconnectSocket does not free the IOHandler we have to do it here.
  if FFreeIOHandlerOnDisconnect then begin
    FreeAndNil(FIOHandler);
    FFreeIOHandlerOnDisconnect := False;
  end;

  FreeAndNil(FLastCmdResult);
  FreeAndNil(FGreeting);
  inherited Destroy;
end;

procedure TIdTCPConnection.Disconnect;
var
  LConnected: boolean;
begin
  {
   there are a few possible situations here:
   1) we are still connected, then everything works as before,
      status disconnecting, then disconnect, status disconnected
   2) we are not connected, and this is just some "rogue" call to
      disconnect(), then nothing happens
   3) we are not connected, because ClosedGracefully, then
      LConnected will be false, but the implicit call to
      CheckForDisconnect (inside Connected) will call the events
  }
  LConnected := Connected;
  if LConnected then begin
    DoStatus(hsDisconnecting);
    IOHandler.Close;
  end;
  if FFreeIOHandlerOnDisconnect then begin
    FreeAndNil(FIOHandler);
    FFreeIOHandlerOnDisconnect := False;
  end;
  if LConnected then begin
    DoOnDisconnected;
    DoStatus(hsDisconnected);
  end;
end;

procedure TIdTCPConnection.DoOnDisconnected;
begin
  if Assigned(OnDisconnected) then begin
    OnDisconnected(Self);
  end;
end;

function TIdTCPConnection.GetResponse(
 const AAllowedResponses: array of SmallInt): SmallInt;
begin
  GetInternalResponse;
  Result := CheckResponse(LastCmdResult.NumericCode, AAllowedResponses);
end;

procedure TIdTCPConnection.RaiseExceptionForLastCmdResult(
 AException: TClassIdException);
begin
  raise AException.Create(LastCmdResult.Text.Text);
end;

procedure TIdTCPConnection.RaiseExceptionForLastCmdResult;
begin
  LastCmdResult.RaiseReplyError;
end;

function TIdTCPConnection.SendCmd(AOut: string;
 const AResponse: Array of SmallInt): SmallInt;
begin
  IOHandler.WriteLn(AOut);
  Result := GetResponse(AResponse);
end;

procedure TIdTCPConnection.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, OPeration);

  if (Operation = opRemove) then begin
    if (AComponent = FIOHandler) then begin
      FIOHandler := nil;
    end;
  end;
end;

procedure TIdTCPConnection.SetIOHandler(AValue: TIdIOHandler);
begin
  if Assigned(FIOHandler) and FFreeIOHandlerOnDisconnect then begin
    FreeAndNil(FIOHandler); // Clear the existing IOHandler
    FFreeIOHandlerOnDisconnect := False;
  end;
  // Clear out old values whether setting AValue to nil, or setting a new value
  if FIOHandler <> nil then begin
    FIOHandler.OnWork := nil;
    FIOHandler.OnWorkBegin := nil;
    FIOHandler.OnWorkEnd := nil;
  end;
  if AValue = nil then begin
    FSocket := nil;
  end else begin
    // Must set to handlers and not events directly as user may change
    // the events of TCPConnection after we have initialized these and then
    // these would point to old values
    AValue.OnWork := WorkEvent;
    AValue.OnWorkBegin := WorkBeginEvent;
    AValue.OnWorkEnd := WorkEndEvent;
    if AValue is TIdIOHandlerSocket then begin
      FSocket := TIdIOHandlerSocket(AValue);
    end;
  end;
  // add self to the IOHandler's free notification list
  if Assigned(AValue) then begin
    AValue.FreeNotification(Self);
  end;
  // Last as some code uses FIOHandler to finalize items
  FIOHandler := AValue;
end;

procedure TIdTCPConnection.WriteHeader(AHeader: TStrings);
var
  i: Integer;
begin
  for i := 0 to AHeader.Count -1 do begin
    // No ReplaceAll flag - we only want to replace the first one
    IOHandler.WriteLn(StringReplace(AHeader[i], '=', ': ', []));
  end;
  IOHandler.WriteLn;
end;

function TIdTCPConnection.SendCmd(AOut: string; AResponse: SmallInt)
 : SmallInt;
begin
  if AResponse = -1 then begin
    Result := SendCmd(AOut, []);
  end else begin
    Result := SendCmd(AOut, [AResponse]);
  end;
end;

procedure TIdTCPConnection.CheckForGracefulDisconnect(
 ARaiseExceptionIfDisconnected: Boolean);
begin
  if Assigned(IOHandler) then begin
    IOHandler.CheckForDisconnect(ARaiseExceptionIfDisconnected);
  end else if ARaiseExceptionIfDisconnected then begin
    raise EIdException.Create(RSNotConnected);
  end;
end;

function TIdTCPConnection.CheckResponse(AResponse: SmallInt;
 const AAllowedResponses: array of SmallInt): SmallInt;
var
  i: Integer;
  LResponseFound: Boolean;
begin
  if High(AAllowedResponses) > -1 then begin
    LResponseFound := False;
    for i := Low(AAllowedResponses) to High(AAllowedResponses) do begin
      if AResponse = AAllowedResponses[i] then begin
        LResponseFound := True;
        Break;
      end;
    end;
    if not LResponseFound then begin
      RaiseExceptionForLastCmdResult;
    end;
  end;
  Result := AResponse;
end;

procedure TIdTCPConnection.GetInternalResponse;
var
  LLine: string;
  LResponse: TStringList;
begin
  LResponse := TStringList.Create; try
    // Some servers with bugs send blank lines before reply. Dont remember which
    // ones, but I do remember we changed this for a reason
    LLine := IOHandler.ReadLnWait;
    LResponse.Add(LLine);
    while not FLastCmdResult.IsEndMarker(LLine) do begin
      LLine := IOHandler.ReadLn;
      LResponse.Add(LLine);
    end;
    //Note that FormattedReply uses an assign in it's property set method.
    FLastCmdResult.FormattedReply := LResponse;
  finally FreeAndNil(LResponse); end;
end;

procedure TIdTCPConnection.WriteRFCStrings(AStrings: TStrings);
var
  i: Integer;
begin
  for i := 0 to AStrings.Count - 1 do begin
    if AStrings[i] = '.' then begin
      IOHandler.WriteLn('..');
    end else begin
      IOHandler.WriteLn(AStrings[i]);
    end;
  end;
  IOHandler.WriteLn('.');
end;

function TIdTCPConnection.GetResponse(AAllowedResponse: SmallInt): SmallInt;
begin
  Result := GetResponse([AAllowedResponse]);
end;

function TIdTCPConnection.GetResponse(AAllowedResponse: string): string;
begin
  GetInternalResponse;
  Result := CheckResponse(LastCmdResult.Code, AAllowedResponse);
end;

function TIdTCPConnection.SendCmd(AOut, AResponse: string): string;
begin
  IOHandler.WriteLn(AOut);
  Result := GetResponse(AResponse);
end;

function TIdTCPConnection.CheckResponse(AResponse
 , AAllowedResponse: string): string;
begin
  if (AAllowedResponse <> '') and (AnsiSameText(AResponse, AAllowedResponse)=False)
   then begin
    RaiseExceptionForLastCmdResult;
  end;
  Result := AResponse;
end;

procedure TIdTCPConnection.WorkBeginEvent(ASender: TObject;
  AWorkMode: TWorkMode; AWorkCountMax: Integer);
begin
  BeginWork(AWorkMode, AWorkCountMax)
end;

procedure TIdTCPConnection.WorkEndEvent(ASender: TObject;
  AWorkMode: TWorkMode);
begin
  EndWork(AWorkMode)
end;

procedure TIdTCPConnection.WorkEvent(ASender: TObject;
  AWorkMode: TWorkMode; AWorkCount: Integer);
begin
  DoWork(AWorkMode, AWorkCount)
end;

end.
