Multi-ObjectLists (Objekte mehrmals in einer Liste)

[himitsu]

Nja, was soll man dazu sagen?

Dieses sind einfach nur Listen, in welchen das selbe Objekt mehrmals enthalten sein kann, ohne das es Probleme geben könnte.

> Es gibt nur Auswirkungen, wenn OwnsObjects auf TRUE steht,
> sonst reagieren diese Listen, wie ihre "normalen" Verwandten.

Ist ein Objekt mehrmals vorhanden, dann wird es erst freigegeben, wenn keine Instanzen mehr in der Liste stecken.
(bei den normalen Listen wird das Objekt ja ohne Prüfung sofort freigegeben)

Delphi-Quellcode:

unit MultiLists;

interface
  {$DEFINE UseGenerics}

  uses
    Classes, Contnrs {$IFDEF UseGenerics}, Generics.Collections{$ENDIF};

  type
    TMultiObjectList = class(TObjectList)
    protected
      procedure Notify(Ptr: Pointer; Action: TListNotification); override;
    public
      function Remove(AObject: TObject; RemoveAll: Boolean): Integer; overload;
      procedure RemoveAll(AObject: TObject); inline;
    end;

    TMultiObjectStringList = class(TStringList)
    protected
      procedure PutObject(Index: Integer; AObject: TObject); override;
    public
      destructor Destroy; override;
      procedure Clear; override;
      procedure Delete(Index: Integer); override;
    end;

    {$IFDEF UseGenerics}

      TMultiObjectList<T: class> = class(TObjectList<T>)
      protected
        procedure Notify(const Value: T; Action: TCollectionNotification); override;
      public
        function Remove(const Value: T; RemoveAll: Boolean): Integer; overload;
        procedure RemoveAll(const Value: T); inline;
      end;

    {$ENDIF}

implementation
  procedure TMultiObjectList.Notify(Ptr: Pointer; Action: TListNotification);
  begin
    if (Action = lnDeleted) and OwnsObjects then begin
      if IndexOf(TObject(Ptr)) < 0 then
        TObject(Ptr).Free;
    end else inherited;
  end;

  function TMultiObjectList.Remove(AObject: TObject; RemoveAll: Boolean): Integer;
  var
    i: Integer;
  begin
    if RemoveAll then begin
      Result := -1;
      repeat
        i := Remove(AObject);
        if i >= 0 then Result := i;
      until i < 0;
    end else Result := Remove(AObject);
  end;

  procedure TMultiObjectList.RemoveAll(AObject: TObject);
  begin
    while Remove(AObject) >= 0 do ;
  end;

  procedure TMultiObjectStringList.PutObject(Index: Integer; AObject: TObject);
  var
    Temp: TObject;
    B: Boolean;
    i: Integer;
  begin
    if Assigned(AObject) then begin
      Temp := Objects[Index];
      if Temp <> AObject then begin
        inherited;
        if IndexOf(Temp) < 0 then
          Temp.Free;
      end;
    end else inherited;
  end;

  destructor TMultiObjectStringList.Destroy;
  begin
    OnChange := nil;
    OnChanging := nil;
    Clear;
    inherited;
  end;

  procedure TMultiObjectStringList.Clear;
  var
    i, i2: Integer;
    Temp: Tobject;
  begin
    BeginUpdate;
    try
      if (Count <> 0) and OwnsObjects then
        for i := Count - 1 downto 0 do begin
          Temp := Objects[i];
          for i2 := i - 1 downto 0 do
            if Objects[i2] = Temp then Objects[i2] := nil;
          Objects[i] := nil;
          Temp.Free;
        end;
      inherited;
    finally
      EndUpdate;
    end;
  end;

  procedure TMultiObjectStringList.Delete(Index: Integer);
  var
    Temp: Tobject;
    i: Integer;
  begin
    if OwnsObjects then begin
      BeginUpdate;
      try
        Temp := Objects[Index];
        for i := Count - 1 downto 0 do
          if (i <> Index) and (Objects[i] = Temp) then begin
            Objects[Index] := nil;
            break;
          end;
        inherited;
      finally
        EndUpdate;
      end;
    end else inherited;
  end;

  {$IFDEF UseGenerics}

    procedure TMultiObjectList<T>.Notify(const Value: T; Action: TCollectionNotification);
    var
      B: Boolean;
      i: Integer;
    begin
      if (Action = cnRemoved) and OwnsObjects then begin
        if Assigned(OnNotify) then OnNotify(Self, Value, cnRemoved);
        if IndexOf(Value) < 0 then Value.Free;
      end else inherited;
    end;

    function TMultiObjectList<T>.Remove(const Value: T; RemoveAll: Boolean): Integer;
    var
      i: Integer;
    begin
      if RemoveAll then begin
        Result := -1;
        repeat
          i := Remove(Value);
          if i >= 0 then Result := i;
        until i < 0;
      end else Result := Remove(AObject);
    end;

    procedure TMultiObjectList<T>.RemoveAll(const Value: T);
    begin
      while Remove(Value) >= 0 do ;
    end;

  {$ENDIF}

end.

[edits]
- kleine Optimierungen (einige For-Schleifen gegen IndexOf ersetzt)
- RemoveAll und Co. eingeführt
- RemoveAll-Parameter wird nun auch beachtet