hk_strings.pas

A generic widestring list for use in all versions of Delphi. It has all the capabilities you find in

unit HK_Strings;

interface

uses Windows,SysUtils,Classes;

type THK_Chars = array[0..MAXWORD] of WideChar;
     PHKChars = ^THK_Chars;

type THK_Strings = class(TPersistent)
private
  FStrings:TList;
  FPointers:TList;
  FSorted:Boolean;
  function GetPointers(Index:Integer):Pointer;
  function GetStringCount:Integer;
  function GetStrings(Index:Integer):WideString;
  function GetText:WideString;
  procedure SetPointers(Index:Integer;Value:Pointer);
  procedure SetStrings(Index:Integer;Value:WideString);
  procedure SetText(Value:WideString);

  function Equals(AStrings:THK_Strings):Boolean;
  procedure ReadData(Reader:TReader);
  procedure WriteData(Writer:TWriter);
protected
  procedure DefineProperties(Filer:TFiler);override;
public
  property Sorted:Boolean read FSorted write FSorted;
  property StringCount:Integer read GetStringCount;
  property Strings[Index:Integer]:WideString read GetStrings write SetStrings;default;
  property Pointers[Index:Integer]:Pointer read GetPointers write SetPointers;
  property Text:WideString read GetText write SetText;

  constructor Create;
  destructor Destroy;override;

  function Add(const Value:WideString):Integer;
  function AddPointer(const Value:WideString;P:Pointer):Integer;
  procedure ClearEx;
  function IndexOf(const Value:WideString):Integer;
  procedure Remove(Index:Integer);
  procedure Sort;
end;

implementation

const SD_LC = #$E000;

constructor THK_Strings.Create;
begin
  inherited Create;
  FStrings:=TList.Create;
  FPointers:=TList.Create;
end;

destructor THK_Strings.Destroy;
begin
  ClearEx;
  FStrings.Free;
  FPointers.Free;
  inherited;
end;
//----------------------------
function THK_Strings.Equals(AStrings:THK_Strings):Boolean;
var AText,BText:WideString;
begin
  AText:=AStrings.Text;
  BText:=Text;
  Result:=(AStrings.StringCount = FStrings.Count) and
          (WideCompareStr(AText,BText) = 0);
end;

procedure THK_Strings.ReadData(Reader:TReader);
var ASorted:Boolean;
begin
  Reader.ReadListBegin;
  ClearEx;
  ASorted:=FSorted;
  FSorted:=False;
  try
    while not Reader.EndOfList do AddPointer(UTF8DeCode(Reader.ReadString),nil);
  finally FSorted:=ASorted end;
  Reader.ReadListEnd;
end;

procedure THK_Strings.WriteData(Writer:TWriter);
var i:Integer;
begin
  Writer.WriteListBegin;
  for i:=0 to StringCount - 1 do Writer.WriteString(UTF8EnCode(Strings[i]));
  Writer.WriteListEnd;
end;

procedure THK_Strings.DefineProperties(Filer:TFiler);

  function DoWrite:Boolean;
  begin
    case (Filer.Ancestor <> nil) of
      False:Result:=(StringCount > 0);
       True: Result:=not(Filer.Ancestor is THK_Strings) or
                     not(Equals(THK_Strings(Filer.Ancestor)));
    end;
  end;

begin
  Filer.DefineProperty('Strings',ReadData,WriteData,DoWrite);
end;
//..............................................................................
function THK_Strings.Add(const Value:WideString):Integer;
begin
  Result:=AddPointer(Value,nil);
end;

function THK_Strings.AddPointer(const Value:WideString;P:Pointer):Integer;
var i,j:Integer;
    PWC:PHKChars;
begin
  i:=Length(Value) + 1;j:=i shl 1;
  PWC:=AllocMem(j);
  if (i > 1) then Move(Value[1],PWC^,j);
  Result:=FStrings.Add(PWC);
  FPointers.Add(P);
  if FSorted then Sort;
end;

procedure THK_Strings.ClearEx;
var i:Integer;
    P:Pointer;
begin
  with FStrings do
  try
    for i:=0 to Count - 1 do
    begin
      P:=Items[i];
      ReAllocMem(P,0);
    end;
  finally Clear end;
  FPointers.Clear;
end;
//------------------------------------------------------------------------------
function THK_Strings.GetPointers(Index:Integer):Pointer;
begin
  if (Index < 0) or (Index >= FPointers.Count) then raise EListError.Create('Invalid List Index');
  Result:=FPointers[Index];
end;

function THK_Strings.GetStringCount:Integer;
begin
  Result:=FStrings.Count;
end;


function THK_Strings.GetStrings(Index:Integer):WideString;
var PWC:PHKChars;
begin
  if (Index >= 0) and (Index < FStrings.Count) then
  begin
    PWC:=FStrings[Index];
    Result:=Copy(PWC^,0,MAXINT);
  end else raise EListError.Create('Invalid List Index');
end;

function THK_Strings.GetText:WideString;
var i:Integer;
begin
  SetLength(Result,0);
  for i:=0 to StringCount - 1 do Result:=WideFormat('%s%s%s',[Result,SD_LC,Strings[i]]);
  if (Length(Result) > 0) then System.Delete(Result,1,1);
end;

procedure THK_Strings.SetPointers(Index:Integer;Value:Pointer);
begin
  if (Index < 0) or (Index >= FPointers.Count) then raise EListError.Create('Invalid List Index');
  FPointers[Index]:=Value;
end;

procedure THK_Strings.SetStrings(Index:Integer;Value:WideString);
var i,j:Integer;
    PWC:PHKChars;
begin
  if (Index < 0) or (Index >= FStrings.Count) then raise EListError.Create('Invalid List Index');
  PWC:=FStrings[Index];
  i:=Length(Value) + 1;
  j:=i shl 1;
  ReAllocMem(PWC,j);
  Move(Value[1],PWC^,j);
  PWC^[i - 1]:=#0;//after realloc could be undefined
  FStrings[Index]:=PWC;//the memory location could have changed!
  if FSorted then Sort;
end;

procedure THK_Strings.SetText(Value:WideString);
var i:Integer;
    ASorted:Boolean;
begin
  ClearEx;
  i:=Pos(SD_LC,Value);
  ASorted:=FSorted;

  FSorted:=False;
  try
    while (i > 0) do
    begin
      AddPointer(Copy(Value,1,i - 1),nil);
      System.Delete(Value,1,i);
      i:=Pos(SD_LC,Value);
    end;
    if (Length(Value) > 0) then AddPointer(Value,nil);
  finally
    FSorted:=ASorted;
    if FSorted then Sort;
  end;
end;

function THK_Strings.IndexOf(const Value:WideString):Integer;
var i,ACount:Integer;
begin
  ACount:=FStrings.Count - 1;
  for i:=0 to ACount do
  if WideSameText(Value,Strings[i]) then
  begin
    Result:=i;
    exit;
  end;
  Result:=-1;
end;

procedure THK_Strings.Remove(Index:Integer);
var P:Pointer;
begin
  with FStrings do if (Index >= 0) and (Index < Count) then
  begin
    P:=Items[Index];
    Items[Index]:=nil;
    Pack;
    ReAllocMem(P,0);
  end;
end;

type TShellCols = array[0..15] of Integer;

procedure THK_Strings.Sort;
var i,j,k,h,AMax:Integer;
    Hold:WideString;
    PHold:Pointer;
const ShellCols:TShellCols = (1391376,463792,198768,86961,
                              33936,13776,4592,1968,861,336,
                              112,48,21,7,3,1);
begin
  AMax:=StringCount - 1;
  for k:=0 to 15 do
  begin
    h:=ShellCols[k];
    for i:=h to AMax do
    begin
      Hold:=Strings[i];
      PHold:=FPointers[i];
      j:=i;
      while ((j >= h) and (WideCompareStr(Strings[j-h],Hold) > 0)) do
      begin
        Strings[j]:=Strings[j-h];
        FPointers[j]:=FPointers[j-h];
        dec(j,h);
      end;
      Strings[j]:=Hold;
      FPointers[j]:=PHold;
    end;
  end;
end;


end.