cxstorage.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 2,215 行 · 第 1/5 页

{*******************************************************************}
{                                                                   }
{       Developer Express Cross Platform Component Library          }
{       Express Cross Platform Library classes                      }
{                                                                   }
{       Copyright (c) 2001-2008 Developer Express Inc.              }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{   The entire contents of this file is protected by U.S. and       }
{   International Copyright Laws. Unauthorized reproduction,        }
{   reverse-engineering, and distribution of all or any portion of  }
{   the code contained in this file is strictly prohibited and may  }
{   result in severe civil and criminal penalties and will be       }
{   prosecuted to the maximum extent possible under the law.        }
{                                                                   }
{   RESTRICTIONS                                                    }
{                                                                   }
{   THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES           }
{   (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE    }
{   SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS   }
{   LICENSED TO DISTRIBUTE THE EXPRESSCROSSPLATFORMLIBRARY AND ALL  }
{   ACCOMPANYING VCL AND CLX CONTROLS AS PART OF AN EXECUTABLE      }
{   PROGRAM ONLY.                                                   }
{                                                                   }
{   THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED      }
{   FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE        }
{   COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE       }
{   AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT  }
{   AND PERMISSION FROM DEVELOPER EXPRESS INC.                      }
{                                                                   }
{   CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON       }
{   ADDITIONAL RESTRICTIONS.                                        }
{                                                                   }
{*******************************************************************}
unit cxStorage;

{$I cxVer.inc}

interface

uses
{$IFDEF DELPHI6}
  Variants,
{$ENDIF}
  Windows, Registry, SysUtils, Classes, TypInfo, IniFiles, cxClasses, cxLibraryStrs;

type
  { IcxStoredObject }
  IcxStoredObject = interface
  ['{79A05009-CAC3-47E8-B454-F6F3D91F495D}']
    function GetObjectName: string;
    function GetProperties(AProperties: TStrings): Boolean;
    procedure GetPropertyValue(const AName: string; var AValue: Variant);
    procedure SetPropertyValue(const AName: string; const AValue: Variant);
  end;

  { IcxStoredParent }
  IcxStoredParent = interface
  ['{6AF48CD0-3A0B-4BEC-AC88-5D323432A686}']
    function CreateChild(const AObjectName, AClassName: string): TObject;
    procedure DeleteChild(const AObjectName: string; AObject: TObject);
    procedure GetChildren(AChildren: TStringList);
  end;

  {$IFNDEF DELPHI5}
  EPropertyConvertError = class(Exception);
  EPropertyError = class(Exception);  
  {$ENDIF}
  EcxStorage = class(Exception);
  EcxHexStringConvertError = class(Exception);
  TcxStorageMode = (smChildrenCreating, smChildrenDeleting, smSavePublishedClassProperties);
  TcxStorageModes = set of TcxStorageMode;
  TcxCustomReader = class;
  TcxCustomWriter = class;
  TcxCustomReaderClass = class of TcxCustomReader;
  TcxCustomWriterClass = class of TcxCustomWriter;
  TcxGetStorageModesEvent = function: TcxStorageModes of object;
  TcxTestClassPropertyEvent = function(const AName: string; AObject: TObject): Boolean of object;
  TcxGetComponentByNameEvent = function(const AName: string): TComponent of object;
  TcxGetUseInterfaceOnlyEvent = function: Boolean of object;

  TcxGetStoredPropertiesEvent = procedure(Sender: TObject; AProperties: TStrings) of object;
  TcxGetStoredPropertyValueEvent = procedure(Sender: TObject; const AName: string; var AValue: Variant) of object;
  TcxInitStoredObjectEvent = procedure(Sender: TObject; AObject: TObject) of object;
  TcxSetStoredPropertyValueEvent = procedure(Sender: TObject; const AName: string; const AValue: Variant) of object;

  { TcxStorageType }
  TcxStorageType = (stIniFile, stRegistry, stStream);

  { TcxStorage }
  TcxStorage = class
  private
    FNamePrefix: string;
    FModes: TcxStorageModes;
    FObjectNamePrefix: string;
    FReCreate: Boolean;
    FStorageName: string;
    FStream: TStream;
    FStoredObject: TObject;
    FSaveComponentPropertiesByName: Boolean;
    FUseInterfaceOnly: Boolean;
    FOnGetStorageModes: TcxGetStorageModesEvent;
    FOnGetComponentByName: TcxGetComponentByNameEvent;
    FOnTestClassProperty: TcxTestClassPropertyEvent;
    FOnGetUseInterfaceOnly: TcxGetUseInterfaceOnlyEvent;
    function CreateChild(const AObjectName, AClassName: string): TObject;
    procedure CreateChildrenNames(AChildren: TStringList);
    procedure DeleteChild(const AObjectName: string; AObject: TObject);
    procedure GetAllPublishedClassProperties(AProperties: TStrings);
    procedure GetAllPublishedProperties(AProperties: TStrings);
    procedure GetChildren(AChildren: TStringList);
    function GetClassProperty(const AName: string): TObject;
    function GetComponentByName(const AName: string): TComponent;
    function GetObjectName(AObject: TObject): string;
    procedure GetProperties(AProperties: TStrings);
    function GetPropertyValue(AName: string): Variant;
    function GetStorageModes: TcxStorageModes;
    function GetUseInterfaceOnly: Boolean;
    procedure SetPropertyValue(AName: string; AValue: Variant);
    function TestClassProperty(const AName: string; AObject: TObject): Boolean;
  protected
    procedure InternalRestoreFrom(AReader: TcxCustomReader; const ADefaultObjectName: string = ''); virtual;
    procedure InternalStoreTo(AWriter: TcxCustomWriter; const ADefaultObjectName: string = ''); virtual;
    procedure SetStoredObject(AObject: TObject);
  public
    constructor Create(const AStorageName: string; AStorageStream: TStream); overload;
    constructor Create(const AStorageName: string); overload;
    constructor Create(AStream: TStream); overload;
    procedure RestoreFrom(AObject: TObject; AReaderClass: TcxCustomReaderClass); virtual;
    procedure RestoreWithExistingReader(AObject: TObject; AReader: TcxCustomReader); virtual;
    procedure RestoreFromIni(AObject: TObject);
    procedure RestoreFromRegistry(AObject: TObject);
    procedure RestoreFromStream(AObject: TObject);
    procedure StoreTo(AObject: TObject; AWriterClass: TcxCustomWriterClass); virtual;
    procedure StoreWithExistingWriter(AObject: TObject; AWriter: TcxCustomWriter); virtual;
    procedure StoreToIni(AObject: TObject);
    procedure StoreToRegistry(AObject: TObject);
    procedure StoreToStream(AObject: TObject);
    property NamePrefix: string read FNamePrefix write FNamePrefix;
    property Modes: TcxStorageModes read FModes write FModes;
    property ReCreate: Boolean read FReCreate write FReCreate;
    property SaveComponentPropertiesByName: Boolean read FSaveComponentPropertiesByName write FSaveComponentPropertiesByName;
    property StoredObject: TObject read FStoredObject;
    property StorageName: string read FStorageName write FStorageName;
    property UseInterfaceOnly: Boolean read FUseInterfaceOnly write FUseInterfaceOnly;
    property OnGetComponentByName: TcxGetComponentByNameEvent read FOnGetComponentByName write FOnGetComponentByName;
    property OnGetStorageModes: TcxGetStorageModesEvent read FOnGetStorageModes write FOnGetStorageModes;
    property OnGetUseInterfaceOnly: TcxGetUseInterfaceOnlyEvent read FOnGetUseInterfaceOnly write FOnGetUseInterfaceOnly;
    property OnTestClassProperty: TcxTestClassPropertyEvent read FOnTestClassProperty write FOnTestClassProperty;
  end;

  { TcxCustomReader }
  TcxCustomReader = class
  protected
    StorageName: string;
  public
    constructor Create(const AStorageName: string); virtual;
    procedure ReadProperties(const AObjectName, AClassName: string; AProperties: TStrings); virtual;
    function ReadProperty(const AObjectName, AClassName, AName: string): Variant; virtual;
    procedure ReadChildren(const AObjectName, AClassName: string; AChildrenNames,
        AChildrenClassNames: TStrings); virtual;
  end;

  { TcxCustomWriter }
  TcxCustomWriter = class
  protected
    FReCreate: Boolean;
    FStorageName: string;
  public
    constructor Create(const AStorageName: string; AReCreate: Boolean = True); virtual;
    procedure BeginWriteObject(const AObjectName, AClassName: string); virtual;
    procedure EndWriteObject(const AObjectName, AClassName: string); virtual;
    procedure WriteProperty(const AObjectName, AClassName, AName: string; AValue: Variant); virtual;

    property ReCreate: Boolean read FReCreate write FReCreate;
    property StorageName: string read FStorageName;
  end;

  { TcxRegistryReader }
  TcxRegistryReader = class(TcxCustomReader)
  private
    FRegistry: TRegistry;
  public
    constructor Create(const AStorageName: string); override;
    destructor Destroy; override;
    procedure ReadProperties(const AObjectName, AClassName: string; AProperties: TStrings); override;
    function ReadProperty(const AObjectName, AClassName, AName: string): Variant; override;
    procedure ReadChildren(const AObjectName, AClassName: string; AChildrenNames,
        AChildrenClassNames: TStrings); override;
  end;

  { TcxRegistryWriter }
  TcxRegistryWriter = class(TcxCustomWriter)
  private
    FRegistry: TRegistry;
    FRootKeyCreated: Boolean;
    FRootKeyOpened: Boolean;
    procedure CreateRootKey;
  public
    constructor Create(const AStorageName: string; AReCreate: Boolean = True); override;
    destructor Destroy; override;
    procedure BeginWriteObject(const AObjectName, AClassName: string); override;
    procedure EndWriteObject(const AObjectName, AClassName: string); override;
    procedure WriteProperty(const AObjectName, AClassName, AName: string; AValue: Variant); override;
  end;

  { TcxIniFileReader }
  TcxIniFileReader = class(TcxCustomReader)
  private
    FIniFile: TMemIniFile;
    FPathList: TStringList;
    FObjectNameList: TStringList;
    FClassNameList: TStringList;
    procedure CreateLists;
    procedure GetSectionDetail(const ASection: string; var APath, AObjectName, AClassName: string);
  public
    constructor Create(const AStorageName: string); override;
    destructor Destroy; override;
    procedure ReadProperties(const AObjectName, AClassName: string; AProperties: TStrings); override;
    function ReadProperty(const AObjectName, AClassName, AName: string): Variant; override;
    procedure ReadChildren(const AObjectName, AClassName: string; AChildrenNames,
        AChildrenClassNames: TStrings); override;
  end;

  { TcxIniFileWriter }
  TcxIniFileWriter = class(TcxCustomWriter)
  private
    FIniFile: TMemIniFile;
  public
    constructor Create(const AStorageName: string; AReCreate: Boolean = True); override;
    destructor Destroy; override;
    procedure BeginWriteObject(const AObjectName, AClassName: string); override;
    procedure WriteProperty(const AObjectName, AClassName, AName: string; AValue: Variant); override;
  end;

type
  TcxStreamObjectData = class;
  TcxStreamPropertyData = class;

  { TcxStreamReader }
  TcxStreamReader = class(TcxCustomReader)
  private
    FCurrentObject: TcxStreamObjectData;
    FCurrentObjectFullName: string;
    FRootObject: TcxStreamObjectData;
    FReader: TReader;
    FStorageStream: TStream;
    function GetObject(const AObjectFullName: string): TcxStreamObjectData;
    function GetProperty(AObject: TcxStreamObjectData; const AName: string): TcxStreamPropertyData;
    function InternalGetObject(const AObjectName: string; AParents: TStrings): TcxStreamObjectData;
  public
    constructor Create(const AStorageName: string); override;
    destructor Destroy; override;
    procedure Read;
    procedure ReadProperties(const AObjectName, AClassName: string; AProperties: TStrings); override;
    function ReadProperty(const AObjectName, AClassName, AName: string): Variant; override;
    procedure ReadChildren(const AObjectName, AClassName: string; AChildrenNames,
        AChildrenClassNames: TStrings); override;
    procedure SetStream(AStream: TStream);
  end;

  { TcxStreamWriter }
  TcxStreamWriter = class(TcxCustomWriter)
  private
    FCurrentObject: TcxStreamObjectData;
    FRootObject: TcxStreamObjectData;
    FWriter: TWriter;
    procedure CreateObject(const AObjectName, AClassName: string; AParents: TStrings);
  public
    constructor Create(const AStorageName: string; AReCreate: Boolean = True); override;
    destructor Destroy; override;
    procedure BeginWriteObject(const AObjectName, AClassName: string); override;
    procedure SetStream(AStream: TStream);
    procedure Write;
    procedure WriteProperty(const AObjectName, AClassName, AName: string; AValue: Variant); override;
  end;

  { TcxStreamPropertyData }
  TcxStreamPropertyData = class
  private
    FName: string;
    FValue: Variant;
    procedure ReadValue(AReader: TReader);
    procedure WriteValue(AWriter: TWriter);
  public
    constructor Create(AName: string; AValue: Variant);
    procedure Read(AReader: TReader);
    procedure Write(AWriter: TWriter);
    property Name: string read FName;
    property Value: Variant read FValue;
  end;

  { TcxStreamObjectData }
  TcxStreamObjectData = class
  private
    FClassName: string;
    FChildren: TList;
    FName: string;
    FProperties: TList;
    procedure Clear;
    function GetChildCount: Integer;
    function GetChildren(AIndex: Integer): TcxStreamObjectData;
    function GetProperties(AIndex: Integer): TcxStreamPropertyData;
    function GetPropertyCount: Integer;
  public
    constructor Create(const AName, AClassName: string);
    destructor Destroy; override;
    procedure AddChild(AChild: TcxStreamObjectData);
    procedure AddProperty(AProperty: TcxStreamPropertyData);
    procedure Read(AReader: TReader);
    procedure Write(AWriter: TWriter);
    property ChildCount: Integer read GetChildCount;
    property Children[AIndex: Integer]: TcxStreamObjectData read GetChildren;
    property Name: string read FName;
    property ClassName_: string read FClassName;
    property Properties[AIndex: Integer]: TcxStreamPropertyData read GetProperties;
    property PropertyCount: Integer read GetPropertyCount;
  end;
  
  function StreamToString(AStream: TStream): string;
  procedure StringToStream(AValue: string; AStream: TStream);
  function StringToHexString(const AString: string): string;
  function HexStringToString(const AHexString: string): string;
  function StringToBoolean(const AString: string): Boolean;
  function EnumerationToString(const AValue: Integer; AEnumNames: array of string): string;
  function StringToEnumeration(const AValue: string; AEnumNames: array of string): Integer;
  function SetToString(const ASet; ASize: Integer; AEnumNames: array of string): string;
  procedure StringToSet(AString: string; var ASet; ASize: Integer; AEnumNames: array of string);
  {$IFNDEF DELPHI5}
  function SetSetProp(APropInfo: PPropInfo; const AValue: string): Integer;
  function GetObjectProp(AObject: TObject; APropInfo: PPropInfo): TObject;
  procedure SetObjectProp(AObject: TObject; APropInfo: PPropInfo; AValue: TObject);
  function GetObjectPropClass(AObject: TObject; APropInfo: PPropInfo): TClass;
  {$ENDIF}

const
  cxBufferSize: Integer = 500000;

  cxStreamBoolean = 1;
  cxStreamChar = 2;
  cxStreamCurrency = 3;
  cxStreamDate = 4;
  cxStreamFloat = 5;
  cxStreamInteger = 6;
  cxStreamSingle = 7;
  cxStreamString = 8;
  cxStreamWideString = 9;

implementation

function StreamToString(AStream: TStream): string;
begin
  if (AStream = nil) or (AStream.Size = 0) then
  begin
    Result := '';
    Exit;
  end;
  SetLength(Result, AStream.Size);
  AStream.Position := 0;
  AStream.ReadBuffer(Result[1], AStream.Size);
  Result := 'Hex:' + StringToHexString(Result);
end;

procedure StringToStream(AValue: string; AStream: TStream);
begin
  if (AStream = nil) or (Length(AValue) < 6) then Exit;
  Delete(AValue, 1, 4);
  if Length(AValue) > 0 then
  begin
    AValue := HexStringToString(AValue);
    AStream.WriteBuffer(AValue[1], Length(AValue));
  end;
end;

function StringToHexString(const AString: string): string;
var
  I: Integer;
begin
  Result := '';
  for I := 1 to Length(AString) do
    Result := Result + IntToHex(Ord(AString[I]), 2);
end;

function HexStringToString(const AHexString: string): string;
  function HexToByte(AHex: Char): Byte;
  begin
    case AHex of
      '0'..'9':
        Result := Byte(AHex) - Byte('0');
      'a'..'f':
        Result := Byte(AHex) - Byte('a') + 10;
      'A'..'F':
        Result := Byte(AHex) - Byte('A') + 10;
      else
        raise EcxHexStringConvertError.Create('');
    end;
  end;
var
  I: Integer;
begin
 Result := '';
 I := 1;
 while I < Length(AHexString) do
 begin
   Result := Result + Char((HexToByte(AHexString[I]) shl 4) + HexToByte(AHexString[I + 1]));
   Inc(I, 2);
 end;
end;

function StringToBoolean(const AString: string): Boolean;
begin
  if UpperCase(AString) = 'TRUE' then
    Result := True
  else if UpperCase(AString) = 'FALSE' then
    Result := False
  else
    raise EPropertyConvertError.Create('');
end;

function EnumerationToString(const AValue: Integer; AEnumNames: array of string): string;
begin
  if (AValue >= 0) and (AValue <= High(AEnumNames)) then
    Result := AEnumNames[AValue]
  else
    raise EPropertyConvertError.Create('');
end;

function StringToEnumeration(const AValue: string; AEnumNames: array of string): Integer;
var
  I: Integer;
  AUpperCaseValue: string;
begin
  AUpperCaseValue := UpperCase(AValue);
  for I := 0 to High(AEnumNames) do
    if AUpperCaseValue = UpperCase(AEnumNames[I]) then
    begin
      Result := I;
      Exit;
    end;
  raise EPropertyConvertError.Create('');
end;

function SetToString(const ASet; ASize: Integer; AEnumNames: array of string): string;