clserializers.pas

用Delphi实现的数据库持久化

unit clSerializers;
{
  clSerializers
  Author: Chris Lichti
  Updated: 4/8/2002
  First version: February 28, 2001

  This unit provides simple functions for saving and loading objects to/from
  an INI files and Registry trees.

  These functions all support the following property kinds:
      tkInteger, tkChar, tkString, tkLString, tkWString, tkEnumeration, tkSet,
      tkFloat, tkClass

  The support for tkClass includes support for both object reference properties
  and delegate objects, including TCollection descendants and TStrings.

  If you need these functions to work with an additional property type or
  class, please let me know via email. ([e-mail])

  This unit requires my RTTI Wrapper classes in clRTTI.pas

  The simplest possible way to use these functions is by calling the versions
  that take a pointer to any object and a string with a starting header in it.

  For example:
  IniSerializer.SaveObjToIniFile( MyObject, 'MyApp.ini', 'MyObject' );
  -and-
  IniSerializer.LoadObjFromIniFile( MyObject, 'MyApp.ini', 'MyObject' );

  or

  RegSerializer.SaveObjToRegistry( MyObject, 'Software\Mine\MyApp\MyObject' );
  -and-
  IniSerializer.LoadObjFromIniFile( MyObject, 'Software\Mine\MyApp\MyObject' );

  However, should you require more power over which properties are saved/loaded,
  or how the TIniFile or TRegistry is configured, you can use one of the
  overloaded versions of these functions which allow you to set up your own
  TIniFile or TRegistry and/or your own TrtWrapper object.

  For example:
  You can filter out property names and property kinds that get saved/loaded
  by creating your own instance of rtWrapper, setting the StopNames or
  VisibleKinds properties, and passing it to one of the overloaded versions
  of the save/load functions.

  These functions are object-centric.  If you are save/loading a class called
  TMyObject, and you later remove a property from TMyObject, these functions
  will simply not try to load the removed property.  If you later add a property
  and try to load an older version from the ini file, LoadObjFromIniFile will
  return a comma-separated list containing the missing property(ies).  You are
  then responsible for filling in default values for those missing properties,
  if necessary.  In most cases, it is easier to just fill all the properties
  of MyObject with defaults before calling LoadObjFromIniFile.  However, if
  you need to change values depending on other conditions, you can get at the
  missing properties like this:

  var
    slMissingProps: TStringList;
    rtMyObj: TrtWrapper;
    nProp: integer;
  begin
    slMissingProps := nil;
    rtMyObj := nil;
    try
      slMissingProps := TStringList.Create;
      slMissingProps.CommaText :=
        LoadObjFromIniFile( MyObject, 'MyApp\MyObject' );

      if slMissingProps.Count > 0 then
      begin
        rtMyObj := TrtWrapper.Create( MyObject );

        for nProp := 0 to slMissingProps.Count - 1 do
        begin
          rtMyObj[slMissingProps[nProp]].Value := //some default value
        end;
      end;
    finally
      rtMyObj.Free;
      slMissingProps.Free;
    end;
  end;
}


interface

uses clRTTI, classes, inifiles, registry, windows;

resourcestring
  ERR_OBJISNIL = '%s: %s cannot be nil';
  ERR_REGISTRY_NOOPENKEY = '%s: TRegistry object (%s) does not have an open key';
  ERR_REGISTRY_OPENKEY = '%s: Error opening key (%s)';
  ERR_NOVALINREGISTRY = '%s: Property value (%s) is not in the registry';

type
  TclAbstractSerializer = class
  protected
    function GetParentSection( sSectionName: string ): string; virtual;
    function FormatSubSection( sSectionName, sSubSection: string ): string; virtual;
    function ExtractSubSectionName( sSectionName: string ): string; virtual;
    //Abstract read/write functions to override
    procedure CreateSection( sSectionName: string ); virtual; abstract;
    procedure RemoveSection( sSectionName: string ); virtual; abstract;
    function SectionExists( sSectionName: string ): boolean; virtual; abstract;
    function ValueExists( sSectionName, sName: string ): boolean; virtual; abstract;
    procedure WriteString( sSectionName: string; sName: string; sValue: string ); virtual; abstract;
    procedure WriteDateTime( sSectionName: string; sName: string; fValue: double ); virtual; abstract;
    procedure WriteTime( sSectionName: string; sName: string; fValue: double ); virtual; abstract;
    procedure WriteDate( sSectionName: string; sName: string; fValue: double ); virtual; abstract;
    procedure WriteFloat( sSectionName: string; sName: string; fValue: double ); virtual; abstract;
    procedure WriteInteger( sSectionName: string; sName: string; nValue: integer ); virtual; abstract;
    function ReadString( sSectionName: string; sName: string): string; virtual; abstract;
    function ReadDateTime( sSectionName: string; sName: string): double; virtual; abstract;
    function ReadTime( sSectionName: string; sName: string): double; virtual; abstract;
    function ReadDate( sSectionName: string; sName: string): double; virtual; abstract;
    function ReadFloat( sSectionName: string; sName: string): double; virtual; abstract;
    function ReadInteger( sSectionName: string; sName: string): integer; virtual; abstract;
    //Internal serialization methods to call
    procedure DoSerializeFrom( Source: TObject; sSection: string ); overload; virtual;
    procedure DoSerializeFrom( Source: TrtWrapper; sSection: string ); overload; virtual;
    function DoDeserializeTo( Target: TObject; sSection: string ): string; overload; virtual;
    function DoDeserializeTo( Target: TrtWrapper; sSection: string ): string; overload; virtual;
  public
    constructor Create; virtual;
  end;

  TclIniSerializer = class( TclAbstractSerializer )
  protected
    IniFile: TIniFile;
    procedure CreateSection( sSectionName: string ); override;
    procedure RemoveSection( sSectionName: string ); override;
    function SectionExists( sSectionName: string ): boolean; override;
    function ValueExists( sSectionName, sName: string ): boolean; override;
    procedure WriteString( sSectionName: string; sName: string; sValue: string ); override;
    procedure WriteDateTime( sSectionName: string; sName: string; fValue: double ); override;
    procedure WriteTime( sSectionName: string; sName: string; fValue: double ); override;
    procedure WriteDate( sSectionName: string; sName: string; fValue: double ); override;
    procedure WriteFloat( sSectionName: string; sName: string; fValue: double ); override;
    procedure WriteInteger( sSectionName: string; sName: string; nValue: integer ); override;
    function ReadString( sSectionName: string; sName: string): string; override;
    function ReadDateTime( sSectionName: string; sName: string): double; override;
    function ReadTime( sSectionName: string; sName: string): double; override;
    function ReadDate( sSectionName: string; sName: string): double; override;
    function ReadFloat( sSectionName: string; sName: string): double; override;
    function ReadInteger( sSectionName: string; sName: string): integer; override;
  public
    //      Saving...
    procedure SaveObjToIniFile( Source: TObject; Target: TIniFile;
      IniSection: string); overload;
    procedure SaveObjToIniFile( Source: TObject; IniFilename, IniSection: string); overload;
    procedure SaveObjToIniFile( Source: TrtWrapper; IniFilename, IniSection: string); overload;
    procedure SaveObjToIniFile( Source: TrtWrapper; Target: TIniFile;
      IniSection: string); overload;
    //      Loading...
    function LoadObjFromIniFile( Target: TObject; IniFilename,
      IniSection: string ): string; overload;
    function LoadObjFromIniFile( Target: TrtWrapper; IniFilename,
      IniSection: string ): string; overload;
    function LoadObjFromIniFile( Source: TIniFile; IniSection: string; Target: TObject ): string; overload;
    function LoadObjFromIniFile( Source: TIniFile; IniSection: string; Target: TrtWrapper ): string; overload;
  end;

  TclRegSerializer = class( TclAbstractSerializer )
  protected
    //Registry Support
    slRegistries: TStringList;
    BaseReg: TRegistry;
    function GetRegForKey( sKey: string ): TRegistry;
    procedure CleanUpRegistries;
    procedure ClearKey(sKey: string);
    //Overrides
    procedure CreateSection( sSectionName: string ); override;
    procedure RemoveSection( sSectionName: string ); override;
    function SectionExists( sSectionName: string ): boolean; override;
    function ValueExists( sSectionName, sName: string ): boolean; override;
    procedure WriteString( sSectionName: string; sName: string; sValue: string ); override;
    procedure WriteDateTime( sSectionName: string; sName: string; fValue: double ); override;
    procedure WriteTime( sSectionName: string; sName: string; fValue: double ); override;
    procedure WriteDate( sSectionName: string; sName: string; fValue: double ); override;
    procedure WriteFloat( sSectionName: string; sName: string; fValue: double ); override;
    procedure WriteInteger( sSectionName: string; sName: string; nValue: integer ); override;
    function ReadString( sSectionName: string; sName: string): string; override;
    function ReadDateTime( sSectionName: string; sName: string): double; override;
    function ReadTime( sSectionName: string; sName: string): double; override;
    function ReadDate( sSectionName: string; sName: string): double; override;
    function ReadFloat( sSectionName: string; sName: string): double; override;
    function ReadInteger( sSectionName: string; sName: string): integer; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    //      Saving...
    procedure SaveObjToRegistry( Source: TObject; Target: TRegistry ); overload;
    procedure SaveObjToRegistry( Source: TObject; RegistryKey: string;
      RootKey: HKEY = HKEY_CURRENT_USER ); overload;
    procedure SaveObjToRegistry( Source: TrtWrapper; RegistryKey: string;
      RootKey: HKEY = HKEY_CURRENT_USER ); overload;
    procedure SaveObjToRegistry( Source: TrtWrapper; Target: TRegistry ); overload;

    //      Loading...
    function LoadObjFromRegistry( Target: TObject; RegistryKey: string;
      RootKey: HKEY = HKEY_CURRENT_USER ): string; overload;
    function LoadObjFromRegistry( Source: TRegistry; Target: TObject ): string; overload;
    function LoadObjFromRegistry( Source: TRegistry; Target: TrtWrapper ): string; overload;
  end;

function IniSerializer: TclIniSerializer;
function RegSerializer: TclRegSerializer;

implementation

uses typinfo, sysutils;

var
  FIniSerializer: TclIniSerializer;
  FRegSerializer: TclRegSerializer;

function IniSerializer: TclIniSerializer;
begin
  if not Assigned(FIniSerializer) then
  begin
    FIniSerializer := TclIniSerializer.Create;
  end;
  Result := FIniSerializer;
end;

function RegSerializer: TclRegSerializer;
begin
  if not Assigned(FRegSerializer) then
  begin
    FRegSerializer := TclRegSerializer.Create;
  end;
  Result := FRegSerializer;
end;


{ TclAbstractSerializer }

constructor TclAbstractSerializer.Create;
begin
  //stupid virtual base constructor that should be in TObject.  sigh...
end;

function TclAbstractSerializer.DoDeserializeTo(Target: TrtWrapper; sSection: string ): string;
  {
  LoadSubObject
  Loads a SubObject from the specified SubSection in the IniFile.

  This method provides any special handling required for special subobjects,
  such as TCollection and TStrings.
  }
  procedure LoadSubObject( SubSection: string; Instance: TObject );
  var
    SubWrapper: TrtWrapper;

    Strings: TStrings;
    nSLine: integer;

    Collection: TCollection;
    nCItem: integer;
    sCSubSection: string;
  begin
    if not Assigned( Instance ) then exit;
    SubWrapper := nil;
    try
      //Create a TrtWrapper and configure it with the same settings as Source
      SubWrapper := TrtWrapper.Create( Instance, Target.VisiblePropKinds );
      SubWrapper.StopNames := Target.StopNames;

      if Instance is TStrings then
      begin //Read in the Text property for TStrings
        Strings := TStrings( Instance );
        Strings.Clear;
        nSLine := 0;
        while ValueExists( SubSection, 'Line' + InttoStr(nSLine) ) do
        begin
          Strings.Add(ReadString( SubSection, 'Line' + InttoStr(nSLine)));
          inc(nSLine);
        end;
      end
      else  //Read in the entire object for everything else
        DoDeserializeTo( Instance, SubSection );

      //If the SubObject is a collection, read in the collection items
      if Instance is TCollection then
      begin
        Collection := TCollection( Instance );
        Collection.Clear;

        for nCItem := 0 to MaxInt do
        begin
          sCSubSection := 'CItem' + InttoStr( nCItem );
          if SectionExists( SubSection + '\' + sCSubSection ) then
          begin
            LoadSubObject( SubSection + '\' + sCSubSection, Collection.Add )
          end
          else break;
        end;
      end;

    finally
      SubWrapper.Free;
    end;
  end;
var
  Prop: TrtProperty;
  nProp: integer;
begin
  //Enforce assumptions
  Assert( Assigned( Target ),
    Format(ERR_OBJISNIL, ['DoDeserializeTo', 'Target'] ));

  Result := '';

  //Loop through the published properties of the object
  for nProp := 0 to Target.Count - 1 do
  begin
    Prop := Target.Items[nProp];

    if Prop.ReadOnly then continue;

    if (not ValueExists( sSection, Prop.Name )) and
      (not SectionExists( sSection + '\' + Prop.Name)) then
    begin
      if length(Result) > 0 then Result := Result + ',';
      Result := Result + Prop.Name;
      continue;
    end;

    //Load the property using the TIniFile method appropriate for the property kind.
    case Prop.Kind of