tntclasses2.pas

TntExUpdate 是 流行的 TntUnicodeControls控件的扩展包.包括很难找到的 TntJVCL 也在里面. TntSysUtils2.pas/TntSysUtilsEx.pa

{*****************************************************************************}
{                                                                             }
{    Tnt Delphi Unicode Controls                                              }
{      http://www.tntware.com/delphicontrols/unicode/                         }
{        Version: 2.1.19                                                      }
{                                                                             }
{    Copyleft (c) 2006, adapted from Troy Wolbrink Tnt delphi controls        }
{    by Jordi March ([e-mail])                                          }
{                                                                             }
{*****************************************************************************}

{ TTntStrings2 enables to load a file forcing with another TTntStreamCharSet
  for example: .po Files (poEdit) usually don't containts a correct ByteOrderMark:
  you can load them correctly with LoadFromFileSCS(Filename,csUtf8) }

unit TntClasses2;

{$I TntCompilers.inc}

interface

uses
  Classes, TntClasses, TntWideStrings;

type
  TTntStrings2 = class;

  TAnsiStringsForWideStringsAdapter2 = class(TAnsiStrings{TNT-ALLOW TAnsiStrings})
  private
    FWideStrings: TTntStrings2;
    FAdapterCodePage: Cardinal;
  protected
    function Get(Index: Integer): AnsiString; override;
    procedure Put(Index: Integer; const S: AnsiString); override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
    procedure SetUpdateState(Updating: Boolean); override;
    function AdapterCodePage: Cardinal; dynamic;
  public
    constructor Create(AWideStrings: TTntStrings2; _AdapterCodePage: Cardinal = 0);
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Insert(Index: Integer; const S: AnsiString); override;
    procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); override;
    procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); override;
  end;

  TTntStrings2 = class(TWideStrings)
  private
    FLastFileCharSet: TTntStreamCharSet;
    FAnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings};
    procedure SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings});
    procedure ReadData(Reader: TReader);
    procedure ReadDataUTF7(Reader: TReader);
    procedure ReadDataUTF8(Reader: TReader);
    procedure WriteDataUTF7(Writer: TWriter);
  protected
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure LoadFromFile(const FileName: WideString); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); virtual;
    procedure SaveToFile(const FileName: WideString); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); virtual;
    {News}
    procedure LoadFromFileSCS(const FileName: WideString;
      AStrCharSet: TTntStreamCharSet);
    procedure LoadFromStreamSCS(Stream: TStream;
      AStrCharSet: TTntStreamCharSet);
    procedure SaveToFileWB(const FileName: WideString; WithBOM: Boolean);
  end;

  TTntStringList2 = class;
  TWideStringListSortCompare = function(List: TTntStringList2; Index1, Index2: Integer): Integer;

  TTntStringList2 = class(TTntStrings2)
  private
    FUpdating: Boolean;
    FList: PWideStringItemList;
    FCount: Integer;
    FCapacity: Integer;
    FSorted: Boolean;
    FDuplicates: TDuplicates;
    FCaseSensitive: Boolean;
    FOnChange: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    procedure ExchangeItems(Index1, Index2: Integer);
    procedure Grow;
    procedure QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare);
    procedure SetSorted(Value: Boolean);
    procedure SetCaseSensitive(const Value: Boolean);
  protected
    procedure Changed; virtual;
    procedure Changing; virtual;
    function Get(Index: Integer): WideString; override;
    function GetCapacity: Integer; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure Put(Index: Integer; const S: 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;
    procedure InsertItem(Index: Integer; const S: WideString; AObject: TObject); virtual;
  public
    destructor Destroy; override;
    function Add(const S: WideString): Integer; 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;
    function IndexOf(const S: WideString): Integer; override;
    function IndexOfName(const Name: WideString): Integer; override;
    procedure Insert(Index: Integer; const S: WideString); override;
    procedure InsertObject(Index: Integer; const S: WideString;
      AObject: TObject); override;
    procedure Sort; virtual;
    procedure CustomSort(Compare: TWideStringListSortCompare); 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;

  TUnicodeLinesEditor = class (TTntStringList)
  public
    function  GetText: WideString;
    procedure SetText (const Value: WideString);
  end;

implementation

uses
  RTLConsts, TntSystem, SysUtils, TntWideStrUtils2;

{--------------------------------------}

function ReaderNeedsUtfHelp(Reader: TReader): Boolean;
begin
  if Reader.Owner = nil then
    Result := False { designtime - visual form inheritance ancestor }
  else if csDesigning in Reader.Owner.ComponentState then
    {$IFDEF COMPILER_7_UP}
    Result := False { Delphi 7+: designtime - doesn't need UTF help. }
    {$ELSE}
    Result := True { Delphi 6: designtime - always needs UTF help. }
    {$ENDIF}
  else
    Result := RuntimeUTFStreaming; { runtime }
end;

{ TAnsiStringsForWideStringsAdapter2 }

constructor TAnsiStringsForWideStringsAdapter2.Create(AWideStrings: TTntStrings2; _AdapterCodePage: Cardinal);
begin
  inherited Create;
  FWideStrings := AWideStrings;
  FAdapterCodePage := _AdapterCodePage;
end;

function TAnsiStringsForWideStringsAdapter2.AdapterCodePage: Cardinal;
begin
  if FAdapterCodePage = 0 then
    Result := TntSystem.DefaultSystemCodePage
  else
    Result := FAdapterCodePage;
end;

procedure TAnsiStringsForWideStringsAdapter2.Clear;
begin
  FWideStrings.Clear;
end;

procedure TAnsiStringsForWideStringsAdapter2.Delete(Index: Integer);
begin
  FWideStrings.Delete(Index);
end;

function TAnsiStringsForWideStringsAdapter2.Get(Index: Integer): AnsiString;
begin
  Result := WideStringToStringEx(FWideStrings.Get(Index), AdapterCodePage);
end;

procedure TAnsiStringsForWideStringsAdapter2.Put(Index: Integer; const S: AnsiString);
begin
  FWideStrings.Put(Index, StringToWideStringEx(S, AdapterCodePage));
end;

function TAnsiStringsForWideStringsAdapter2.GetCount: Integer;
begin
  Result := FWideStrings.GetCount;
end;

procedure TAnsiStringsForWideStringsAdapter2.Insert(Index: Integer; const S: AnsiString);
begin
  FWideStrings.Insert(Index, StringToWideStringEx(S, AdapterCodePage));
end;

function TAnsiStringsForWideStringsAdapter2.GetObject(Index: Integer): TObject;
begin
  Result := FWideStrings.GetObject(Index);
end;

procedure TAnsiStringsForWideStringsAdapter2.PutObject(Index: Integer; AObject: TObject);
begin
  FWideStrings.PutObject(Index, AObject);
end;

procedure TAnsiStringsForWideStringsAdapter2.SetUpdateState(Updating: Boolean);
begin
  FWideStrings.SetUpdateState(Updating);
end;

procedure TAnsiStringsForWideStringsAdapter2.LoadFromStreamEx(Stream: TStream; CodePage: Cardinal);
var
  Size: Integer;
  S: AnsiString;
begin
  BeginUpdate;
  try
    Size := Stream.Size - Stream.Position;
    SetString(S, nil, Size);
    Stream.Read(Pointer(S)^, Size);
    FWideStrings.SetTextStr(StringToWideStringEx(S, CodePage));
  finally
    EndUpdate;
  end;
end;

procedure TAnsiStringsForWideStringsAdapter2.SaveToStreamEx(Stream: TStream; CodePage: Cardinal);
var
  S: AnsiString;
begin
  S := WideStringToStringEx(FWideStrings.GetTextStr, CodePage);
  Stream.WriteBuffer(Pointer(S)^, Length(S));
end;

{ TTntStrings2 }

constructor TTntStrings2.Create;
begin
  inherited;
  FAnsiStrings := TAnsiStringsForWideStringsAdapter2.Create(Self);
  FLastFileCharSet := csUnicode;
end;

destructor TTntStrings2.Destroy;
begin
  FreeAndNil(FAnsiStrings);
  inherited;
end;

procedure TTntStrings2.SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings});
begin
  FAnsiStrings.Assign(Value);
end;

procedure TTntStrings2.DefineProperties(Filer: TFiler);

  {$IFNDEF COMPILER_7_UP}
  function DoWrite: Boolean;
  begin
    if Filer.Ancestor <> nil then
    begin
      Result := True;
      if Filer.Ancestor is TWideStrings then
        Result := not Equals(TWideStrings(Filer.Ancestor))
    end
    else Result := Count > 0;
  end;

  function DoWriteAsUTF7: Boolean;
  var
    i: Integer;
  begin
    Result := False;
    for i := 0 to Count - 1 do begin
      if (Strings[i] <> '') and (WideStringToUTF8(Strings[i]) <> Strings[i]) then begin
        Result := True;
        break; { found a string with non-ASCII chars (> 127) }
      end;
    end;
  end;
  {$ENDIF}

begin
  inherited DefineProperties(Filer); { Handles main 'Strings' property.' }
  Filer.DefineProperty('WideStrings', ReadData, nil, False);
  Filer.DefineProperty('WideStringsW', ReadDataUTF8, nil, False);
  {$IFDEF COMPILER_7_UP}
  Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, False);
  {$ELSE}
  Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, DoWrite and DoWriteAsUTF7);
  {$ENDIF}
end;

procedure TTntStrings2.LoadFromFile(const FileName: WideString);
var
  Stream: TStream;
begin
  Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    FLastFileCharSet := AutoDetectCharacterSet(Stream);
    Stream.Position := 0;
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TTntStrings2.LoadFromStream(Stream: TStream);
begin
  LoadFromStream_BOM(Stream, True);
end;

procedure TTntStrings2.LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean);
var
  DataLeft: Integer;
  StreamCharSet: TTntStreamCharSet;
  SW: WideString;
  SA: AnsiString;
begin
  BeginUpdate;
  try
    if WithBOM then
      StreamCharSet := AutoDetectCharacterSet(Stream)
    else
      StreamCharSet := csUnicode;
    DataLeft := Stream.Size - Stream.Position;
    if (StreamCharSet in [csUnicode, csUnicodeSwapped]) then
    begin
      // BOM indicates Unicode text stream
      if DataLeft < SizeOf(WideChar) then
        SW := ''
      else begin
        SetLength(SW, DataLeft div SizeOf(WideChar));
        Stream.Read(PWideChar(SW)^, DataLeft);
        if StreamCharSet = csUnicodeSwapped then
          StrSwapByteOrder(PWideChar(SW));
      end;
      SetTextStr(SW);
    end
    else if StreamCharSet = csUtf8 then
    begin
      // BOM indicates UTF-8 text stream
      SetLength(SA, DataLeft div SizeOf(AnsiChar));
      Stream.Read(PAnsiChar(SA)^, DataLeft);
      SetTextStr(UTF8ToWideString(SA));
    end
    else
    begin
      // without byte order mark it is assumed that we are loading ANSI text
      SetLength(SA, DataLeft div SizeOf(AnsiChar));
      Stream.Read(PAnsiChar(SA)^, DataLeft);
      SetTextStr(SA);
    end;
  finally
    EndUpdate;
  end;
end;

procedure TTntStrings2.LoadFromFileSCS(const FileName: WideString;
  AStrCharSet: TTntStreamCharSet);
var
  Stream: TStream;
begin
  Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    Stream.Position := 0;
    LoadFromStreamSCS(Stream, AStrCharSet);
  finally
    Stream.Free;
  end;
end;

procedure TTntStrings2.LoadFromStreamSCS(Stream: TStream;
  AStrCharSet: TTntStreamCharSet);
var
  DataLeft: Integer;
  SW: WideString;
  SA: AnsiString;
begin
  BeginUpdate;
  try
    DataLeft := Stream.Size - Stream.Position;
    if (AStrCharSet in [csUnicode, csUnicodeSwapped]) then
    begin
      // BOM indicates Unicode text stream
      if DataLeft < SizeOf(WideChar) then
        SW := ''
      else begin
        SetLength(SW, DataLeft div SizeOf(WideChar));
        Stream.Read(PWideChar(SW)^, DataLeft);
        if AStrCharSet = csUnicodeSwapped then
          StrSwapByteOrder(PWideChar(SW));
      end;
      SetTextStr(SW);
    end
    else if AStrCharSet = csUtf8 then
    begin
      // BOM indicates UTF-8 text stream
      SetLength(SA, DataLeft div SizeOf(AnsiChar));
      Stream.Read(PAnsiChar(SA)^, DataLeft);
      SetTextStr(UTF8ToWideString(SA));
    end
    else
    begin
      // without byte order mark it is assumed that we are loading ANSI text
      SetLength(SA, DataLeft div SizeOf(AnsiChar));
      Stream.Read(PAnsiChar(SA)^, DataLeft);
      SetTextStr(SA);
    end;
  finally
    EndUpdate;
  end;
end;

procedure TTntStrings2.ReadData(Reader: TReader);
begin
  if Reader.NextValue in [vaString, vaLString] then
    SetTextStr(Reader.ReadString) {JCL compatiblity}
  else if Reader.NextValue = vaWString then
    SetTextStr(Reader.ReadWideString) {JCL compatiblity}
  else begin
    BeginUpdate;
    try
      Clear;
      Reader.ReadListBegin;
      while not Reader.EndOfList do
        if Reader.NextValue in [vaString, vaLString] then
          Add(Reader.ReadString) {TStrings compatiblity}
        else
          Add(Reader.ReadWideString);
      Reader.ReadListEnd;
    finally