894 lines
28 KiB
Plaintext
894 lines
28 KiB
Plaintext
// ***************************************************************
|
|
// madLists.pas version: 1.2.0 · date: 2012-04-03
|
|
// -------------------------------------------------------------
|
|
// several list interfaces
|
|
// -------------------------------------------------------------
|
|
// Copyright (C) 1999 - 2012 www.madshi.net, All Rights Reserved
|
|
// ***************************************************************
|
|
|
|
// 2012-04-03 1.2.0 added x64 and unicode support
|
|
// 2009-02-09 1.1f Delphi 2009 support
|
|
// 2005-03-09 1.1e bug in handling with multiple lists fixed
|
|
// 2001-01-05 1.1d changed parameter in IPointerList.AddItems to "const"
|
|
// 2000-11-13 1.1c minor changes in order to get rid of SysUtils
|
|
// 2000-10-31 1.1b little bug in TIInterfaceList.AddItem / TIPointerList.AddItem fixed
|
|
|
|
unit madLists;
|
|
|
|
{$I mad.inc}
|
|
|
|
interface
|
|
|
|
uses madBasic;
|
|
|
|
// ***************************************************************
|
|
|
|
type
|
|
// full IBasic list
|
|
IBasicList = interface (ICustomBasicList) ['{0DDE44C0-71EB-11D3-A52D-00005A180D69}']
|
|
// access to the items of the list
|
|
// function BasicItem (index: integer) : IBasic;
|
|
procedure SetItem (index: integer; const item: IBasic);
|
|
property Items [index: integer] : IBasic read BasicItem write SetItem; default;
|
|
|
|
// access to the capacity of the list
|
|
// function GetCapacity : integer;
|
|
procedure SetCapacity (capacity: integer);
|
|
property Capacity : integer read GetCapacity write SetCapacity;
|
|
|
|
// add one or more items to the list
|
|
// return value is the new index of the (first) added item
|
|
function AddItem (const item : IBasic) : integer;
|
|
function AddItems (const items : array of IBasic) : integer;
|
|
|
|
// insert one item to the list
|
|
function InsertItem (const item: IBasic; index: integer = 0) : integer;
|
|
|
|
// swap two items
|
|
function Swap (index1, index2: integer) : boolean;
|
|
|
|
// delete an item (via index or via content)
|
|
function DeleteItem ( index : integer) : boolean; overload;
|
|
function DeleteItem (const item : IBasic ) : boolean; overload;
|
|
|
|
// remove all items
|
|
procedure Clear;
|
|
end;
|
|
|
|
// create a new IBasicList
|
|
function NewBasicList : IBasicList; overload;
|
|
function NewBasicList (const items: array of IBasic) : IBasicList; overload;
|
|
|
|
// ***************************************************************
|
|
|
|
type
|
|
// function type that compares (sorts) two interfaces; needed for IInterfaceList
|
|
TCompareInterface = function (const list: IList; const item1, item2: IUnknown; info: integer) : integer;
|
|
|
|
// interface list
|
|
IInterfaceList = interface (IList) ['{8C780300-4E4D-11D3-A52D-00005A180D69}']
|
|
// access to the items of the list
|
|
function GetItem (index: integer) : IUnknown;
|
|
procedure SetItem (index: integer; const item: IUnknown);
|
|
property Items [index: integer] : IUnknown read GetItem write SetItem; default;
|
|
|
|
// access to the capacity of the list
|
|
// function GetCapacity : integer;
|
|
procedure SetCapacity (capacity: integer);
|
|
property Capacity : integer read GetCapacity write SetCapacity;
|
|
|
|
// add one or more items to the list
|
|
// return value is the new index of the (first) added item
|
|
function AddItem (const item : IUnknown) : integer;
|
|
function AddItems (const items : array of IUnknown) : integer;
|
|
|
|
// insert one item to the list
|
|
function InsertItem (const item : IUnknown;
|
|
index : integer = 0) : integer;
|
|
|
|
// looks through all items and returns the index of "item"
|
|
function FindItem (const item: IUnknown) : integer;
|
|
|
|
// swap two items
|
|
function Swap (index1, index2: integer) : boolean;
|
|
|
|
// delete an item (via index or via content)
|
|
function DeleteItem ( index : integer ) : boolean; overload;
|
|
function DeleteItem (const item : IUnknown) : boolean; overload;
|
|
|
|
// remove all items
|
|
procedure Clear;
|
|
|
|
// sort stuff...
|
|
function GetSortProc : TCompareInterface;
|
|
procedure SetSortProc (value: TCompareInterface);
|
|
property SortProc : TCompareInterface read GetSortProc write SetSortProc;
|
|
function GetSortParams (var func: TCompareInterface; var down: boolean; var info: integer ) : boolean;
|
|
procedure SetSortParams ( func: TCompareInterface; down: boolean = true; info: integer = 0);
|
|
end;
|
|
|
|
// create a new IInterfaceList
|
|
function NewInterfaceList : IInterfaceList; overload;
|
|
function NewInterfaceList (const items: array of IUnknown) : IInterfaceList; overload;
|
|
|
|
// ***************************************************************
|
|
|
|
type
|
|
// function type that compares (sorts) two pointers; needed for IPointerList
|
|
TComparePointer = function (const list: IList; item1, item2: pointer; info: integer) : integer;
|
|
|
|
// some function types that simulate basic interface functions for pointers
|
|
TDestroyPointerProc = procedure (var item: pointer);
|
|
|
|
// pointer list
|
|
IPointerList = interface (IList) ['{F6B8D485-40DB-11D3-A52D-00005A180D69}']
|
|
// access to the items of the list
|
|
function GetItem (index: integer) : pointer;
|
|
procedure SetItem (index: integer; item: pointer);
|
|
property Items [index: integer] : pointer read GetItem write SetItem; default;
|
|
|
|
// access to the capacity of the list
|
|
// function GetCapacity : integer;
|
|
procedure SetCapacity (capacity: integer);
|
|
property Capacity : integer read GetCapacity write SetCapacity;
|
|
|
|
// add one or more items to the list
|
|
// return value is the new index of the (first) added item
|
|
function AddItem (item : pointer) : integer;
|
|
function AddItems (const items : array of pointer) : integer;
|
|
|
|
// insert one item to the list
|
|
function InsertItem (item: pointer; index: integer = 0) : integer;
|
|
|
|
// looks through all items and returns the index of "item"
|
|
function FindItem (item: pointer) : integer;
|
|
|
|
// swap two items
|
|
function Swap (index1, index2: integer) : boolean;
|
|
|
|
// delete an item (via index or via content)
|
|
function DeleteItem (index : integer) : boolean; overload;
|
|
function DeleteItem (item : pointer) : boolean; overload;
|
|
|
|
// remove all items
|
|
procedure Clear;
|
|
|
|
// sort stuff...
|
|
function GetSortProc : TComparePointer;
|
|
procedure SetSortProc (value: TComparePointer);
|
|
property SortProc : TComparePointer read GetSortProc write SetSortProc;
|
|
function GetSortParams (var func: TComparePointer; var down: boolean; var info: integer ) : boolean;
|
|
procedure SetSortParams ( func: TComparePointer; down: boolean = true; info: integer = 0);
|
|
end;
|
|
|
|
// create a new IPointerList
|
|
function NewPointerList : IPointerList; overload;
|
|
function NewPointerList (const items: array of pointer; destroyProc: TDestroyPointerProc = nil) : IPointerList; overload;
|
|
|
|
// ***************************************************************
|
|
|
|
implementation
|
|
|
|
uses Windows, madTypes;
|
|
|
|
// ***************************************************************
|
|
|
|
type
|
|
// implements the final IBasicList interface
|
|
TIBasicList = class (TICustomBasicList, IBasicList)
|
|
public
|
|
procedure SetItem (index: integer; const item: IBasic);
|
|
|
|
function Swap (index1, index2: integer) : boolean;
|
|
|
|
function DeleteItem (const item : IBasic) : boolean; overload;
|
|
|
|
function GetMaxInterface : IBasic; override;
|
|
end;
|
|
|
|
procedure TIBasicList.SetItem(index: integer; const item: IBasic);
|
|
var index_ : integer absolute index;
|
|
ib : IBasic;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
if CheckValid then
|
|
if (index >= 0) and (index < FCount) then begin
|
|
if item <> nil then begin
|
|
if item.Index[self] = -1 then begin
|
|
if FItemInfos[index] <> nil then begin
|
|
Change(FItems[index], true, lctDeleted, index, -1);
|
|
item.Selected[self] := false;
|
|
item.Focused [self] := false;
|
|
item.Checked [self] := no;
|
|
with FItemInfos[index]^ do begin
|
|
LastChangeType := lctDeleted;
|
|
OldIndex := Index;
|
|
Index := -1;
|
|
end;
|
|
ib := FItems[index];
|
|
FItems[index] := nil;
|
|
Change(ib, false, lctDeleted, index, -1);
|
|
TIBasic(ib.SelfAsTObject).DelParent(self);
|
|
end;
|
|
FItems[index] := item;
|
|
FItemInfos[index] := nil;
|
|
if item <> nil then begin
|
|
Change(item, true, lctNew, -1, index);
|
|
FItemInfos[index] := TIBasic(item.SelfAsTObject).AddParent(self);
|
|
with FItemInfos[index]^ do begin
|
|
LastChangeType := lctNew;
|
|
OldIndex := -1;
|
|
Index := index_;
|
|
Selected := false;
|
|
Focused := false;
|
|
Checked := no;
|
|
end;
|
|
Change(item, false, lctNew, -1, index);
|
|
end;
|
|
end;
|
|
end else SetLastError(ERROR_INVALID_PARAMETER);
|
|
end else SetLastError(CErrorNo_InvalidIndex, UnicodeString(AnsiString(CErrorStr_InvalidIndex)));
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIBasicList.Swap(index1, index2: integer) : boolean;
|
|
var i1 : integer;
|
|
p1 : pointer;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
result := CheckValid;
|
|
if result then begin
|
|
result := (index1 >= 0) and (index2 >= 0) and (index1 < FCount) and (index2 < FCount);
|
|
if result then begin
|
|
if index1 <> index2 then begin
|
|
if index1 > index2 then begin
|
|
i1 := index1;
|
|
index1 := index2;
|
|
index2 := i1;
|
|
end;
|
|
Change(FItems[index1], true, lctChanged, index1, index2);
|
|
Change(FItems[index2], true, lctChanged, index2, index1);
|
|
p1 := pointer(FItems[index1]);
|
|
pointer(FItems[index1]) := pointer(FItems[index2]);
|
|
pointer(FItems[index2]) := p1;
|
|
p1 := pointer(FItemInfos[index1]);
|
|
pointer(FItemInfos[index1]) := pointer(FItemInfos[index2]);
|
|
pointer(FItemInfos[index2]) := p1;
|
|
if FItemInfos[index1] <> nil then
|
|
with FItemInfos[index1]^ do begin
|
|
LastChangeType := lctChanged;
|
|
OldIndex := index2;
|
|
Index := index1;
|
|
end;
|
|
if FItemInfos[index2] <> nil then
|
|
with FItemInfos[index2]^ do begin
|
|
LastChangeType := lctChanged;
|
|
OldIndex := index1;
|
|
Index := index2;
|
|
end;
|
|
Change(FItems[index1], false, lctChanged, index2, index1);
|
|
Change(FItems[index2], false, lctChanged, index1, index2);
|
|
end;
|
|
end else SetLastError(CErrorNo_InvalidIndex, UnicodeString(AnsiString(CErrorStr_InvalidIndex)));
|
|
end;
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIBasicList.DeleteItem(const item: IBasic) : boolean;
|
|
var i1 : integer;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
i1 := item.Index[self];
|
|
result := (i1 <> -1) and DeleteItem(i1);
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIBasicList.GetMaxInterface : IBasic;
|
|
begin
|
|
result := IBasicList(self);
|
|
end;
|
|
|
|
function NewBasicList : IBasicList;
|
|
begin
|
|
result := TIBasicList.Create(true, 0, '');
|
|
end;
|
|
|
|
function NewBasicList(const items: array of IBasic) : IBasicList;
|
|
begin
|
|
result := TIBasicList.Create(true, 0, '');
|
|
result.AddItems(items);
|
|
end;
|
|
|
|
// ***************************************************************
|
|
|
|
type
|
|
// implements IInterfaceList
|
|
TIInterfaceList = class (TIList, IInterfaceList)
|
|
public
|
|
FItems : TDAIUnknown;
|
|
FSortProc : TCompareInterface;
|
|
FSortDown : boolean;
|
|
FSortInfo : integer;
|
|
|
|
function GetItem (index: integer) : IUnknown;
|
|
procedure SetItem (index: integer; const item: IUnknown);
|
|
|
|
procedure SetCapacity (capacity: integer); override;
|
|
|
|
procedure Pack; override;
|
|
|
|
function AddItem (const item : IUnknown) : integer;
|
|
function AddItems (const items : array of IUnknown) : integer;
|
|
|
|
function InsertItem (const item: IUnknown; index: integer = 0) : integer;
|
|
|
|
function FindItem (const item: IUnknown) : integer;
|
|
|
|
function Swap (index1, index2: integer) : boolean;
|
|
|
|
function DeleteItem ( index : integer ) : boolean; override;
|
|
function DeleteItem (const item : IUnknown) : boolean; overload;
|
|
|
|
function GetSortProc : TCompareInterface;
|
|
function GetSortDown : boolean; override;
|
|
function GetSortInfo : integer; override;
|
|
procedure SetSortProc (value: TCompareInterface);
|
|
procedure SetSortDown (value: boolean); override;
|
|
procedure SetSortInfo (value: integer); override;
|
|
function GetSortParams (var func: TCompareInterface; var down: boolean; var info: integer ) : boolean;
|
|
procedure SetSortParams ( func: TCompareInterface; down: boolean = true; info: integer = 0);
|
|
|
|
function GetMaxInterface : IBasic; override;
|
|
end;
|
|
|
|
function TIInterfaceList.GetItem(index: integer) : IUnknown;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
if (index < 0) or (index >= FCount) then
|
|
raise MadException.Create(string(CErrorStr_IndexOutOfRange));
|
|
result := FItems[index];
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
procedure TIInterfaceList.SetItem(index: integer; const item: IUnknown);
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
if CheckValid then
|
|
if (index >= 0) and (index < FCount) then
|
|
FItems[index] := item
|
|
else SetLastError(CErrorNo_InvalidIndex, UnicodeString(AnsiString(CErrorStr_InvalidIndex)));
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
procedure TIInterfaceList.SetCapacity(capacity: integer);
|
|
var i1 : integer;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
if capacity <> FCapacity then begin
|
|
for i1 := FCount - 1 downto capacity do
|
|
DeleteItem(i1);
|
|
SetLength(FItems, capacity);
|
|
FCapacity := capacity;
|
|
if FCount > FCapacity then FCount := FCapacity;
|
|
end;
|
|
FSuccess := true;
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
procedure TIInterfaceList.Pack;
|
|
var i1 : integer;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
for i1 := FCount-1 downto 0 do
|
|
if FItems[i1] = nil then
|
|
DeleteItem(i1);
|
|
SetCapacity(FCount);
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIInterfaceList.AddItem(const item: IUnknown) : integer;
|
|
var i1 : integer;
|
|
begin
|
|
result := -1;
|
|
FSection.Enter;
|
|
try
|
|
if CheckValid then
|
|
if item <> nil then begin
|
|
if (@FSortProc <> nil) and (FCount > 0) then begin
|
|
if FSortDown then begin
|
|
for i1 := 0 to FCount - 1 do
|
|
if (FItems[i1] <> nil) and (FSortProc(IList(GetMaxInterface), FItems[i1], item, FSortInfo) >= 0) then
|
|
break;
|
|
end else
|
|
for i1 := 0 to FCount - 1 do
|
|
if (FItems[i1] = nil) or (FSortProc(IList(GetMaxInterface), item, FItems[i1], FSortInfo) >= 0) then
|
|
break;
|
|
result := InsertItem(item, i1);
|
|
end else begin
|
|
if FCount = FCapacity then Grow;
|
|
result := FCount;
|
|
FItems[result] := item;
|
|
inc(FCount);
|
|
end;
|
|
end else SetLastError(ERROR_INVALID_PARAMETER);
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIInterfaceList.AddItems(const items: array of IUnknown) : integer;
|
|
var i1, i2 : integer;
|
|
begin
|
|
result := -1;
|
|
FSection.Enter;
|
|
try
|
|
if CheckValid then
|
|
for i1 := 0 to high(items) do begin
|
|
i2 := AddItem(items[i1]);
|
|
if (i2 < result) or (result = -1) then
|
|
result := i2;
|
|
end;
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIInterfaceList.InsertItem(const item: IUnknown; index: integer = 0) : integer;
|
|
begin
|
|
result := -1;
|
|
FSection.Enter;
|
|
try
|
|
if CheckValid then
|
|
if index >= 0 then begin
|
|
if FCount = FCapacity then Grow;
|
|
if index < FCount then begin
|
|
Move(FItems[index], FItems[index + 1], (FCount - index) * sizeOf(IUnknown));
|
|
result := index;
|
|
pointer(FItems[result]) := nil;
|
|
end else result := FCount;
|
|
FItems[result] := item;
|
|
inc(FCount);
|
|
end else SetLastError(CErrorNo_InvalidIndex, UnicodeString(AnsiString(CErrorStr_InvalidIndex)));
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIInterfaceList.FindItem(const item: IUnknown) : integer;
|
|
begin
|
|
FSuccess := true;
|
|
FSection.Enter;
|
|
try
|
|
for result := 0 to FCount - 1 do
|
|
if item = FItems[result] then
|
|
exit;
|
|
result := -1;
|
|
SetLastError(ERROR_FILE_NOT_FOUND);
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIInterfaceList.Swap(index1, index2: integer) : boolean;
|
|
var p1 : pointer;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
result := CheckValid;
|
|
if result then begin
|
|
result := (index1 >= 0) and (index2 >= 0) and (index1 < FCount) and (index2 < FCount);
|
|
if result then begin
|
|
if index1 <> index2 then begin
|
|
p1 := pointer(FItems[index1]);
|
|
pointer(FItems[index1]) := pointer(FItems[index2]);
|
|
pointer(FItems[index2]) := p1;
|
|
end;
|
|
end else SetLastError(CErrorNo_InvalidIndex, UnicodeString(AnsiString(CErrorStr_InvalidIndex)));
|
|
end;
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIInterfaceList.DeleteItem(index: integer) : boolean;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
result := (index >= 0) and (index < FCount);
|
|
if result then begin
|
|
FSuccess := true;
|
|
FItems[index] := nil;
|
|
dec(FCount);
|
|
if index < FCount then begin
|
|
Move(FItems[index+1], FItems[index], (FCount - index) * sizeOf(IUnknown));
|
|
pointer(FItems[FCount]) := nil;
|
|
end;
|
|
end else SetLastError(CErrorNo_InvalidIndex, UnicodeString(AnsiString(CErrorStr_InvalidIndex)));
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIInterfaceList.DeleteItem(const item: IUnknown) : boolean;
|
|
var i1 : integer;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
i1 := FindItem(item);
|
|
result := (i1 <> -1) and DeleteItem(i1);
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIInterfaceList.GetSortProc : TCompareInterface;
|
|
begin
|
|
result := FSortProc;
|
|
end;
|
|
|
|
function TIInterfaceList.GetSortDown : boolean;
|
|
begin
|
|
result := FSortDown;
|
|
end;
|
|
|
|
function TIInterfaceList.GetSortInfo : integer;
|
|
begin
|
|
result := FSortInfo;
|
|
end;
|
|
|
|
procedure TIInterfaceList.SetSortProc(value: TCompareInterface);
|
|
begin
|
|
SetSortParams(value, true, FSortInfo);
|
|
end;
|
|
|
|
procedure TIInterfaceList.SetSortDown(value: boolean);
|
|
begin
|
|
SetSortParams(FSortProc, value, FSortInfo);
|
|
end;
|
|
|
|
procedure TIInterfaceList.SetSortInfo(value: integer);
|
|
begin
|
|
SetSortParams(FSortProc, FSortDown, value);
|
|
end;
|
|
|
|
function TIInterfaceList.GetSortParams(var func: TCompareInterface; var down: boolean; var info: integer) : boolean;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
func := FSortProc;
|
|
down := FSortDown;
|
|
info := FSortInfo;
|
|
result := @FSortProc <> nil;
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
procedure TIInterfaceList.SetSortParams(func: TCompareInterface; down: boolean = true; info: integer = 0);
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
if CheckValid then
|
|
if (@func <> @FSortProc) or (down <> FSortDown) or (info <> FSortInfo) then begin
|
|
FSortProc := func;
|
|
FSortDown := down;
|
|
FSortInfo := info;
|
|
if (@FSortProc <> nil) and (FCount > 0) then
|
|
QuickSort(FItems[0], pointer(nil^), 0, FCount - 1, @FSortProc, FSortDown, FSortInfo);
|
|
end;
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIInterfaceList.GetMaxInterface : IBasic;
|
|
begin
|
|
result := IInterfaceList(self);
|
|
end;
|
|
|
|
function NewInterfaceList : IInterfaceList;
|
|
begin
|
|
result := TIInterfaceList.Create(true, 0, '');
|
|
end;
|
|
|
|
function NewInterfaceList(const items: array of IUnknown) : IInterfaceList;
|
|
begin
|
|
result := TIInterfaceList.Create(true, 0, '');
|
|
result.AddItems(items);
|
|
end;
|
|
|
|
// ***************************************************************
|
|
|
|
type
|
|
// pointer list
|
|
TIPointerList = class (TIList, IPointerList)
|
|
public
|
|
FItems : TDAPointer;
|
|
FDestroyProc : TDestroyPointerProc;
|
|
FSortProc : TComparePointer;
|
|
FSortDown : boolean;
|
|
FSortInfo : integer;
|
|
|
|
constructor Create (valid: boolean; lastErrorNo: cardinal; const lastErrorStr: UnicodeString;
|
|
destroyProc : TDestroyPointerProc);
|
|
|
|
function GetItem (index: integer) : pointer;
|
|
procedure SetItem (index: integer; item: pointer);
|
|
|
|
procedure SetCapacity (capacity: integer); override;
|
|
|
|
procedure Pack; override;
|
|
|
|
function AddItem (item : pointer) : integer;
|
|
function AddItems (const items : array of pointer) : integer;
|
|
|
|
function InsertItem (item: pointer; index: integer = 0) : integer;
|
|
|
|
function FindItem (item: pointer) : integer;
|
|
|
|
function Swap (index1, index2: integer) : boolean;
|
|
|
|
function DeleteItem (index : integer) : boolean; override;
|
|
function DeleteItem (item : pointer) : boolean; overload;
|
|
|
|
function GetSortProc : TComparePointer;
|
|
function GetSortDown : boolean; override;
|
|
function GetSortInfo : integer; override;
|
|
procedure SetSortProc (value: TComparePointer);
|
|
procedure SetSortDown (value: boolean); override;
|
|
procedure SetSortInfo (value: integer); override;
|
|
function GetSortParams (var func: TComparePointer; var down: boolean; var info: integer ) : boolean;
|
|
procedure SetSortParams ( func: TComparePointer; down: boolean = true; info: integer = 0);
|
|
|
|
function GetMaxInterface : IBasic; override;
|
|
end;
|
|
|
|
constructor TIPointerList.Create(valid: boolean; lastErrorNo: cardinal; const lastErrorStr: UnicodeString;
|
|
destroyProc : TDestroyPointerProc);
|
|
begin
|
|
inherited Create(valid, lastErrorNo, lastErrorStr);
|
|
if FValid then
|
|
FDestroyProc := destroyProc;
|
|
end;
|
|
|
|
function TIPointerList.GetItem(index: integer) : pointer;
|
|
begin
|
|
{$ifndef d10_2}
|
|
result := nil;
|
|
{$endif}
|
|
FSection.Enter;
|
|
try
|
|
if (index < 0) or (index > FCount) then
|
|
raise MadException.Create(string(CErrorStr_IndexOutOfRange))
|
|
else
|
|
result := FItems[index];
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
procedure TIPointerList.SetItem(index: integer; item: pointer);
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
if CheckValid then
|
|
if (index >= 0) and (index < FCount) then begin
|
|
if (FItems[index] <> nil) and (@FDestroyProc <> nil) then
|
|
FDestroyProc(FItems[index]);
|
|
FItems[index] := item;
|
|
end else SetLastError(CErrorNo_InvalidIndex, UnicodeString(AnsiString(CErrorStr_InvalidIndex)));
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
procedure TIPointerList.SetCapacity(capacity: integer);
|
|
var i1 : integer;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
if capacity <> FCapacity then begin
|
|
for i1 := FCount - 1 downto capacity do
|
|
DeleteItem(i1);
|
|
SetLength(FItems, capacity);
|
|
FCapacity := capacity;
|
|
if FCount > FCapacity then FCount := FCapacity;
|
|
end;
|
|
FSuccess := true;
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
procedure TIPointerList.Pack;
|
|
var i1 : integer;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
for i1 := FCount-1 downto 0 do
|
|
if FItems[i1] = nil then
|
|
DeleteItem(i1);
|
|
SetCapacity(FCount);
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIPointerList.AddItem(item: pointer) : integer;
|
|
var i1 : integer;
|
|
begin
|
|
result := -1;
|
|
FSection.Enter;
|
|
try
|
|
if CheckValid then
|
|
if item <> nil then begin
|
|
if (@FSortProc <> nil) and (FCount > 0) then begin
|
|
if FSortDown then begin
|
|
for i1 := 0 to FCount - 1 do
|
|
if (FItems[i1] <> nil) and (FSortProc(IList(GetMaxInterface), FItems[i1], item, FSortInfo) >= 0) then
|
|
break;
|
|
end else
|
|
for i1 := 0 to FCount - 1 do
|
|
if (FItems[i1] = nil) or (FSortProc(IList(GetMaxInterface), item, FItems[i1], FSortInfo) >= 0) then
|
|
break;
|
|
result := InsertItem(item, i1);
|
|
end else begin
|
|
if FCount = FCapacity then Grow;
|
|
result := FCount;
|
|
FItems[result] := item;
|
|
inc(FCount);
|
|
end;
|
|
end else SetLastError(ERROR_INVALID_PARAMETER);
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIPointerList.AddItems(const items: array of pointer) : integer;
|
|
var i1, i2 : integer;
|
|
begin
|
|
result := -1;
|
|
FSection.Enter;
|
|
try
|
|
if CheckValid then
|
|
for i1 := 0 to high(items) do begin
|
|
i2 := AddItem(items[i1]);
|
|
if (i2 < result) or (result = -1) then
|
|
result := i2;
|
|
end;
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIPointerList.InsertItem(item : pointer;
|
|
index : integer = 0) : integer;
|
|
begin
|
|
result := -1;
|
|
FSection.Enter;
|
|
try
|
|
if CheckValid then
|
|
if index >= 0 then begin
|
|
if FCount = FCapacity then Grow;
|
|
if index < FCount then begin
|
|
Move(FItems[index], FItems[index + 1], (FCount - index) * sizeOf(pointer));
|
|
result := index;
|
|
FItems[result] := nil;
|
|
end else result := FCount;
|
|
FItems[result] := item;
|
|
inc(FCount);
|
|
end else SetLastError(CErrorNo_InvalidIndex, UnicodeString(AnsiString(CErrorStr_InvalidIndex)));
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIPointerList.FindItem(item: pointer) : integer;
|
|
begin
|
|
FSuccess := true;
|
|
FSection.Enter;
|
|
try
|
|
for result := 0 to FCount - 1 do
|
|
if item = FItems[result] then
|
|
exit;
|
|
result := -1;
|
|
SetLastError(ERROR_FILE_NOT_FOUND);
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIPointerList.Swap(index1, index2: integer) : boolean;
|
|
var p1 : pointer;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
result := CheckValid;
|
|
if result then begin
|
|
result := (index1 >= 0) and (index2 >= 0) and (index1 < FCount) and (index2 < FCount);
|
|
if result then begin
|
|
if index1 <> index2 then begin
|
|
p1 := FItems[index1];
|
|
FItems[index1] := FItems[index2];
|
|
FItems[index2] := p1;
|
|
end;
|
|
end else SetLastError(CErrorNo_InvalidIndex, UnicodeString(AnsiString(CErrorStr_InvalidIndex)));
|
|
end;
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIPointerList.DeleteItem(index: integer) : boolean;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
result := (index >= 0) and (index < FCount);
|
|
if result then begin
|
|
FSuccess := true;
|
|
FItems[index] := nil;
|
|
dec(FCount);
|
|
if index < FCount then begin
|
|
Move(FItems[index+1], FItems[index], (FCount - index) * sizeOf(pointer));
|
|
FItems[FCount] := nil;
|
|
end;
|
|
end else SetLastError(CErrorNo_InvalidIndex, UnicodeString(AnsiString(CErrorStr_InvalidIndex)));
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIPointerList.DeleteItem(item: pointer) : boolean;
|
|
var i1 : integer;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
i1 := FindItem(item);
|
|
result := (i1 <> -1) and DeleteItem(i1);
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIPointerList.GetSortProc : TComparePointer;
|
|
begin
|
|
result := FSortProc;
|
|
end;
|
|
|
|
function TIPointerList.GetSortDown : boolean;
|
|
begin
|
|
result := FSortDown;
|
|
end;
|
|
|
|
function TIPointerList.GetSortInfo : integer;
|
|
begin
|
|
result := FSortInfo;
|
|
end;
|
|
|
|
procedure TIPointerList.SetSortProc(value: TComparePointer);
|
|
begin
|
|
SetSortParams(value, true, FSortInfo);
|
|
end;
|
|
|
|
procedure TIPointerList.SetSortDown(value: boolean);
|
|
begin
|
|
SetSortParams(FSortProc, value, FSortInfo);
|
|
end;
|
|
|
|
procedure TIPointerList.SetSortInfo(value: integer);
|
|
begin
|
|
SetSortParams(FSortProc, FSortDown, value);
|
|
end;
|
|
|
|
function TIPointerList.GetSortParams(var func: TComparePointer; var down: boolean; var info: integer) : boolean;
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
func := FSortProc;
|
|
down := FSortDown;
|
|
info := FSortInfo;
|
|
result := @FSortProc <> nil;
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
procedure TIPointerList.SetSortParams(func: TComparePointer; down: boolean = true; info: integer = 0);
|
|
begin
|
|
FSection.Enter;
|
|
try
|
|
if CheckValid then
|
|
if (@func <> @FSortProc) or (down <> FSortDown) or (info <> FSortInfo) then begin
|
|
FSortProc := func;
|
|
FSortDown := down;
|
|
FSortInfo := info;
|
|
if (@FSortProc <> nil) and (FCount > 0) then
|
|
QuickSort(FItems[0], pointer(nil^), 0, FCount - 1, @FSortProc, FSortDown, FSortInfo);
|
|
end;
|
|
finally FSection.Leave end;
|
|
end;
|
|
|
|
function TIPointerList.GetMaxInterface : IBasic;
|
|
begin
|
|
result := IPointerList(self);
|
|
end;
|
|
|
|
function NewPointerList : IPointerList;
|
|
begin
|
|
result := TIPointerList.Create(true, 0, '', nil);
|
|
end;
|
|
|
|
function NewPointerList(const items: array of pointer; destroyProc: TDestroyPointerProc = nil) : IPointerList;
|
|
begin
|
|
result := TIPointerList.Create(true, 0, '', destroyProc);
|
|
result.AddItems(items);
|
|
end;
|
|
|
|
// ***************************************************************
|
|
|
|
end. |