|
- unit uutlGenerics;
-
- { Package: Utils
- Prefix: utl - UTiLs
- Beschreibung: diese Unit implementiert allgemein nützliche ausschließlich-generische Klassen }
-
- {$mode objfpc}{$H+}
- {$modeswitch nestedprocvars}
-
- interface
-
- uses
- Classes, SysUtils, typinfo,
- uutlSyncObjs, uutlInterfaces;
-
- type
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlListBase<T> = class(TObject)
- private type
- TListItem = packed record
- data: T;
- end;
- PListItem = ^TListItem;
-
- public type
- TItemEvent = procedure(aSender: TObject; const aIndex: Integer; const aItem: T) of object;
- TEnumerator = class(TObject)
- private
- fReverse: Boolean;
- fList: TFPList;
- fPosition: Integer;
- function GetCurrent: T;
- public
- property Current: T read GetCurrent;
- function GetEnumerator: TEnumerator;
- function MoveNext: Boolean;
- constructor Create(const aList: TFPList; const aReverse: Boolean = false);
- end;
-
- private
- fList: TFPList;
- fOwnsObjects: Boolean;
-
- protected
- property List: TFPList read fList;
-
- function GetCount: Integer;
- function GetItem(const aIndex: Integer): T;
- procedure SetCount(const aValue: Integer);
- procedure SetItem(const aIndex: Integer; const aItem: T);
-
- function CreateItem: PListItem; virtual;
- procedure DestroyItem(const aItem: PListItem; const aFreeItem: Boolean = true); virtual;
- procedure InsertIntern(const aIndex: Integer; const aItem: T); virtual;
- procedure DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean = true); virtual;
-
- public
- property OwnsObjects: Boolean read fOwnsObjects write fOwnsObjects;
-
- function GetEnumerator: TEnumerator;
- function GetReverseEnumerator: TEnumerator;
- procedure ForEach(const aEvent: TItemEvent);
- procedure Clear;
-
- constructor Create(const aOwnsObjects: Boolean = true);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- { a simple list without the ability to compare objects (e.g. for IndexOf, Remove, Extract) }
- generic TutlSimpleList<T> = class(specialize TutlListBase<T>)
- public type
- IComparer = specialize IutlComparer<T>;
- TSortDirection = (sdAscending, sdDescending);
- private
- function Split(aComparer: IComparer; const aDirection: TSortDirection; const aLeft, aRight: Integer): Integer;
- procedure QuickSort(aComparer: IComparer; const aDirection: TSortDirection; const aLeft, aRight: Integer);
- public
- property Items[const aIndex: Integer]: T read GetItem write SetItem; default;
- property Count: Integer read GetCount write SetCount;
-
- function Add(const aItem: T): Integer;
- procedure Insert(const aIndex: Integer; const aItem: T);
-
- procedure Exchange(const aIndex1, aIndex2: Integer);
- procedure Move(const aCurIndex, aNewIndex: Integer);
- procedure Sort(aComparer: IComparer; const aDirection: TSortDirection = sdAscending);
-
- procedure Delete(const aIndex: Integer);
-
- function First: T;
- procedure PushFirst(const aItem: T);
- function PopFirst(const aFreeItem: Boolean = false): T;
-
- function Last: T;
- procedure PushLast(const aItem: T);
- function PopLast(const aFreeItem: Boolean = false): T;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlCustomList<T> = class(specialize TutlSimpleList<T>)
- public type
- IEqualityComparer = specialize IutlEqualityComparer<T>;
- private
- fEqualityComparer: IEqualityComparer;
- public
- function IndexOf(const aItem: T): Integer;
- function Extract(const aItem: T; const aDefault: T): T;
- function Remove(const aItem: T): Integer;
-
- constructor Create(aEqualityComparer: IEqualityComparer; const aOwnsObjects: Boolean = true);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlList<T> = class(specialize TutlCustomList<T>)
- public type
- TEqualityComparer = specialize TutlEqualityComparer<T>;
- public
- constructor Create(const aOwnsObjects: Boolean = true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlHashSetBase<T> = class(specialize TutlListBase<T>)
- public type
- THashItemEvent = procedure(aSender: TObject; const aItem: T) of object;
- IComparer = specialize IutlComparer<T>;
- private
- fComparer: IComparer;
- protected
- function SearchItem(const aMin, aMax: Integer; const aItem: T; out aIndex: Integer): Integer;
- public
- procedure ForEach(const aEvent: THashItemEvent);
-
- constructor Create(aComparer: IComparer; const aOwnsObjects: Boolean = true);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlCustomHashSet<T> = class(specialize TutlHashSetBase<T>)
- public
- property Items[const aIndex: Integer]: T read GetItem; default;
- property Count: Integer read GetCount;
-
- function Add(const aItem: T): Boolean;
- function Contains(const aItem: T): Boolean;
- function IndexOf(const aItem: T): Integer;
- function Remove(const aItem: T): Boolean;
- procedure Delete(const aIndex: Integer);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlHashSet<T> = class(specialize TutlCustomHashSet<T>)
- public type
- TComparer = specialize TutlComparer<T>;
- public
- constructor Create(const aOwnsObjects: Boolean = true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- EutlMap = class(Exception);
- EutlMapKeyNotFound = class(EutlMap)
- public
- constructor Create;
- end;
- EutlMapKeyAlreadyExists = class(EutlMap)
- public
- constructor Create;
- end;
-
- generic TutlMapBase<TKey, TValue> = class(TObject)
- public type
- TKeyValuePairEvent = procedure(aSender: TObject; const aKey: TKey; const aValue: TValue) of object;
-
- IComparer = specialize IutlComparer<TKey>;
- TKeyValuePair = packed record
- Key: TKey;
- Value: TValue;
- end;
-
- THashSet = class(specialize TutlCustomHashSet<TKeyValuePair>)
- protected
- procedure DestroyItem(const aItem: PListItem; const aFreeItem: Boolean = true); override;
- public
- property Items[const aIndex: Integer]: TKeyValuePair read GetItem write SetItem; default;
- end;
-
- TKeyValuePairComparer = class(TInterfacedObject, THashSet.IComparer)
- private
- fComparer: IComparer;
- public
- function Compare(const i1, i2: TKeyValuePair): Integer;
- constructor Create(aComparer: IComparer);
- destructor Destroy; override;
- end;
-
- TEnumeratorProxy = class(TObject)
- fEnumerator: THashSet.TEnumerator;
- function MoveNext: Boolean;
- constructor Create(const aEnumerator: THashSet.TEnumerator);
- destructor Destroy; override;
- end;
-
- TValueEnumerator = class(TEnumeratorProxy)
- function GetCurrent: TValue;
- property Current: TValue read GetCurrent;
- function GetEnumerator: TValueEnumerator;
- end;
-
- TKeyEnumerator = class(TEnumeratorProxy)
- function GetCurrent: TKey;
- property Current: TKey read GetCurrent;
- function GetEnumerator: TKeyEnumerator;
- end;
-
- TKeyWrapper = class(TObject)
- private
- fHashSet: THashSet;
- function GetItem(const aIndex: Integer): TKey;
- function GetCount: Integer;
- public
- property Items[const aIndex: Integer]: TKey read GetItem; default;
- property Count: Integer read GetCount;
- function GetEnumerator: TKeyEnumerator;
- function GetReverseEnumerator: TKeyEnumerator;
- constructor Create(const aHashSet: THashSet);
- end;
-
- TKeyValuePairWrapper = class(TObject)
- private
- fHashSet: THashSet;
- function GetItem(const aIndex: Integer): TKeyValuePair;
- function GetCount: Integer;
- public
- property Items[const aIndex: Integer]: TKeyValuePair read GetItem; default;
- property Count: Integer read GetCount;
- function GetEnumerator: THashSet.TEnumerator;
- function GetReverseEnumerator: THashSet.TEnumerator;
- constructor Create(const aHashSet: THashSet);
- end;
-
- private
- fAutoCreate: Boolean;
- fHashSetRef: THashSet;
- fKeyWrapper: TKeyWrapper;
- fKeyValuePairWrapper: TKeyValuePairWrapper;
-
- function GetValues(const aKey: TKey): TValue;
- function GetValueAt(const aIndex: Integer): TValue;
- function GetCount: Integer;
-
- procedure SetValueAt(const aIndex: Integer; aValue: TValue);
- procedure SetValues(const aKey: TKey; aValue: TValue);
- public
- property Values [const aKey: TKey]: TValue read GetValues write SetValues; default;
- property ValueAt[const aIndex: Integer]: TValue read GetValueAt write SetValueAt;
- property Keys: TKeyWrapper read fKeyWrapper;
- property KeyValuePairs: TKeyValuePairWrapper read fKeyValuePairWrapper;
- property Count: Integer read GetCount;
- property AutoCreate: Boolean read fAutoCreate write fAutoCreate;
-
- procedure Add(const aKey: TKey; const aValue: TValue);
- function IndexOf(const aKey: TKey): Integer;
- function Contains(const aKey: TKey): Boolean;
- procedure Delete(const aKey: TKey);
- procedure DeleteAt(const aIndex: Integer);
- procedure Clear;
-
- procedure ForEach(const aEvent: TKeyValuePairEvent);
- function GetEnumerator: TValueEnumerator;
- function GetReverseEnumerator: TValueEnumerator;
-
- constructor Create(const aHashSet: THashSet);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlCustomMap<TKey, TValue> = class(specialize TutlMapBase<TKey, TValue>)
- private
- fHashSetImpl: THashSet;
- public
- constructor Create(const aComparer: IComparer; const aOwnsObjects: Boolean = true);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlMap<TKey, TValue> = class(specialize TutlCustomMap<TKey, TValue>)
- public type
- TComparer = specialize TutlComparer<TKey>;
- public
- constructor Create(const aOwnsObjects: Boolean = true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlQueue<T> = class(TObject)
- public type
- PListItem = ^TListItem;
- TListItem = packed record
- data: T;
- next: PListItem;
- end;
- private
- function GetCount: Integer;
- protected
- fFirst: PListItem;
- fLast: PListItem;
- fCount: Integer;
- fOwnsObjects: Boolean;
- public
- property Count: Integer read GetCount;
-
- procedure Push(const aItem: T); virtual;
- function Pop(out aItem: T): Boolean; virtual;
- function Pop: Boolean;
- procedure Clear;
-
- constructor Create(const aOwnsObjects: Boolean = true);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlSyncQueue<T> = class(specialize TutlQueue<T>)
- private
- fPushLock: TutlSpinLock;
- fPopLock: TutlSpinLock;
- public
- procedure Push(const aItem: T); override;
- function Pop(out aItem: T): Boolean; override;
-
- constructor Create(const aOwnsObjects: Boolean = true);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlInterfaceList<T> = class(TInterfaceList)
- private type
- TInterfaceEnumerator = class(TObject)
- private
- fList: TInterfaceList;
- fPos: Integer;
- function GetCurrent: T;
- public
- property Current: T read GetCurrent;
- function MoveNext: Boolean;
- constructor Create(const aList: TInterfaceList);
- end;
-
- private
- function Get(i : Integer): T;
- procedure Put(i : Integer; aItem : T);
- public
- property Items[Index : Integer]: T read Get write Put; default;
-
- function First: T;
- function IndexOf(aItem : T): Integer;
- function Add(aItem : IUnknown): Integer;
- procedure Insert(i : Integer; aItem : T);
- function Last : T;
- function Remove(aItem : T): Integer;
-
- function GetEnumerator: TInterfaceEnumerator;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- EutlEnumConvert = class(EConvertError)
- public
- constructor Create(const aValue, aExpectedType: String);
- end;
- generic TutlEnumHelper<T> = class(TObject)
- private type
- TValueArray = array of T;
- private class var
- FTypeInfo: PTypeInfo;
- FValues: TValueArray;
- public
- class constructor Initialize;
- class function ToString(aValue: T): String; reintroduce;
- class function TryToEnum(aStr: String; out aValue: T): Boolean;
- class function ToEnum(aStr: String): T; overload;
- class function ToEnum(aStr: String; const aDefault: T): T; overload;
- class function Values: TValueArray;
- class function TypeInfo: PTypeInfo;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlRingBuffer<T> = class
- private
- fAborted: boolean;
- fData: packed array of T;
- fDataLen: Integer;
- fDataSize: integer;
- fFillState: integer;
- fWritePtr, fReadPtr: integer;
- fWrittenEvent,
- fReadEvent: TutlAutoResetEvent;
- public
- constructor Create(const Elements: Integer);
- destructor Destroy; override;
- function Read(Buf: Pointer; Items: integer; BlockUntilAvail: boolean): integer;
- function Write(Buf: Pointer; Items: integer; BlockUntilDone: boolean): integer;
- procedure BreakPipe;
- property FillState: Integer read fFillState;
- property Size: integer read fDataLen;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlPagedDataFiFo<TData> = class
- private type
- PPage = ^TPage;
- TPage = packed record
- Next: PPage;
- Data: array of TData;
- ReadPos: Integer;
- WritePos: Integer;
- end;
- public type
- PData = ^TData;
-
- IDataProvider = interface(IUnknown)
- function Give(const aBuffer: PData; aCount: Integer): Integer;
- end;
-
- IDataConsumer = interface(IUnknown)
- function Take(const aBuffer: PData; aCount: Integer): Integer;
- end;
-
- // read from buffer, write to fifo
- TDataProvider = class(TInterfacedObject, IDataProvider)
- private
- fData: PData;
- fPos: Integer;
- fCount: Integer;
- public
- function Give(const aBuffer: PData; aCount: Integer): Integer;
- constructor Create(const aData: PData; const aCount: Integer);
- end;
-
- // read from fifo, write to buffer
- TDataConsumer = class(TInterfacedObject, IDataConsumer)
- private
- fData: PData;
- fPos: Integer;
- fCount: Integer;
- public
- function Take(const aBuffer: PData; aCount: Integer): Integer;
- constructor Create(const aData: PData; const aCount: Integer);
- end;
-
- // read from nested callback, write to fifo
- TDataCallback = function(const aBuffer: PData; aCount: Integer): Integer is nested;
- TNestedDataProvider = class(TInterfacedObject, IDataProvider)
- private
- fCallback: TDataCallback;
- public
- function Give(const aBuffer: PData; aCount: Integer): Integer;
- constructor Create(const aCallback: TDataCallback);
- end;
-
- // read from fifo, write to nested callback
- TNestedDataConsumer = class(TInterfacedObject, IDataConsumer)
- private
- fCallback: TDataCallback;
- public
- function Take(const aBuffer: PData; aCount: Integer): Integer;
- constructor Create(const aCallback: TDataCallback);
- end;
-
- // read from stream, write to fifo
- TStreamDataProvider = class(TInterfacedObject, IDataProvider)
- private
- fStream: TStream;
- public
- function Give(const aBuffer: PData; aCount: Integer): Integer;
- constructor Create(const aStream: TStream);
- end;
-
- // read from fifo, write to stream
- TStreamDataConsumer = class(TInterfacedObject, IDataConsumer)
- private
- fStream: TStream;
- public
- function Take(const aBuffer: PData; aCount: Integer): Integer;
- constructor Create(const aStream: TStream);
- end;
-
- private
- fPageSize: Integer;
- fReadPage: PPage;
- fWritePage: PPage;
- fSize: Integer;
- protected
- function WriteIntern(const aProvider: IDataProvider; aCount: Integer): Integer; virtual;
- function ReadIntern(const aConsumer: IDataConsumer; aCount: Integer; const aMoveReadPos: Boolean): Integer; virtual;
- public
- property Size: Integer read fSize;
- property PageSize: Integer read fPageSize;
-
- function Write(const aProvider: IDataProvider; const aCount: Integer): Integer; overload;
- function Write(const aData: PData; const aCount: Integer): Integer; overload;
-
- function Read(const aConsumer: IDataConsumer; const aCount: Integer): Integer; overload;
- function Read(const aData: PData; const aCount: Integer): Integer; overload;
-
- function Peek(const aConsumer: IDataConsumer; const aCount: Integer): Integer; overload;
- function Peek(const aData: PData; const aCount: Integer): Integer; overload;
-
- function Discard(const aCount: Integer): Integer;
- procedure Clear;
-
- constructor Create(const aPageSize: Integer = 2048);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlSyncPagedDataFiFo<TData> = class(specialize TutlPagedDataFiFo<TData>)
- private
- fLock: TutlSpinLock;
- protected
- function WriteIntern(const aProvider: IDataProvider; aCount: Integer): Integer; override;
- function ReadIntern(const aConsumer: IDataConsumer; aCount: Integer; const aMoveReadPos: Boolean): Integer; override;
- public
- constructor Create(const aPageSize: Integer = 2048);
- destructor Destroy; override;
- end;
-
- function utlFreeOrFinalize(var obj; const aTypeInfo: PTypeInfo; const aFreeObj: Boolean = true): Boolean;
-
- implementation
-
- uses
- uutlExceptions, syncobjs;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //Helper////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function utlFreeOrFinalize(var obj; const aTypeInfo: PTypeInfo; const aFreeObj: Boolean = true): Boolean;
- var
- o: TObject;
- begin
- result := true;
- case aTypeInfo^.Kind of
- tkClass: begin
- if (aFreeObj) then begin
- o := TObject(obj);
- Pointer(obj) := nil;
- o.Free;
- end;
- end;
-
- tkInterface: begin
- IUnknown(obj) := nil;
- end;
-
- tkAString: begin
- AnsiString(Obj) := '';
- end;
-
- tkUString: begin
- UnicodeString(Obj) := '';
- end;
-
- tkString: begin
- String(Obj) := '';
- end;
- else
- result := false;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.Create(const aComparer: IComparer; const aOwnsObjects: Boolean);
- begin
- fHashSetImpl := THashSet.Create(TKeyValuePairComparer.Create(aComparer), aOwnsObjects);
- inherited Create(fHashSetImpl);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlCustomMap.Destroy;
- begin
- inherited Destroy;
- FreeAndNil(fHashSetImpl);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //EutlEnumConvert///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor EutlEnumConvert.Create(const aValue, aExpectedType: String);
- begin
- inherited Create(Format('%s is not a %s', [aValue, aExpectedType]));
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //EutlMapKeyNotFound////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor EutlMapKeyNotFound.Create;
- begin
- inherited Create('key not found');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //EutlMapKeyAlreadyExists///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor EutlMapKeyAlreadyExists.Create;
- begin
- inherited Create('key already exists');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlListBase//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlListBase.TEnumerator.GetCurrent: T;
- begin
- result := PListItem(fList[fPosition])^.data;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlListBase.TEnumerator.GetEnumerator: TEnumerator;
- begin
- result := self;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlListBase.TEnumerator.MoveNext: Boolean;
- begin
- if fReverse then begin
- dec(fPosition);
- result := (fPosition >= 0);
- end else begin
- inc(fPosition);
- result := (fPosition < fList.Count)
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlListBase.TEnumerator.Create(const aList: TFPList; const aReverse: Boolean);
- begin
- inherited Create;
- fList := aList;
- fReverse := aReverse;
- if fReverse then
- fPosition := fList.Count
- else
- fPosition := -1;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlListBase//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlListBase.GetCount: Integer;
- begin
- result := fList.Count;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlListBase.GetItem(const aIndex: Integer): T;
- begin
- if (aIndex >= 0) and (aIndex < fList.Count) then
- result := PListItem(fList[aIndex])^.data
- else
- raise EOutOfRange.Create(aIndex, 0, fList.Count-1);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlListBase.SetCount(const aValue: Integer);
- var
- item: PListItem;
- begin
- if (aValue < 0) then
- raise EArgument.Create('new value for count must be positiv');
- while (aValue > fList.Count) do begin
- item := CreateItem;
- FillByte(item^, SizeOf(item^), 0);
- fList.Add(item);
- end;
- while (aValue < fList.Count) do
- DeleteIntern(fList.Count-1);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlListBase.SetItem(const aIndex: Integer; const aItem: T);
- var
- item: PListItem;
- begin
- if (aIndex >= 0) and (aIndex < fList.Count) then begin
- item := PListItem(fList[aIndex]);
- utlFreeOrFinalize(item^, TypeInfo(item^), fOwnsObjects);
- item^.data := aItem;
- end else
- raise EOutOfRange.Create(aIndex, 0, fList.Count-1);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlListBase.CreateItem: PListItem;
- begin
- new(result);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlListBase.DestroyItem(const aItem: PListItem; const aFreeItem: Boolean);
- begin
- utlFreeOrFinalize(aItem^.data, TypeInfo(aItem^.data), fOwnsObjects and aFreeItem);
- Dispose(aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlListBase.InsertIntern(const aIndex: Integer; const aItem: T);
- var
- item: PListItem;
- begin
- item := CreateItem;
- try
- item^.data := aItem;
- fList.Insert(aIndex, item);
- except
- DestroyItem(item, false);
- raise;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlListBase.DeleteIntern(const aIndex: Integer; const aFreeItem: Boolean);
- var
- item: PListItem;
- begin
- if (aIndex >= 0) and (aIndex < fList.Count) then begin
- item := PListItem(fList[aIndex]);
- fList.Delete(aIndex);
- DestroyItem(item, aFreeItem);
- end else
- raise EOutOfRange.Create(aIndex, 0, fList.Count-1);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlListBase.GetEnumerator: TEnumerator;
- begin
- result := TEnumerator.Create(fList, false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlListBase.GetReverseEnumerator: TEnumerator;
- begin
- result := TEnumerator.Create(fList, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlListBase.ForEach(const aEvent: TItemEvent);
- var i: Integer;
- begin
- if not Assigned(aEvent) then
- for i := 0 to fList.Count-1 do
- aEvent(self, i, PListItem(fList[i])^.data);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlListBase.Clear;
- begin
- while (fList.Count > 0) do
- DeleteIntern(fList.Count-1);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlListBase.Create(const aOwnsObjects: Boolean);
- begin
- inherited Create;
- fOwnsObjects := aOwnsObjects;
- fList := TFPList.Create;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlListBase.Destroy;
- begin
- Clear;
- FreeAndNil(fList);
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlSimpleList////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.Split(aComparer: IComparer; const aDirection: TSortDirection; const aLeft, aRight: Integer): Integer;
- var
- i, j: Integer;
- pivot: T;
- begin
- i := aLeft;
- j := aRight - 1;
- pivot := GetItem(aRight);
- repeat
- while ((aDirection = sdAscending) and (aComparer.Compare(GetItem(i), pivot) <= 0) or
- (aDirection = sdDescending) and (aComparer.Compare(GetItem(i), pivot) >= 0)) and
- (i < aRight) do inc(i);
-
- while ((aDirection = sdAscending) and (aComparer.Compare(GetItem(j), pivot) >= 0) or
- (aDirection = sdDescending) and (aComparer.Compare(GetItem(j), pivot) <= 0)) and
- (j > aLeft) do dec(j);
-
- if (i < j) then
- Exchange(i, j);
- until (i >= j);
-
- if ((aDirection = sdAscending) and (aComparer.Compare(GetItem(i), pivot) > 0)) or
- ((aDirection = sdDescending) and (aComparer.Compare(GetItem(i), pivot) < 0)) then
- Exchange(i, aRight);
-
- result := i;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.QuickSort(aComparer: IComparer; const aDirection: TSortDirection; const aLeft, aRight: Integer);
- var
- s: Integer;
- begin
- if (aLeft < aRight) then begin
- s := Split(aComparer, aDirection, aLeft, aRight);
- QuickSort(aComparer, aDirection, aLeft, s - 1);
- QuickSort(aComparer, aDirection, s + 1, aRight);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.Add(const aItem: T): Integer;
- begin
- result := Count;
- InsertIntern(result, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Insert(const aIndex: Integer; const aItem: T);
- begin
- InsertIntern(aIndex, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Exchange(const aIndex1, aIndex2: Integer);
- begin
- if (aIndex1 < 0) or (aIndex1 >= Count) then
- raise EOutOfRange.Create(aIndex1, 0, Count-1);
- if (aIndex2 < 0) or (aIndex2 >= Count) then
- raise EOutOfRange.Create(aIndex2, 0, Count-1);
- fList.Exchange(aIndex1, aIndex2);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Move(const aCurIndex, aNewIndex: Integer);
- begin
- if (aCurIndex < 0) or (aCurIndex >= Count) then
- raise EOutOfRange.Create(aCurIndex, 0, Count-1);
- if (aNewIndex < 0) or (aNewIndex >= Count) then
- raise EOutOfRange.Create(aNewIndex, 0, Count-1);
- fList.Move(aCurIndex, aNewIndex);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Sort(aComparer: IComparer; const aDirection: TSortDirection);
- begin
- QuickSort(aComparer, aDirection, 0, fList.Count-1);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Delete(const aIndex: Integer);
- begin
- DeleteIntern(aIndex);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.First: T;
- begin
- result := Items[0];
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.PushFirst(const aItem: T);
- begin
- InsertIntern(0, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.PopFirst(const aFreeItem: Boolean): T;
- begin
- if aFreeItem then
- FillByte(result{%H-}, SizeOf(result), 0)
- else
- result := First;
- DeleteIntern(0, aFreeItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.Last: T;
- begin
- result := Items[Count-1];
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.PushLast(const aItem: T);
- begin
- InsertIntern(Count, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.PopLast(const aFreeItem: Boolean): T;
- begin
- if aFreeItem then
- FillByte(result{%H-}, SizeOf(result), 0)
- else
- result := Last;
- DeleteIntern(Count-1, aFreeItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomList////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomList.IndexOf(const aItem: T): Integer;
- var
- c: Integer;
- begin
- c := List.Count;
- result := 0;
- while (result < c) and
- not fEqualityComparer.EqualityCompare(PListItem(List[result])^.data, aItem) do
- inc(result);
- if (result >= c) then
- result := -1;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomList.Extract(const aItem: T; const aDefault: T): T;
- var
- i: Integer;
- begin
- i := IndexOf(aItem);
- if (i >= 0) then begin
- result := Items[i];
- DeleteIntern(i, false);
- end else
- result := aDefault;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomList.Remove(const aItem: T): Integer;
- begin
- result := IndexOf(aItem);
- if (result >= 0) then
- DeleteIntern(result);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomList.Create(aEqualityComparer: IEqualityComparer; const aOwnsObjects: Boolean);
- begin
- inherited Create(aOwnsObjects);
- fEqualityComparer := aEqualityComparer;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlCustomList.Destroy;
- begin
- fEqualityComparer := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlList//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlList.Create(const aOwnsObjects: Boolean);
- begin
- inherited Create(TEqualityComparer.Create, aOwnsObjects);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlHashSetBase///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlHashSetBase.SearchItem(const aMin, aMax: Integer; const aItem: T; out aIndex: Integer): Integer;
- var
- i, cmp: Integer;
- begin
- if (aMin <= aMax) then begin
- i := aMin + Trunc((aMax - aMin) / 2);
- cmp := fComparer.Compare(aItem, GetItem(i));
- if (cmp = 0) then
- result := i
- else if (cmp < 0) then
- result := SearchItem(aMin, i-1, aItem, aIndex)
- else if (cmp > 0) then
- result := SearchItem(i+1, aMax, aItem, aIndex);
- end else begin
- result := -1;
- aIndex := aMin;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlHashSetBase.ForEach(const aEvent: THashItemEvent);
- var item: T;
- begin
- if Assigned(aEvent) then
- for item in self do
- aEvent(self, item);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlHashSetBase.Create(aComparer: IComparer; const aOwnsObjects: Boolean);
- begin
- inherited Create(aOwnsObjects);
- fComparer := aComparer;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlHashSetBase.Destroy;
- begin
- fComparer := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomHashSet/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomHashSet.Add(const aItem: T): Boolean;
- var
- i: Integer;
- begin
- result := (SearchItem(0, List.Count-1, aItem, i) < 0);
- if result then
- InsertIntern(i, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomHashSet.Contains(const aItem: T): Boolean;
- var
- tmp: Integer;
- begin
- result := (SearchItem(0, List.Count-1, aItem, tmp) >= 0);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomHashSet.IndexOf(const aItem: T): Integer;
- var
- tmp: Integer;
- begin
- result := SearchItem(0, List.Count-1, aItem, tmp);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomHashSet.Remove(const aItem: T): Boolean;
- var
- i, tmp: Integer;
- begin
- i := SearchItem(0, List.Count-1, aItem, tmp);
- result := (i >= 0);
- if result then
- DeleteIntern(i);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomHashSet.Delete(const aIndex: Integer);
- begin
- DeleteIntern(aIndex);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlHashSet///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlHashSet.Create(const aOwnsObjects: Boolean);
- begin
- inherited Create(TComparer.Create, aOwnsObjects);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlMapBase.THashSet//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlMapBase.THashSet.DestroyItem(const aItem: PListItem; const aFreeItem: Boolean);
- begin
- // never free objects used as keys, but do finalize strings, interfaces etc.
- utlFreeOrFinalize(aItem^.data.key, TypeInfo(aItem^.data.key), false);
- utlFreeOrFinalize(aItem^.data.value, TypeInfo(aItem^.data.value), aFreeItem and OwnsObjects);
- inherited DestroyItem(aItem, aFreeItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlMapBase.TKeyValuePairComparer/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TKeyValuePairComparer.Compare(const i1, i2: TKeyValuePair): Integer;
- begin
- result := fComparer.Compare(i1.Key, i2.Key);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlMapBase.TKeyValuePairComparer.Create(aComparer: IComparer);
- begin
- inherited Create;
- fComparer := aComparer;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlMapBase.TKeyValuePairComparer.Destroy;
- begin
- fComparer := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlMapBase.TEnumeratorProxy//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TEnumeratorProxy.MoveNext: Boolean;
- begin
- result := fEnumerator.MoveNext;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlMapBase.TEnumeratorProxy.Create(const aEnumerator: THashSet.TEnumerator);
- begin
- inherited Create;
- fEnumerator := aEnumerator;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlMapBase.TEnumeratorProxy.Destroy;
- begin
- FreeAndNil(fEnumerator);
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlMapBase.TValueEnumerator//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TValueEnumerator.GetCurrent: TValue;
- begin
- result := fEnumerator.GetCurrent.Value;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TValueEnumerator.GetEnumerator: TValueEnumerator;
- begin
- result := self;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlMapBase.TKeyEnumerator////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TKeyEnumerator.GetCurrent: TKey;
- begin
- result := fEnumerator.GetCurrent.Key;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TKeyEnumerator.GetEnumerator: TKeyEnumerator;
- begin
- result := self;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlMapBase.TKeyWrapper///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TKeyWrapper.GetItem(const aIndex: Integer): TKey;
- begin
- result := fHashSet[aIndex].Key;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TKeyWrapper.GetCount: Integer;
- begin
- result := fHashSet.Count;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TKeyWrapper.GetEnumerator: TKeyEnumerator;
- begin
- result := TKeyEnumerator.Create(fHashSet.GetEnumerator);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TKeyWrapper.GetReverseEnumerator: TKeyEnumerator;
- begin
- result := TKeyEnumerator.Create(fHashSet.GetReverseEnumerator);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlMapBase.TKeyWrapper.Create(const aHashSet: THashSet);
- begin
- inherited Create;
- fHashSet := aHashSet;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlMapBase.TKeyValuePairWrapper//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TKeyValuePairWrapper.GetItem(const aIndex: Integer): TKeyValuePair;
- begin
- result := fHashSet[aIndex];
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TKeyValuePairWrapper.GetCount: Integer;
- begin
- result := fHashSet.Count;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TKeyValuePairWrapper.GetEnumerator: THashSet.TEnumerator;
- begin
- result := fHashSet.GetEnumerator;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.TKeyValuePairWrapper.GetReverseEnumerator: THashSet.TEnumerator;
- begin
- result := fHashSet.GetReverseEnumerator;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlMapBase.TKeyValuePairWrapper.Create(const aHashSet: THashSet);
- begin
- inherited Create;
- fHashSet := aHashSet;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlMapBase///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.GetValues(const aKey: TKey): TValue;
- var
- i: Integer;
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- i := fHashSetRef.IndexOf(kvp);
- if (i < 0) then
- FillByte(result{%H-}, SizeOf(result), 0)
- else
- result := fHashSetRef[i].Value;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.GetValueAt(const aIndex: Integer): TValue;
- begin
- result := fHashSetRef[aIndex].Value;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.GetCount: Integer;
- begin
- result := fHashSetRef.Count;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlMapBase.SetValues(const aKey: TKey; aValue: TValue);
- var
- i: Integer;
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- kvp.Value := aValue;
- i := fHashSetRef.IndexOf(kvp);
- if (i < 0) then begin
- if not fAutoCreate then
- raise EutlMap.Create('key not found');
- fHashSetRef.Add(kvp);
- end else
- fHashSetRef[i] := kvp;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlMapBase.SetValueAt(const aIndex: Integer; aValue: TValue);
- var
- kvp: TKeyValuePair;
- begin
- kvp := fHashSetRef[aIndex];
- kvp.Value := aValue;
- fHashSetRef[aIndex] := kvp;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlMapBase.Add(const aKey: TKey; const aValue: TValue);
- var
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- kvp.Value := aValue;
- if not fHashSetRef.Add(kvp) then
- raise EutlMapKeyAlreadyExists.Create();
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.IndexOf(const aKey: TKey): Integer;
- var
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- result := fHashSetRef.IndexOf(kvp);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.Contains(const aKey: TKey): Boolean;
- var
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- result := (fHashSetRef.IndexOf(kvp) >= 0);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlMapBase.Delete(const aKey: TKey);
- var
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- if not fHashSetRef.Remove(kvp) then
- raise EutlMapKeyNotFound.Create;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlMapBase.DeleteAt(const aIndex: Integer);
- begin
- fHashSetRef.Delete(aIndex);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlMapBase.Clear;
- begin
- fHashSetRef.Clear;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlMapBase.ForEach(const aEvent: TKeyValuePairEvent);
- var kvp: TKeyValuePair;
- begin
- if Assigned(aEvent) then
- for kvp in fHashSetRef do
- aEvent(self, kvp.Key, kvp.Value);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.GetEnumerator: TValueEnumerator;
- begin
- result := TValueEnumerator.Create(fHashSetRef.GetEnumerator);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlMapBase.GetReverseEnumerator: TValueEnumerator;
- begin
- result := TValueEnumerator.Create(fHashSetRef.GetReverseEnumerator);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlMapBase.Create(const aHashSet: THashSet);
- begin
- inherited Create;
- fAutoCreate := false;
- fHashSetRef := aHashSet;
- fKeyWrapper := TKeyWrapper.Create(fHashSetRef);
- fKeyValuePairWrapper := TKeyValuePairWrapper.Create(fHashSetRef);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlMapBase.Destroy;
- begin
- FreeAndNil(fKeyValuePairWrapper);
- FreeAndNil(fKeyWrapper);
- fHashSetRef := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlMap///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlMap.Create(const aOwnsObjects: Boolean);
- begin
- inherited Create(TComparer.Create, aOwnsObjects);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlQueue/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.GetCount: Integer;
- begin
- InterLockedExchange(result{%H-}, fCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.Push(const aItem: T);
- var
- p: PListItem;
- begin
- new(p);
- p^.data := aItem;
- p^.next := nil;
- fLast^.next := p;
- fLast := fLast^.next;
- InterLockedIncrement(fCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.Pop(out aItem: T): Boolean;
- var
- old: PListItem;
- begin
- result := false;
- FillByte(aItem{%H-}, SizeOf(aItem), 0);
- if (Count <= 0) then
- exit;
- result := true;
- old := fFirst;
- fFirst := fFirst^.next;
- aItem := fFirst^.data;
- InterLockedDecrement(fCount);
- Dispose(old);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.Pop: Boolean;
- var
- tmp: T;
- begin
- result := Pop(tmp);
- utlFreeOrFinalize(tmp, TypeInfo(tmp), fOwnsObjects);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.Clear;
- begin
- while Pop do;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlQueue.Create(const aOwnsObjects: Boolean);
- begin
- inherited Create;
- new(fFirst);
- FillByte(fFirst^, SizeOf(fFirst^), 0);
- fLast := fFirst;
- fCount := 0;
- fOwnsObjects := aOwnsObjects;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlQueue.Destroy;
- begin
- Clear;
- if Assigned(fLast) then begin
- Dispose(fLast);
- fLast := nil;
- end;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlSyncQueue/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSyncQueue.Push(const aItem: T);
- begin
- fPushLock.Enter;
- try
- inherited Push(aItem);
- finally
- fPushLock.Leave;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSyncQueue.Pop(out aItem: T): Boolean;
- begin
- fPopLock.Enter;
- try
- result := inherited Pop(aItem);
- finally
- fPopLock.Leave;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlSyncQueue.Create(const aOwnsObjects: Boolean);
- begin
- inherited Create(aOwnsObjects);
- fPushLock := TutlSpinLock.Create;
- fPopLock := TutlSpinLock.Create;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlSyncQueue.Destroy;
- begin
- inherited Destroy; //inherited will pop all remaining items, so do not destroy spinlock before!
- FreeAndNil(fPushLock);
- FreeAndNil(fPopLock);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlInterfaceList.TInterfaceEnumerator////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlInterfaceList.TInterfaceEnumerator.GetCurrent: T;
- begin
- result := T(fList[fPos]);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlInterfaceList.TInterfaceEnumerator.MoveNext: Boolean;
- begin
- inc(fPos);
- result := (fPos < fList.Count);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlInterfaceList.TInterfaceEnumerator.Create(const aList: TInterfaceList);
- begin
- inherited Create;
- fPos := -1;
- fList := aList;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlInterfaceList/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlInterfaceList.Get(i : Integer): T;
- begin
- result := T(inherited Get(i));
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlInterfaceList.Put(i : Integer; aItem : T);
- begin
- inherited Put(i, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlInterfaceList.First: T;
- begin
- result := T(inherited First);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlInterfaceList.IndexOf(aItem : T): Integer;
- begin
- result := inherited IndexOf(aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlInterfaceList.Add(aItem : IUnknown): Integer;
- begin
- result := inherited Add(aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlInterfaceList.Insert(i : Integer; aItem : T);
- begin
- inherited Insert(i, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlInterfaceList.Last : T;
- begin
- result := T(inherited Last);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlInterfaceList.Remove(aItem : T): Integer;
- begin
- result := inherited Remove(aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlInterfaceList.GetEnumerator: TInterfaceEnumerator;
- begin
- result := TInterfaceEnumerator.Create(self);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlEnumHelper////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class constructor TutlEnumHelper.Initialize;
- var
- tiArray: PTypeInfo;
- tdArray, tdEnum: PTypeData;
- aName: PShortString;
- i: integer;
- en: T;
- begin
- {
- See FPC Bug http://bugs.freepascal.org/view.php?id=27622
- For Sparse Enums, the compiler won't give us TypeInfo, because it contains some wrong data. This is
- safe, but sadly we don't even get the *correct* fields (TypeName, NameList), even though they are
- generated in any case.
- Fortunately, arrays do know this type info segment as their Element Type (and we declared one anyway).
- }
- tiArray := System.TypeInfo(TValueArray);
- tdArray := GetTypeData(tiArray);
- FTypeInfo:= tdArray^.elType2;
-
- {
- Now that we have the TypeInfo, fill our values from it. This is safe because while the *values* in
- TypeData are wrong for Sparse Enums, the *names* are always correct.
- }
- tdEnum:= GetTypeData(FTypeInfo);
- aName:= @tdEnum^.NameList;
- SetLength(FValues, 0);
- i:= 0;
- While Length(aName^) > 0 do begin
- SetLength(FValues, i+1);
- {
- Memory layout for TTypeData has the declaring EnumUnitName after the last NameList entry.
- This can normally not be the same as a valid enum value, because it is in the same identifier
- namespace. However, with scoped enums we might have the same name for module and element, because
- the full identifier for the element would be TypeName.ElementName.
- In either case, the next PShortString will point to a zero-length string, and the loop is left
- with the last element being invalid (either empty or whatever value the unit-named element has).
- }
- if TryToEnum(aName^, en) then
- FValues[i]:= en;
- inc(i);
- inc(PByte(aName), Length(aName^) + 1);
- end;
- // remove the EnumUnitName item
- SetLength(FValues, Length(FValues) - 1);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.ToString(aValue: T): String;
- begin
- {$Push}
- {$IOChecks OFF}
- WriteStr(Result, aValue);
- if IOResult = 107 then
- Result:= '';
- {$Pop}
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.TryToEnum(aStr: String; out aValue: T): Boolean;
- var
- a: T;
- begin
- a := T(0);
- Result := false;
- if Length(aStr) = 0 then
- exit;
-
- {$Push}
- {$IOChecks OFF}
- ReadStr(aStr, a);
- Result:= IOResult <> 106;
- {$Pop}
- if Result then
- aValue := a;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.ToEnum(aStr: String): T;
- begin
- if not TryToEnum(aStr, result) then
- raise EutlEnumConvert.Create(aStr, TypeInfo^.Name);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.ToEnum(aStr: String; const aDefault: T): T;
- begin
- if not TryToEnum(aStr, result) then
- result := aDefault;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.Values: TValueArray;
- begin
- Result:= FValues;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.TypeInfo: PTypeInfo;
- begin
- Result:= FTypeInfo;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlRingBuffer////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlRingBuffer.Create(const Elements: Integer);
- begin
- inherited Create;
- fAborted:= false;
- fDataLen:= Elements;
- fDataSize:= SizeOf(T);
- SetLength(fData, fDataLen);
- fWritePtr:= 1;
- fReadPtr:= 0;
- fFillState:= 0;
- fReadEvent:= TutlAutoResetEvent.Create;
- fWrittenEvent:= TutlAutoResetEvent.Create;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlRingBuffer.Destroy;
- begin
- BreakPipe;
- FreeAndNil(fReadEvent);
- FreeAndNil(fWrittenEvent);
- SetLength(fData, 0);
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlRingBuffer.Read(Buf: Pointer; Items: integer; BlockUntilAvail: boolean): integer;
- var
- wp, c, r: Integer;
- begin
- Result:= 0;
- while Items > 0 do begin
- if fAborted then
- exit;
-
- InterLockedExchange(wp{%H-}, fWritePtr);
- r:= (fReadPtr + 1) mod fDataLen;
- if wp < r then
- wp:= fDataLen;
- c:= wp - r;
- if c > Items then
- c:= Items;
- if c > 0 then begin
- Move(fData[r], Buf^, c * fDataSize);
- Dec(Items, c);
- inc(Result, c);
- dec(fFillState, c);
- inc(PByte(Buf), c * fDataSize);
- InterLockedExchange(fReadPtr, (fReadPtr + c) mod fDataLen);
- fReadEvent.SetEvent;
- end else begin
- if not BlockUntilAvail then
- break;
- fWrittenEvent.WaitFor(INFINITE);
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlRingBuffer.Write(Buf: Pointer; Items: integer; BlockUntilDone: boolean): integer;
- var
- rp, c: integer;
- begin
- Result:= 0;
- while Items > 0 do begin
- if fAborted then
- exit;
-
- InterLockedExchange(rp{%H-}, fReadPtr);
- if rp < fWritePtr then
- rp:= fDataLen;
- c:= rp - fWritePtr;
- if c > Items then
- c:= Items;
- if c > 0 then begin
- Move(Buf^, fData[fWritePtr], c * fDataSize);
- dec(Items, c);
- inc(Result, c);
- inc(fFillState, c);
- inc(PByte(Buf), c * fDataSize);
- InterLockedExchange(fWritePtr, (fWritePtr + c) mod fDataLen);
- fWrittenEvent.SetEvent;
- end else begin
- if not BlockUntilDone then
- Break;
- fReadEvent.WaitFor(INFINITE);
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlRingBuffer.BreakPipe;
- begin
- fAborted:= true;
- fWrittenEvent.SetEvent;
- fReadEvent.SetEvent;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlPagedDataFiFo.TDataProvider///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.TDataProvider.Give(const aBuffer: PData; aCount: Integer): Integer;
- begin
- result := 0;
- if (aCount > fCount - fPos) then
- aCount := fCount - fPos;
- if (aCount <= 0) then
- exit;
- Move((fData + fPos)^, aBuffer^, aCount * SizeOf(TData));
- inc(fPos, aCount);
- result := aCount;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlPagedDataFiFo.TDataProvider.Create(const aData: PData; const aCount: Integer);
- begin
- inherited Create;
- fData := aData;
- fCount := aCount;
- fPos := 0;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlPagedDataFiFo.TDataConsumer///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.TDataConsumer.Take(const aBuffer: PData; aCount: Integer): Integer;
- begin
- result := 0;
- if (aCount > fCount - fPos) then
- aCount := fCount - fPos;
- if (aCount <= 0) then
- exit;
- Move(aBuffer^, (fData + fPos)^, aCount * SizeOf(TData));
- inc(fPos, aCount);
- result := aCount;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlPagedDataFiFo.TDataConsumer.Create(const aData: PData; const aCount: Integer);
- begin
- inherited Create;
- fData := aData;
- fCount := aCount;
- fPos := 0;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlPagedDataFiFo.TNestedDataProvider/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.TNestedDataProvider.Give(const aBuffer: PData; aCount: Integer): Integer;
- begin
- result := fCallback(aBuffer, aCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlPagedDataFiFo.TNestedDataProvider.Create(const aCallback: TDataCallback);
- begin
- inherited Create;
- fCallback := aCallback;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlPagedDataFiFo.TNestedDataConsumer/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.TNestedDataConsumer.Take(const aBuffer: PData; aCount: Integer): Integer;
- begin
- result := fCallback(aBuffer, aCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlPagedDataFiFo.TNestedDataConsumer.Create(const aCallback: TDataCallback);
- begin
- inherited Create;
- fCallback := aCallback;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlPagedDataFiFo.TStreamDataProvider/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.TStreamDataProvider.Give(const aBuffer: PData; aCount: Integer): Integer;
- begin
- result := fStream.Read(aBuffer^, aCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlPagedDataFiFo.TStreamDataProvider.Create(const aStream: TStream);
- begin
- inherited Create;
- fStream := aStream;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlPagedDataFiFo.TStreamDataConsumer/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.TStreamDataConsumer.Take(const aBuffer: PData; aCount: Integer): Integer;
- begin
- result := fStream.Write(aBuffer^, aCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlPagedDataFiFo.TStreamDataConsumer.Create(const aStream: TStream);
- begin
- inherited Create;
- fStream := aStream;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlPagedDataFiFo/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.WriteIntern(const aProvider: IDataProvider; aCount: Integer): Integer;
- var
- c, r: Integer;
- p: PPage;
- begin
- if not Assigned(aProvider) then
- raise EArgumentNil.Create('aProvider');
-
- result := 0;
- while (aCount > 0) do begin
- if not Assigned(fWritePage) or (fWritePage^.WritePos >= fPageSize) then begin
- new(p);
- p^.ReadPos := 0;
- p^.WritePos := 0;
- p^.Next := nil;
- SetLength(p^.Data, fPageSize);
- if Assigned(fWritePage) then
- fWritePage^.Next := p;
- fWritePage := p;
- if not Assigned(fReadPage) then
- fReadPage := fWritePage;
- end;
-
- c := fPageSize - fWritePage^.WritePos;
- if (c > aCount) then
- c := aCount;
-
- r := aProvider.Give(@fWritePage^.Data[fWritePage^.WritePos], c);
- if (r = 0) then
- exit;
-
- inc(result, r);
- inc(fWritePage^.WritePos, r);
- inc(fSize, r);
- dec(aCount, r);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.ReadIntern(const aConsumer: IDataConsumer; aCount: Integer; const aMoveReadPos: Boolean): Integer;
- var
- ReadPage: PPage;
- DummyPage: TPage;
- c, r: Integer;
-
- begin
- result := 0;
-
- if not Assigned(fReadPage) then
- exit;
-
- //init read page
- if not aMoveReadPos then begin
- DummyPage := fReadPage^; // copy page (data is not copied, because it's a dynamic array)
- ReadPage := @DummyPage;
- end else
- ReadPage := fReadPage;
-
- while (aCount > 0) do begin
- if (ReadPage^.ReadPos >= fPageSize) then begin
- if not Assigned(ReadPage^.Next) then
- exit;
- if aMoveReadPos then begin
- if (fReadPage = fWritePage) then // write finished with page end, so reset WritePage wenn disposing ReadPage
- fWritePage := nil;
- fReadPage := fReadPage^.Next;
- Dispose(ReadPage);
- ReadPage := fReadPage;
- end else
- ReadPage^ := ReadPage^.Next^;
- end;
-
- c := ReadPage^.WritePos - ReadPage^.ReadPos;
- if (c = 0) then
- exit;
- if (c > aCount) then
- c := aCount;
-
- if Assigned(aConsumer) then begin
-
- r := aConsumer.Take(@ReadPage^.Data[ReadPage^.ReadPos], c);
- if (r = 0) then
- exit;
- end else
- r := c;
-
- inc(result, r);
- inc(ReadPage^.ReadPos, r);
- dec(aCount, r);
- if aMoveReadPos then
- dec(fSize, r);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.Write(const aProvider: IDataProvider; const aCount: Integer): Integer;
- begin
- result := WriteIntern(aProvider, aCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.Write(const aData: PData; const aCount: Integer): Integer;
- var
- provider: IDataProvider;
- begin
- provider := TDataProvider.Create(aData, aCount);
- result := WriteIntern(provider, aCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.Read(const aConsumer: IDataConsumer; const aCount: Integer): Integer;
- begin
- result := ReadIntern(aConsumer, aCount, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.Read(const aData: PData; const aCount: Integer): Integer;
- var
- consumer: IDataConsumer;
- begin
- consumer := TDataConsumer.Create(aData, aCount);
- result := ReadIntern(consumer, aCount, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.Peek(const aConsumer: IDataConsumer; const aCount: Integer): Integer;
- begin
- result := ReadIntern(aConsumer, aCount, false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.Peek(const aData: PData; const aCount: Integer): Integer;
- var
- consumer: IDataConsumer;
- begin
- consumer := TDataConsumer.Create(aData, aCount);
- result := ReadIntern(consumer, aCount, false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlPagedDataFiFo.Discard(const aCount: Integer): Integer;
- begin
- result := ReadIntern(nil, aCount, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlPagedDataFiFo.Clear;
- var
- tmp: PPage;
- begin
- while Assigned(fReadPage) do begin
- tmp := fReadPage;
- fReadPage := tmp^.Next;
- Dispose(tmp);
- end;
- fReadPage := nil;
- fWritePage := nil;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlPagedDataFiFo.Create(const aPageSize: Integer);
- begin
- inherited Create;
- fReadPage := nil;
- fWritePage := nil;
- fPageSize := aPageSize;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlPagedDataFiFo.Destroy;
- begin
- Clear;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlSyncPagedDataFiFo/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSyncPagedDataFiFo.WriteIntern(const aProvider: IDataProvider; aCount: Integer): Integer;
- begin
- fLock.Enter;
- try
- result := inherited WriteIntern(aProvider, aCount);
- finally
- fLock.Leave;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSyncPagedDataFiFo.ReadIntern(const aConsumer: IDataConsumer; aCount: Integer; const aMoveReadPos: Boolean): Integer;
- begin
- fLock.Enter;
- try
- result := inherited ReadIntern(aConsumer, aCount, aMoveReadPos);
- finally
- fLock.Leave;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlSyncPagedDataFiFo.Create(const aPageSize: Integer);
- begin
- inherited Create(aPageSize);
- fLock := TutlSpinLock.Create;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlSyncPagedDataFiFo.Destroy;
- begin
- inherited Destroy;
- FreeAndNil(fLock);
- end;
-
- end.
|