kpcntn.pas

一个delphi中压缩的组件VCLZip

      Mov     EDI,[EAX].TObjectList.FList
      Mov     ESI,EDX
@@1:  Push    ECX
      Push    EDI
      Push    EDX
      Push    EBP(* Set stack frame *)
      Mov     EAX, [EDI]    (* Current List item *)
      Call    EDX
      Pop     EBP
      Pop     EDX
      Pop     EDI
      Pop     ECX
      Add     EDI,4    (* Next Item *)
{$ENDIF}
      Loop    @@1
@@2:
End;



function tObjectList.FirstThat(Test: Pointer): tObject; 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    Test
        POP     CX
        POP     DI
        POP     ES
        OR      AL,AL
        JNE     @@3
        ADD     DI,4
        LOOP    @@1
@@2:    XOR     AX,AX
        MOV     DX,AX
        JMP     @@4
@@3:	  MOV	    AX,ES:[DI]
	     MOV	    DX,ES:[DI+2]
{$ELSE} (*    32 bit  *)
        (* EAX = Self *)
        (* EDX = Test *)
      {$IFDEF Comp16_32Streams}
      Xor     ECX,ECX
      Mov     CX,[EAX].TObjectList.FCount
      {$ELSE}
      Mov     ECX,[EAX].TObjectList.FCount
      {$ENDIF}
      JCXZ    @@2
      Mov     EDI,[EAX].TObjectList.FList
 (*     Mov     ESI,EDX*)
@@1:  Push    ECX
      Push    EDX           (* Bug fix. ESI/EDI could be zapped!! *)
      Push    EDI
      Push    EBP           (* Set stack frame *)
      Mov     EAX, [EDI]    (* Current List item *)
      Call    EDX
      Pop     EBP
      Pop     EDI
      Pop     EDX
      Pop     ECX
      Or      Al,Al    (* True result ? *)
      Jne     @@3
      Add     EDI,4    (* Next Item *)
      LOOP    @@1
@@2:
      Xor     EAX,EAX
      Jmp     @@4
@@3:  Mov     EAX, [EDI]    (* Current List item *)
{$ENDIF}
@@4:   
End;



function tObjectList.LastThat(Test: Pointer): tObject; assembler;
asm
{$IFDEF WINDOWS}
        LES     DI,Self
        MOV     CX,ES:[DI].tObjectList.FCount
        JCXZ    @@2
        LES     DI,ES:[DI].tObjectList.FList
        MOV     AX,CX
        SHL     AX,1
        SHL     AX,1
        ADD     DI,AX
@@1:    SUB     DI,4
        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       (* Set stack frame for Test *)
        CALL    Test
        POP     CX
        POP     DI
        POP     ES
        OR      AL,AL
        JNE     @@3
        LOOP    @@1
@@2:    XOR     AX,AX
        MOV     DX,AX
        JMP     @@4
@@3:	  MOV     AX,ES:[DI]
    	MOV	    DX,ES:[DI+2]
{$ELSE} (* EAX = Self *)
        (* EDX = Test *)
      {$IFDEF Comp16_32Streams}
      Xor     ECX,ECX
      Mov     CX,[EAX].TObjectList.FCount
      {$ELSE}
      Mov     ECX, [EAX].TObjectList.FCount
      {$ENDIF}
      JCXZ    @@2
      Mov     EDI,[EAX].TObjectList.FList
      Mov     EAX,ECX
      SHL     EAX,2
      Add     EDI,EAX
@@1:  Sub     EDI,4    (* preceding Item *)
      Push    ECX
      Push    EDX
      Push    EDI
      Push    EBP(* Set stack frame *)
      Mov     EAX, [EDI]    (* Current List item *)
      Call    EDX
      Pop     EBP
      Pop     EDI
      Pop     EDX
      Pop     ECX
      Or      Al,Al    (*  True result ? *)
      Jne     @@3
      LOOP    @@1
@@2:
      Xor     EAX,EAX
      Jmp     @@4
@@3:  Mov     EAX, [EDI]    (* Current List item *)
{$ENDIF}
@@4:
end;

Function  tObjectList.Allocate(Size:LongInt):Pointer;
begin
 GetMem(Result,Size);
end;


constructor TSortedObjectList.Create(WithDuplicates:TDuplicates);
begin
  inherited Create;
  FDuplicates:=WithDuplicates;
end;

procedure TSortedObjectList.ReadData(S:TStream);
begin
  S.ReadBuffer(FDuplicates,sizeof(FDuplicates));
  inherited ReadData(S);
end;

procedure TSortedObjectList.WriteData(S:TStream);
begin
  S.WriteBuffer(FDuplicates,sizeof(FDuplicates));
  inherited WriteData(S);
end;

Function TSortedObjectList.AddObject(Item: tObject): tOLSize;
Var Position:tOLSize;
begin
 Position := 0;
 Insert(Position, Item);
 Result := Position;
end;

{ ignores the Index-Value! }
procedure TSortedObjectList.Insert(Index: tOLSize; Item: tObject);
begin
  If Search(KeyOf(Item),Index)
   then Case FDuplicates of
         DupIgnore: Exit;
         DupError : Raise EListError.Create('Duplicate Object index');
        end;
  inherited Insert(Index,Item);
end;


function TSortedObjectList.KeyOf(Item:TObject):Pointer;
begin
  Result:=Item;
end;

function TSortedObjectList.IndexOf(Item: tObject): tOLSize;
begin
 If not Search(KeyOf(Item),Result)
  then Result:=-1;
end;

function TSortedObjectList.Search(Key:Pointer; var Index:tOLSize):boolean;
var
  L, H, I, C: tOLSize;
begin
  Result := False;
  L := 0;
  H := Count - 1;
  while L <= H do
  begin
    I := (L + H) shr 1;
    C := Compare(KeyOf(Items[I]), Key);
    if C < 0 then L := I + 1 else
    begin
      H := I - 1;
      if C = 0 then
      begin
        Result := True;
        if Duplicates<>dupAccept then L := I;
      end;
    end;
  end;
  Index := L;
end;

procedure TSortedObjectList.Put(Index: tOLSize; Item: tObject);
begin
 Raise EListError.Create('Cannot <Put> an Object in a sorted list!');
end;


            (* tAbsMemStream *)
{$IFDEF WINDOWS}
procedure __AHSHIFT; far; external 'KERNEL' index 113;
function OffsetPointer(P: Pointer; Ofs: Longint): Pointer; assembler;
asm
        MOV     AX,Ofs.Word[0]
        MOV     DX,Ofs.Word[2]
        ADD     AX,P.Word[0]
        ADC     DX,0
        MOV     CX,OFFSET __AHSHIFT
        SHL     DX,CL
        ADD     DX,P.Word[2]
end;
{$ENDIF}
Constructor tAbsMemStream.Create(UseBuf:Pointer; MaxSize:LongInt);
begin
 Inherited Create;
 FMemory:=UseBuf;
 FSize:=MaxSize;
 FPosition := 0;
end;

function tAbsMemStream.Read(var Buffer; Count: Longint): Longint;
begin
 if (FPosition >= 0) and (Count >= 0) then
 begin
  Result := FSize - FPosition; (* Remaining buffer *)
  if Result >= Count
   then Result:=Count
   else Raise EStreamError.Create('MemStream reading behond limits');
  {$IFDEF WINDOWS}
  hmemcpy(@Buffer, OffsetPointer(FMemory, FPosition), Result);
  {$ELSE}
  Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
  {$ENDIF}
  Inc(FPosition, Result);
 end
 else Result := 0;
end;

function tAbsMemStream.Write(const Buffer; Count: Longint): Longint;
var Pos: Longint;
begin
 if (FPosition >= 0) and (Count >= 0)
  then begin
   Pos := FPosition + Count; (* Ending FPosition *)
   If (Pos>=FSize)
    then Raise EStreamError.Create('MemStream writing behond limits');
   {$IFDEF WINDOWS}
   hmemcpy(OffsetPointer(FMemory, FPosition), @Buffer, Count);
   {$ELSE}
    System.Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count);
   {$ENDIF}
   FPosition := Pos;
   Result := Count;
  end
 else Result := 0;
end;

function tAbsMemStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
 case Origin of
   0: FPosition := Offset;
   1: Inc(FPosition, Offset);
   2: FPosition := FSize - Offset;
 end;
 If (FPosition>FSize) Or (FPosition<0)
  then Raise EStreamError.Create('MemStream seeking behond limits');
 Result := FPosition;
end;

(*************************************************)
(*          Clipboard related                    *)
(*************************************************)
Function RegisterClipBoardType(const TypeName:String):Word;
Var Name:pChar;
begin
 GetMem(Name,Length(TypeName)+1);
 StrpCopy(Name,TypeName);
 Result:=RegisterClipBoardFormat(Name);
 FreeMem(Name,Length(TypeName)+1);
end;


function CopyObjectToClipboard(ClipType:word; Source:TObject):boolean;
var
  S:tMemoryStream;
  MemHandle:THandle;
  MemPtr:Pointer;
begin
  If Source<>nil
   then begin
    Result:=False;
      S:=tMemoryStream.Create;
    try
      WriteObjectToStream(Source,S);
      S.Seek(0,0);                       		 (* Rewind to beginning *)
      MemHandle:=GlobalAlloc(GHND,S.Size);  	{allocate memory }
      If MemHandle=0
       then raise EOutOfMemory.Create('Not enough memory to copy object to clipboard');
      MemPtr:=GlobalLock(MemHandle);
      S.Read(MemPtr^,S.Size);  		{ read in the stream contents into MemPtr}
      GlobalUnlock(MemHandle);
      if SetClipboardData(ClipType, MemHandle)=0
       then GlobalFree(MemHandle)
       else Result:=true;
     Finally  S.Free;
    end;
  end
 else Raise EClassNotFound.Create('Nil Source Class!');
end;

function PasteObjectFromClipboard(ClipType:word):TObject;
var
  MemHandle:THandle;
  clipData:Pointer;
  ClipSize:longint;
  S:TAbsMemStream;
begin
  Result:=Nil;
  MemHandle:=GetClipBoardData(ClipType);
  if MemHandle<>0 then
  begin
    ClipSize:=GlobalSize(MemHandle);
    ClipData:=GlobalLock(MemHandle);
    S:=tAbsMemStream.Create(ClipData,ClipSize);
    try
      Result:=ReadObjectFromStream(S);
    finally
      GlobalUnlock(MemHandle);
      S.Free;
    end;
  end;
end;

{$IFNDEF WIN32}
(*************************************************)
Procedure tContainExitProc; far;
Var Idx:Integer;
begin
 For Idx:=0 to ClassRegistry.Count-1
  do (ClassRegistry.Objects[Idx] as tRegisterRec).Free;
 ClassRegistry.Free;
end;
{$ENDIF}

(*************************************************)
               Initialization
(*************************************************)
 ClassRegistry:=tStringList.Create;
 ClassRegistry.Sorted:=True;
 ClassRegistry.Duplicates:=dupIgnore;
 {$IFNDEF WIN32}
 AddExitProc(tContainExitProc);
 {$ENDIF}

{$IFDEF WIN32}
(*************************************************)
 Finalization
(*************************************************)
 FIdx := 0;
 While FIdx < ClassRegistry.Count do
  begin
     (ClassRegistry.Objects[FIdx] as tRegisterRec).Free;
     Inc(FIdx);
  end;
 ClassRegistry.Free;
{$ENDIF}

end.