mmcmpman.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: [phone]                   =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 20.01.1998 - 18:00:00 $                                      =}
{========================================================================}
unit MMCmpMan;

{$I COMPILER.INC}

interface

uses
    MMObj,
    Classes;

type
    TMMFindUniqueName = procedure(Sender: TObject; C: TComponent; var Name: string) of object;

    {-- TMMCompManager --------------------------------------------------}
    TMMCompManager  = class(TMMNonVisualComponent)
    private
        FResult    : TComponent;
        FOwner     : TComponent;
        FParent    : TComponent;
        FOnFindName: TMMFindUniqueName;

        procedure   ComponentRead(C: TComponent);
        procedure   ReaderSetName(Reader: TReader; Component: TComponent; var Name: string );
    protected
        function    UniqueName(C: TComponent; Name: string): string;
        function    GetNewOwner: TComponent;
        function    GetNewParent: TComponent;
    public
        procedure   SaveComponent(Stream: TStream; C: TComponent);
        function    LoadComponent(Stream: TStream): TComponent;
        function    CloneComponent(C: TComponent): TComponent;
    published
        property    OnFindUniqueName: TMMFindUniqueName read FOnFindName write FOnFindName;
        property    Owner: TComponent read FOwner write FOwner;
        property    Parent: TComponent read FParent write FParent;
    end;

implementation

uses
    SysUtils;

{== TMMCompManager ======================================================}
procedure TMMCompManager.SaveComponent(Stream: TStream; C: TComponent);
var
    W: TWriter;
begin
    W := TWriter.Create(Stream,1024);
    try
       W.Root := C.Owner;
       W.WriteSignature;
       W.WriteComponent(C);
       W.WriteListEnd;
    finally
       W.Free;
    end;
end;

{-- TMMCompManager ------------------------------------------------------}
function TMMCompManager.LoadComponent(Stream: TStream): TComponent;
var
    R: TReader;
begin
    FResult := nil;
    R := TReader.Create(Stream,1024);
    try
       R.OnSetName := ReaderSetName;
       R.ReadComponents(GetNewOwner,GetNewParent,ComponentRead);
    finally
       R.Free;
    end;
    Result := FResult;
end;

{-- TMMCompManager ------------------------------------------------------}
function TMMCompManager.CloneComponent(C: TComponent): TComponent;
var
    S: TMemoryStream;
begin
    S := TMemoryStream.Create;
    try
       SaveComponent(S, C);
       S.Position := 0;
       Result := LoadComponent(S);
    finally
       S.Free;
    end;
end;

{-- TMMCompManager ------------------------------------------------------}
procedure TMMCompManager.ComponentRead(C: TComponent);
begin
    FResult := C;
end;

{-- TMMCompManager ------------------------------------------------------}
procedure TMMCompManager.ReaderSetName(Reader: TReader; Component: TComponent; var Name: string);
begin
    if (Reader.Root = GetNewOwner) and (GetNewOwner.FindComponent(Name) <> nil) then
        Name := UniqueName(Component,Name);
end;

{-- TMMCompManager ------------------------------------------------------}
function TMMCompManager.UniqueName(C: TComponent; Name: string): string;
var
    Base : string;
    i    : Integer;
    Sugg : string;
begin
    if assigned(FOnFindName) then
    begin
       FOnFindName(Self,C,Name);
       Result := Name;
    end
    else
    begin
       Base := Copy(C.ClassName,2,MaxInt);
       for i := 1 to MaxInt do
       begin
          Sugg := Base + IntToStr(i);
          if GetNewOwner.FindComponent(Sugg) = nil then
          begin
             Result := Sugg;
             Exit;
          end;
       end;
       { TODO: Should be resource id }
       raise Exception.Create('Not enough unique names');
    end;
end;

{-- TMMCompManager ------------------------------------------------------}
function TMMCompManager.GetNewOwner: TComponent;
begin
    if FOwner = nil then
       Result := inherited Owner
    else
       Result := FOwner;
end;

{-- TMMCompManager ------------------------------------------------------}
function TMMCompManager.GetNewParent: TComponent;
begin
    if FParent = nil then
       Result := GetNewOwner
    else
       Result := FParent;
end;

end.