www.pudn.com > indy10.0.52_source.rar > IdReplyRFC.pas
{ $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: 11962: IdReplyRFC.pas
{
{ 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
uses
Classes,
IdReply,
IdTStrings;
type
TIdReplyRFC = class(TIdReply)
protected
procedure AssignTo(ADest: TPersistent); 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: TPersistent); reintroduce; overload; virtual;
constructor Create(AOwner: TPersistent; 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,
SysUtils;
{ TIdReplyRFC }
procedure TIdReplyRFC.AssignTo(ADest: TPersistent);
var
LR: TIdReplyRFC;
begin
if ADest is TIdReplyRFC then begin
LR := TIdReplyRFC(ADest);
LR.NumericCode := NumericCode;
LR.FText.Assign(Text);
end else begin
inherited;
end;
end;
function TIdReplyRFC.CheckIfCodeIsValid(const ACode: string): Boolean;
var
LCode: Integer;
begin
LCode := StrToIntDef(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 (Trim(ACode) = '');
end;
function TIdReplyRFC.GetFormattedReply: TIdStrings;
var
i: Integer;
begin
Result := GetFormattedReplyStrings;
if NumericCode > 0 then begin
if Text.Count > 0 then begin
for i := 0 to Text.Count - 1 do begin
if i < Text.Count - 1 then begin
Result.Add(IntToStr(NumericCode) + '-' + Text[i]);
end else begin
Result.Add(IntToStr(NumericCode) + ' ' + Text[i]);
end;
end;
end else begin
Result.Add(IntToStr(NumericCode));
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 := 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: TPersistent);
begin
inherited Create(AOwner, TIdReplyRFC);
end;
constructor TIdRepliesRFC.Create(AOwner: TPersistent; const AReplyClass: TIdReplyClass);
begin
inherited Create(AOwner, AReplyClass);
end;
procedure TIdRepliesRFC.UpdateText(AReply: TIdReply);
var
LGenericNumCode: Integer;
LReply: TIdReply;
begin
inherited;
// 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;
LReply := Find(IntToStr(LGenericNumCode));
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.