Componentes.Terceros.RemObjects/internal/5.0.23.613/1/Data Abstract for Delphi/Source/uDASupportClasses.pas

unit uDASupportClasses;

{----------------------------------------------------------------------------}
{ Data Abstract Library - Core Library                                       }
{                                                                            }
{ compiler: Delphi 6 and up, Kylix 3 and up                                  }
{ platform: Win32, Linux                                                     }
{                                                                            }
{ (c)opyright RemObjects Software. all rights reserved.                      }
{                                                                            }
{ Using this code requires a valid license of the Data Abstract              }
{ which can be obtained at http://www.remobjects.com.                        }
{----------------------------------------------------------------------------}

{$I DataAbstract.inc}

interface

uses Classes;

type
  { TCollectionEvents }
  TCollectionNotificationEvent = procedure(Item: TCollectionItem; Action: TCollectionNotification) of object;

  { TInterfacedCollectionItem }
  TInterfacedCollectionItem = class(TCollectionItem, IUnknown)
  protected
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  end;

  TDAItemRenamedEvent = procedure(aSender: TObject; const aOldName, aNewName: string) of object;
  TDAItemRemovedEvent = procedure(aSender: TObject; const aName: string) of object;

  { TSearcheableCollection }
  TSearcheableCollection = class(TOwnedCollection)
  private
    fOnNotification: TCollectionNotificationEvent;
    fOnItemRemoved: TDAItemRemovedEvent;
    fOnItemRenamed: TDAItemRenamedEvent;

  protected
    FAllowEmptyName: Boolean;
    function SetItemName(anItem: TCollectionItem; const aName: string): string; reintroduce; dynamic;
    function GetItemName(anItem: TCollectionItem): string; reintroduce; dynamic;
    function GetItemDefault(anItem: TCollectionItem): boolean; dynamic;

    procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;

    function ItemName: string; virtual;

  public
    constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
    function ItemByName(const aName: string): TCollectionItem;
    function FindItem(const aName: string): TCollectionItem; virtual;
    function GetDefaultItem: TCollectionItem;

    procedure TriggerOnItemRenamed(const iOldName, iNewName: string);
    procedure TriggerOnItemRemoved(const iName: string);

    function FindUniqueName(const iBaseName: string): string;
    function FindUniqueNameEx(const iBaseName, iNumberedName: string): string;
    function CloneItem(iIndex: integer): integer;

    procedure MoveItem(iFromIndex, iToIndex: integer);

    property OnNotification: TCollectionNotificationEvent read fOnNotification write fOnNotification;

    property OnItemRenamed: TDAItemRenamedEvent read fOnItemRenamed write fOnItemRenamed;
    property OnItemRemoved: TDAItemRemovedEvent read fOnItemRemoved write fOnItemRemoved;
  end;

  { TSearcheableInterfacedCollection }
  TSearcheableInterfacedCollection = class(TSearcheableCollection, IUnknown)
  protected
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;

    // Required by most interfaces
    function GetCount: integer;

  end;

  { TSearcheableInterfacedCollection }
  TInterfacedCollection = class(TOwnedCollection, IUnknown)
  protected
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;

    // Required by most interfaces
    function GetCount: integer;

  end;


implementation

uses uROClasses, uDARes, TypInfo, SysUtils;

{ TInterfacedCollectionItem }

function TInterfacedCollectionItem._AddRef: Integer;
begin
  result := -1;
end;

function TInterfacedCollectionItem._Release: Integer;
begin
  result := -1;
end;

function TInterfacedCollectionItem.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

{ TSearcheableInterfacedCollection }

function TSearcheableInterfacedCollection._AddRef: Integer;
begin
  result := -1;
end;

function TSearcheableInterfacedCollection._Release: Integer;
begin
  result := -1;
end;

function TSearcheableInterfacedCollection.QueryInterface(const IID: TGUID;
  out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

function TSearcheableInterfacedCollection.GetCount: integer;
begin
  result := Count;
end;

{ TSearcheableCollection }

function TSearcheableCollection.GetDefaultItem: TCollectionItem;
var
  i: integer;
begin
  result := nil;
  for i := 0 to (Count - 1) do
    if GetItemDefault(Items[i]) then begin
      result := Items[i];
      Exit;
    end;

  RaiseError(err_CannotFindDefaultItem,[ItemName]);
end;

function TSearcheableCollection.FindItem(
  const aName: string): TCollectionItem;
var
  i: integer;
  nme: string;
begin
  result := nil;
  for i := 0 to (Count - 1) do begin
    nme := GetItemName(Items[i]);
    if SameText(nme, aName) then begin
      result := Items[i];
      Exit;
    end;
  end;
end;

function TSearcheableCollection.GetItemDefault(
  anItem: TCollectionItem): boolean;
begin
  try
    result := GetPropValue(anItem, 'Default', TRUE); // Defaul implementation. Not super-fast but for now's ok
  except
    on e: EPropertyError do
      raise EPropertyError.CreateFmt('The %s collection doesn''t support Default items',[ClassName]);
    else
      raise;
  end;
end;

function TSearcheableCollection.GetItemName(
  anItem: TCollectionItem): string;
begin
  result := GetPropValue(anItem, 'Name', TRUE); // Defaul implementation. Not super-fast but for now's ok
end;

function TSearcheableCollection.ItemByName(
  const aName: string): TCollectionItem;
begin
  { ToDo: This is not perfect, since not all collections will properly support GetDefaultItem. }
  if (aName = '') then
    result := GetDefaultItem
  else
    result := FindItem(aName);

  Check(result = nil, err_CannotFindItem, [ItemName, aName, ClassName]);
end;

procedure TSearcheableCollection.Notify(Item: TCollectionItem;
  Action: TCollectionNotification);
begin
  inherited;

  if (not FAllowEmptyName) and (Action = cnAdded) then begin
    if (GetItemName(Item) = '') then SetItemName(Item, 'Item' + IntToStr(Count));
  end;

  if Assigned(fOnNotification) then fOnNotification(Item, Action);
end;

function TSearcheableCollection.SetItemName(anItem: TCollectionItem; const aName: string): string;
begin
  SetPropValue(anItem, 'Name', aName); // Defaul implementation. Not super-fast but for now's ok
end;

function TSearcheableCollection.CloneItem(iIndex: integer): integer;
var
  lOldItem, lNewItem: TCollectionItem;
begin
  lOldItem := Items[iIndex];
  lNewItem := Add();
  lNewItem.Assign(lOldItem);
  lNewItem.DisplayName := FindUniqueNameEx('Copy of ' + lOldItem.DisplayName, 'Copy (%d) of ' + lOldItem.DisplayName);
  result := lNewItem.Index;
end;

procedure TSearcheableCollection.MoveItem(iFromIndex, iToIndex: integer);
var
  lSave: TCollectionItem;
  lOld: TCollectionItem;
begin
  if (iFromIndex < 0) or (iFromIndex >= Count) then raise ERangeError.CreateFmt('iFromIndex out of range (%d).', [iFromIndex]);
  if (iToIndex < 0) or (iToIndex >= Count) then raise ERangeError.CreateFmt('iToIndex out of range (%d).', [iToIndex]);

  lOld := Items[iFromIndex];

  if iToIndex > iFromIndex then inc(iToIndex); //account for the old item that will be removed later

  lSave := Insert(iToIndex);
  lSave.Assign(lOld);
  Delete(lOld.Index);
end;

function TSearcheableCollection.FindUniqueName(const iBaseName: string): string;
var
  lIndex: integer;
begin
  result := iBaseName;
  lIndex := 0;
  while Assigned(FindItem(result)) do begin
    inc(lIndex);
    result := iBaseName + IntToStr(lIndex);
  end;
end;

function TSearcheableCollection.FindUniqueNameEx(const iBaseName, iNumberedName: string): string;
var
  lIndex: integer;
begin
  result := iBaseName;
  lIndex := 0;
  while Assigned(FindItem(result)) do begin
    inc(lIndex);
    result := Format(iNumberedName, [lIndex]);
  end;
end;

function TSearcheableCollection.ItemName: string;
begin
  result := 'item';
end;

procedure TSearcheableCollection.TriggerOnItemRemoved(const iName: string);
begin
  if Assigned(OnItemRemoved) then OnItemRemoved(self, iName);
end;

procedure TSearcheableCollection.TriggerOnItemRenamed(const iOldName, iNewName: string);
begin
  if Assigned(OnItemRenamed) then OnItemRenamed(self, iOldName, iNewName);
end;

constructor TSearcheableCollection.Create(AOwner: TPersistent;
  ItemClass: TCollectionItemClass);
begin
  inherited Create(AOwner,ItemClass);
  FAllowEmptyName:=False; 
end;

{ TInterfacedCollection }

function TInterfacedCollection._AddRef: Integer;
begin
  result := -1;
end;

function TInterfacedCollection._Release: Integer;
begin
  result := -1;
end;

function TInterfacedCollection.GetCount: integer;
begin
  result := -1;
end;

function TInterfacedCollection.QueryInterface(const IID: TGUID;
  out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

end.