mmobjlst.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 MMObjLst;

{$I COMPILER.INC}

{*********  Parts from  ****************************}
{                                                   }
{  Delphi Visual Component Library                  }
{                                                   }
{  Copyright (c) 1995 Borland International         }
{                                                   }
{***************************************************}
(* Send bug reports (with reproducable source)     *)
(*    LPL Soft : Robert Daignault                  *)
(*    Compuserve: 70302,1653                       *)
(*                                                 *)
(***************************************************)

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    Classes,
    SysUtils,
    MMObj;

const
{ Remmove the following comment if you don't need 16/32 bit stream       }
{ compatability In that case, the default list size is 64K objects.      }
{ To change, simply edit the cMaxList constant for 32 bit only operation }

{$DEFINE Comp16_32Streams}

{$IFDEF WIN32}
 {$IFDEF Comp16_32Streams}
   cMaxList = MaxListSize;
 {$ELSE}
   cMaxList = $FFFE;   { 32 bit only operation : 64K objects }
 {$ENDIF}
{$ELSE}
   cMaxList = MaxListSize;
{$ENDIF}
   STREAMKENNUNG : Longint = $004A424F; { 'OBJ ' }

type
{$IFDEF WIN32}
 {$IFDEF Comp16_32Streams}
   TOLSize = SmallInt;
 {$ELSE}
   TOLSize = integer;   { 32 bit only operation : 64K objects }
 {$ENDIF}
{$ELSE}
   TOLSize = integer;
{$ENDIF}

 PObjects    = ^TObjects;
 TObjects    = array[0..cMaxList-1] of Pointer;

 {-- TObjectList --------------------------------------------------------}
 TObjectList = class(TMMObject)
 private
    FDestroy    : Boolean;
    FList       : PObjects;
    FCount      : TOLSize;
    FCapacity   : TOLSize;

 protected
    procedure Error; virtual;
    procedure Grow; virtual;
    procedure Put(Index: TOLSize; Item: TObject);virtual;
    function  Get(Index: TOLSize): TObject; virtual;
    procedure SetCapacity(NewCapacity: TOLSize);
    procedure SetCount(NewCount: TOLSize);
    Function  Allocate(Size: LongInt): Pointer;
    Procedure FreeItem(AnItem: Pointer); virtual;

    procedure ReadData(S: TStream); virtual;
    procedure WriteData(S: TStream); virtual;
    procedure DefineProperties(Filer: TFiler); override;

 public
    constructor Create; virtual;
    constructor CreateWithOptions(DestroyObjects: Boolean; InitialCapacity: TOLSize);
    destructor  Destroy; override;

    function    AddObject(Item: TObject): TOLSize; virtual;
    procedure   AddObjects(Objects: TObjectList); virtual;

    { Clear and Delete are identical. They do not Free each object }
    procedure   Clear; virtual;
    procedure   Delete(Index: TOLSize);
    procedure   DeleteAll;

    function    Remove(Item: TObject): TOLSize;

    { Free procedures first destroy tObjects and then call Delete procedures }
    procedure   FreeAll; virtual;
    procedure   FreeAt(Index: TOLSize);
    procedure   FreeObject(Item: TObject);

    function    First: TObject;
    function    Last: TObject;

    function    IndexOf(Item: TObject): TOLSize; virtual;
    procedure   Insert(Index: TOLSize; Item: TObject); virtual;
    procedure   Move(CurIndex, NewIndex: TOLSize);
    procedure   Exchange(Index1, Index2: TOLSize);
    procedure   Pack;

    constructor CreateFromFile(const FileName: string);
    procedure   SaveToFile(const FileName:String);
    procedure   LoadFromFile(const FileName: string);

    property OnChange;
    property OnChanging;

    property DestroyObjects: Boolean read FDestroy write FDestroy;
    property Capacity: TOLSize read FCapacity write SetCapacity;
    property Count: TOLSize read FCount;
    property Items[Index: TOLSize]: TObject read Get write Put; {$IFDEF WIN32}default;{$ENDIF}
  end;

  {-- TSortedObjectList -------------------------------------------------}
  TSortedObjectList = class(TObjectList)
  private
    FDuplicates: TDuplicates;

  protected
    function  KeyOf(Item: TObject): Pointer; virtual;
    procedure Put(Index: TOLSize; Item: TObject); override;

  public
    constructor CreateEx(WithDuplicates: TDuplicates);

    procedure ReadData(S: TStream); override;
    procedure WriteData(S: TStream); override;
    function  Compare(Key1, Key2: Pointer): integer; virtual; abstract;
    function  AddObject(Item: TObject): TOLSize; override;
    function  Search(Key: Pointer; var Index: TOLSize): Boolean;virtual;
    procedure Insert(Index: tOLSize; Item: TObject); override;
    function  IndexOf(Item: TObject): TOLSize; override;

    property  Items[Index: TOLSize]: TObject read Get;
    property  Duplicates: TDuplicates read FDuplicates;
  end;

  { Specialized memory Stream. Will Stream to a fixed memory buffer }
  { Mainly used when storing objects into a Object database record  }
  { NOTE: the memory is not freed. That is your job!                }
  { An exception will be raised if an operation causes the stream   }
  { position to go behond it's max size                             }
  TAbsMemStream = class(TStream)
  private
    FMemory: Pointer;
    FSize,
    FPosition: Longint;
  public
    Constructor Create(UseBuf: Pointer; MaxSize: LongInt);

    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;

    property Position: LongInt read FPosition;
    property Memory: Pointer read FMemory;
    property Size: Longint read FSize;
  end;

{ Streaming registration support }
Procedure  DoRegisterClass(const LoadProc,StoreProc:Pointer;Sender:tClass);
Function   IsRegistered(AClass:tClass):Boolean;

(******************************************************)
(* Misc. Usefull tools enabled by registering classes *)
(******************************************************)
Procedure  WriteObjectToStream(Source: TObject; S: TStream);
Function   ReadObjectFromStream(S: TStream): TObject;

(* CopyOf creates and returns a new instance of Source *)
Function   CopyOf(Source: TObject): TObject;

(*******************************************************)
(* Clipboard related functions. Cut & paste tObjects!  *)
(*******************************************************)
Function RegisterClipBoardType(const TypeName:String):Word;
  (* Use the result of RegisterClipBoardType as the ClipType
    Parameter to the 2 following procedures   *)
Function CopyObjectToClipboard(ClipType: Word; Source: TObject): Boolean;
Function PasteObjectFromClipboard(ClipType: Word): TObject;

{========================================================================}
implementation
{========================================================================}
Uses
    Consts
    {$IFDEF DELPHI6}
    ,RTLConsts
    {$ENDIF}
    ;

type
    TClassName = String[63];

    TRegisterRec = class(TObject)
      Obj: TClass; { Class type }
      { This is a pointer because otherwise a
         class instance would be required to register }
      DoLoad,
      DoStore : Pointer;
      Constructor Create(aClass: TClass; Loader, Storer: Pointer);
 end;

var
   ClassRegistry: TStringList;

{========================================================================}
constructor TRegisterRec.Create(aClass: TClass; Loader, Storer:Pointer);
begin
   inherited Create;
   Obj := aClass;
   DoLoad := Loader;
   DoStore := Storer;
end;

{========================================================================}
procedure DoRegisterClass(const LoadProc,StoreProc:Pointer;Sender:TClass);
begin
   ClassRegistry.AddObject(Sender.ClassName,
                 TRegisterRec.Create(Sender,LoadProc,StoreProc));
end;

{========================================================================}
function IsRegistered(aClass: TClass): Boolean;
Var
   Index: Integer;

begin
   Result := ClassRegistry.Find(aClass.ClassName,Index);
end;

{========================================================================}
function GetRegistration(aName: TClassName): TRegisterRec;
Var
   Index: Integer;

begin
   with ClassRegistry do
   if Find(aName,Index) then
      Result := TRegisterRec(Objects[Index])
   else
      Result := nil;
end;

{========================================================================}
function CreateInstanceByName(const Name: TClassName; var Loader: Pointer): TObject;
var
   R: TRegisterRec;

begin
   R := GetRegistration(Name);
   If R <> nil then
   begin
      Result := R.Obj.Create;
      Loader := R.DoLoad;
   end
   else raise EClassNotFound.CreateFmt('Class <%s> not registered',[Name]);
end;

{========================================================================}
procedure CallStreamProc(Obj: TObject; S: TStream; SProc: Pointer);
begin
   asm
      {$IFNDEF WIN32}
      les    di,S
      push   es
      push   di
      les    di,Obj
      push   es
      push   di
      call   DWord ptr SProc; { Call Obj's Load or Store proc }
      {$ELSE}
      {  In delphi32 : using registers calling
      EAX = pointer to Obj
      EDX = pointer to S
      ECX = SProc }
      call   ecx
      {$ENDIF}
   end;
end;

{========================================================================}
function CopyOf(Source: TObject): TObject;
Var
   S: TMemoryStream;

begin
   if Source <> nil then 
   begin
      S := TMemoryStream.Create;
      try
         WriteObjectToStream(Source,S);
         S.Seek(0,0);    { Rewind to beginning }
         Result := ReadObjectFromStream(S);
      finally
        S.Free;
      end;
   end
   else raise EClassNotFound.Create('Nil Source Class!');
end;

{========================================================================}
function ReadObjectFromStream(S: TStream): TObject;
var
   Name: TClassName;
   LoadProc: Pointer;
begin