kpcntn.pas

一个delphi中压缩的组件VCLZip

{**********************************************************************}
{ Unit archived using GP-Version                                       }
{ GP-Version is Copyright 1997 by Quality Software Components Ltd      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.qsc.u-net.com                                             }
{**********************************************************************}

{ $Log:  D:\Util\GP-Version\Archives\Components\VCLZip\Library\kpCntn.UFV 
{
{   Rev 1.2    7/9/98 6:47:21 PM  Supervisor
{ Version 2.13
{ 
{ 1) New property ResetArchiveBitOnZip causes each file's 
{ archive bit to be turned  off after being zipped.
{ 
{ 2) New Property SkipIfArchiveBitNotSet causes files 
{ who's archive bit is not set to be skipped during zipping 
{ operations.
{ 
{ 3) A few modifications were made to allow more 
{ compatibility with BCB 1.
{ 
{ 4) Modified how directory information is used when 
{ comparing filenames to be unzipped.  Now it is always 
{ used.
}
{
{   Rev 1.1    Mon 27 Apr 1998   17:32:53  Supervisor
{ Added BCB 3 support
}

{%keywords: tcontain.pas 1.4 March 21. 1996 03:25:09 PM%}
{%nokeywords%}
Unit kpCntn;
(**************************************************)
(* tObjectList is taken largely from BI's RTL     *)
(* modified to use & free tObjects and added      *)
(* persistant stream support &                    *)
(* emulation of BP7's tCollection iteration       *)
(* support with ForEach,FirstThat & LastThat      *)
(*                                                *)
(* This container class assumes all items are     *)
(* derived from tObject                           *)
(* Limit is still MaxListSize items, for now..    *)
(**************************************************)
(*    95/05   LPL Soft inc                        *)
(**************************************************)
(* This source code is freeware. Use as you wish, *)
(* but *YOU* are responsible! RD(LPL Soft)        *)
{*********  Parts from  ***************************}
{                                                  }
{  Delphi Visual Component Library                 }
{                                                  }
{  Copyright (c) 1995 Borland International        }
{                                                  }
{**************************************************}
(* Send bug reports (with reproducable source)    *)
(*    LPL Soft : Robert Daignault                 *)
(*    Compuserve: 70302,1653                      *)
(*                                                *)
(**************************************************)
(*                History                         *)
(**************************************************)
(* 95/07/09 Fixed: FDestroy was not written/read  *)
(*                to/from stream in Read/WriteData*)
(*          Added: CopyOf Function. Copy instance *)
(*                of any registered object        *)
(*          Changed: Put all streaming Asm code in*)
(*                one procedure (CallStreamProc)  *)
(**************************************************)
(* 95/07/15 Added: Thomas's tSortedObjectList     *)
(**************************************************)
(* 95/07/25 Changed: Renamed RegisterClass        *)
(**************************************************)
(* 95/07/29 Added: Absolute memory stream object  *)
(*                moved to this unit              *)
(**************************************************)
(* 95/08/24 Added: ReadFromStream & WriteToStream *)
(*                procedures. Enables use of raw  *)
(*                streams (No need of lists).     *)
(**************************************************)
(* 95/08/28 Added: Clipboard support functions    *)
(**************************************************)
(* 96/03/01 Added:   Partial Support for Delphi 32*)
(*                   Read/write compatible streams*)
(*                   between Delphi 1 & 2         *)
(*                   Under Delphi32, maximum items*)
(*                   in list raised to 64K items  *)
(* Not yet done: Iterators ForEach, FirstThat and *)
(*               LastThat. Will need a real debug-*)
(*               ger for these. Just ordered today*)
(**************************************************)
(**************************************************)
(* 96/03/14 Added:   Full Support for Delphi 32   *)
(**************************************************)
(* 96/03/21 Fixed: Asm Iterators where dependant  *)
(*                on called proc not to modify    *)
(*                registers (EDX,EDI). They worked*)
(*                with my test samples (to simple)*)
(**************************************************)
                interface
(**************************************************)
Uses
{$IFDEF WIN32}
  Windows,
{$ELSE}
  WinProcs, WinTypes,
{$ENDIF}
 {$IFDEF VER140}
  RTLConsts,
{$ENDIF}
{$IFDEF VER150}
  RTLConsts,
{$ENDIF}
 Classes, SysUtils;

const

(* Remove 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 VER100}
  {$DEFINE DELPHI_BCB_3}      { Delphi 3 }
{$ENDIF}
{$IFDEF VER110}               { BCB 3    }
  {$DEFINE DELPHI_BCB_3}
{$ENDIF}
{$IFDEF VER125}               { BCB 4    }
  {$DEFINE DELPHI_BCB_3}
{$ENDIF}
{$IFDEF VER120}               { Delphi 4 }
  {$DEFINE DELPHI_BCB_3}
{$ENDIF}
{$IFDEF VER130}               { Delphi 5 }
  {$DEFINE DELPHI_BCB_3}
{$ENDIF}
{$IFDEF VER140}               { Delphi 6 }
  {$DEFINE DELPHI_BCB_3}
{$ENDIF}
{$IFDEF VER150}               { Delphi 7 }
  {$DEFINE DELPHI_BCB_3}
{$ENDIF}

{$IFDEF WIN32}
 {$IFDEF Comp16_32Streams}
   cMaxList=$4000;
 {$ELSE}
   cMaxList=$1FFFFFFF; { 7/10/00 2.21b3+ }  (* 32 bit only operation : 64K objects. Could be much more ... *)
 {$ENDIF}
{$ELSE}
 cMaxList=MaxListSize;
 {$UNDEF Comp16_32Streams} (* Never defined in 16 bit mode *)
{$ENDIF}

type
 {$IFDEF Comp16_32Streams}
   tOLSize=SmallInt;
 {$ELSE}
   tOLSize=Integer;
 {$ENDIF}

 pObjects = ^tObjects;
 TObjects = array[0..cMaxList - 1] of pointer{tObject};
 TObjectList = class(TPersistent)
  private
    FDestroy : Boolean;
    FList    : pObjects;
    FCount   ,
    FCapacity: tOLSize;

    (*****************) protected {procedures *****************}
    procedure Error; virtual;
    procedure Grow; virtual;
    procedure Put(Index: tOLSize; Item: tObject);virtual;
    function  Get(Index: tOLSize): tObject;
    procedure SetCapacity(NewCapacity: tOLSize);
    procedure SetCount(NewCount: tOLSize);
    Function  Allocate(Size:LongInt):Pointer;
    Procedure FreeItem(AnItem:Pointer); virtual;
    (*****************) Public {procedures *****************}
    Constructor Create;
    Constructor CreateWithOptions(DestroyObjects:Boolean; InitialCapacity:tOLSize);
    destructor  Destroy; override;

    function    AddObject(Item: tObject): tOLSize; virtual;

    (* Clear and Delete are identical. They do not Free each object *)
    procedure   Clear; virtual;
    procedure   Delete(Index: tOLSize);
    Procedure   DeleteAll;

    (* Free procedures first destroy tObjects and then call Delete procedures*)
    Procedure   FreeAll;
    Procedure   FreeAt(Index:tOLSize);
    Procedure   FreeObject(Item: tObject);

    function    IndexOf(Item: tObject): tOLSize; virtual;
    procedure   Insert(Index: tOLSize; Item: tObject); virtual;
    procedure   Move(CurIndex, NewIndex: tOLSize);
    procedure   Pack;

    (***************** Streaming support *****************)
    Constructor CreateFromStream(const FileName: string);

    Procedure   SaveToStream(const FileName:String);
    procedure   LoadFromStream(const FileName: string);
    procedure   ReadData(S: TStream); virtual;
    procedure   WriteData(S: TStream); virtual;
    procedure   DefineProperties(Filer: TFiler); override;


    (***************** Iteration procedures **************)
    function    First: tObject; virtual;
    function    Last: tObject; virtual;
    Function    Next(Item:tObject; Forward:Boolean):tObject; virtual;

         (* Action will be called Count times, each with*)
         (* one of its contained tObject                *)
    (* Procedure Action(AnObject:YourClass); far; *)
    procedure   ForEach(Action: Pointer);

    (* Function Test(AnObject:YourClass):Boolean; far; *)
    function    LastThat(Test: Pointer): tObject;
    function    FirstThat(Test: Pointer): tObject;


   (*           ForEach, FirstThat and LastThat iterators
          These work exactly like BP7's tCollection methods.

              These methods will call their Action or test
             parameters for each tObject it contains.
             All Iterators assume that Action and test are
             <embedded procedures> or functions declared with
             the far attribute. Forgetting to put the far
             attribute will cause a GPF (Delphi 16 bit only). 
             Note that there is no type checking done by the 
             compiler on either the procedure type or the 
             parameters to Test and Action.
   *)

         (* FirstThat and LastThat stop the iteration when Test *)
         (* returns TRUE.These functions return the object that *)
         (* caused the iteration to stop. The differ only in the*)
         (* Iteration order. LastThat processes the list in     *)
         (* reverse order                                       *)

    (*****************  Properties  **************)
    property    Capacity: tOLSize read FCapacity write SetCapacity;
    property    Items[Index: tOLSize]: tObject read Get write Put; default;
    property    Count:tOLSize read FCount;
    Property    DestroyObjects:Boolean read FDestroy write FDestroy;
  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;

    (*****************  Properties  **************)
    Property Position:LongInt read FPosition;
    Property Memory:Pointer read FMemory;
    Property Size: Longint read FSize;
  end;



(*************************************************)
(* Thanks to Thomas Roehrich, for the following. *)
(*************************************************)

  TSortedObjectList=class(TObjectList)
  private
    FDuplicates:TDuplicates;
  protected
    function  KeyOf(Item:TObject):Pointer;virtual;
    procedure Put(Index: tOLSize; Item: tObject); override;
  public
    constructor Create(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;


             (* 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!  *)
(*************************************************)
(* Thanks to Thomas Roehrich, for the following. *)
(*************************************************)
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;

var
  FIdx: Integer;

type
 tClassName=String[63];

 tRegisterRec=Class(tObject)
  Obj:tClass; (* Class type *)
  DoLoad,
  DoStore :Pointer{TStreamProc}; (* This is a pointer because otherwise
                              a class instance would be required to register*)
  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
   {$IFDEF WINDOWS}
    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  (* Jmp ??? *)