tntclasses.pas

TNT Components Source

{*****************************************************************************}
{                                                                             }
{    Tnt Delphi Unicode Controls                                              }
{      http://www.tntware.com/delphicontrols/unicode/                         }
{        Version: 2.3.0                                                       }
{                                                                             }
{    Copyright (c) 2002-2007, Troy Wolbrink ([e-mail])       }
{                                                                             }
{*****************************************************************************}

unit TntClasses;

{$INCLUDE TntCompilers.inc}

interface

{ TODO: Consider: TTntRegIniFile, TTntMemIniFile (consider if UTF8 fits into this solution). }

{***********************************************}
{  WideChar-streaming implemented by Ma雔 H鰎z  }
{***********************************************}

uses
  Classes, SysUtils, Windows,
  {$IFNDEF COMPILER_10_UP}
  TntWideStrings,
  {$ELSE}
  WideStrings,
  {$ENDIF}
  ActiveX, Contnrs;

// ......... introduced .........
type
  TTntStreamCharSet = (csAnsi, csUnicode, csUnicodeSwapped, csUtf8);

function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet;

//---------------------------------------------------------------------------------------------
//                                 Tnt - Classes
//---------------------------------------------------------------------------------------------

{TNT-WARN ExtractStrings}
{TNT-WARN LineStart}
{TNT-WARN TStringStream}   // TODO: Implement a TWideStringStream

// A potential implementation of TWideStringStream can be found at:
//   http://kdsxml.cvs.sourceforge.net/kdsxml/Global/KDSClasses.pas?revision=1.10&view=markup

procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent);

type
{TNT-WARN TFileStream}
  TTntFileStream = class(THandleStream)
  public
    constructor Create(const FileName: WideString; Mode: Word);
    destructor Destroy; override;
  end;

{TNT-WARN TMemoryStream}
  TTntMemoryStream = class(TMemoryStream{TNT-ALLOW TMemoryStream})
  public
    procedure LoadFromFile(const FileName: WideString);
    procedure SaveToFile(const FileName: WideString);
  end;

{TNT-WARN TResourceStream}
  TTntResourceStream = class(TCustomMemoryStream)
  private
    HResInfo: HRSRC;
    HGlobal: THandle;
    procedure Initialize(Instance: THandle; Name, ResType: PWideChar);
  public
    constructor Create(Instance: THandle; const ResName: WideString; ResType: PWideChar);
    constructor CreateFromID(Instance: THandle; ResID: Word; ResType: PWideChar);
    destructor Destroy; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    procedure SaveToFile(const FileName: WideString);
  end;

  TTntStrings = class;

{TNT-WARN TAnsiStrings}
  TAnsiStrings{TNT-ALLOW TAnsiStrings} = class(TStrings{TNT-ALLOW TStrings})
  public
    procedure LoadFromFile(const FileName: WideString); reintroduce;
    procedure SaveToFile(const FileName: WideString); reintroduce;
    procedure LoadFromFileEx(const FileName: WideString; CodePage: Cardinal);
    procedure SaveToFileEx(const FileName: WideString; CodePage: Cardinal);
    procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract;
    procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract;
  end;

  TAnsiStringsForWideStringsAdapter = class(TAnsiStrings{TNT-ALLOW TAnsiStrings})
  private
    FWideStrings: TTntStrings;
    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: TTntStrings; _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;

{TNT-WARN TStrings}
  TTntStrings = 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;

    property LastFileCharSet: TTntStreamCharSet read FLastFileCharSet;
  published
    property AnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings} read FAnsiStrings write SetAnsiStrings stored False;
  end;

{ TTntStringList class }

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

{TNT-WARN TStringList}
  TTntStringList = class(TTntStrings)
  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;

// ......... introduced .........
type
  TListTargetCompare = function (Item, Target: Pointer): Integer;

function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare;
  Target: Pointer; var Index: Integer): Boolean;

function ClassIsRegistered(const clsid: TCLSID): Boolean;

var
  RuntimeUTFStreaming: Boolean;

type
  TBufferedAnsiString = class(TObject)
  private
    FStringBuffer: AnsiString;
    LastWriteIndex: Integer;
  public
    procedure Clear;
    procedure AddChar(const wc: AnsiChar);
    procedure AddString(const s: AnsiString);
    procedure AddBuffer(Buff: PAnsiChar; Chars: Integer);
    function Value: AnsiString;
    function BuffPtr: PAnsiChar;
  end;

  TBufferedWideString = class(TObject)
  private
    FStringBuffer: WideString;
    LastWriteIndex: Integer;
  public
    procedure Clear;
    procedure AddChar(const wc: WideChar);
    procedure AddString(const s: WideString);
    procedure AddBuffer(Buff: PWideChar; Chars: Integer);
    function Value: WideString;
    function BuffPtr: PWideChar;
  end;

  TBufferedStreamReader = class(TStream)
  private
    FStream: TStream;
    FStreamSize: Integer;
    FBuffer: array of Byte;
    FBufferSize: Integer;
    FBufferStartPosition: Integer;
    FVirtualPosition: Integer;
    procedure UpdateBufferFromPosition(StartPos: Integer);
  public
    constructor Create(Stream: TStream; BufferSize: Integer = 1024);
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
  end;

// "synced" wide string
type TSetAnsiStrEvent = procedure(const Value: AnsiString) of object;
function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString;
procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString;
  const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent);

type
  TWideComponentHelper = class(TComponent)
  private
    FComponent: TComponent;
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    constructor CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList);
  end;

function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper;

implementation

uses
  RTLConsts, ComObj, Math,
  Registry, TypInfo, TntSystem, TntSysUtils;

{ TntPersistent }

//===========================================================================
//   The Delphi 5 Classes.pas never supported the streaming of WideStrings.
//   The Delphi 6 Classes.pas supports WideString streaming.  But it's too bad that
//     the Delphi 6 IDE doesn't use the updated Classes.pas.  Switching between Form/Text
//       mode corrupts extended characters in WideStrings even under Delphi 6.
//   Delphi 7 seems to finally get right.  But let's keep the UTF7 support at design time
//     to enable sharing source code with previous versions of Delphi.
//
//   The purpose of this solution is to store WideString properties which contain
//     non-ASCII chars in the form of UTF7 under the old property name + '_UTF7'.
//
//   Special thanks go to Francisco Leong for helping to develop this solution.
//

{ TTntWideStringPropertyFiler }
type
  TTntWideStringPropertyFiler = class
  private
    FInstance: TPersistent;
    FPropInfo: PPropInfo;
    procedure ReadDataUTF8(Reader: TReader);
    procedure ReadDataUTF7(Reader: TReader);
    procedure WriteDataUTF7(Writer: TWriter);
  public
    procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString);
  end;

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;

procedure TTntWideStringPropertyFiler.ReadDataUTF8(Reader: TReader);
begin
  if ReaderNeedsUtfHelp(Reader) then
    SetWideStrProp(FInstance, FPropInfo, UTF8ToWideString(Reader.ReadString))
  else
    Reader.ReadString; { do nothing with Result }
end;

procedure TTntWideStringPropertyFiler.ReadDataUTF7(Reader: TReader);
begin
  if ReaderNeedsUtfHelp(Reader) then
    SetWideStrProp(FInstance, FPropInfo, UTF7ToWideString(Reader.ReadString))
  else
    Reader.ReadString; { do nothing with Result }
end;

procedure TTntWideStringPropertyFiler.WriteDataUTF7(Writer: TWriter);
begin
  Writer.WriteString(WideStringToUTF7(GetWideStrProp(FInstance, FPropInfo)));
end;

procedure TTntWideStringPropertyFiler.DefineProperties(Filer: TFiler; Instance: TPersistent;
  PropName: AnsiString);

  {$IFNDEF COMPILER_7_UP}
  function HasData: Boolean;
  var
    CurrPropValue: WideString;
  begin
    // must be stored
    Result := IsStoredProp(Instance, FPropInfo);
    if Result
    and (Filer.Ancestor <> nil)
    and (GetPropInfo(Filer.Ancestor, PropName, [tkWString]) <> nil) then
    begin
      // must be different than ancestor
      CurrPropValue := GetWideStrProp(Instance, FPropInfo);
      Result := CurrPropValue <> GetWideStrProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName));
    end;
    if Result then begin
      // must be non-blank and different than UTF8 (implies all ASCII <= 127)
      CurrPropValue := GetWideStrProp(Instance, FPropInfo);
      Result := (CurrPropValue <> '') and (WideStringToUTF8(CurrPropValue) <> CurrPropValue);
    end;
  end;
  {$ENDIF}

begin
  FInstance := Instance;
  FPropInfo := GetPropInfo(Instance, PropName, [tkWString]);
  if FPropInfo <> nil then begin
    // must be published (and of type WideString)
    Filer.DefineProperty(PropName + 'W', ReadDataUTF8, nil, False);
    {$IFDEF COMPILER_7_UP}
    Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, False);
    {$ELSE}
    Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, HasData);
    {$ENDIF}
  end;
  FInstance := nil;
  FPropInfo := nil;
end;

{ TTntWideCharPropertyFiler }
type
  TTntWideCharPropertyFiler = class
  private
    FInstance: TPersistent;
    FPropInfo: PPropInfo;
    {$IFNDEF COMPILER_9_UP}
    FWriter: TWriter;
    procedure GetLookupInfo(var Ancestor: TPersistent;
      var Root, LookupRoot, RootAncestor: TComponent);
    {$ENDIF}
    procedure ReadData_W(Reader: TReader);
    procedure ReadDataUTF7(Reader: TReader);
    procedure WriteData_W(Writer: TWriter);
    function ReadChar(Reader: TReader): WideChar;
  public
    procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString);
  end;

{$IFNDEF COMPILER_9_UP}
type
  TGetLookupInfoEvent = procedure(var Ancestor: TPersistent;
    var Root, LookupRoot, RootAncestor: TComponent) of object;

function AncestorIsValid(Ancestor: TPersistent; Root, RootAncestor: TComponent): Boolean;
begin
  Result := (Ancestor <> nil) and (RootAncestor <> nil) and
            Root.InheritsFrom(RootAncestor.ClassType);
end;

function IsDefaultOrdPropertyValue(Instance: TObject; PropInfo: PPropInfo;
  OnGetLookupInfo: TGetLookupInfoEvent): Boolean;
var
  Ancestor: TPersistent;
  LookupRoot: TComponent;
  RootAncestor: TComponent;
  Root: TComponent;
  AncestorValid: Boolean;
  Value: Longint;
  Default: LongInt;
begin
  Ancestor := nil;
  Root := nil;
  LookupRoot := nil;
  RootAncestor := nil;

  if Assigned(OnGetLookupInfo) then
    OnGetLookupInfo(Ancestor, Root, LookupRoot, RootAncestor);

  AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor);

  Result := True;
  if (PropInfo^.GetProc <> nil) and (PropInfo^.SetProc <> nil) then
  begin
    Value := GetOrdProp(Instance, PropInfo);
    if AncestorValid then
      Result := Value = GetOrdProp(Ancestor, PropInfo)
    else
    begin
      Default := PPropInfo(PropInfo)^.Default;