//*******************************************************
//
// Copyright © 1995-2002 by Lucian Radulescu
// mailto : lucian@ez-delphi.com
// http : http://www.ez-delphi.com
//
// TStringList
// +--TFreeableObjStrings
// +-- TCommonTextProcessor
// +-- TDictionaryStrings
//
// TFreeableObjStrings handles internally freeing of objects, it overrides
// Destroy, Clear and Delete. It is though user's responsibility to set the
// flag FHasObjects to the right type of data: toNone, toPtr, toObject.
//
// TDictionaryStrings overrides Create and sets Sorted to true
// and Duplicates to dupIgnore. Unlike TStringList, TDictionaryStrings takes
// advantage of the sorted property when using Values and Names.
//******************************************************************************
unit Dict;
interface
{$WARNINGS OFF}
uses
SysUtils, Classes;
type
THasObjects = ( toNone, toPtr, toObject );
// TFreeableObjStrings
TFreeableObjStrings = class( TStringList )
private
FHasObjects : THasObjects; // it is user responsiblity to set this property !!!
procedure FreeAllObjects;
procedure SetHasObjects( Value: THasObjects );
protected
procedure FreeObject( Index: Integer ); virtual;
public
constructor Create; virtual;
destructor Destroy; override;
procedure Clear; override;
procedure Delete( Index: Integer ); override;
property HasObjects: THasObjects read FHasObjects write SetHasObjects;
end;
// TCommonTextProcessor
TCommonTextProcessor = Class( TFreeableObjStrings )
protected
Cur : PChar;
Last : PChar;
EOT : Boolean;
function GetNextLine( var Okay: Boolean ): String;
procedure Pop;
procedure Process( Line: String; Outlist: TStrings = nil ); virtual;
procedure SetTextStr( const Value: String ); override;
function LineStartTest( Ch: Char ): Boolean; virtual;
end;
// TDictionaryStrings
TDictionaryStrings = class( TCommonTextProcessor )
private
FNVDelimiter: Char;
function GetValue( const Name: string ): string;
procedure SetValue( const Name, Value: string );
protected
function CompareStrings( const S1, S2: string ): Integer; override;
property Sorted; // hide it, don't allow unsorted lists
public
constructor Create; override;
function HasName( const Name: String ): Integer;
function IndexOfName( const Name: String ): Integer; override;
property NVDelimiter: Char read FNVDelimiter write FNVDelimiter;
property Values[const Name: string]: string read GetValue write SetValue;
end;
implementation
uses
RTLConsts;
//TFreeableObjStrings ----------------------------------------------------------
procedure TFreeableObjStrings.FreeObject( Index: Integer );
begin
if Assigned( Objects[Index] ) then
begin
case FHasObjects of
toPtr : FreeMem( Pointer(Objects[Index]) );
toObject : Objects[Index].Free;
end;
Objects[Index] := nil;
end;
end;
constructor TFreeableObjStrings.Create;
begin
inherited Create;
FHasObjects := toNone;
end;
destructor TFreeableObjStrings.Destroy;
begin
FreeAllObjects;
inherited Destroy;
end;
procedure TFreeableObjStrings.Clear;
begin
FreeAllObjects;
inherited Clear;
end;
procedure TFreeableObjStrings.FreeAllObjects;
var
I: Integer;
begin
if ( Count > 0 ) and ( FHasObjects <> toNone ) then
for I := 0 to Count - 1 do
FreeObject( I );
end;
procedure TFreeableObjStrings.Delete( Index: Integer );
begin
if (Index < 0) or (Index >= Count) then Error(@SListIndexError, Index);
if FHasObjects <> toNone then
FreeObject( Index );
inherited Delete( Index );
end;
procedure TFreeableObjStrings.SetHasObjects( Value: THasObjects );
begin
if ( FHasObjects <> Value ) then
begin
if ( Value <> toNone ) and ( FHasObjects <> toNone ) then
raise EStringListError.Create( 'Previously FHasObjects is not <toNone>.' );
if Value = toNone then FreeAllObjects;
FHasObjects := Value;
end;
end;
// ***
// TCommonTextProcessor -----------------------------------------------------
function TCommonTextProcessor.LineStartTest( Ch: Char ): Boolean;
begin
Result := TRUE;
end;
function TCommonTextProcessor.GetNextLine( var Okay: Boolean ): String;
var
Start, Stop: PChar;
begin
Result := ''; // initialize empty string
Last := Cur; // save where we started
Start := Cur; // initialize our work ptr
while not (Cur^ in [#0,#10,#13]) // find EOL
do Inc( Cur );
while ( Start^ <> #0 ) and ( Start^ in [#9, #32] ) // skip initial spaces, tabs
do Inc( Start );
Okay := LineStartTest( Start^ );
if Okay then
begin
Stop := Cur-1; // go to EOL mark less one char
while ( Stop^ in [#9, #32] ) do // because we want to skip spaces, tabs
Dec( Stop );
SetString( Result, Start, Stop-Start+1 ); // RETRIEVE CURRENT LINE
end;
if Cur^ = #13 then Inc( Cur ); // skip <CR>
if Cur^ = #10 then Inc( Cur ); // skip <LF>
EOT := Cur^ = #0; // Flag if we reach End Of Text
end;
procedure TCommonTextProcessor.Pop;
begin
Cur := Last;
end;
procedure TCommonTextProcessor.Process( Line: String; Outlist: TStrings = nil );
begin
if Outlist <> nil then Outlist.Add( Line )
else Add( Line );
end;
procedure TCommonTextProcessor.SetTextStr( const Value: String );
var
Okay: Boolean;
str: String;
begin
Cur := Pointer( Value );
if Cur <> nil then
while Cur^ <> #0 do
begin
str := GetNextLine( Okay );
if Okay then
Process( str );
end;
end;
// ***
// TDictionaryStrings ----------------------------------------------------------
constructor TDictionaryStrings.Create;
begin
inherited Create;
FNVDelimiter := '=';
Sorted := TRUE;
Duplicates := dupIgnore;
end;
function TDictionaryStrings.CompareStrings(const S1, S2: string): Integer;
function GetName( const S: String ): String;
var
EqPos : integer;
begin
EqPos := AnsiPos('=', S);
if EqPos = 0 then Result:= S
else Result := Copy(S, 1, EqPos-1);
end;
begin
Result := CompareText( GetName(S1), GetName(S2) );
end;
function TDictionaryStrings.GetValue( const Name: string ): string;
var
P, I: Integer;
S: String;
begin
Result := ''; // assume we didn't find it
// Search Name.
// If we find it, it's a NO GO (it should be Name=Value, not just Name)
if Find( Name, I ) then Exit
else
// we didn't find it, I is the index where Name should be inserted
// and actually *IS* the index of our potential guess, so, test it
if I < Count then
begin
// here we go
S := Get( I ); // get the I'th item: Item or Item=Something or Name=Something
P := AnsiPos( FNVDelimiter, S ); // search for name-value delimiter
if (P <> 0) and (CompareStrings(Copy(S, 1, P-1), Name)=0) then
Result := Copy( S, P+1, MaxInt); // THIS IS IT !!! Get the Value
end;
end;
procedure TDictionaryStrings.SetValue( const Name, Value: string );
function Delete( Index: Integer ): Pointer;
begin
Result := Objects[Index];
inherited Delete( Index );
end;
var
I, P: Integer;
S: String;
O: Pointer;
begin
O := nil;
if Find( Name, I ) then O := Delete( I ) // when we find only "Name", delete it
else // if we don't find Name
if I < Count then // Name might be in the list
begin
S := Get( I ); // get the I'th item: Item or Item=Something or Name=Something
P := AnsiPos( FNVDelimiter, S ); // search for name-value delimiter
if (P <> 0) and (CompareStrings(Copy(S, 1, P-1), Name)=0) then
// here we go, the Item is Item=Something or Name=Something
O := Delete( I ); // it's our guy, delete old entry
end;
if Value <> '' then // now, if Value not empty insertitem a new item at I
InsertItem( I, Name + FNVDelimiter + Value, O );
end;
function TDictionaryStrings.HasName( const Name: String ): Integer;
var
P: Integer;
S: String;
begin
if Find( Name, Result ) then Exit // cool! we already found it
else
if Result < Count then // Name might be in the list
begin
S := Get( Result ); // get the I'th item: Item or Item=Something or Name=Something
P := AnsiPos( FNVDelimiter, S ); // search for name-value delimiter
if (P = 0) or (CompareStrings(Copy(S, 1, P-1), Name)<>0) then
Result := -1;
end
else Result := -1;
end;
function TDictionaryStrings.IndexOfName( const Name: String ): Integer;
var
P: Integer;
S: String;
begin
if Find( Name, Result ) then Result := -1 // not good when we find only "Name"
else
if Result < Count then // Name might be in the list
begin
S := Get( Result ); // get the I'th item: Item or Item=Something or Name=Something
P := AnsiPos( FNVDelimiter, S ); // search for name-value delimiter
if (P = 0) or (CompareStrings(Copy(S, 1, P-1), Name)<>0) then
Result := -1;
end
else Result := -1; // not good
end;
// ***
end.