jclwidestrings.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: WStrUtils.PAS, released on 2004-01-25

The Initial Developers of the Original Code are: Andreas Hausladen <Andreas dott Hausladen att gmx dott de>
All Rights Reserved.

Contributors:
  Robert Marquardt (marquardt)
  Robert Rossmair (rrossmair)

You may retrieve the latest version of this file at the Project JEDI's JCL home page,
located at http://jcl.sourceforge.net

This is a lightweight Unicode unit. For more features use JclUnicode.

Known Issues:
-----------------------------------------------------------------------------}

unit JclWideStrings;

{$I jcl.inc}

interface

uses
  Classes, SysUtils;

const
  BOM_LSB_FIRST = WideChar($FEFF);
  BOM_MSB_FIRST = WideChar($FFFE);

type
  TWideFileOptionsType =
   (
    foAnsiFile,  // loads/writes an ANSI file
    foUnicodeLB  // reads/writes BOM_LSB_FIRST/BOM_MSB_FIRST
   );
  TWideFileOptions = set of TWideFileOptionsType;

  TSearchFlag = (
    sfCaseSensitive,    // match letter case
    sfIgnoreNonSpacing, // ignore non-spacing characters in search
    sfSpaceCompress,    // handle several consecutive white spaces as one white space
                        // (this applies to the pattern as well as the search text)
    sfWholeWordOnly     // match only text at end/start and/or surrounded by white spaces
  );
  TSearchFlags = set of TSearchFlag;

  TWStrings = class;
  TWStringList = class;

  TWStringListSortCompare = function(List: TWStringList; Index1, Index2: Integer): Integer;

  TWStrings = class(TPersistent)
  private
    FDelimiter: WideChar;
    FQuoteChar: WideChar;
    FNameValueSeparator: WideChar;
    FLineSeparator: WideString;
    FUpdateCount: Integer;
    function GetCommaText: WideString;
    function GetDelimitedText: WideString;
    function GetName(Index: Integer): WideString;
    function GetValue(const Name: WideString): WideString;
    procedure ReadData(Reader: TReader);
    procedure SetCommaText(const Value: WideString);
    procedure SetDelimitedText(const Value: WideString);
    procedure SetValue(const Name, Value: WideString);
    procedure WriteData(Writer: TWriter);
    function GetValueFromIndex(Index: Integer): WideString;
    procedure SetValueFromIndex(Index: Integer; const Value: WideString);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    function ExtractName(const S: WideString): WideString;
    function GetP(Index: Integer): PWideString; virtual; abstract;
    function Get(Index: Integer): WideString; 
    function GetCapacity: Integer; virtual;
    function GetCount: Integer; virtual; abstract;
    function GetObject(Index: Integer): TObject; virtual;
    function GetTextStr: WideString; virtual;
    procedure Put(Index: Integer; const S: WideString); virtual; abstract;
    procedure PutObject(Index: Integer; AObject: TObject); virtual; abstract;
    procedure SetCapacity(NewCapacity: Integer); virtual;
    procedure SetTextStr(const Value: WideString); virtual;
    procedure SetUpdateState(Updating: Boolean); virtual;
    property UpdateCount: Integer read FUpdateCount;
    function CompareStrings(const S1, S2: WideString): Integer; virtual;
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create;
    function Add(const S: WideString): Integer; virtual;
    function AddObject(const S: WideString; AObject: TObject): Integer; virtual;
    procedure Append(const S: WideString);
    procedure AddStrings(Strings: TWStrings); overload; virtual;
    procedure AddStrings(Strings: TStrings); overload; virtual;
    procedure Assign(Source: TPersistent); override;
    function CreateAnsiStringList: TStrings;
    procedure AddStringsTo(Dest: TStrings); virtual;
    procedure BeginUpdate;
    procedure Clear; virtual; abstract;
    procedure Delete(Index: Integer); virtual; abstract;
    procedure EndUpdate;
    function Equals(Strings: TWStrings): Boolean; overload;
    function Equals(Strings: TStrings): Boolean; overload;
    procedure Exchange(Index1, Index2: Integer); virtual;
    function GetText: PWideChar; virtual;
    function IndexOf(const S: WideString): Integer; virtual;
    function IndexOfName(const Name: WideString): Integer; virtual;
    function IndexOfObject(AObject: TObject): Integer; virtual;
    procedure Insert(Index: Integer; const S: WideString); virtual;
    procedure InsertObject(Index: Integer; const S: WideString;
      AObject: TObject); virtual;
    procedure LoadFromFile(const FileName: AnsiString;
      WideFileOptions: TWideFileOptions = []); virtual;
    procedure LoadFromStream(Stream: TStream;
      WideFileOptions: TWideFileOptions = []); virtual;
    procedure Move(CurIndex, NewIndex: Integer); virtual;
    procedure SaveToFile(const FileName: AnsiString;
      WideFileOptions: TWideFileOptions = []); virtual;
    procedure SaveToStream(Stream: TStream;
      WideFileOptions: TWideFileOptions = []); virtual;
    procedure SetText(Text: PWideChar); virtual;
    function GetDelimitedTextEx(ADelimiter, AQuoteChar: WideChar): WideString;
    procedure SetDelimitedTextEx(ADelimiter, AQuoteChar: WideChar; const Value: WideString);
    property Capacity: Integer read GetCapacity write SetCapacity;
    property CommaText: WideString read GetCommaText write SetCommaText;
    property Count: Integer read GetCount;
    property Delimiter: WideChar read FDelimiter write FDelimiter;
    property DelimitedText: WideString read GetDelimitedText write SetDelimitedText;
    property Names[Index: Integer]: WideString read GetName;
    property Objects[Index: Integer]: TObject read GetObject write PutObject;
    property QuoteChar: WideChar read FQuoteChar write FQuoteChar;
    property Values[const Name: WideString]: WideString read GetValue write SetValue;
    property ValueFromIndex[Index: Integer]: WideString read GetValueFromIndex write SetValueFromIndex;
    property NameValueSeparator: WideChar read FNameValueSeparator write FNameValueSeparator;
    property LineSeparator: WideString read FLineSeparator write FLineSeparator;
    property PStrings[Index: Integer]: PWideString read GetP;
    property Strings[Index: Integer]: WideString read Get write Put; default;
    property Text: WideString read GetTextStr write SetTextStr;
  end;

  // do not replace by JclUnicode.TWideStringList (speed and size issue)
  PWStringItem = ^TWStringItem;
  TWStringItem = record
    FString: WideString;
    FObject: TObject;
  end;

  TWStringList = class(TWStrings)
  private
    FList: TList;
    FSorted: Boolean;
    FDuplicates: TDuplicates;
    FCaseSensitive: Boolean;
    FOnChange: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    procedure SetSorted(Value: Boolean);
    procedure SetCaseSensitive(const Value: Boolean);
  protected
    function GetItem(Index: Integer): PWStringItem;
    procedure Changed; virtual;
    procedure Changing; virtual;
    function GetP(Index: Integer): PWideString; override;
    function GetCapacity: Integer; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure Put(Index: Integer; const Value: WideString); override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
    procedure SetCapacity(NewCapacity: Integer); override;
    procedure SetUpdateState(Updating: Boolean); override;
    function CompareStrings(const S1, S2: WideString): Integer; override;
  public
    constructor Create;
    destructor Destroy; override;
    function AddObject(const S: WideString; AObject: TObject): Integer; override;
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Exchange(Index1, Index2: Integer); override;
    function Find(const S: WideString; var Index: Integer): Boolean; virtual;
    // Find() also works with unsorted lists
    function IndexOf(const S: WideString): Integer; override;
    procedure InsertObject(Index: Integer; const S: WideString;
      AObject: TObject); override;
    procedure Sort; virtual;
    procedure CustomSort(Compare: TWStringListSortCompare); virtual;
    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
    property Sorted: Boolean read FSorted write SetSorted;
    property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  end;

  TWideStringList = TWStringList;
  TWideStrings = TWStrings;

// WideChar functions
function CharToWideChar(Ch: AnsiChar): WideChar;
function WideCharToChar(Ch: WideChar): AnsiChar;

// PWideChar functions
procedure MoveWideChar(const Source; var Dest; Count: Integer);

function StrAllocW(WideSize: Cardinal): PWideChar;
function StrNewW(const S: WideString): PWideChar;
procedure StrDisposeW(var P: PWideChar);
function StrLICompW(S1, S2: PWideChar; MaxLen: Cardinal): Integer;
function StrLICompW2(S1, S2: PWideChar; MaxLen: Cardinal): Integer;
function StrCompW(S1, S2: PWideChar): Integer;
function StrLCompW(S1, S2: PWideChar; MaxLen: Cardinal): Integer;
function StrIComp(S1, S2: PWideChar; MaxLen: Cardinal): Integer;
function StrPosW(S, SubStr: PWideChar): PWideChar;
function StrLenW(P: PWideChar): Integer;
function StrScanW(P: PWideChar; Ch: WideChar): PWideChar;
function StrEndW(P: PWideChar): PWideChar;
function StrCopyW(Dest, Source: PWideChar): PWideChar;
function StrECopyW(Dest, Source: PWideChar): PWideChar;
function StrLCopyW(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar;
function StrCatW(Dest, Source: PWideChar): PWideChar;
function StrLCatW(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar;
function StrMoveW(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar;
function StrPCopyW(Dest: PWideChar; const Source: WideString): PWideChar;
function StrPLCopyW(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar;
function StrRScanW(const Str: PWideChar; Chr: WideChar): PWideChar;

// WideString functions
function WidePos(const SubStr, S: WideString): Integer;
function WideQuotedStr(const S: WideString; Quote: WideChar): WideString;
function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): WideString;
{$IFNDEF RTL140_UP}
function WideCompareText(const S1, S2: WideString): Integer;
function WideCompareStr(const S1, S2: WideString): Integer;
function WideUpperCase(const S: WideString): WideString;
function WideLowerCase(const S: WideString): WideString;
{$ENDIF ~RTL140_UP}
function TrimW(const S: WideString): WideString;
function TrimLeftW(const S: WideString): WideString;
function TrimRightW(const S: WideString): WideString;

function TrimLeftLengthW(const S: WideString): Integer;
function TrimRightLengthW(const S: WideString): Integer;

implementation

uses
  {$IFDEF HAS_UNIT_RTLCONSTS}
  RTLConsts,
  {$ELSE}
  {$IFDEF FPC}
  rtlconst,
  {$ELSE ~FPC}
  Consts,
  {$ENDIF ~FPC}
  {$ENDIF HAS_UNIT_RTLCONSTS}
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF MSWINDOWS}
  Math;

{$IFDEF BORLAND}
  {$IFNDEF RTL140_UP}
    {$DEFINE RTL130_DOWN}
  {$ENDIF ~RTL140_UP}
{$ENDIF BORLAND}

{$IFDEF RTL130_DOWN // Delphi 5 Math unit has no Sign function }
function Sign(A: Integer): Integer;
begin
  if A < 0 then
    Result := -1
  else if A > 0 then
    Result := 1
  else
    Result := 0;
end;
{$ENDIF RTL130_DOWN}

procedure SwapWordByteOrder(P: PChar; Len: Cardinal);
var
  B: Char;
begin
  while Len > 0 do
  begin
    B := P[0];
    P[0] := P[1];
    P[1] := B;
    Inc(P, 2);
    Dec(Len);
  end;
end;

//=== WideChar functions =====================================================

function CharToWideChar(Ch: Char): WideChar;
var
  WS: WideString;
begin
  WS := Ch;
  Result := WS[1];
end;

function WideCharToChar(Ch: WideChar): AnsiChar;
var
  S: AnsiString;
begin
  S := Ch;
  Result := S[1];
end;

//=== PWideChar functions ====================================================

procedure MoveWideChar(const Source; var Dest; Count: Integer);
begin
  Move(Source, Dest, Count * SizeOf(WideChar));
end;

function StrAllocW(WideSize: Cardinal): PWideChar;
begin
  if WideSize > 0 then
    Result := AllocMem(WideSize * SizeOf(WideChar))
  else
    Result := nil;
end;

function StrNewW(const S: WideString): PWideChar;
begin
  Result := nil;
  if S <> '' then
  begin
    Result := StrAllocW(Length(S) + 1);
    MoveWideChar(S[1], Result^, Length(S));
  end;
end;

procedure StrDisposeW(var P: PWideChar);
begin
  if P <> nil then
    FreeMem(P);
  P := nil;
end;

function StrLICompW(S1, S2: PWideChar; MaxLen: Cardinal): Integer;
var
  P1, P2: WideString;
begin
  SetString(P1, S1, Min(MaxLen, Cardinal(StrLenW(S1))));
  SetString(P2, S2, Min(MaxLen, Cardinal(StrLenW(S2))));
  Result := WideCompareText(P1, P2);
end;

function StrLICompW2(S1, S2: PWideChar; MaxLen: Cardinal): Integer;
var
  P1, P2: WideString;
begin
  // faster than the JclUnicode.StrLICompW function
  SetString(P1, S1, Min(MaxLen, Cardinal(StrLenW(S1))));
  SetString(P2, S2, Min(MaxLen, Cardinal(StrLenW(S2))));
  Result := WideCompareText(P1, P2);
end;

function StrCompW(S1, S2: PWideChar): Integer;
var
  NullWide: WideChar;
begin
  Result := 0;
  if S1 = S2 then // "equal" and "nil" case
    Exit;
  NullWide := #0;

  if S1 = nil then
    S1 := @NullWide
  else
  if S2 = nil then
    S2 := @NullWide;
  while (S1^ = S2^) and (S1^ <> #0) and (S2^ <> #0) do
  begin
    Inc(S1);
    Inc(S2);
  end;
  Result := Sign(Integer(S1^) - Integer(S2^));
end;

function StrLCompW(S1, S2: PWideChar; MaxLen: Cardinal): Integer;
var
  NullWide: WideChar;
begin
  Result := 0;
  if S1 = S2 then // "equal" and "nil" case
    Exit;
  NullWide := #0;

  if S1 = nil then
    S1 := @NullWide
  else
  if S2 = nil then
    S2 := @NullWide;
  while (MaxLen > 0) and (S1^ = S2[0]) and (S1^ <> #0) and (S2^ <> #0) do
  begin
    Inc(S1);
    Inc(S2);
    Dec(MaxLen);
  end;
  Result := Sign(Integer(S1^) - Integer(S2^));
end;

function StrIComp(S1, S2: PWideChar; MaxLen: Cardinal): Integer;
var
  NullWide: WideChar;
begin
  Result := 0;
  if S1 = S2 then // "equal" and "nil" case
    Exit;
  NullWide := #0;

  if S1 = nil then
    S1 := @NullWide
  else
  if S2 = nil then
    S2 := @NullWide;
  while (MaxLen > 0) and (S1^ = S2^) and (S1^ <> #0) and (S2^ <> #0) do
  begin
    Inc(S1);
    Inc(S2);
    Dec(MaxLen);
  end;
  Result := Sign(Integer(S1^) - Integer(S2^));
end;

function StrPosW(S, SubStr: PWideChar): PWideChar;
var
  P: PWideChar;
  I: Integer;
begin
  Result := nil;
  if (S = nil) or (SubStr = nil) or (S^ = #0) or (SubStr^ = #0) then
    Exit;
  Result := S;
  while Result^ <> #0 do
  begin
    if Result^ <> SubStr^ then
      Inc(Result)
    else
    begin
      P := Result + 1;
      I := 1;
      while (P^ <> #0) and (P^ = SubStr[I]) do
      begin
        Inc(I);
        Inc(P);
      end;
      if SubStr[I] = #0 then
        Exit