lists.pas

木马源程序,供大家研究

  begin
    R := Write(C, SizeOf(C));
    if R <> Sizeof(C) then
      raise EValueList.CreateFmt(SErrStream, [SWrite, SizeOf(C), R]);

    R := Write(FItemSize, SizeOf(FItemSize));
    if R <> Sizeof(C) then
      raise EValueList.CreateFmt(SErrStream, [SWrite, SizeOf(FItemSize), R]);

    for i := 0 to C - 1 do
    begin
      R := Write(Items[i]^, FItemSize);
      if R <> Sizeof(C) then
        raise EValueList.CreateFmt(SErrStream, [SWrite, FItemSize, R]);
    end;
  end;
end;

procedure TValueList.SetItemSize(const Value: Integer);
begin
  if Count = 0 then
    FItemSize := Value
  else
    raise EValueList.CreateFmt(SErrSetItemSize, [Count]);
end;

procedure TValueList.DoSetItems(Index: integer; const Value);
begin
  if (Index < 0) or (Index >= Count) then
    raise EObjectList.CreateFmt(SErrOutBounds, [Index, Count - 1]);
  System.Move(Value, Items[Index]^, FItemSize);
end;

function CompareHighToLow(Item1, Item2: Pointer): integer;
var
  P1: PByte;
  P2: PByte;
  Size: integer;
begin
  Size := ByteToCompare;
  if SortOrderAsc then
  begin
    P1 := Item1;
    P2 := Item2;
  end
  else
  begin
    P1 := Item2;
    P2 := Item1;
  end;
  Inc(P1, Size);
  Inc(P2, Size);
  Result := 0;
  while Size > 0 do
  begin
    Dec(Size);
    Dec(P1);
    Dec(P2);
    if P1^ < P2^ then
    begin
      Result := -1;
      Break;
    end
    else if P1^ > P2^ then
    begin
      Result := 1;
      Break;
    end;
  end;
end;

function CompareLowToHigh(Item1, Item2: Pointer): integer;
var
  P1: PByte;
  P2: PByte;
  i: integer;
begin
  Result := 0;

  if SortOrderAsc then
  begin
    P1 := Item1;
    P2 := Item2;
  end
  else
  begin
    P1 := Item2;
    P2 := Item1;
  end;

  i := 1;
  while i <= ByteToCompare do
  begin
    if P1^ < P2^ then
    begin
      Result := -1;
      Break;
    end
    else if P1^ > P2^ then
    begin
      Result := 1;
      Break;
    end;
    Inc(P1);
    Inc(P2);
    Inc(i);
  end;
end;

procedure TValueList.DefaultSort(const Asc: Boolean = True; const LowToHigh: Boolean
  = True);
begin
  ByteToCompare := FItemSize;
  SortOrderAsc := Asc;
  if LowToHigh then
    Sort(@CompareLowToHigh)
  else
    Sort(@CompareHighToLow);
end;

procedure TValueList.FreeItem(Index: integer);
begin
  if (Index < 0) or (Index >= Count) then
    raise EValueList.CreateFmt(SErrOutBounds, [Index, Count - 1]);
  if Assigned(inherited Items[Index]) then
    FreeMem(inherited Items[Index], FItemSize);
  inherited Items[Index] := nil;
end;

function TValueList.Item(Index: integer): Pointer;
begin
  Result := inherited Items[Index];
end;

procedure TValueList.InsertPointer(Index: integer; Value: Pointer);
begin
  inherited Insert(Index, Value);
end;

function TValueList.BinSearch(const Value; CompareProc: TListSortCompare = nil):
  integer;
var
  L, H, M: integer;
begin
  Result := -1;
  if Count = 0 then exit;
  if @CompareProc = nil then
  begin
    ByteToCompare := FItemSize;
    CompareProc := CompareHighToLow;
  end;
  L := 0;
  H := Count - 1;
  if (CompareProc(@Value, Items[L]) < 0) or (CompareProc(@Value, Items[H]) > 0) then
    exit;
  while L <= H do
  begin
    M := (L + H) div 2;
    if CompareProc(Items[M], @Value) = 0 then
    begin
      Result := M;
      Break;
    end;
    if CompareProc(Items[M], @Value) > 0 then
      H := M - 1
    else
      L := M + 1;
  end;
end;

{ TObjectList }

function TObjectList.Add(AObject: TObject): Integer;
begin
  Result := -1;
  if (AObject = nil) or (AObject is FClassType) then
    Result := inherited Add(AObject)
  else
    ClassTypeError(AObject.ClassName);
end;

procedure TObjectList.Clear;
begin
  while Count > 0 do
    Delete(Count - 1);
  inherited Clear;
end;

constructor TObjectList.Create;
begin
  Create(TObject);
end;

constructor TObjectList.Create(AClassType: TClass);
begin
  inherited Create;
  FClassType := AClassType;
end;

procedure TObjectList.Delete(Index: Integer);
begin
  FreeItem(Index);
  inherited Delete(Index);
end;

procedure TObjectList.ClassTypeError(Message: string);
begin
  raise EObjectList.CreateFmt(SErrClassType, [FClassType.ClassName, Message]);
end;

function TObjectList.Expand: TObjectList;
begin
  Result := (inherited Expand) as TObjectList;
end;

function TObjectList.First: TObject;
begin
  Result := TObject(inherited First);
end;

function TObjectList.GetItems(Index: Integer): TObject;
begin
  Result := TObject(inherited Items[Index]);
end;

function TObjectList.IndexOf(AObject: TObject): Integer;
begin
  Result := inherited IndexOf(AObject);
end;

procedure TObjectList.Insert(Index: Integer; Item: TObject);
begin
  if (Item = nil) or (Item is FClassType) then
    inherited Insert(Index, Pointer(Item))
  else
    ClassTypeError(Item.ClassName);
end;

function TObjectList.Last: TObject;
begin
  Result := TObject(inherited Last);
end;

function TObjectList.Remove(AObject: TObject): Integer;
begin
  Result := IndexOf(AObject);
  if Result >= 0 then Delete(Result);
end;

procedure TObjectList.SetItems(Index: Integer; const Value: TObject);
begin
  if Value = nil then
    FreeItem(Index)
  else if Value is FClassType then
    inherited Items[Index] := Value
  else
    ClassTypeError(Value.ClassName);
end;

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

procedure TObjectList.FreeItem(Index: integer);
begin
  if (Index < 0) or (Index >= Count) then
    raise EObjectList.CreateFmt(SErrOutBounds, [Index, Count - 1]);
  if Assigned(inherited Items[Index]) then Items[Index].Free;
  inherited Items[Index] := nil;
end;

{ TIntegerList }

procedure TIntegerList.Add(Value: integer);
begin
  inherited Add(Value);
end;

constructor TIntegerList.Create;
begin
  inherited Create(SizeOf(integer));
end;

function TIntegerList.GetItems(Index: integer): integer;
begin
  Result := integer(inherited Items[Index]^);
end;

procedure TIntegerList.SetItems(Index: integer; const Value: integer);
begin
  DoSetItems(Index, Value);
end;

function TIntegerList.ValueExist(Value: integer): Boolean;
begin
  Result := IndexOf(Value) <> -1;
end;

{ TInt64List }

constructor TInt64List.Create;
begin
  inherited Create(SizeOf(Int64));
end;

function TInt64List.GetItems(Index: integer): Int64;
begin
  Result := int64(inherited Items[index]^);
end;

procedure TInt64List.SetItems(Index: integer; const Value: Int64);
begin
  DoSetItems(Index, Value);
end;

{ TOrderValueList }

procedure TOrderValueList.Sort(const AscOrder: Boolean);
begin
  DefaultSort(AscOrder, False);
end;

end.