www.pudn.com > indyprelim.zip > IdReplyRFC.pas
{
$Project$
$Workfile$
$Revision$
$DateUTC$
$Id$
This file is part of the Indy (Internet Direct) project, and is offered
under the dual-licensing agreement described on the Indy website.
(http://www.indyproject.org/)
Copyright:
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
}
{
$Log$
}
{
Rev 1.29 1/15/05 2:28:28 PM RLebeau
Added local variables to TIdReplyRFC.GetFormattedReply() to reduce the number
of repeated string operations that were being performed.
Updated TIdRepliesRFC.UpdateText() to ignore the TIdReply that was passed in
when looking for a TIdReply to extract Text from.
Rev 1.28 10/26/2004 8:43:00 PM JPMugaas
Should be more portable with new references to TIdStrings and TIdStringList.
Rev 1.27 6/11/2004 8:48:28 AM DSiders
Added "Do not Localize" comments.
Rev 1.26 18/05/2004 23:17:18 CCostelloe
Bug fix
Rev 1.25 5/18/04 2:39:02 PM RLebeau
Added second constructor to TIdRepliesRFC
Rev 1.24 5/17/04 9:50:08 AM RLebeau
Changed TIdRepliesRFC constructor to use 'reintroduce' instead
Rev 1.23 5/16/04 5:12:04 PM RLebeau
Added construvtor to TIdRepliesRFC class
Rev 1.22 2004.03.01 5:12:36 PM czhower
-Bug fix for shutdown of servers when connections still existed (AV)
-Implicit HELP support in CMDserver
-Several command handler bugs
-Additional command handler functionality.
Rev 1.21 2004.02.29 8:17:20 PM czhower
Minor cosmetic changes to code.
Rev 1.20 2004.02.03 4:16:50 PM czhower
For unit name changes.
Rev 1.19 1/3/2004 8:06:18 PM JPMugaas
Bug fix: Sometimes, replies will appear twice due to the way functionality
was enherited.
Rev 1.18 2003.10.18 9:33:28 PM czhower
Boatload of bug fixes to command handlers.
Rev 1.17 9/20/2003 10:01:04 AM JPMugaas
Minor change. WIll now accept all 3 digit numbers (not just ones below 600).
The reason is that developers may want something in 600-999 range. RFC 2228
defines a 6xx reply range for protected replies.
Rev 1.16 2003.09.20 10:33:14 AM czhower
Bug fix to allow clearing code field (Return to default value)
Rev 1.15 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.14 6/3/2003 04:09:30 PM JPMugaas
class function TIdReplyRFC.IsEndMarker(const ALine: string): Boolean had the
wrong parameters causing FTP to freeze. It probably effected other stuff.
Rev 1.13 5/30/2003 8:37:42 PM BGooijen
Changed virtual to override
Rev 1.12 2003.05.30 10:25:58 PM czhower
Implemented IsEndMarker
Rev 1.11 2003.05.30 10:06:08 PM czhower
Changed code property mechanisms.
Rev 1.10 2003.05.26 10:48:12 PM czhower
1) Removed deprecated code.
2) Removed POP3 bastardizations as they are now in IdReplyPOP3.
Rev 1.9 5/26/2003 12:19:52 PM JPMugaas
Rev 1.8 2003.05.26 11:38:20 AM czhower
Rev 1.7 5/25/2003 03:16:54 AM JPMugaas
Rev 1.6 2003.05.25 10:23:46 AM czhower
Rev 1.5 5/21/2003 08:43:38 PM JPMugaas
Overridable hook for the SMTP Reply object.
Rev 1.4 5/20/2003 12:43:48 AM BGooijen
changeable reply types
Rev 1.3 5/19/2003 12:26:50 PM JPMugaas
Now uses base class.
Rev 1.2 11/05/2003 23:29:04 CCostelloe
IMAP-specific code moved up to TIdIMAP4.pas
Rev 1.1 11/14/2002 02:51:54 PM JPMugaas
Added FormatType property. If it is rfIndentMidLines, it will accept
properly parse reply lines that begin with a space. Setting this to
rfIndentMidLines will also cause the reply object to generate lines that
start with a space if the Text.Line starts with a space. This should
accommodate the FTP MLSD and FEAT commands on both the client and server.
Rev 1.0 11/13/2002 08:45:50 AM JPMugaas
}
unit IdReplyRFC;
interface
{$I IdCompilerDefines.inc}
//we need to put this in Delphi mode to work
uses
IdReply,
IdSys,
IdObjs;
type
TIdReplyRFC = class(TIdReply)
protected
procedure AssignTo(ADest: TIdPersistent); override;
function CheckIfCodeIsValid(const ACode: string): Boolean; override;
function GetFormattedReply: TIdStrings; override;
procedure SetFormattedReply(const AValue: TIdStrings); override;
public
class function IsEndMarker(const ALine: string): Boolean; override;
procedure RaiseReplyError; override;
function ReplyExists: Boolean; override;
end;
TIdRepliesRFC = class(TIdReplies)
public
constructor Create(AOwner: TIdPersistent); reintroduce; overload; virtual;
constructor Create(AOwner: TIdPersistent; const AReplyClass: TIdReplyClass); overload; override;
procedure UpdateText(AReply: TIdReply); override;
end;
// This exception is for protocol errors such as 404 HTTP error and also
// SendCmd / GetResponse
EIdReplyRFCError = class(EIdReplyError)
protected
FErrorCode: Integer;
public
// Params must be in this order to avoid conflict with CreateHelp
// constructor in CBuilder as CB does not differentiate constructors
// by name as Delphi does
constructor CreateError(const AErrorCode: Integer;
const AReplyMessage: string); reintroduce; virtual;
//
property ErrorCode: Integer read FErrorCode;
end;
implementation
uses
IdGlobal;
{ TIdReplyRFC }
procedure TIdReplyRFC.AssignTo(ADest: TIdPersistent);
var
LR: TIdReplyRFC;
begin
if ADest is TIdReplyRFC then begin
LR := TIdReplyRFC(ADest);
LR.NumericCode := NumericCode;
LR.Text.Assign(Text);
end else begin
inherited AssignTo(ADest);
end;
end;
function TIdReplyRFC.CheckIfCodeIsValid(const ACode: string): Boolean;
var
LCode: Integer;
begin
LCode := Sys.StrToInt(ACode, 0);
{Replaced 600 with 999 because some developers may want 6xx, 7xx, and 8xx reply
codes for their protocols. It also turns out that RFC 2228 defines 6xx reply codes.
From RFC 2228
A new class of reply types (6yz) is also introduced for protected
replies.
}
Result := ((LCode >= 100) and (LCode < 1000)) or (Sys.Trim(ACode) = '');
end;
function TIdReplyRFC.GetFormattedReply: TIdStrings;
var
I, LCode: Integer;
LCodeStr: String;
begin
Result := GetFormattedReplyStrings;
LCode := NumericCode;
if LCode > 0 then begin
LCodeStr := Sys.IntToStr(LCode);
if Text.Count > 0 then begin
for I := 0 to Text.Count - 1 do begin
if I < Text.Count - 1 then begin
Result.Add(LCodeStr + '-' + Text[I]);
end else begin
Result.Add(LCodeStr + ' ' + Text[I]);
end;
end;
end else begin
Result.Add(LCodeStr);
end;
end else if FText.Count > 0 then begin
Result.AddStrings(FText);
end;
end;
class function TIdReplyRFC.IsEndMarker(const ALine: string): Boolean;
begin
// Use copy not ALine[4] as it might not be long enough for that reference
// to be valid
Result := (Length(ALine) < 4) or (Copy(ALine, 4, 1) = ' ');
end;
procedure TIdReplyRFC.RaiseReplyError;
begin
raise EIdReplyRFCError.CreateError(NumericCode, Text.Text);
end;
function TIdReplyRFC.ReplyExists: Boolean;
begin
Result := (NumericCode > 0) or (FText.Count > 0);
end;
procedure TIdReplyRFC.SetFormattedReply(const AValue: TIdStrings);
// Just parse and put in items, no need to store after parse
var
i: Integer;
s: string;
begin
Clear;
if AValue.Count > 0 then begin
s := Sys.Trim(Copy(AValue[0], 1, 3));
Code := s;
for i := 0 to AValue.Count - 1 do begin
Text.Add(Copy(AValue[i], 5, MaxInt));
end;
end;
end;
{ EIdReplyRFCError }
constructor EIdReplyRFCError.CreateError(const AErrorCode: Integer;
const AReplyMessage: string);
begin
inherited Create(AReplyMessage);
FErrorCode := AErrorCode;
end;
{ TIdReplies }
constructor TIdRepliesRFC.Create(AOwner: TIdPersistent);
begin
inherited Create(AOwner, TIdReplyRFC);
end;
constructor TIdRepliesRFC.Create(AOwner: TIdPersistent; const AReplyClass: TIdReplyClass);
begin
inherited Create(AOwner, AReplyClass);
end;
procedure TIdRepliesRFC.UpdateText(AReply: TIdReply);
var
LGenericNumCode: Integer;
LReply: TIdReply;
begin
inherited UpdateText(AReply);
// If text is still blank after inherited see if we can find a generic version
if AReply.Text.Count = 0 then begin
LGenericNumCode := (AReply.NumericCode div 100) * 100;
// RLebeau - in cases where the AReply.Code is the same as the
// generic code, ignore the AReply as it doesn't have any text
// to assign, or else the code wouldn't be this far
LReply := Find(Sys.IntToStr(LGenericNumCode), AReply);
if LReply = nil then begin
// If no generic was found, then use defaults.
case LGenericNumCode of
100: AReply.Text.Text := 'Information'; {do not localize}
200: AReply.Text.Text := 'Ok'; {do not localize}
300: AReply.Text.Text := 'Temporary Error'; {do not localize}
400: AReply.Text.Text := 'Permanent Error'; {do not localize}
500: AReply.Text.Text := 'Unknown Internal Error'; {do not localize}
end;
end else begin
AReply.Text.Assign(LReply.Text);
end;
end;
end;
end.