idtcpconnection.pas

photo.163.com 相册下载器 多线程下载

    // 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 SetGreeting;
    // 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: TIdStrings);
    procedure WriteRFCStrings(AStrings: TIdStrings);
    //
    property LastCmdResult: TIdReply read FLastCmdResult;
    property ManagedIOHandler: Boolean read FManagedIOHandler write FManagedIOHandler;
    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, IdResourceStringsCore, IdStackConsts, IdReplyRFC,
  SysUtils;

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

procedure TIdTCPConnection.CreateIOHandler(ABaseType:TIdIOHandlerClass=nil);
begin
  EIdException.IfTrue(Connected, RSIOHandlerCannotChange);
  if Assigned(ABaseType) then begin
    IOHandler := TIdIOHandler.MakeIOHandler(ABaseType);
  end else begin
    IOHandler := TIdIOHandler.MakeDefaultIOHandler;
  end;
  ManagedIOHandler := True;
end;

function TIdTCPConnection.Connected: Boolean;
begin
  // Its been changed now that IOHandler is not usually nil, but can be before the initial connect
  // and also this keeps it here so the user does not have to access the IOHandler for this and
  // also to allow future control from the connection.
  Result := IOHandler <> nil;
  if Result then begin
    Result := IOHandler.Connected;
  end;
end;

destructor TIdTCPConnection.Destroy;
begin
  // Just close IOHandler directly. Dont call Disconnect - Disconnect may be override and
  // try to read/write to the socket.
  if Assigned(IOHandler) then begin
    IOHandler.Close;
    // This will free any managed IOHandlers
    IOHandler := nil;
  end;
  FreeAndNil(FLastCmdResult);
  FreeAndNil(FGreeting);
  inherited Destroy;
end;

procedure TIdTCPConnection.Disconnect(ANotifyPeer: Boolean);
begin
  try
    // Separately to avoid calling .Connected unless needed
    if ANotifyPeer then begin
      if Connected then begin
        DisconnectNotifyPeer;
      end;
    end;
  finally
    {
     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
    }
    // We dont check connected here - we realy dont care about actual socket state
    // Here we just want to close the actual IOHandler. It is very possible for a
    // socket to be disconnected but the IOHandler still open. In this case we only
    // care of the IOHandler is still open.
    //
    // This is especially important if the socket has been disconnected with error, at this
    // point we just want to ignore it and checking .Connected would trigger this. We
    // just want to close. For some reason NS 7.1 (And only 7.1, not 7.0 or Mozilla) cause
    // CONNABORTED. So its extra important we just disconnect without checking socket state.
    if Assigned(IOHandler) then begin
      if IOHandler.Opened then begin
        DoStatus(hsDisconnecting);
        IOHandler.Close;
        DoOnDisconnected;
        DoStatus(hsDisconnected);
      end;
    end;
  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
  CheckConnected;
  IOHandler.WriteLn(AOut);
  Result := GetResponse(AResponse);
end;

procedure TIdTCPConnection.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if Operation = opRemove then begin
    if AComponent = FIOHandler then begin
      FIOHandler := nil;
    end;
  end;
end;

procedure TIdTCPConnection.SetIOHandler(AValue: TIdIOHandler);
begin
  if AValue <> IOHandler then begin
    if ManagedIOHandler and Assigned(IOHandler) then begin
      FreeAndNil(FIOHandler);
    end;
    // Reset this if nil (to match nil, but not needed) or when a new IOHandler is specified
    // If true, code must set it after the IOHandler is set
    // Must do after call to FreeManagedIOHandler
    ManagedIOHandler := False;
    // Clear out old values whether setting AValue to nil, or setting a new value
    if FIOHandler <> nil then begin
      FIOHandler.WorkTarget := nil;
    end;
    if AValue <> nil then 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.WorkTarget := Self;
    end;
    if (AValue <> nil) and (AValue is TIdIOHandlerSocket) then begin
      FSocket := TIdIOHandlerSocket(AValue);
    end else begin
      FSocket := nil;
    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;
end;

procedure TIdTCPConnection.WriteHeader(AHeader: TIdStrings);
var
  i: Integer;
begin
  CheckConnected;
  with IOHandler do begin
    WriteBufferOpen; try
      for i := 0 to AHeader.Count -1 do begin
        // No ReplaceAll flag - we only want to replace the first one
        WriteLn(StringReplace(AHeader[i], '=', ': ', []));
      end;
      WriteLn;
    finally WriteBufferClose; end;
  end;
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: TIdStringList;
begin
  CheckConnected;
  LResponse := TIdStringList.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: TIdStrings);
var
  i: Integer;
begin
  CheckConnected;
  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
  CheckConnected;
  IOHandler.WriteLn(AOut);
  Result := GetResponse(AResponse);
end;

function TIdTCPConnection.CheckResponse(AResponse
 , AAllowedResponse: string): string;
begin
  if (AAllowedResponse <> '')
   and (TextIsSame(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;

procedure TIdTCPConnection.InitComponent;
begin
  inherited;
  FReplyClass := GetReplyClass;
  FGreeting := FReplyClass.Create(nil, nil);
  FLastCmdResult := FReplyClass.Create(nil, nil);
end;

procedure TIdTCPConnection.CheckConnected;
begin
  EIdNotConnected.IfNotAssigned(IOHandler, 'Not connected.'); {do not localize}
end;

procedure TIdTCPConnection.SetGreeting(AValue: TIdReply);
begin
  FGreeting.Assign(AValue);
end;

procedure TIdTCPConnection.Disconnect;
begin
  // The default should be to tell the other side we are disconnecting
  Disconnect(True);
end;

procedure TIdTCPConnection.DisconnectNotifyPeer;
begin
end;

end.