www.pudn.com > indy10.0.52_source.rar > IdTCPConnection.pas
//TODO: Elim read/write methods - they are duped
//TODO: See second uses comment
{ $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.63 10/26/2004 8:43:02 PM JPMugaas
{ Should be more portable with new references to TIdStrings and TIdStringList.
}
{
Rev 1.62 6/11/2004 8:48:36 AM DSiders
Added "Do not Localize" comments.
}
{
{ Rev 1.61 2004.06.07 1:34:20 PM czhower
{ OnWork fix now sends running total as it should.
}
{
{ Rev 1.60 2004.06.06 5:18:04 PM czhower
{ OnWork bug fix
}
{
{ Rev 1.59 2004.06.05 9:46:30 AM czhower
{ IOHandler OnWork fix
}
{
{ Rev 1.58 11/05/2004 17:13:32 HHariri
{ Fix brought from IW for overflow of DoWork
}
{
{ Rev 1.57 4/19/2004 9:50:08 AM BGooijen
{ Fixed AV in .Disconnect
}
{
{ Rev 1.56 2004.04.18 12:52:04 AM czhower
{ Big bug fix with server disconnect and several other bug fixed that I found
{ along the way.
}
{
{ Rev 1.55 2004.03.06 10:40:30 PM czhower
{ Changed IOHandler management to fix bug in server shutdowns.
}
{
{ Rev 1.54 2004.03.06 1:32:58 PM czhower
{ -Change to disconnect
{ -Addition of DisconnectNotifyPeer
{ -WriteHeader now write bufers
}
{
{ Rev 1.53 3/1/04 7:12:00 PM RLebeau
{ Bug fix for SetIOHandler() not updating the FSocket member correctly.
}
{
{ Rev 1.52 2004.02.03 4:16:56 PM czhower
{ For unit name changes.
}
{
{ Rev 1.51 1/29/04 9:37:18 PM RLebeau
{ Added setter method for Greeting property
}
{
{ Rev 1.50 2004.01.28 9:42:32 PM czhower
{ Now checks for connection.
}
{
{ Rev 1.49 2004.01.20 10:03:36 PM czhower
{ InitComponent
}
{
{ Rev 1.48 2003.12.31 3:47:44 PM czhower
{ Changed to use TextIsSame
}
{
{ Rev 1.47 12/28/2003 4:47:40 PM BGooijen
{ Removed ChangeReplyClass
}
{
{ Rev 1.46 14/12/2003 18:14:54 CCostelloe
{ Added ChangeReplyClass procedure.
}
{
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
{
2003-12-14 - Ciaran Costelloe
- Added procedure ChangeReplyClass, because in .NET, you cannot set FReplyClass
before calling the constructor, so call this procedure after the constructor
to set FReplyClass to (say) TIdReplyIMAP4.
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,
IdExceptionCore, IdException, IdComponent, IdGlobal, IdSocketHandle, IdIOHandler, IdReply,
IdIOHandlerSocket, IdIOHandlerStack, IdTStrings;
type
TIdTCPConnection = class(TIdComponent)
protected
FGreeting: TIdReply;
FIOHandler: TIdIOHandler;
FLastCmdResult: TIdReply;
FManagedIOHandler: Boolean;
FOnDisconnected: TNotifyEvent;
FSocket: TIdIOHandlerSocket;
FReplyClass: TIdReplyClass;
//
procedure CheckConnected;
procedure DoOnDisconnected; virtual;
procedure InitComponent; override;
function GetReplyClass:TIdReplyClass; virtual;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure SetIOHandler(AValue: TIdIOHandler); virtual;
procedure SetGreeting(AValue: TIdReply);
procedure WorkBeginEvent(ASender: TObject; AWorkMode: TWorkMode;
AWorkCountMax: Integer);
procedure WorkEndEvent(ASender: TObject; AWorkMode: TWorkMode);
procedure WorkEvent(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Integer);
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;
destructor Destroy; override;
// Dont allow override of this one, its for overload only
procedure Disconnect; overload; // .Net overload
procedure Disconnect(ANotifyPeer: Boolean); overload; virtual;
// This is called when a protocol sends a command to tell the other side (typically client to
// server) that it is about to disconnect. The implementation should go here.
procedure DisconnectNotifyPeer; 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 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.