kpcntn.pas

一个delphi中压缩的组件VCLZip

   {$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  (* Read the object name *)
 S.ReadBuffer(Name[0],1);
 S.ReadBuffer(Name[1],Ord(Name[0]));
  (* If Name is valid (registered)... *)
 Result:=CreateInstanceByName(Name,LoadProc);
  (* Then ask it to load itself *)
 CallStreamProc(Result,S,LoadProc);
end;

Procedure  WriteObjectToStream(Source:tObject; S:tStream);
Var R:tRegisterRec;
    Name:tClassName;
begin
 If Source<>nil
  then begin
   Name:=Source.ClassName;
   R:=GetRegistration(Name);
   If R=Nil
    then Raise EClassNotFound.CreateFmt('Source Class <%s> not registered',[Name]);
    (* First write out the object name *)
   S.WriteBuffer(Name,Length(Name)+1);
    (* And ask the object to write itself to S *)
   CallStreamProc(Source,S,R.DoStore); (* S now contains Source *)
  end
 else Raise EClassNotFound.Create('Nil Source Class!');
end;


(**************************************************************************)
Constructor tObjectList.Create;
begin
 Inherited Create;
 FCount:=0;
 FCapacity:=0;
 FDestroy:=True;
end;

Constructor tObjectList.CreateWithOptions(DestroyObjects:Boolean; InitialCapacity:tOLSize);
begin
 Create;
 FDestroy:=DestroyObjects;
 SetCapacity(InitialCapacity);
end;

Constructor tObjectList.CreateFromStream(const FileName: string);
begin
 Create;
 LoadFromStream(FileName);
end;

destructor tObjectList.Destroy;
begin
 FreeAll;
 Clear;
 Inherited Destroy;
end;

function tObjectList.AddObject(Item: tObject): tOLSize;
begin
 Result := FCount;
 if Result = FCapacity
  then Grow;
 FList^[Result] := Item;
 Inc(FCount);
end;

(**************************************************)
(* Clear does not free it's objects. It's the same*)
(* as calling DeleteAll                           *)
(**************************************************)
procedure tObjectList.Clear;
begin
 SetCount(0);
 SetCapacity(0);
end;

(**************************************************)
(* To provide some kind of support of tWriter &   *)
(* tReader classes.     Not yet tested            *)
(**************************************************)
procedure tObjectList.DefineProperties(Filer: TFiler);
begin
 Filer.DefineBinaryProperty('ObjectContainer', ReadData, WriteData, FCount>0);
end;

(**************************************************)
(* Add stream content to existing items           *)
(**************************************************)
procedure tObjectList.ReadData(S: TStream);
Var ObjCount,
    Index:tOLSize;
begin
 S.ReadBuffer(FDestroy,SizeOf(FDestroy));
 S.ReadBuffer(ObjCount,SizeOf(Objcount));  (* Read in Object count *)
 If FCapacity-FCount<ObjCount
  then SetCapacity(FCount+ObjCount);

   (* Read in Object Count *)
 For Index:=0 to ObjCount-1
  do AddObject(ReadObjectFromStream(S));
end;

      (* Write list to Stream *)
procedure tObjectList.WriteData(S: TStream);

 Procedure WriteItem(ThisItem:tObject);{far;}
 begin
  WriteObjectToStream(ThisItem,S);
 end;
Var Index,
    ObjCount:tOlSize;
begin
 S.WriteBuffer(FDestroy,SizeOf(FDestroy));
 ObjCount:=FCount;
 S.WriteBuffer(ObjCount,SizeOf(ObjCount));
  For Index:=0 to FCount-1
  do WriteObjectToStream(Items[Index],S);
 {ForEach(@WriteItem);}
end;

(**************************************************)
(* Overwrite if Items are not objects             *)
(**************************************************)
Procedure tObjectList.FreeItem(AnItem:Pointer);
begin
 If FDestroy
  then tObject(AnItem).Free;
end;

procedure tObjectList.Delete(Index: tOLSize);
begin
 if (Index < 0) or (Index >= FCount)
  then Error;
 Dec(FCount);
 if Index < FCount
  then System.Move(FList^[Index+1],
                   FList^[Index],
                   (FCount-Index)*SizeOf(tObject));
end;

procedure tObjectList.DeleteAll;
begin
 Clear;
end;

procedure tObjectList.FreeAt(Index: tOLSize);
begin
 if (Index < 0) or (Index >= FCount) then Error;
 FreeItem(FList^[Index]);
 Delete(Index);
end;

procedure tObjectList.FreeAll;
 Procedure DoFree(AnItem:Pointer); far;
 begin
  FreeItem(AnItem);
 end;
 Var Index:tOLSize;
begin
 For Index:=0 to FCount-1
  do FreeItem(FList^[Index]);
{ ForEach(@DoFree);}
 Clear;
end;

Procedure tObjectList.FreeObject(Item: tObject);
begin
 try
  FreeAt(IndexOf(Item));
 Except on EListError do
   Raise EListError.CreateFmt('tObject %s not in item list',[Item.ClassName]);end;
end;

procedure tObjectList.Error;
begin
{$IFDEF DELPHI_BCB_3}    { added D3 support 5-26-97  KLB }
	raise EListError.Create(SListIndexError);            {  This is for Delphi & BCB version 3  }
{$ELSE}
	raise EListError.Create(LoadStr(SListIndexError));   { version 1 and 2 and BCB 1 }
{$ENDIF}
end;

function tObjectList.Get(Index: tOLSize): tObject;
begin
 if (Index < 0) or (Index >= FCount)
  then Error;
 Result := FList^[Index];
end;

procedure tObjectList.Grow;
Var Delta:tOLSize;
begin
 if FCapacity > 8
  then Delta := 16
  else if FCapacity > 4
        then Delta := 8
        else Delta := 4;
 SetCapacity(FCapacity+Delta);
end;

function tObjectList.IndexOf(Item: tObject): tOLSize;
begin
 Result := 0;
 while (Result < FCount) and (FList^[Result] <> Item)
  do Inc(Result);
 if Result = FCount
  then Result := -1;
end;

procedure tObjectList.Insert(Index: tOLSize; Item: tObject);
begin
 if (Index < 0) or (Index > FCount)
  then Error;
 if FCount = FCapacity
  then Grow;
 If FCount=0
  then FList^[0]:=Item
  else begin
   System.Move(FList^[Index], FList^[Index+1], (FCount-Index)*SizeOf(tObject));
   FList^[Index] := Item;
  end;
 Inc(FCount);
end;

function tObjectList.First: tObject;
begin
 Result:= Get(0);
end;

function tObjectList.Last: tObject;
begin
 Result := Get(FCount - 1);
end;
(**************************************************)
(* Call Next with a direction flag (forward=True  *)
(* or false. Returns Nil At end or at beginning   *)
(**************************************************)
(*
 O:=First
 repeat
  ...
  O:=Next(O,True);
 until O=Nil;
*)
Function    tObjectList.Next(Item:tObject; Forward:Boolean):tObject;
Const cDirection: Array[False..True] of Integer=(-1,1);
Var Index: tOLSize;
begin
 If Item=Nil
  then If Forward
        then result:=First
        else Result:=Last
  else begin
   Index:=IndexOf(Item);
   If Index>=0  (* If Object not found, Raise *)
    Then begin
     Index:=Index+cDirection[Forward];
     If (Index>=0) and (Index<FCount)
      then Result:=FList^[Index]
      else Result:=Nil;
    end
    else Raise EListError.CreateFmt('tObject %s not in item list',[Item.ClassName]);
  end;
end;

procedure tObjectList.Move(CurIndex, NewIndex: tOLSize);
var Item: tObject;
begin
 if CurIndex <> NewIndex
  then begin
   if (NewIndex < 0) or (NewIndex >= FCount)
    then Error;
   Item := Get(CurIndex);
   Delete(CurIndex);
   Insert(NewIndex, Item);
  end;
end;

procedure tObjectList.Put(Index: tOLSize; Item: tObject);
begin
 if (Index < 0) or (Index >= FCount)
  then Error;
 FList^[Index] := Item;
end;

procedure tObjectList.Pack;
var
  I: Integer;
begin
 for I := FCount - 1 downto 0
  do if Items[I] = nil
      then Delete(I);
end;

procedure tObjectList.SetCapacity(NewCapacity: tOLSize);
var NewList: pObjects;
begin
 if NewCapacity<>FCapacity
  then begin
   if (NewCapacity < FCount) or (NewCapacity>=cMaxList)
    then Error;
   if NewCapacity=0
    then NewList := nil
    else begin
     NewList:=Allocate(NewCapacity * SizeOf(tObject));
     if FCount<>0
      then System.Move(FList^, NewList^, FCount * SizeOf(tObject));
    end;
   if FCapacity<>0
    then FreeMem(FList, FCapacity * SizeOf(tObject));
   FList := NewList;
   FCapacity := NewCapacity;
  end;
end;

procedure tObjectList.SetCount(NewCount: tOLSize);
begin
 if (NewCount < 0) or (NewCount >= cMaxList)
  then Error;
 if NewCount > FCapacity
  then SetCapacity(NewCount);
 if NewCount > FCount
  then FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(tObject), 0);
 FCount := NewCount;
end;

(**************************************************)
(* Will create Filename and overwrite any existing*)
(* file of the same name                          *)
(**************************************************)
Procedure   tObjectList.SaveToStream(const FileName:String);
Var S:tFileStream;
begin
 S:=tFileStream.Create(FileName,fmCreate);
 try
  WriteData(S);
 Finally
  S.Free;
 end;
end;

(* LoadFromStream will add the Stream's content to it's current items *)
procedure   tObjectList.LoadFromStream(const FileName: string);
Var S:tFileStream;
begin
 S:=tFileStream.Create(FileName,fmOpenRead);
 try
  ReadData(S)
 Finally
  S.Free;
 end;
end;



(* These three methods where taken as is from the BP7 RTL
   the only change required was class name from tCollection
   to tObjectList and 32 bit support *)
procedure TObjectList.ForEach(Action: Pointer); assembler;
asm
{$IFDEF WINDOWS}
      LES     DI,Self
      MOV     CX,ES:[DI].TObjectList.FCount
      JCXZ    @@2
      LES     DI,ES:[DI].tObjectList.FList
@@1:  PUSH    ES
      PUSH    DI
      PUSH    CX
      PUSH    WORD PTR ES:[DI+2]
      PUSH    WORD PTR ES:[DI]
      MOV     AX,[BP]
      AND     AL,0FEH
      PUSH    AX
      CALL    Action
      POP     CX
      POP     DI
      POP     ES
      ADD     DI,4
{$ELSE} (* EAX = Self *)
        (* EDX = Action *)
      {$IFDEF Comp16_32Streams}
      Xor     ECX,ECX
      Mov     CX,[EAX].TObjectList.FCount
      {$ELSE}
      Mov     ECX,[EAX].TObjectList.FCount
      {$ENDIF}
      JCXZ    @@2