RTTI и другие трюки с информацией о классах, модулях и т.п.

Code:

unit uStreamableExample;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Contnrs;

type

TStreamableObject = class(TPersistent)

protected

   function ReadString(Stream: TStream): String;

   function ReadLongInt(Stream: TStream): LongInt;

   function ReadDateTime(Stream: TStream): TDateTime;

   function ReadCurrency(Stream: TStream): Currency;

   function ReadClassName(Stream: TStream): ShortString;

   procedure WriteString(Stream: TStream; const Value: String);

   procedure WriteLongInt(Stream: TStream; const Value: LongInt);

   procedure WriteDateTime(Stream: TStream; const Value: TDateTime);

   procedure WriteCurrency(Stream: TStream; const Value: Currency);

   procedure WriteClassName(Stream: TStream; const Value: ShortString);

public

   constructor CreateFromStream(Stream: TStream);

   procedure LoadFromStream(Stream: TStream); virtual; abstract;

   procedure SaveToStream(Stream: TStream); virtual; abstract;

end;

TStreamableObjectClass = classof TStreamableObject;

TPerson = class(TStreamableObject)

private

   FName: String;

   FBirthDate: TDateTime;

public

   constructor Create(const AName: string; ABirthDate: TDateTime);

   procedure LoadFromStream(Stream: TStream); override;

   procedure SaveToStream(Stream: TStream); override;

   propertyName: Stringread FName write FName;

   property BirthDate: TDateTime read FBirthDate write FBirthDate;

end;

TCompany = class(TStreamableObject)

private

   FName: String;

   FRevenues: Currency;

   FEmployeeCount: LongInt;

public

   constructor Create(const AName: string; ARevenues: Currency; AEmployeeCount: LongInt);

   procedure LoadFromStream(Stream: TStream); override;

   procedure SaveToStream(Stream: TStream); override;

   propertyName: Stringread FName write FName;

   property Revenues: Currency read FRevenues write FRevenues;

   property EmployeeCount: LongInt read FEmployeeCount write FEmployeeCount;

end;

TStreamableList = class(TStreamableObject)

private

   FItems: TObjectList;

   function Get_Count: LongInt;

   function Get_Objects(Index: LongInt): TStreamableObject;

public

   constructor Create;

   destructor Destroy; override;

   function FindClass(const AClassName: String): TStreamableObjectClass;

   procedure Add(Item: TStreamableObject);

   procedure Delete(Index: LongInt);

   procedure Clear;

   procedure LoadFromStream(Stream: TStream); override;

   procedure SaveToStream(Stream: TStream); override;

   property Objects[Index: LongInt]: TStreamableObject read Get_Objects; default;

   property Count: LongInt read Get_Count;

end;

TForm1 = class(TForm)

   SaveButton: TButton;

   LoadButton: TButton;

   procedure SaveButtonClick(Sender: TObject);

   procedure LoadButtonClick(Sender: TObject);

   procedure FormCreate(Sender: TObject);

private

   { Private declarations }

public

   Path: String;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

resourcestring

DEFAULT_FILENAME = 'test.dat';

procedure TForm1.SaveButtonClick(Sender: TObject);

var

List: TStreamableList;

Stream: TStream;

begin

List := TStreamableList.Create;

try

   List.Add(TPerson.Create('Rick Rogers', StrToDate('05/20/68')));

   List.Add(TCompany.Create('Fenestra', 1000000, 7));

   Stream := TFileStream.Create(Path + DEFAULT_FILENAME, fmCreate);

   try

     List.SaveToStream(Stream);

   finally

     Stream.Free;

   end;

finally

   List.Free;

end;

end;

{ TPerson }

constructor TPerson.Create(const AName: string; ABirthDate: TDateTime);

begin

inherited Create;

FName := AName;

FBirthDate := ABirthDate;

end;

procedure TPerson.LoadFromStream(Stream: TStream);

begin

FName := ReadString(Stream);

FBirthDate := ReadDateTime(Stream);

end;

procedure TPerson.SaveToStream(Stream: TStream);

begin

WriteString(Stream, FName);

WriteDateTime(Stream, FBirthDate);

end;

{ TStreamableList }

procedure TStreamableList.Add(Item: TStreamableObject);

begin

FItems.Add(Item);

end;

procedure TStreamableList.Clear;

begin

FItems.Clear;

end;

constructor TStreamableList.Create;

begin

FItems := TObjectList.Create;

end;

procedure TStreamableList.Delete(Index: LongInt);

begin

FItems.Delete(Index);

end;

destructor TStreamableList.Destroy;

begin

FItems.Free;

inherited;

end;

function TStreamableList.FindClass(const AClassName: String): TStreamableObjectClass;

begin

Result :=  TStreamableObjectClass(Classes.FindClass(AClassName));

end;

function TStreamableList.Get_Count: LongInt;

begin

Result := FItems.Count;

end;

function TStreamableList.Get_Objects(Index: LongInt): TStreamableObject;

begin

Result := FItems[Index] as TStreamableObject;

end;

procedure TStreamableList.LoadFromStream(Stream: TStream);

var

StreamCount: LongInt;

I: Integer;

S: String;

ClassRef: TStreamableObjectClass;

begin

StreamCount := ReadLongInt(Stream);

for I := 0to StreamCount - 1do

begin

   S := ReadClassName(Stream);

   ClassRef := FindClass(S);

   Add(ClassRef.CreateFromStream(Stream));

end;

end;

procedure TStreamableList.SaveToStream(Stream: TStream);

var

I: Integer;

begin

WriteLongInt(Stream, Count);

for I := 0to Count - 1do

begin

   WriteClassName(Stream, Objects[I].ClassName);

   Objects[I].SaveToStream(Stream);

end;

end;

{ TStreamableObject }

constructor TStreamableObject.CreateFromStream(Stream: TStream);

begin

inherited Create;

LoadFromStream(Stream);

end;

function TStreamableObject.ReadClassName(Stream: TStream): ShortString;

begin

Result := ReadString(Stream);

end;

function TStreamableObject.ReadCurrency(Stream: TStream): Currency;

begin

Stream.Read(Result, SizeOf(Currency));

end;

function TStreamableObject.ReadDateTime(Stream: TStream): TDateTime;

begin

Stream.Read(Result, SizeOf(TDateTime));

end;

function TStreamableObject.ReadLongInt(Stream: TStream): LongInt;

begin

Stream.Read(Result, SizeOf(LongInt));

end;

function TStreamableObject.ReadString(Stream: TStream): String;

var

L: LongInt;

begin

L := ReadLongInt(Stream);

SetLength(Result, L);

Stream.Read(Result[1], L);

end;

procedure TStreamableObject.WriteClassName(Stream: TStream; const Value: ShortString);

begin

WriteString(Stream, Value);

end;

procedure TStreamableObject.WriteCurrency(Stream: TStream; const Value: Currency);

begin

Stream.Write(Value, SizeOf(Currency));

end;

procedure TStreamableObject.WriteDateTime(Stream: TStream; const Value: TDateTime);

begin

Stream.Write(Value, SizeOf(TDateTime));

end;

procedure TStreamableObject.WriteLongInt(Stream: TStream; const Value: LongInt);

begin

Stream.Write(Value, SizeOf(LongInt));

end;

procedure TStreamableObject.WriteString(Stream: TStream; const Value: String);

var

L: LongInt;

begin

L := Length(Value);

WriteLongInt(Stream, L);

Stream.Write(Value[1], L);

end;

{ TCompany }

constructor TCompany.Create(const AName: string; ARevenues: Currency;

AEmployeeCount: Integer);

begin

FName := AName;

FRevenues := ARevenues;

FEmployeeCount := AEmployeeCount;

end;

procedure TCompany.LoadFromStream(Stream: TStream);

begin

FName := ReadString(Stream);

FRevenues := ReadCurrency(Stream);

FEmployeeCount := ReadLongInt(Stream);

end;

procedure TCompany.SaveToStream(Stream: TStream);

begin

WriteString(Stream, FName);

WriteCurrency(Stream, FRevenues);

WriteLongInt(Stream, FEmployeeCount);

end;

procedure TForm1.LoadButtonClick(Sender: TObject);

var

List: TStreamableList;

Stream: TStream;

Instance: TStreamableObject;

I: Integer;

begin

Stream := TFileStream.Create(Path + DEFAULT_FILENAME, fmOpenRead);

try

   List := TStreamableList.Create;

   try

     List.LoadFromStream(Stream);

     for I := 0to List.Count - 1do

     begin

       Instance := List[I];

       if Instance is TPerson then

         ShowMessage(TPerson(Instance).Name);

       if Instance is TCompany then

         ShowMessage(TCompany(Instance).Name);

     end;

   finally

     List.Free;

   end;

finally

   Stream.Free;

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Path := ExtractFilePath(Application.ExeName);

end;

initialization

RegisterClasses([TPerson, TCompany]);

end.

Code:

unit UmbCollection;

interface

uses

Windows, Messages, SysUtils, Classes, contnrs;

type

TUmbCollectionItemClass = Classof TUmbCollectionItem;

TUmbCollectionItem = class(TCollectionItem)

private

   FPosition: Integer;

public

   {when overriding this method, you must call the inherited assign.}

   procedure Assign(Source: TPersistent); Override;

published

   {the position property is used by the streaming mechanism to place the object in the

   right position when reading the items. do not use this property.}

   property Position: Integer read FPosition write FPosition;

end;

TUmbCollection = class(TObjectList)

private

   procedure SetItems(Index: Integer; Value: TUmbCollectionItem);

   function GetItems(Index: Integer): TUmbCollectionItem;

public

   function Add(AObject: TUmbCollectionItem): Integer;

   function Remove(AObject: TUmbCollectionItem): Integer;

   function IndexOf(AObject: TUmbCollectionItem): Integer;

   function FindInstanceOf(AClass: TUmbCollectionItemClass; AExact: Boolean = True;

                                                 AStartAt: Integer = 0): Integer;

   procedure Insert(Index: Integer; AObject: TUmbCollectionItem);

   procedure WriteToStream(AStream: TStream); virtual;

   procedure ReadFromStream(AStream: TStream); virtual;

   property Items[Index: Integer]: TUmbCollectionItem read GetItems write SetItems; default;

published

   property OwnsObjects;

end;

implementation

{ TUmbCollection }

function ItemsCompare(Item1, Item2: Pointer): Integer;

begin

Result := TUmbCollectionItem(Item1).Position - TUmbCollectionItem(Item2).Position;

end;

function TUmbCollection.Add(AObject: TUmbCollectionItem): Integer;

begin

Result := inherited Add(AObject);

end;

function TUmbCollection.FindInstanceOf(AClass: TUmbCollectionItemClass;

AExact: Boolean; AStartAt: Integer): Integer;

begin

Result := inherited FindInstanceOf(AClass, AExact, AStartAt);

end;

function TUmbCollection.GetItems(Index: Integer): TUmbCollectionItem;

begin

Result := inherited Items[Index] as TUmbCollectionItem;

end;

function TUmbCollection.IndexOf(AObject: TUmbCollectionItem): Integer;

begin

Result := inherited IndexOf(AObject);

end;

procedure TUmbCollection.Insert(Index: Integer; AObject: TUmbCollectionItem);

begin

inherited Insert(Index, AObject);

end;

procedure TUmbCollection.ReadFromStream(AStream: TStream);

var

Reader: TReader;

Collection: TCollection;

ItemClassName: string;

ItemClass: TUmbCollectionItemClass;

Item: TUmbCollectionItem;

i: Integer;

begin

Clear;

Reader := TReader.Create(AStream, 1024);

try

   Reader.ReadListBegin;

   whilenot Reader.EndOfList do

   begin

     ItemClassName := Reader.ReadString;

     ItemClass := TUmbCollectionItemClass(FindClass(ItemClassName));

     Collection := TCollection.Create(ItemClass);

     try

       Reader.ReadValue;

       Reader.ReadCollection(Collection);

       for i := 0to Collection.Count - 1do

       begin

         item := ItemClass.Create(nil);

         item.Assign(Collection.Items[i]);

         Add(Item);

       end;

     finally

       Collection.Free;

     end;

   end;

   Sort(ItemsCompare);

   Reader.ReadListEnd;

finally

   Reader.Free;

end;

end;

function TUmbCollection.Remove(AObject: TUmbCollectionItem): Integer;

begin

Result := inherited Remove(AObject);

end;

procedure TUmbCollection.SetItems(Index: Integer; Value: TUmbCollectionItem);

begin

inherited Items[Index] := Value;

end;

procedure TUmbCollection.WriteToStream(AStream: TStream);

var

Writer: TWriter;

CollectionList: TObjectList;

Collection: TCollection;

ItemClass: TUmbCollectionItemClass;

ObjectWritten: arrayof Boolean;

i, j: Integer;

begin

Writer := TWriter.Create(AStream, 1024);

CollectionList := TObjectList.Create(True);

try

   Writer.WriteListBegin;

   {init the flag array and the position property of the TCollectionItem objects.}

   SetLength(ObjectWritten, Count);

   for i := 0to Count - 1do

   begin

     ObjectWritten[i] := False;

     Items[i].Position := i;

   end;

   {write the TCollectionItem objects. we write first the name of the objects class,

   then write all the object of the same class.}

   for i := 0to Count - 1do

   begin

     if ObjectWritten[i] then

       Continue;

     ItemClass := TUmbCollectionItemClass(Items[i].ClassType);

     Collection := TCollection.Create(ItemClass);

     CollectionList.Add(Collection);

     {write the items class name}

     Writer.WriteString(Items[i].ClassName);

     {insert the items to the collection}

     for j := i to Count - 1do

       if ItemClass = Items[j].ClassType then

       begin

         ObjectWritten[j] := True;

         (Collection.Add as ItemClass).Assign(Items[j]);

       end;

     {write the collection}

     Writer.WriteCollection(Collection);

   end;

finally

   CollectionList.Free;

   Writer.WriteListEnd;

   Writer.Free;

end;

end;

{ TUmbCollectionItem }

procedure TUmbCollectionItem.Assign(Source: TPersistent);

begin

if Source is TUmbCollectionItem then

   Position := (Source as TUmbCollectionItem).Position

else

   inherited;

end;

end.