331 lines
9.5 KiB
ObjectPascal
331 lines
9.5 KiB
ObjectPascal
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.
|
|
|