www.pudn.com > Indy_9_00_14_src.zip > IdHeaderList.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: 10185: IdHeaderList.pas
{
{ Rev 1.1 2/25/2003 12:47:34 PM JPMugaas
{ Updated with Hadi's fix. If complete boolean evaluation was on, the code
{ could sometimes with an index out of range.
}
{
{ Rev 1.0 2002.11.12 10:40:38 PM czhower
}
unit IdHeaderList;
{
2002-Jan-27 Don Siders
- Modified FoldLine to include Comma in break character set.
2000-May-31 J. Peter Mugaas
- started this class to facilitate some work on Indy so we don't have to
convert '=' to ":" and vice-versa just to use the Values property.
}
{
NOTE: This is a modification of Borland's TStrings definition in a
TStringList descendant. I had to conceal the original Values to do
this since most of low level property setting routines aren't virtual
and are private.
}
interface
uses
Classes;
type
TIdHeaderList = class(TStringList)
protected
FNameValueSeparator : String;
FCaseSensitive : Boolean;
FUnfoldLines : Boolean;
FFoldLines : Boolean;
FFoldLinesLength : Integer;
//
{This deletes lines which were folded}
Procedure DeleteFoldedLines(Index : Integer);
{This folds one line into several lines}
function FoldLine(AString : string) : TStringList;
{Folds lines and inserts them into a position, Index}
procedure FoldAndInsert(AString : String; Index : Integer);
{Name property get method}
function GetName(Index: Integer): string;
{Value property get method}
function GetValue(const AName: string): string;
{Value property set method}
procedure SetValue(const Name, Value: string);
{Gets a value from a string}
function GetValueFromLine(ALine : Integer) : String;
Function GetNameFromLine(ALine : Integer) : String;
public
procedure AddStdValues(ASrc: TStrings);
procedure ConvertToStdValues(ADest: TStrings);
constructor Create;
{ This method given a name specified by AName extracts all of the values for that name - and puts them in a new string
list (just the values) one per line in the ADest TStrings.}
procedure Extract(const AName: string; ADest: TStrings);
{ This property works almost exactly as Borland's IndexOfName except it uses
our deliniator defined in NameValueSeparator }
function IndexOfName(const AName: string): Integer; reintroduce;
{ This property works almost exactly as Borland's Values except it uses
our deliniator defined in NameValueSeparator }
property Names[Index: Integer]: string read GetName;
{ This property works almost exactly as Borland's Values except it uses
our deliniator defined in NameValueSeparator }
property Values[const Name: string]: string read GetValue write SetValue;
{ This is the separator we need to separate the name from the value }
property NameValueSeparator : String read FNameValueSeparator
write FNameValueSeparator;
{ Should the names be tested in a case-senstive manner. }
property CaseSensitive : Boolean read FCaseSensitive write FCaseSensitive;
{ Should we unfold lines so that continuation header data is returned as
well}
property UnfoldLines : Boolean read FUnfoldLines write FUnfoldLines;
{ Should we fold lines we the Values(x) property is set with an
assignment }
property FoldLines : Boolean read FFoldLines write FFoldLines;
{ The Wrap position for our folded lines }
property FoldLength : Integer read FFoldLinesLength write FFoldLinesLength;
end;
implementation
uses
IdGlobal,
SysUtils;
{This is taken from Borland's SysUtils and modified for our folding} {Do not Localize}
function FoldWrapText(const Line, BreakStr: string; BreakChars: TSysCharSet;
MaxCol: Integer): string;
const
QuoteChars = ['"']; {Do not Localize}
var
Col, Pos: Integer;
LinePos, LineLen: Integer;
BreakLen, BreakPos: Integer;
QuoteChar, CurChar: Char;
ExistingBreak: Boolean;
begin
Col := 1;
Pos := 1;
LinePos := 1;
BreakPos := 0;
QuoteChar := ' '; {Do not Localize}
ExistingBreak := False;
LineLen := Length(Line);
BreakLen := Length(BreakStr);
Result := ''; {Do not Localize}
while Pos <= LineLen do
begin
CurChar := Line[Pos];
if CurChar in LeadBytes then
begin
Inc(Pos);
Inc(Col);
end //if CurChar in LeadBytes then
else
if CurChar = BreakStr[1] then
begin
if QuoteChar = ' ' then {Do not Localize}
begin
ExistingBreak := AnsiSameText(BreakStr, Copy(Line, Pos, BreakLen));
if ExistingBreak then
begin
Inc(Pos, BreakLen-1);
BreakPos := Pos;
end; //if ExistingBreak then
end // if QuoteChar = ' ' then {Do not Localize}
end // if CurChar = BreakStr[1] then
else
if CurChar in BreakChars then
begin
if QuoteChar = ' ' then {Do not Localize}
BreakPos := Pos
end // if CurChar in BreakChars then
else
if CurChar in QuoteChars then
if CurChar = QuoteChar then
QuoteChar := ' ' {Do not Localize}
else
if QuoteChar = ' ' then {Do not Localize}
QuoteChar := CurChar;
Inc(Pos);
Inc(Col);
if not (QuoteChar in QuoteChars) and (ExistingBreak or
((Col > MaxCol) and (BreakPos > LinePos))) then
begin
Col := Pos - BreakPos;
Result := Result + Copy(Line, LinePos, BreakPos - LinePos + 1);
if not (CurChar in QuoteChars) then
while (Pos <= LineLen) and (Line[Pos] in BreakChars + [#13, #10]) do Inc(Pos);
if not ExistingBreak and (Pos < LineLen) then
Result := Result + BreakStr;
Inc(BreakPos);
LinePos := BreakPos;
ExistingBreak := False;
end; //if not
end; //while Pos <= LineLen do
Result := Result + Copy(Line, LinePos, MaxInt);
end;
{ TIdHeaderList }
procedure TIdHeaderList.AddStdValues(ASrc: TStrings);
var
i: integer;
begin
for i := 0 to ASrc.Count - 1 do begin
Add(StringReplace(ASrc[i], '=', NameValueSeparator, [])); {Do not Localize}
end;
end;
procedure TIdHeaderList.ConvertToStdValues(ADest: TStrings);
var
i: integer;
begin
for i := 0 to Count - 1 do begin
ADest.Add(StringReplace(Strings[i], NameValueSeparator, '=', [])); {Do not Localize}
end;
end;
constructor TIdHeaderList.Create;
begin
inherited Create;
FNameValueSeparator := ': '; {Do not Localize}
FCaseSensitive := False;
FUnfoldLines := True;
FFoldLines := True;
{ 78 was specified by a message draft available at
http://www.imc.org/draft-ietf-drums-msg-fmt }
FFoldLinesLength := 78;
end;
procedure TIdHeaderList.DeleteFoldedLines(Index: Integer);
begin
Inc(Index); {skip the current line}
if Index < Count then begin
while ( Index < Count ) and ( ( Length( Get( Index ) ) > 0) and
( Get( Index ) [ 1 ] = ' ' ) or ( Get( Index ) [ 1 ] = #9 ) ) do {Do not Localize}
begin
Delete( Index );
end; //while
end;
end;
procedure TIdHeaderList.Extract(const AName: string; ADest: TStrings);
var idx : Integer;
begin
if not Assigned(ADest) then
Exit;
for idx := 0 to Count - 1 do
begin
if AnsiSameText(AName, GetNameFromLine(idx)) then
begin
ADest.Add(GetValueFromLine(idx));
end;
end;
end;
procedure TIdHeaderList.FoldAndInsert(AString : String; Index: Integer);
var strs : TStringList;
idx : Integer;
begin
strs := FoldLine( AString );
try
idx := strs.Count - 1;
Put(Index, strs [ idx ] );
{We decrement by one because we put the last string into the HeaderList}
Dec( idx );
while ( idx > -1 ) do
begin
Insert(Index, strs [ idx ] );
Dec( idx );
end;
finally
FreeAndNil( strs );
end; //finally
end;
function TIdHeaderList.FoldLine(AString : string): TStringList;
var s : String;
begin
Result := TStringList.Create;
try
{we specify a space so that starts a folded line}
s := FoldWrapText(AString, EOL+' ', LWS+[','], FFoldLinesLength); {Do not Localize}
while s <> '' do {Do not Localize}
begin
Result.Add( TrimRight( Fetch( s, EOL ) ) );
end; // while s <> '' do {Do not Localize}
finally
end; //try..finally
end;
function TIdHeaderList.GetName(Index: Integer): string;
var
P: Integer;
begin
Result := Get( Index );
P := IndyPos( FNameValueSeparator , Result );
if P <> 0 then
begin
SetLength( Result, P - 1 );
end // if P <> 0 then
else
begin
SetLength( Result, 0 );
end; // else if P <> 0 then
Result := Result;
end;
function TIdHeaderList.GetNameFromLine(ALine: Integer): String;
var p : Integer;
begin
Result := Get( ALine );
if not FCaseSensitive then
begin
Result := UpperCase( Result );
end; // if not FCaseSensitive then
{We trim right to remove space to accomodate header errors such as
Message-ID:= 0) and (ALine < Count) then begin
LName := GetNameFromLine(ALine);
Result := Copy(Get(ALine), Length(LName) + 2, MaxInt);
if FUnfoldLines then begin
while True do begin
Inc(ALine);
if ALine = Count then begin
Break;
end;
LFoldedLine := Get(ALine);
// s[1] is safe since header lines cannot be empty as that causes then end of the header block
if not (LFoldedLine[1] in LWS) then begin
Break;
end;
Result := Trim(Result) + ' ' + Trim(LFoldedLine); {Do not Localize}
end;
end;
end else begin
Result := ''; {Do not Localize}
end;
// User may be fetching an folded line diretly.
Result := Trim(Result);
end;
function TIdHeaderList.IndexOfName(const AName: string): Integer;
var
i: Integer;
begin
Result := -1;
for i := 0 to Count - 1 do begin
if AnsiSameText(GetNameFromLine(i), AName) then begin
Result := i;
Break;
end;
end;
end;
procedure TIdHeaderList.SetValue(const Name, Value: string);
var
I: Integer;
begin
I := IndexOfName(Name);
if Value <> '' then {Do not Localize}
begin
if I < 0 then
begin
I := Add( '' ); {Do not Localize}
end; //if I < 0 then
if FFoldLines then
begin
DeleteFoldedLines( I );
FoldAndInsert( Name + FNameValueSeparator + Value, I );
end
else
begin
Put( I, Name + FNameValueSeparator + Value );
end; //else..FFoldLines
end //if Value <> '' then {Do not Localize}
else
begin
if I >= 0 then
begin
if FFoldLines then
begin
DeleteFoldedLines( I );
end;
Delete( I );
end; //if I >= 0 then
end; //else .. if Value <> '' then {Do not Localize}
end;
end.