unit pcTree;

interface

uses classes, pcList;

type
  TpcTree = class;

  TpcTreeItem = ^RpcTreeItem;
  RpcTreeItem = record
    Parent : TpcTreeItem;
    Data : pointer;
    List : TpcList;
  end;

  TIterProc = procedure(Item : TpcTreeItem; Index : integer; var ContinueIterate : boolean;
    IterateData : pointer);

  TItemSaveEvent = procedure(Sender : TObject; Item : TpcTreeItem; Stream : TStream) of object;

  TpcTreeItemDelete = procedure(Sender : TObject; Item : TpcTreeItem; Data : pointer) of object;

  TpcTree = class
  private
    FRoot : TpcTreeItem;
    FCount : integer;
    FOnItemSave : TItemSaveEvent;
    FOnItemLoad : TItemSaveEvent;
    FOnItemDelete : TpcTreeItemDelete;
    function GetItem(index : integer) : TpcTreeItem;
  protected
    procedure TriggerItemSaveEvent(Item : TpcTreeItem; Stream : TStream); virtual;
    procedure TriggerItemLoadEvent(Item : TpcTreeItem; Stream : TStream); virtual;
    procedure TriggerItemDeleteEvent(Item : TpcTreeItem; Data : pointer); virtual;
  public
    constructor Create;
    destructor Destroy; override;
    function AddItem(Parent : TpcTreeItem; Value : pointer) : TpcTreeItem;
    function InsertItem(Parent : TpcTreeItem; Index : integer; Value : pointer) : TpcTreeItem;
    procedure DeleteItem(Item : TpcTreeItem);
    procedure MoveTo(Item, NewParent : TpcTreeItem);
    procedure Clear;
    function GetIndex(Item : TpcTreeItem) : Integer;
    function GetAbsIndex(Item : TpcTreeItem) : Integer;
    procedure Iterate(IterateProc : TIterProc; IterateData : pointer);
    procedure SaveToStream(Stream : TStream); virtual;
    procedure LoadFromStream(Stream : TStream); virtual;
    procedure SaveSubTreeToStream(Item : TpcTreeItem; Stream : TStream); virtual;
    procedure LoadSubTreeFromStream(Item : TpcTreeItem; Stream : TStream); virtual;
    property Count : Integer read FCount; { Public }
    property Item[index : integer] : TpcTreeItem read GetItem; { Public }
    property OnItemSave : TItemSaveEvent read FOnItemSave write FOnItemSave;
    property OnItemLoad : TItemSaveEvent read FOnItemLoad write FOnItemLoad;
    property OnItemDelete : TpcTreeItemDelete read FOnItemDelete write FOnItemDelete;
    property Root : TpcTreeItem read FRoot;
  end;

{Binary Tree}

TBTree = class
  private
    froot: String;
    fRTree: TBTree;
    fLTree: TBTree;
  public
   property Root:String read froot;
   constructor Create(ACaption:String);
   property  L:TBTree read fLTree write fLTree;
   property  R:TBTree read fRTree write fRTree;
 end;

implementation

procedure TpcTree.Iterate(IterateProc : TIterProc; IterateData : pointer);
var
  j : integer;
  DoContinue : boolean;

  procedure IntIterate(Item : TpcTreeItem);
  var
    i : integer;
  begin
    inc(j);
    if j >= 0 then IterateProc(Item, j, DoContinue, IterateData);
    if not (DoContinue) then exit;
    for i := 0 to Item^.List.Count - 1 do
    begin
      IntIterate(TpcTreeItem(Item.List[i]));
      if not (DoContinue) then exit;
    end;
  end;

begin
  j := -2;
  DoContinue := true;
  IntIterate(FRoot);
end;

function TpcTree.GetItem(index : integer) : TpcTreeItem;
type
  PGIRec = ^TGIRec;
  TGIRec = record
    j : integer;
    TSI : TpcTreeItem;
  end;
var
  GIRec : TGIRec;

  procedure IntGetItem(Item : TpcTreeItem; Index : integer; var ContinueIterate : boolean;
    IterateData : pointer);
  begin
    if Index = PGIRec(IterateData)^.j then
    begin
      PGIRec(IterateData)^.TSI := Item;
      ContinueIterate := false;
    end;
  end;

begin
  if (index < 0) or (index >= FCount) then
  begin
    result := nil;
    exit;
  end;
  GIRec.TSI := nil;
  GIRec.j := index;
  Iterate(@IntGetItem, @GIRec);
  result := GIRec.TSI;
end;

function TpcTree.AddItem(Parent : TpcTreeItem; Value : pointer) : TpcTreeItem; { public }
var
  TI : TpcTreeItem;
begin
  New(TI);
  TI^.List := TpcList.Create;
  TI^.Data := Value;
  if Parent = nil then
    FRoot^.List.Add(TI)
  else
    Parent^.List.Add(TI);
  if Parent = nil then
    TI^.Parent := FRoot
  else
    TI^.Parent := Parent;
  result := ti;
  inc(FCount);
end; { AddItem }

function TpcTree.InsertItem(Parent : TpcTreeItem; Index : integer; Value : pointer) : TpcTreeItem; { public }
var
  TI : TpcTreeItem;
begin
  New(TI);
  TI^.List := TpcList.Create;
  TI^.Data := Value;
  if Parent = nil then
  begin
    FRoot^.List.Insert(index, TI);
    TI^.Parent := FRoot;
  end
  else
  begin
    Parent^.List.Insert(Index, TI);
    TI^.Parent := Parent;
  end;
  result := ti;
  inc(FCount);
end; { InsertItem }

procedure TpcTree.DeleteItem(Item : TpcTreeItem); { public }
begin
  if (Item = nil) then exit;
  while Item^.List.Count > 0 do
    DeleteItem(Item^.List[0]);
  Item^.List.Free;
  Item^.Parent^.List.Remove(Item);
  TriggerItemDeleteEvent(Item, Item^.Data);
  Dispose(Item);
  dec(FCount);
end; { DeleteItem }

procedure TpcTree.Clear; { public }
begin
  while FRoot^.List.Count > 0 do
    DeleteItem(FRoot^.List[0]);
end; { Clear }

procedure TpcTree.MoveTo(Item, NewParent : TpcTreeItem); { public }
begin
  if Item = nil then exit;
  Item^.Parent.List.Remove(Item);
  if NewParent = nil then NewParent := FRoot;
  NewParent^.List.Add(Item);
  Item^.Parent := NewParent;
end; { MoveTo }

function TpcTree.GetIndex(Item : TpcTreeItem) : Integer; { public }
begin
  result := Item^.Parent^.List.IndexOf(Item);
end; { GetIndex }

function TpcTree.GetAbsIndex(Item : TpcTreeItem) : Integer; { public }
type
  PGIRec = ^TGIRec;
  TGIRec = record
    j : integer;
    TSI : TpcTreeItem;
  end;
var
  GIRec : TGIRec;

  procedure IntGetIndex(Item : TpcTreeItem; Index : integer; var ContinueIterate : boolean;
    IterateData : pointer);
  begin
    if PGIRec(IterateData)^.TSI = Item then
    begin
      PGIRec(IterateData)^.j := index;
      ContinueIterate := false;
    end;
  end;

begin
  if Item = nil then
  begin result := -1;
    exit;
  end;
  GIRec.j := -1;
  GIRec.TSI := Item;
  Iterate(@IntGetIndex, @GIRec);
  result := GIRec.j;
end;

procedure TpcTree.SaveToStream(Stream : TStream); { public }
begin
  SaveSubTreeToStream(FRoot, Stream);
end; { SaveToStream }

procedure TpcTree.LoadFromStream(Stream : TStream); { public }
begin
  LoadSubTreeFromStream(FRoot, Stream);
end; { LoadFromStream }

procedure TpcTree.SaveSubTreeToStream(Item : TpcTreeItem; Stream : TStream);

  procedure IntSave(Item : TpcTreeItem; Stream : TStream; Tree : TpcTree);
  var
    i, j : integer;
  begin
    i := Item^.List.Count;
    Stream.WriteBuffer(i, sizeof(integer));
    if (Item <> Tree.FRoot) then
      Tree.TriggerItemSaveEvent(Item, Stream);
    for j := 0 to i - 1 do
      IntSave(TpcTreeItem(Item^.List[j]), Stream, Tree);
  end;

begin
  if Item = nil then Item := FRoot;
  IntSave(Item, Stream, self);
end;

procedure TpcTree.LoadSubTreeFromStream(Item : TpcTreeItem; Stream : TStream);

  procedure IntLoad(Item : TpcTreeItem; Stream : TStream; Tree : TpcTree);
  var
    i, j : integer;
    NewItem : TpcTreeItem;
  begin
    Stream.ReadBuffer(i, sizeof(integer));
    if Item <> Tree.FRoot then
      Tree.TriggerItemLoadEvent(Item, Stream);
    for j := 0 to i - 1 do
    begin
      NewItem := Tree.AddItem(Item, nil);
      IntLoad(NewItem, Stream, Tree);
    end;
  end;

begin
  if Item = nil then Item := FRoot;
  IntLoad(Item, Stream, self);
end;

procedure TpcTree.TriggerItemSaveEvent(Item : TpcTreeItem; Stream : TStream);
{ Triggers the OnItemSave event. This is a virtual method (descendants of this component can override it). }
begin
  if (assigned(FOnItemSave)) then
    FOnItemSave(Self, Item, Stream);
end; { TriggerItemSaveEvent }

procedure TpcTree.TriggerItemLoadEvent(Item : TpcTreeItem; Stream : TStream);
{ Triggers the OnItemLoad event. This is a virtual method (descendants of this component can override it). }
begin
  if (assigned(FOnItemLoad)) then
    FOnItemLoad(Self, Item, Stream);
end; { TriggerItemLoadEvent }

procedure TpcTree.TriggerItemDeleteEvent(Item : TpcTreeItem; Data : pointer);
{ Triggers the OnItemDelete event. This is a virtual method (descendants of this component can override it). }
begin
  if (assigned(FOnItemDelete)) then
    FOnItemDelete(Self, Item, Data);
end; { TriggerItemDeleteEvent }

constructor TpcTree.Create; { public }
begin
  inherited;
  New(FRoot);
  FRoot.Parent := nil;
  FRoot.Data := nil;
  FRoot^.List := TpcList.Create;
end; { Create }

destructor TpcTree.Destroy; { public }
begin
  FRoot^.List.Free;
  Dispose(FRoot);
  inherited;
end; { Destroy }

{BTREE}
constructor TBTree.Create(ACaption: String);
begin
 froot:=ACaption;
end;

end.

 

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

unit pcEncode;
{Declare the compiler defines}
{------Changeable compiler switches-----------------------------------}
{$A+   Word align variables }
{$F+   Force Far calls }
{$K+   Use smart callbacks
{$N+   Allow coprocessor instructions }
{$P+   Open parameters enabled }
{$S+   Stack checking }
{$T-   @ operator is NOT typed }
{$U-   Non Pentium safe FDIV }
{$Z-   No automatic word-sized enumerations}
{$H+   Huge Strings}

{$RANGECHECKS OFF}
{$Q-}
{---------------------------------------------------------------------}

{$DEFINE MD5ONLY}

interface

uses SysUtils, Classes,Windows;

type
  TSourceType = (SourceFile, SourceByteArray, SourceString);

type
  ULONG32 = record
    LoWord16 : WORD;
    HiWord16 : WORD;
  end;

  PULONG32 = ^ULONG32;
  PLong = ^LongInt;

  hashDigest = record
    A : DWORD;
    B : DWORD;
    C : DWORD;
    D : DWORD;
  end; {hashArray}

  PTR_Hash = ^hashDigest;

  TCrMD5 = class
  private
 { Private declarations }

    FType : TSourceType; {Source type, whether its a file or ByteArray, or
                                            a Pascal String}
    FInputFilePath : string; {Full Path to Input File}
    FInputArray : PByte; {Point to input array}
    FInputString : string; {Input String}
    FOutputDigest : PTR_Hash; {output MD5 Digest}
    FSourceLength : LongInt; {input length in BYTES}
    FActiveBlock : array[0..15] of DWORD; {the 64Byte block being transformed}
    FA, FB, FC, FD, FAA, FBB, FCC, FDD : DWORD;
  {FA..FDD are used during Step 4, the transform.  I made them part of the
   Object to cut down on time used to pass variables.}
  {FF, GG, HH, II are used in Step 4, the transform}
    procedure FF(var a, b, c, d, x : DWORD; s : BYTE; ac : DWORD);
    procedure GG(var a, b, c, d, x : DWORD; s : BYTE; ac : DWORD);
    procedure HH(var a, b, c, d, x : DWORD; s : BYTE; ac : DWORD);
    procedure II(var a, b, c, d, x : DWORD; s : BYTE; ac : DWORD);

  protected
    { Protected declarations }
  public
    { Public declarations }
  {Initialize is used in Step 3, this fills FA..FD with init. values and points FpA..FpD to FA..FD}
    procedure MD5_Initialize;
  {this is where all the magic happens}
    procedure MD5_Transform;
    procedure MD5_Finish;
    procedure MD5_Hash_Bytes;
    procedure MD5_Hash_File;
  {This procedure sends the data 64Bytes at a time to MD5_Transform}
    procedure MD5_Hash;
    property pInputArray : PByte read FInputArray write FInputArray;
    property pOutputArray : PTR_Hash read FOutputDigest write FOutputDigest; {!!See FOutputArray}
  published
    property InputType : TSourceType read FType write FType;
    property InputFilePath : string read FInputFilePath write FInputFilePath;
    property InputString : string read FInputString write FInputString;
    property InputLength : LongInt read FSourceLength write FSourceLength;
  end; {TCrMD5}

const
{Constants for MD5Transform routine.}
  S11 = 7;
  S12 = 12;
  S13 = 17;
  S14 = 22;
  S21 = 5;
  S22 = 9;
  S23 = 14;
  S24 = 20;
  S31 = 4;
  S32 = 11;
  S33 = 16;
  S34 = 23;
  S41 = 6;
  S42 = 10;
  S43 = 15;
  S44 = 21;
// CRC 32 Base Functions

function CRC32(crc : longint; const c : byte) : longint;

function CRCStr(Str : string) : longint;

implementation

const
  CRC32_POLYNOMIAL = $EDB88320;

var
  Ccitt32Table : array[0..255] of longint;

function CrcStr(Str : string) : longint;
var
  i, l, c : integer;
begin
  l := length(Str);
  c := 0;
  for i := 1 to l do
    c := crc32(c, byte(str[i]));
  result := c;
end;

function crc32(crc : longint; const c : byte) : longint;
begin
  crc32 := (((crc shr 8) and $00FFFFFF) xor (Ccitt32Table[(crc xor c) and $FF]));
end;

procedure BuildCRCTable;
var
  i, j, value : DWORD;
begin
  for i := 0 to 255 do
  begin
    value := i;
    for j := 8 downto 1 do
    begin
      if ((value and 1) <> 0) then
        value := (value shr 1) xor CRC32_POLYNOMIAL
      else
        value := value shr 1;
    end;
    Ccitt32Table[i] := value;
  end
end;

{MD5 Unit}
{This will only work on an intel}

{$WARNINGS off}

function ROL(A : Longint; Amount : BYTE) : Longint;
begin
  asm
   mov cl, Amount
   mov eax, a
   rol eax, cl
   mov result, eax
  end;
end;
{$WARNINGS on}

procedure TCrMD5.MD5_Initialize;
begin
  FA := $67452301;
  FB := $EFCDAB89;
  FC := $98BADCFE;
  FD := $10325476;
end; {MD5_Initialize}

procedure TCrMD5.FF;
{Purpose:  Round 1 of the Transform.
           Equivalent to a = b + ((a + F(b,c,d) + x + ac) <<< s)
           Where F(b,c,d) = b And c Or Not(b) And d
}
begin
  a := a + ((b and c) or (not (b) and (d))) + x + ac;
  a := ROL(a, s);
  Inc(a, b);
end; {FF}

procedure TCrMD5.GG;
{Purpose:  Round 2 of the Transform.
           Equivalent to a = b + ((a + G(b,c,d) + x + ac) <<< s)
           Where G(b,c,d) = b And d Or c Not d
}
begin
  a := a + ((b and d) or (c and (not d))) + x + ac;
  a := ROL(a, s);
  Inc(a, b);
end; {GG}

procedure TCrMD5.HH;
{Purpose:  Round 3 of the Transform.
           Equivalent to a = b + ((a + H(b,c,d) + x + ac) <<< s)
           Where H(b,c,d) = b Xor c Xor d
}
begin
  a := a + (b xor c xor d) + x + ac;
  a := ROL(a, s);
  a := b + a;
end; {HH}

procedure TCrMD5.II;
{Purpose:  Round 4 of the Transform.
           Equivalent to a = b + ((a + I(b,c,d) + x + ac) <<< s)
           Where I(b,c,d) = C Xor (b Or Not(d))
}
begin
  a := a + (c xor (b or (not d))) + x + ac;
  a := ROL(a, s);
  a := b + a;
end; {II}

procedure TCrMD5.MD5_Transform;
{Purpose:  Perform Step 4 of the algorithm.  This is where all the important
           stuff happens.  This performs the rounds on a 64Byte Block.  This
           procedure should be called in a loop until all input data has been
           transformed.
}

begin
  FAA := FA;
  FBB := FB;
  FCC := FC;
  FDD := FD;

  { Round 1 }
  FF(FA, FB, FC, FD, FActiveBlock[0], S11, $D76AA478); { 1 }
  FF(FD, FA, FB, FC, FActiveBlock[1], S12, $E8C7B756); { 2 }
  FF(FC, FD, FA, FB, FActiveBlock[2], S13, $242070DB); { 3 }
  FF(FB, FC, FD, FA, FActiveBlock[3], S14, $C1BDCEEE); { 4 }
  FF(FA, FB, FC, FD, FActiveBlock[4], S11, $F57C0FAF); { 5 }
  FF(FD, FA, FB, FC, FActiveBlock[5], S12, $4787C62A); { 6 }
  FF(FC, FD, FA, FB, FActiveBlock[6], S13, $A8304613); { 7 }
  FF(FB, FC, FD, FA, FActiveBlock[7], S14, $FD469501); { 8 }
  FF(FA, FB, FC, FD, FActiveBlock[8], S11, $698098D8); { 9 }
  FF(FD, FA, FB, FC, FActiveBlock[9], S12, $8B44F7AF); { 10 }
  FF(FC, FD, FA, FB, FActiveBlock[10], S13, $FFFF5BB1); { 11 }
  FF(FB, FC, FD, FA, FActiveBlock[11], S14, $895CD7BE); { 12 }
  FF(FA, FB, FC, FD, FActiveBlock[12], S11, $6B901122); { 13 }
  FF(FD, FA, FB, FC, FActiveBlock[13], S12, $FD987193); { 14 }
  FF(FC, FD, FA, FB, FActiveBlock[14], S13, $A679438E); { 15 }
  FF(FB, FC, FD, FA, FActiveBlock[15], S14, $49B40821); { 16 }

 { Round 2 }
  GG(FA, FB, FC, FD, FActiveBlock[1], S21, $F61E2562); { 17 }
  GG(FD, FA, FB, FC, FActiveBlock[6], S22, $C040B340); { 18 }
  GG(FC, FD, FA, FB, FActiveBlock[11], S23, $265E5A51); { 19 }
  GG(FB, FC, FD, FA, FActiveBlock[0], S24, $E9B6C7AA); { 20 }
  GG(FA, FB, FC, FD, FActiveBlock[5], S21, $D62F105D); { 21 }
  GG(FD, FA, FB, FC, FActiveBlock[10], S22, $2441453); { 22 }
  GG(FC, FD, FA, FB, FActiveBlock[15], S23, $D8A1E681); { 23 }
  GG(FB, FC, FD, FA, FActiveBlock[4], S24, $E7D3FBC8); { 24 }
  GG(FA, FB, FC, FD, FActiveBlock[9], S21, $21E1CDE6); { 25 }
  GG(FD, FA, FB, FC, FActiveBlock[14], S22, $C33707D6); { 26 }
  GG(FC, FD, FA, FB, FActiveBlock[3], S23, $F4D50D87); { 27 }
  GG(FB, FC, FD, FA, FActiveBlock[8], S24, $455A14ED); { 28 }
  GG(FA, FB, FC, FD, FActiveBlock[13], S21, $A9E3E905); { 29 }
  GG(FD, FA, FB, FC, FActiveBlock[2], S22, $FCEFA3F8); { 30 }
  GG(FC, FD, FA, FB, FActiveBlock[7], S23, $676F02D9); { 31 }
  GG(FB, FC, FD, FA, FActiveBlock[12], S24, $8D2A4C8A); { 32 }

  { Round 3 }
  HH(FA, FB, FC, FD, FActiveBlock[5], S31, $FFFA3942); { 33 }
  HH(FD, FA, FB, FC, FActiveBlock[8], S32, $8771F681); { 34 }
  HH(FC, FD, FA, FB, FActiveBlock[11], S33, $6D9D6122); { 35 }
  HH(FB, FC, FD, FA, FActiveBlock[14], S34, $FDE5380C); { 36 }
  HH(FA, FB, FC, FD, FActiveBlock[1], S31, $A4BEEA44); { 37 }
  HH(FD, FA, FB, FC, FActiveBlock[4], S32, $4BDECFA9); { 38 }
  HH(FC, FD, FA, FB, FActiveBlock[7], S33, $F6BB4B60); { 39 }
  HH(FB, FC, FD, FA, FActiveBlock[10], S34, $BEBFBC70); { 40 }
  HH(FA, FB, FC, FD, FActiveBlock[13], S31, $289B7EC6); { 41 }
  HH(FD, FA, FB, FC, FActiveBlock[0], S32, $EAA127FA); { 42 }
  HH(FC, FD, FA, FB, FActiveBlock[3], S33, $D4EF3085); { 43 }
  HH(FB, FC, FD, FA, FActiveBlock[6], S34, $4881D05); { 44 }
  HH(FA, FB, FC, FD, FActiveBlock[9], S31, $D9D4D039); { 45 }
  HH(FD, FA, FB, FC, FActiveBlock[12], S32, $E6DB99E5); { 46 }
  HH(FC, FD, FA, FB, FActiveBlock[15], S33, $1FA27CF8); { 47 }
  HH(FB, FC, FD, FA, FActiveBlock[2], S34, $C4AC5665); { 48 }

  { Round 4 }
  II(FA, FB, FC, FD, FActiveBlock[0], S41, $F4292244); { 49 }
  II(FD, FA, FB, FC, FActiveBlock[7], S42, $432AFF97); { 50 }
  II(FC, FD, FA, FB, FActiveBlock[14], S43, $AB9423A7); { 51 }
  II(FB, FC, FD, FA, FActiveBlock[5], S44, $FC93A039); { 52 }
  II(FA, FB, FC, FD, FActiveBlock[12], S41, $655B59C3); { 53 }
  II(FD, FA, FB, FC, FActiveBlock[3], S42, $8F0CCC92); { 54 }
  II(FC, FD, FA, FB, FActiveBlock[10], S43, $FFEFF47D); { 55 }
  II(FB, FC, FD, FA, FActiveBlock[1], S44, $85845DD1); { 56 }
  II(FA, FB, FC, FD, FActiveBlock[8], S41, $6FA87E4F); { 57 }
  II(FD, FA, FB, FC, FActiveBlock[15], S42, $FE2CE6E0); { 58 }
  II(FC, FD, FA, FB, FActiveBlock[6], S43, $A3014314); { 59 }
  II(FB, FC, FD, FA, FActiveBlock[13], S44, $4E0811A1); { 60 }
  II(FA, FB, FC, FD, FActiveBlock[4], S41, $F7537E82); { 61 }
  II(FD, FA, FB, FC, FActiveBlock[11], S42, $BD3AF235); { 62 }
  II(FC, FD, FA, FB, FActiveBlock[2], S43, $2AD7D2BB); { 63 }
  II(FB, FC, FD, FA, FActiveBlock[9], S44, $EB86D391); { 64 }

  Inc(FA, FAA);
  Inc(FB, FBB);
  Inc(FC, FCC);
  Inc(FD, FDD);
  { Zeroize sensitive information}
  FillChar(FActiveBlock, SizeOf(FActiveBlock), #0);
end; {TCrMD5.MD5_Transform}

procedure TCrMD5.MD5_Hash;
var
  pStr : PChar;
begin
  MD5_Initialize;
  case FType of
    SourceFile :
      begin
        MD5_Hash_File;
      end; {SourceFile}
    SourceByteArray :
      begin
        MD5_Hash_Bytes;
      end; {SourceByteArray}
    SourceString :
      begin
    {Convert Pascal String to Byte Array}
        pStr := nil;
        try {protect dyanmic memory allocation}
          GetMem(pStr, Length(FInputString) + 1);
          StrPCopy(pStr, FInputString);
          FSourceLength := Length(FInputString);
          FInputArray := Pointer(pStr);
          MD5_Hash_Bytes;
        finally
          if pStr <> nil then FreeMem(pStr, Length(FInputString) + 1);
        end;
      end; {SourceString}
  end; {case}
  MD5_Finish;
end; {TCrMD5.MD5_Hash}

procedure TCrMD5.MD5_Hash_Bytes;
var
  Buffer : array[0..4159] of Byte;
  Count64 : Comp;
  index : longInt;
begin
  Move(FInputArray^, Buffer, FSourceLength);
  Count64 := FSourceLength * 8; {Save the Length(in bits) before padding}
  Buffer[FSourceLength] := $80; {Must always pad with at least a '1'}
  inc(FSourceLength);

  while (FSourceLength mod 64) <> 56 do
  begin
    Buffer[FSourceLength] := 0;
    Inc(FSourceLength);
  end;
  Move(Count64, Buffer[FSourceLength], SizeOf(Count64) {This better be 64bits});
  index := 0;
  Inc(FSourceLength, 8);
  repeat
    MoveMemory(@FActiveBlock, @Buffer[Index], 64);
    MD5_Transform;
    Inc(Index, 64);
  until Index = FSourceLength;
end; {TCrMD5.Hash_Bytes}

procedure TCrMD5.MD5_Hash_File;
var
  Buffer : array[0..4159] of BYTE;
  InputFile : file;
  Count64 : Comp;
  DoneFile : Boolean;
  Index : LongInt;
  NumRead : integer;
begin
  DoneFile := False;
{$IFDEF DELPHI}
  AssignFile(InputFile, FInputFilePath);
{$ENDIF}
{$IFDEF BP7}
  Assign(InputFile, FInputFilePath);
{$ENDIF}

  Reset(InputFile, 1);
  Count64 := 0;
  repeat
    BlockRead(InputFile, Buffer, 4096, NumRead);
    Count64 := Count64 + NumRead;
    if NumRead <> 4096 {reached end of file} then
    begin
      Buffer[NumRead] := $80;
      Inc(NumRead);
      while (NumRead mod 64) <> 56 do
      begin
        Buffer[NumRead] := 0;
        Inc(NumRead);
      end;
      Count64 := Count64 * 8;
      Move(Count64, Buffer[NumRead], 8);
      Inc(NumRead, 8);
      DoneFile := True;
    end;
    Index := 0;
    repeat
      Move(Buffer[Index], FActiveBlock, 64);
     {Flip bytes here on a Mac(I think)}

      MD5_Transform;
      Inc(Index, 64);
    until Index = NumRead;
  until DoneFile;
{$IFDEF DELPHI}
  CloseFile(InputFile);
{$ENDIF}
{$IFDEF BP7}
  Close(InputFile);
{$ENDIF}
end; {TCrMD5.MD5_Hash_File}

procedure TCrMD5.MD5_Finish;
begin
  FOutputDigest^.A := FA;
  FOutputDigest^.B := FB;
  FOutputDigest^.C := FC;
  FOutputDigest^.D := FD;
end;

initialization
  BuildCRCTable;
end.

 

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

unit pcList;

interface

uses ElContBase;

type
  TpcListSortCompare = function(Item1, Item2: Pointer; Cargo: Pointer): Integer;

  TpcListDeleteEvent = procedure(Sender: TObject; Item: Pointer) of object;

  TpcList = class
  protected
    FList: PPointerList;
    FCount: Integer;
    FCapacity: Integer;
    FAutoClearObjects: Boolean;
    FOnDelete: TpcListDeleteEvent;
    function Get(Index: Integer): Pointer; virtual;
    procedure Grow; virtual;
    procedure Put(Index: Integer; Item: Pointer); virtual;
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);
    procedure TriggerDeleteEvent(Item: Pointer); virtual;
    class procedure Error(const Msg: string; Data: Integer);
  public
    constructor Create;
    destructor Destroy; override;
    function Add(Item: Pointer): Integer;
    procedure Clear; virtual;
    procedure Assign(AList: TpcList);
    procedure Delete(Index: Integer); virtual;
    procedure Exchange(Index1, Index2: Integer);
    function Expand: TpcList;
    function First: Pointer;
    function IndexOf(Item: Pointer): Integer;
    function IndexOfFrom(StartIndex: integer; Item: Pointer): Integer;
    function IndexOfBack(StartIndex: integer; Item: Pointer): Integer;
    procedure Insert(Index: Integer; Item: Pointer);
    function Last: Pointer;
    procedure Move(CurIndex, NewIndex: Integer);
    procedure MoveRange(CurStart, CurEnd, NewStart: integer);
    function Remove(Item: Pointer): Integer;
    procedure Pack;
    procedure Sort(Compare: TpcListSortCompare; Cargo: Pointer);
    property Capacity: Integer read FCapacity write SetCapacity;
    property Count: Integer read FCount write SetCount;
    property Items[Index: Integer]: Pointer read Get write Put; default;
    property List: PPointerList read FList;
    property AutoClearObjects: Boolean read FAutoClearObjects write FAutoClearObjects; { Published }
    property OnDelete: TpcListDeleteEvent read FOnDelete write FOnDelete;
  end;

implementation

uses SysUtils;

type
  EpcListError = class(Exception);
//T & R
resourcestring
  rs_ListIndexOutOfBounds = 'List index [%d] out of bounds...';

procedure RaiseOutOfBoundsError(Ind: integer);
begin
  raise EpcListError.CreateFmt(rs_ListIndexOutOfBounds, [Ind]);
// raise EListError.Create('List index out of bounds.');
end;

class procedure TpcList.Error(const Msg: string; Data: Integer);

  function ReturnAddr: Pointer;
  asm
    MOV     EAX,[EBP+4]
  end;

begin
  raise EpcListError.CreateFmt(Msg, [Data])at ReturnAddr;
end;

constructor TpcList.Create;
begin
  inherited;
  FList := nil;
  FCount := 0;
  FCapacity := 0;
  FAutoClearObjects := FALSE;
  FOnDelete := nil;
end;

destructor TpcList.Destroy;
begin
  Clear;
  inherited;
end;

function TpcList.Add(Item: Pointer): Integer;
begin
  Result := FCount;
  if Result = FCapacity then Grow;
  FList^[Result] := Item;
  Inc(FCount);
end;

procedure TpcList.Assign(AList: TpcList);
begin
  Clear;
  SetCapacity(AList.Capacity);
  SetCount(AList.Count);
  System.Move(AList.FList^[0], FList^[0], FCount * sizeof(pointer));
end;

procedure TpcList.Clear;
var
  I: integer;
  p: pointer;
begin
  if Assigned(FOnDelete) then
    for i := 0 to Count - 1 do
      TriggerDeleteEvent(Get(i));
  if AutoClearObjects then
    for i := 0 to Count - 1 do
    begin
      p := Get(i);
      try
        if (P <> nil) and (TObject(P) is TObject) then TObject(P).Free;
      except
      end;
    end;
  SetCount(0);
  SetCapacity(0);
end;

procedure TpcList.Delete(Index: Integer);
begin
  if (Index < 0) or (Index >= FCount) then RaiseOutOfBoundsError(Index);
  TriggerDeleteEvent(Get(Index));
  Dec(FCount);
  if Index < FCount then
    System.Move(FList^[Index + 1], FList^[Index],
      (FCount - Index) * SizeOf(Pointer));
  if FCount < (FCapacity div 2) then SetCapacity(FCapacity div 2);
end;

procedure TpcList.Exchange(Index1, Index2: Integer);
var
  Item: Pointer;
begin
  if (Index1 < 0) or (Index1 >= FCount) then RaiseOutOfBoundsError(Index1);
  if (Index2 < 0) or (Index2 >= FCount) then RaiseOutOfBoundsError(Index2);
  Item := FList^[Index1];
  FList^[Index1] := FList^[Index2];
  FList^[Index2] := Item;
end;

function TpcList.Expand: TpcList;
begin
  if FCount = FCapacity then Grow;
  Result := Self;
end;

function TpcList.First: Pointer;
begin
  Result := Get(0);
end;

function TpcList.Get(Index: Integer): Pointer;
begin
  if (Index < 0) or (Index >= FCount) then RaiseOutOfBoundsError(Index);
  Result := FList^[Index];
end;

procedure TpcList.Grow;
var
  Delta: Integer;
begin
  if FCapacity > 64 then
    Delta := FCapacity div 4
  else if FCapacity > 8 then
    Delta := 16
  else
    Delta := 4;
  SetCapacity(FCapacity + Delta);
end;

function TpcList.IndexOfFrom(StartIndex: integer; Item: Pointer): Integer;
begin
  if (StartIndex < 0) or (StartIndex >= FCount) then RaiseOutOfBoundsError(StartIndex);
  Result := StartIndex;
  while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result);
  if Result = FCount then Result := -1;
end;

function TpcList.IndexOfBack(StartIndex: integer; Item: Pointer): Integer;
begin
  if (StartIndex < 0) or (StartIndex >= FCount) then RaiseOutOfBoundsError(StartIndex);
  Result := StartIndex;
  while (Result >= 0) and (FList^[Result] <> Item) do dec(Result);
end;

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

procedure TpcList.Insert(Index: Integer; Item: Pointer);
begin
  if (Index < 0) or (Index > FCount) then RaiseOutOfBoundsError(Index);
  if FCount = FCapacity then Grow;
  if Index < FCount then
    System.Move(FList^[Index], FList^[Index + 1],
      (FCount - Index) * SizeOf(Pointer));
  FList^[Index] := Item;
  Inc(FCount);
end;

function TpcList.Last: Pointer;
begin
  Result := Get(FCount - 1);
end;

procedure TpcList.MoveRange(CurStart, CurEnd, NewStart: integer);
var
  bs: integer;
  P: PChar;
begin
  if CurStart <> NewStart then
  begin
    if (NewStart < 0) or (NewStart >= FCount) or
      ((NewStart >= CurStart) and (NewStart <= CurEnd)) then RaiseOutOfBoundsError(NewStart);
    if (CurStart < 0) or (CurStart >= FCount) then RaiseOutOfBoundsError(CurStart);
    if (CurEnd < 0) or (CurEnd >= FCount) then RaiseOutOfBoundsError(CurEnd);
    if CurStart > NewStart then
    begin
      bs := CurEnd - CurStart + 1;
      GetMem(P, bs * SizeOf(Pointer));
      System.Move(FList^[CurStart], P^, BS * SizeOf(Pointer));
      System.Move(FList^[NewStart], FList^[NewStart + BS], (CurStart - NewStart) * SizeOf(Pointer));
      System.Move(P^, FList^[NewStart], BS * SizeOf(Pointer));
      FreeMem(P);
    end else
    begin
      bs := CurEnd - CurStart + 1;
      GetMem(P, BS * SizeOf(Pointer));
      System.Move(FList^[CurStart], P^, BS * SizeOf(Pointer));
      System.Move(FList^[CurEnd + 1], FList^[CurStart], (NewStart - CurEnd) * SizeOf(Pointer));
      NewStart := CurStart - 1 + NewStart - CurEnd;
      System.Move(P^, FList^[NewStart], BS * SizeOf(Pointer));
      FreeMem(P);
    end;
  end;
end;

procedure TpcList.Move(CurIndex, NewIndex: Integer);
var
  Item: Pointer;
begin
  if CurIndex <> NewIndex then
  begin
    if (NewIndex < 0) or (NewIndex >= FCount) then RaiseOutOfBoundsError(NewIndex);
    Item := Get(CurIndex);
    Delete(CurIndex);
    Insert(NewIndex, Item);
  end;
end;

procedure TpcList.Put(Index: Integer; Item: Pointer);
begin
  if (Index < 0) or (Index >= FCount) then RaiseOutOfBoundsError(Index);
  if FList[Index] <> nil then TriggerDeleteEvent(FList^[Index]);
  FList^[Index] := Item;
end;

function TpcList.Remove(Item: Pointer): Integer;
begin
  Result := IndexOf(Item);
  if Result <> -1 then Delete(Result);
end;

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

procedure TpcList.SetCapacity(NewCapacity: Integer);
begin
  if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
    RaiseOutOfBoundsError(NewCapacity);
  if NewCapacity <> FCapacity then
  begin
    ReallocMem(FList, NewCapacity * SizeOf(Pointer));
    FCapacity := NewCapacity;
  end;
end;

procedure TpcList.SetCount(NewCount: Integer);
begin
  if (NewCount < 0) or (NewCount > MaxListSize) then
    RaiseOutOfBoundsError(NewCount);
  if NewCount > FCapacity then SetCapacity(NewCount);
  if NewCount > FCount then
    FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0);
  FCount := NewCount;
end;

procedure QuickSort(SortList: PPointerList; L, R: Integer;
  SCompare: TpcListSortCompare; Cargo: Pointer);
var
  I, J, rI, rJ: Integer;
  P, T: Pointer;
begin
  repeat
    I := L;
    J := R;
    P := SortList^[(L + R) shr 1];

    repeat
      rI := SCompare(SortList^[I], P, Cargo);
      rJ := SCompare(SortList^[J], P, Cargo);

      while rI < 0 do
      begin
        Inc(I);
        rI := SCompare(SortList^[I], P, Cargo);
      end;

      while rJ > 0 do
      begin
        Dec(J);
        rJ := SCompare(SortList^[J], P, Cargo);
      end;

      if I <= J then
      begin
        if (I <> J) and ((rI <> 0) or (rJ <> 0)) then
        begin
          T := SortList^[I];
          SortList^[I] := SortList^[J];
          SortList^[J] := T;
        end;

        Inc(I);
        Dec(J);
      end;
    until I > J;

    if L < J then QuickSort(SortList, L, J, SCompare, Cargo);

    L := I;
  until I >= R;
end;

procedure TpcList.Sort(Compare: TpcListSortCompare; Cargo: Pointer);
begin
  if (FList <> nil) and (Count > 0) then
    QuickSort(FList, 0, Count - 1, Compare, Cargo);
end;

procedure TpcList.TriggerDeleteEvent(Item: Pointer);
{ Triggers the OnDelete event. This is a virtual method (descendants of this component can override it). }
begin
  if (assigned(FOnDelete)) then
    FOnDelete(Self, Item);
end; { TriggerDeleteEvent }

end.

 

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

unit pcStack;

interface

uses Classes, SysUtils;

type
  EpcStackError = class(exception)
  end;

type
  TpcStack = class
  private
    FList : PPointerList;
    FCount : Integer;
    FCapacity : Integer;
    function Get(index : integer) : pointer;
    procedure Put(index : integer; value : pointer);
    procedure Grow;
    procedure SetCapacity(NewCapacity : Integer);
  public
    destructor Destroy; override;
    procedure Clear;
    procedure Push(value : pointer);
    function Pop : pointer;
    function Empty : boolean;
    property Capacity : integer read FCapacity write SetCapacity;
    property Items[Index : Integer] : Pointer read Get write Put; default;
    property Count : integer read FCount;
  end;

implementation

function TpcStack.Empty : boolean;
begin
  result := Count = 0;
end;

function TpcStack.Get(index : integer) : pointer;
begin
  result := FList^[index];
end;

procedure TpcStack.Put(index : integer; value : pointer);
begin
  FList^[index] := value;
end;

destructor TpcStack.Destroy;
begin
  FreeMem(FList, FCapacity);
  inherited Destroy;
end;

procedure TpcStack.Grow;
var
  Delta : Integer;
begin
  if FCapacity > 64 then
    Delta := FCapacity div 4
  else if FCapacity > 8 then
    Delta := 16
  else
    Delta := 4;
  SetCapacity(FCapacity + Delta);
end;

procedure TpcStack.SetCapacity(NewCapacity : Integer);
begin
  if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
    raise EpcStackError.Create('Invalid pcStack capacity.');
  if NewCapacity <> FCapacity then
  begin
    ReallocMem(FList, NewCapacity * SizeOf(Pointer));
    FCapacity := NewCapacity;
  end;
end;

procedure TpcStack.Push;
begin
  if FCount = FCapacity then Grow;
  FList^[FCount] := value;
  Inc(FCount);
end;

function TpcStack.Pop;
begin
  if FCount = 0 then raise EpcStackError.Create('pcStack is empty.');
  result := FList^[FCount - 1];
  dec(FCount);
  if FCount < (FCapacity div 2) then SetCapacity(FCapacity div 2);
end;

procedure TpcStack.Clear;
begin
  FCount := 0;
  SetCapacity(0);
end;

end.

 

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

unit pcArray;

interface

uses pcCBase;

type
  TpcArraySortCompare = function(Item1, Item2: Pointer; Cargo: Pointer): Integer;

  TpcArrayDeleteEvent = procedure(Sender: TObject; Item: Pointer) of object;

  TpcArray = class
  protected
    FList: PPointerList;
    FCount: Integer;
    FCapacity: Integer;
    FAutoClearObjects: Boolean;
    FOnDelete: TpcArrayDeleteEvent;
    function Get(Index: Integer): Pointer; virtual;
    procedure Grow; virtual;
    procedure Put(Index: Integer; Item: Pointer); virtual;
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);
    procedure TriggerDeleteEvent(Item: Pointer); virtual;
    class procedure Error(const Msg: string; Data: Integer);
  public
    constructor Create;
    destructor Destroy; override;
    function Add(Item: Pointer): Integer;
    procedure Clear;
    procedure Assign(AList: TpcArray);
    procedure Delete(Index: Integer); virtual;
    procedure Exchange(Index1, Index2: Integer);
    function Expand: TpcArray;
    function First: Pointer;
    function IndexOf(Item: Pointer): Integer;
    function IndexOfFrom(StartIndex: integer; Item: Pointer): Integer;
    function IndexOfBack(StartIndex: integer; Item: Pointer): Integer;
    procedure Insert(Index: Integer; Item: Pointer);
    function Last: Pointer;
    procedure Move(CurIndex, NewIndex: Integer);
    procedure MoveRange(CurStart, CurEnd, NewStart: integer);
    function Remove(Item: Pointer): Integer;
    procedure Pack;
    procedure Sort(Compare: TpcArraySortCompare; Cargo: Pointer);
    property Capacity: Integer read FCapacity write SetCapacity;
    property Count: Integer read FCount write SetCount;
    property Items[Index: Integer]: Pointer read Get write Put; default;
    property List: PPointerList read FList;
    property AutoClearObjects: Boolean read FAutoClearObjects write FAutoClearObjects; { Published }
    property OnDelete: TpcArrayDeleteEvent read FOnDelete write FOnDelete;
  end;

implementation

uses SysUtils;

type
  EpcArrayError = class(Exception);

resourcestring
  rs_ListIndexOutOfBounds = 'List index [%d] out of bounds...';

procedure RaiseOutOfBoundsError(Ind: integer);
begin
  raise EpcArrayError.CreateFmt(rs_ListIndexOutOfBounds, [Ind]);
end;

class procedure TpcArray.Error(const Msg: string; Data: Integer);

  function ReturnAddr: Pointer;
  asm
    MOV     EAX,[EBP+4]
  end;

begin
  raise EpcArrayError.CreateFmt(Msg, [Data])at ReturnAddr;
end;

constructor TpcArray.Create;
begin
  inherited;
  FList := nil;
  FCount := 0;
  FCapacity := 0;
  FAutoClearObjects := FALSE;
  FOnDelete := nil;
end;

destructor TpcArray.Destroy;
begin
  Clear;
  inherited;
end;

function TpcArray.Add(Item: Pointer): Integer;
begin
  Result := FCount;
  if Result = FCapacity then Grow;
  FList^[Result] := Item;
  Inc(FCount);
end;

procedure TpcArray.Assign(AList: TpcArray);
begin
  Clear;
  SetCapacity(AList.Capacity);
  SetCount(AList.Count);
  System.Move(AList.FList^[0], FList^[0], FCount);
end;

procedure TpcArray.Clear;
var
  I: integer;
  p: pointer;
begin
  if Assigned(FOnDelete) then
    for i := 0 to Count - 1 do
      if FList[i] <> nil then TriggerDeleteEvent(FList[i]);
  if AutoClearObjects then
    for i := 0 to Count - 1 do
    begin
      p := Get(i);
      try
        if (P <> nil) and (TObject(P) is TObject) then TObject(P).Free;
      except
      end;
    end;
  SetCount(0);
  SetCapacity(0);
end;

procedure TpcArray.Delete(Index: Integer);
begin
  if (Index < 0) or (Index >= FCount) then RaiseOutOfBoundsError(Index);
  TriggerDeleteEvent(Get(Index));
  Dec(FCount);
  if Index < FCount then System.Move(FList^[Index + 1], FList^[Index], (FCount - Index) * SizeOf(Pointer));
  if FCount < (FCapacity div 2) then SetCapacity(FCapacity div 2);
end;

procedure TpcArray.Exchange(Index1, Index2: Integer);
var
  Item: Pointer;
begin
  if (Index1 < 0) then RaiseOutOfBoundsError(Index1);
  if (Index2 < 0) then RaiseOutOfBoundsError(Index2);
  if (Index1 >= FCount) then Count := Index1 + 1;
  if (Index2 >= FCount) then Count := Index2 + 1;
  Item := FList^[Index1];
  FList^[Index1] := FList^[Index2];
  FList^[Index2] := Item;
end;

function TpcArray.Expand: TpcArray;
begin
  if FCount = FCapacity then Grow;
  Result := Self;
end;

function TpcArray.First: Pointer;
begin
  Result := Get(0);
end;

function TpcArray.Get(Index: Integer): Pointer;
begin
  if (Index < 0) then RaiseOutOfBoundsError(Index);
  if (Index >= FCount) then result := nil else Result := FList^[Index];
end;

procedure TpcArray.Grow;
var
  Delta: Integer;
begin
  if FCapacity > 64 then
    Delta := FCapacity div 4
  else if FCapacity > 8 then
    Delta := 16
  else
    Delta := 4;
  SetCapacity(FCapacity + Delta);
end;

function TpcArray.IndexOfFrom(StartIndex: integer; Item: Pointer): Integer;
begin
  if (StartIndex < 0) then RaiseOutOfBoundsError(StartIndex);
  if (StartIndex >= FCount) then result := -1 else
  begin
    Result := StartIndex;
    while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result);
    if Result = FCount then Result := -1;
  end;
end;

function TpcArray.IndexOfBack(StartIndex: integer; Item: Pointer): Integer;
begin
  if (StartIndex < 0) then RaiseOutOfBoundsError(StartIndex);
  if (StartIndex >= FCount) then result := FCount - 1 else Result := StartIndex;
  while (Result >= 0) and (FList^[Result] <> Item) do dec(Result);
end;

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

procedure TpcArray.Insert(Index: Integer; Item: Pointer);
begin
  if (Index < 0) or (Index > FCount) then RaiseOutOfBoundsError(Index);
  if FCount = FCapacity then Grow;
  if Index < FCount then System.Move(FList^[Index], FList^[Index + 1], (FCount - Index) * SizeOf(Pointer));
  FList^[Index] := Item;
  Inc(FCount);
end;

function TpcArray.Last: Pointer;
begin
  Result := Get(FCount - 1);
end;

procedure TpcArray.MoveRange(CurStart, CurEnd, NewStart: integer);
var
  bs: integer;
  P: PChar;
begin
  if CurStart <> NewStart then
  begin
    if (NewStart < 0) or (NewStart >= FCount) or
      ((NewStart >= CurStart) and (NewStart <= CurEnd)) then RaiseOutOfBoundsError(NewStart);
    if (CurStart < 0) or (CurStart >= FCount) then RaiseOutOfBoundsError(CurStart);
    if (CurEnd < 0) or (CurEnd >= FCount) then RaiseOutOfBoundsError(CurEnd);
    if CurStart > NewStart then
    begin
      bs := CurEnd - CurStart + 1;
      GetMem(P, bs * SizeOf(Pointer));
      System.Move(FList^[CurStart], P^, BS * SizeOf(Pointer));
      System.Move(FList^[NewStart], FList^[NewStart + BS], (CurStart - NewStart) * SizeOf(Pointer));
      System.Move(P^, FList^[NewStart], BS * SizeOf(Pointer));
      FreeMem(P);
    end else
    begin
      bs := CurEnd - CurStart + 1;
      GetMem(P, BS * SizeOf(Pointer));
      System.Move(FList^[CurStart], P^, BS * SizeOf(Pointer));
      System.Move(FList^[CurEnd + 1], FList^[CurStart], (NewStart - CurEnd) * SizeOf(Pointer));
      NewStart := CurStart - 1 + NewStart - CurEnd;
      System.Move(P^, FList^[NewStart], BS * SizeOf(Pointer));
      FreeMem(P);
    end;
  end;
end;

procedure TpcArray.Move(CurIndex, NewIndex: Integer);
var
  Item: Pointer;
begin
  if CurIndex <> NewIndex then
  begin
    if (NewIndex < 0) then RaiseOutOfBoundsError(NewIndex);
    if (NewIndex >= FCount) then Count := NewIndex + 1;
    Item := Get(CurIndex);
    Delete(CurIndex);
    Insert(NewIndex, Item);
  end;
end;

procedure TpcArray.Put(Index: Integer; Item: Pointer);
begin
  if (Index < 0) then RaiseOutOfBoundsError(Index);
  if (Index >= FCount) then Count := Index + 1;
  if FList[Index] <> nil then TriggerDeleteEvent(FList^[Index]);
  FList^[Index] := Item;
end;

function TpcArray.Remove(Item: Pointer): Integer;
begin
  Result := IndexOf(Item);
  if Result <> -1 then Delete(Result);
end;

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

procedure TpcArray.SetCapacity(NewCapacity: Integer);
begin
  if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
    RaiseOutOfBoundsError(NewCapacity);
  if NewCapacity <> FCapacity then
  begin
    ReallocMem(FList, NewCapacity * SizeOf(Pointer));
    FCapacity := NewCapacity;
  end;
end;

procedure TpcArray.SetCount(NewCount: Integer);
begin
  if (NewCount < 0) or (NewCount > MaxListSize) then
    RaiseOutOfBoundsError(NewCount);
  if NewCount > FCapacity then SetCapacity(NewCount);
  if NewCount > FCount then
    FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0);
  FCount := NewCount;
end;

procedure QuickSort(SortList: PPointerList; L, R: Integer;
  SCompare: TpcArraySortCompare; Cargo: Pointer);
var
  I, J, rI, rJ: Integer;
  P, T: Pointer;
begin
  repeat
    I := L;
    J := R;
    P := SortList^[(L + R) shr 1];

    repeat
      rI := SCompare(SortList^[I], P, Cargo);
      rJ := SCompare(SortList^[J], P, Cargo);

      while rI < 0 do
      begin
        Inc(I);
        rI := SCompare(SortList^[I], P, Cargo);
      end;

      while rJ > 0 do
      begin
        Dec(J);
        rJ := SCompare(SortList^[J], P, Cargo);
      end;

      if I <= J then
      begin
        if (I <> J) and ((rI <> 0) or (rJ <> 0)) then
        begin
          T := SortList^[I];
          SortList^[I] := SortList^[J];
          SortList^[J] := T;
        end;

        Inc(I);
        Dec(J);
      end;
    until I > J;

    if L < J then QuickSort(SortList, L, J, SCompare, Cargo);

    L := I;
  until I >= R;
end;

procedure TpcArray.Sort(Compare: TpcArraySortCompare; Cargo: Pointer);
begin
  if (FList <> nil) and (Count > 0) then QuickSort(FList, 0, Count - 1, Compare, Cargo);
end;

procedure TpcArray.TriggerDeleteEvent(Item: Pointer);
begin
  if (assigned(FOnDelete)) then FOnDelete(Self, Item);
end; { TriggerDeleteEvent }

end.