|
- unit uutlGenerics;
-
- {$mode objfpc}{$H+}
-
- interface
-
- uses
- Classes, SysUtils, typinfo,
- uutlCommon, uutlArrayContainer, uutlListBase, uutlComparer, uutlAlgorithm, uutlInterfaces;
-
- type
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlQueue<T> = class(
- specialize TutlArrayContainer<T>
- , specialize IEnumerable<T>
- {$IFDEF UTL_ENUMERATORS}
- , specialize IutlEnumerable<T>
- {$ENDIF})
-
- strict private
- fCount: Integer;
- fReadPos: Integer;
- fWritePos: Integer;
-
- protected
- function GetCount: Integer; override;
- procedure SetCount(const aValue: Integer); override;
- procedure SetCapacity(const aValue: integer); override;
-
- public { IEnumerable }
- function GetEnumerator: specialize IEnumerator<T>;
-
- {$IFDEF UTL_ENUMERATORS}
- public { IutlEnumerable }
- function GetUtlEnumerator: specialize IutlEnumerator<T>;
- {$ENDIF}
-
- public
- property Count: Integer read GetCount;
- property IsEmpty;
- property Capacity;
- property CanExpand;
- property CanShrink;
- property OwnsItems;
-
- procedure Enqueue(constref aItem: T);
- function Dequeue: T;
- function Dequeue(const aFreeItem: Boolean): T;
- function Peek: T;
- procedure ShrinkToFit;
- procedure Clear;
-
- constructor Create(const aOwnsItems: Boolean);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlStack<T> = class(
- specialize TutlArrayContainer<T>
- , specialize IEnumerable<T>
- {$IFDEF UTL_ENUMERATORS}
- , specialize IutlEnumerable<T>
- {$ENDIF})
-
- strict private
- fCount: Integer;
-
- protected
- function GetCount: Integer; override;
- procedure SetCount(const aValue: Integer); override;
-
- public { IEnumerable }
- function GetEnumerator: specialize IEnumerator<T>;
-
- {$IFDEF UTL_ENUMERATORS}
- public { IUtlEnumerable }
- function GetUtlEnumerator: specialize IutlEnumerator<T>;
- {$ENDIF}
-
- public
- property Count: Integer read GetCount;
- property IsEmpty;
- property Capacity;
- property CanExpand;
- property CanShrink;
- property OwnsItems;
-
- procedure Push(constref aItem: T);
- function Pop: T;
- function Pop(const aFreeItem: Boolean): T;
- function Peek: T;
- procedure ShrinkToFit;
- procedure Clear;
-
- constructor Create(const aOwnsItems: Boolean);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlSimpleList<T> = class(
- specialize TutlListBase<T>
- , specialize IutlReadOnlyArray<T>
- , specialize IutlArray<T>)
-
- strict private
- function GetFirst: T;
- function GetLast: T;
-
- public
- property First: T read GetFirst;
- property Last: T read GetLast;
-
- property Items[const aIndex: Integer]: T read GetItem write SetItem; default;
-
- function Add (constref aItem: T): Integer;
- procedure Insert (const aIndex: Integer; constref aItem: T);
- procedure Exchange (const aIndex1, aIndex2: Integer);
- procedure Move (const aCurrentIndex, aNewIndex: Integer);
- procedure Delete (const aIndex: Integer);
- function Extract (const aIndex: Integer): T;
-
- procedure PushFirst (constref aItem: T);
- function PopFirst (const aFreeItem: Boolean): T;
-
- procedure PushLast (constref aItem: T);
- function PopLast (const aFreeItem: Boolean): T;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlCustomList<T> = class(
- specialize TutlSimpleList<T>)
-
- public type
- IEqualityComparer = specialize IutlEqualityComparer<T>;
-
- strict private
- fEqualityComparer: IEqualityComparer;
-
- public
- function IndexOf (const aItem: T): Integer;
- function Extract (const aItem: T; const aDefault: T): T; overload;
- function Remove (const aItem: T): Integer;
-
- constructor Create (const aEqualityComparer: IEqualityComparer; const aOwnsItems: Boolean);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlList<T> = class(
- specialize TutlCustomList<T>)
-
- public type
- TEqualityComparer = specialize TutlEqualityComparer<T>;
-
- public
- constructor Create(const aOwnsItems: Boolean);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlCustomHashSet<T> = class(
- specialize TutlListBase<T>
- , specialize IutlReadOnlyArray<T>)
-
- private type
- TBinarySearch = specialize TutlBinarySearch<T>;
-
- public type
- IComparer = specialize IutlComparer<T>;
-
- strict private
- fComparer: IComparer;
-
- protected
- procedure SetCount (const aValue: Integer); override;
- procedure SetItem (const aIndex: Integer; aValue: T); override;
-
- public
- property Count: Integer read GetCount;
- property Items[const aIndex: Integer]: T read GetItem write SetItem; default;
-
- function Add (constref aItem: T): Boolean;
- function Contains (constref aItem: T): Boolean;
- function IndexOf (constref aItem: T): Integer;
- function Remove (constref aItem: T): Boolean;
- procedure Delete (const aIndex: Integer);
-
- constructor Create (const aComparer: IComparer; const aOwnsItems: Boolean);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlHashSet<T> = class(
- specialize TutlCustomHashSet<T>)
-
- public type
- TComparer = specialize TutlComparer<T>;
-
- public
- constructor Create(const aOwnsItems: Boolean);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlCustomMap<TKey, TValue> = class(
- TutlInterfaceNoRefCount
- {$IFDEF UTL_ENUMERATORS}
- , specialize IutlEnumerable<TValue>
- {$ENDIF})
-
- public type
- ////////////////////////////////////////////////////////////////////////////////////////////////
- TKeyValuePair = packed record
- Key: TKey;
- Value: TValue;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////
- THashSet = class(
- specialize TutlCustomHashSet<TKeyValuePair>)
-
- strict private
- fOwner: TutlCustomMap;
-
- protected
- procedure Release(var aItem: TKeyValuePair; const aFreeItem: Boolean); override;
-
- public
- constructor Create(const aOwner: TutlCustomMap; const aComparer: IComparer);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////
- IComparer = specialize IutlComparer<TKey>;
- TKeyValuePairComparer = class(
- TInterfacedObject
- , THashSet.IComparer)
-
- strict private
- fComparer: IComparer;
-
- public { IutlEqualityComparer }
- function EqualityCompare(constref i1, i2: TKeyValuePair): Boolean;
-
- public { IutlComparer }
- function Compare(constref i1, i2: TKeyValuePair): Integer;
-
- public
- constructor Create(aComparer: IComparer);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////
- TKeyCollection = class(
- TutlInterfaceNoRefCount
- , specialize IutlReadOnlyArray<TKey>
- {$IFDEF UTL_ENUMERATORS}
- , specialize IutlEnumerable<TKey>
- {$ENDIF})
-
- strict private
- fHashSet: THashSet;
-
- public { IEnumerable }
- function GetEnumerator: specialize IEnumerator<TKey>;
-
- {$IFDEF UTL_ENUMERATORS}
- public { IutlEnumerable }
- function GetUtlEnumerator: specialize IutlEnumerator<TKey>;
- {$ENDIF}
-
- public { IutlReadOnlyArray }
- function GetCount: Integer;
- function GetItem(const aIndex: Integer): TKey;
-
- property Count: Integer read GetCount;
- property Items[const aIndex: Integer]: TKey read GetItem; default;
-
- public
- constructor Create(const aHashSet: THashSet);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////
- TKeyValuePairCollection = class(
- TutlInterfaceNoRefCount
- , specialize IutlReadOnlyArray<TKeyValuePair>
- {$IFDEF UTL_ENUMERATORS}
- , specialize IutlEnumerable<TKeyValuePair>
- {$ENDIF})
-
- strict private
- fHashSet: THashSet;
-
- public { IEnumerable }
- function GetEnumerator: specialize IEnumerator<TKeyValuePair>;
-
- {$IFDEF UTL_ENUMERATORS}
- public { IutlEnumerable }
- function GetUtlEnumerator: specialize IutlEnumerator<TKeyValuePair>;
- {$ENDIF}
-
- public { IutlReadOnlyArray }
- function GetCount: Integer;
- function GetItem(const aIndex: Integer): TKeyValuePair;
-
- property Count: Integer read GetCount;
- property Items[const aIndex: Integer]: TKeyValuePair read GetItem; default;
-
- public
- constructor Create(const aHashSet: THashSet);
- end;
-
- strict private
- fAutoCreate: Boolean;
- fOwnsKeys: Boolean;
- fOwnsValues: Boolean;
- fHashSetRef: THashSet;
- fKeyCollection: TKeyCollection;
- fKeyValuePairCollection: TKeyValuePairCollection;
-
- function GetValue (aKey: TKey): TValue; inline;
- function GetValueAt (const aIndex: Integer): TValue; inline;
- function GetCount: Integer; inline;
- function GetIsEmpty: Boolean; inline;
- function GetCapacity: Integer; inline;
- function GetCanShrink: Boolean; inline;
- function GetCanExpand: Boolean; inline;
-
- procedure SetValue (aKey: TKey; const aValue: TValue); inline;
- procedure SetValueAt (const aIndex: Integer; const aValue: TValue); inline;
- procedure SetCapacity (const aValue: Integer); inline;
- procedure SetCanShrink (const aValue: Boolean); inline;
- procedure SetCanExpand (const aValue: Boolean); inline;
-
- public { IEnumerable }
- function GetEnumerator: specialize IEnumerator<TValue>;
-
- {$IFDEF UTL_ENUMERATORS}
- public { IutlEnumerable }
- function GetUtlEnumerator: specialize IutlEnumerator<TValue>;
- {$ENDIF}
-
- public
- property Values [aKey: TKey]: TValue read GetValue write SetValue; default;
- property ValueAt[const aIndex: Integer]: TValue read GetValueAt write SetValueAt;
-
- property Keys: TKeyCollection read fKeyCollection;
- property KeyValuePairs: TKeyValuePairCollection read fKeyValuePairCollection;
-
- property Count: Integer read GetCount;
- property IsEmpty: Boolean read GetIsEmpty;
- property Capacity: Integer read GetCapacity write SetCapacity;
- property CanShrink: Boolean read GetCanShrink write SetCanShrink;
- property CanExpand: Boolean read GetCanExpand write SetCanExpand;
- property OwnsKeys: Boolean read fOwnsKeys write fOwnsKeys;
- property OwnsValues: Boolean read fOwnsValues write fOwnsValues;
- property AutoCreate: Boolean read fAutoCreate write fAutoCreate;
-
- procedure Add (constref aKey: TKey; constref aValue: TValue);
- function TryAdd (constref aKey: TKey; constref aValue: TValue): Boolean;
- function TryGetValue (constref aKey: TKey; out aValue: TValue): Boolean;
- function IndexOf (constref aKey: TKey): Integer;
- function Contains (constref aKey: TKey): Boolean;
- procedure Delete (constref aKey: TKey);
- procedure DeleteAt (const aIndex: Integer);
- procedure Clear;
-
- constructor Create(const aHashSet: THashSet; const aOwnsKeys: Boolean; const aOwnsValues: Boolean);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- generic TutlMap<TKey, TValue> = class(
- specialize TutlCustomMap<TKey, TValue>)
-
- public type
- TComparer = specialize TutlComparer<TKey>;
-
- strict private
- fHashSetImpl: THashSet;
-
- public
- constructor Create(const aOwnsKeys: Boolean; const aOwnsValues: Boolean);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- EutlEnumConvert = class(EConvertError)
- public
- constructor Create(const aValue, aExpectedType: String);
- end;
-
- generic TutlEnumHelper<T> = class
- public type
- TValueArray = array of T;
- TStringArray = array of String;
-
- private class var
- fTypeInfo: PTypeInfo;
- fValues: TValueArray;
- fNames: TStringArray;
-
- public
- 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; inline;
- class function Names: TStringArray; inline;
- class function TypeInfo: PTypeInfo; inline;
-
- class constructor Initialize;
- end;
-
- implementation
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlQueue/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.GetCount: Integer;
- begin
- result := fCount;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.SetCount(const aValue: Integer);
- begin
- raise ENotSupportedException.Create('SetCount not supported');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.SetCapacity(const aValue: integer);
- var
- cnt: Integer;
- begin
- if (aValue < Count) then
- raise EArgumentException.Create('can not reduce capacity below count');
-
- if (aValue < Capacity) then begin // is shrinking
- if (fReadPos <= fWritePos) then begin // ReadPos Before WritePos -> Move To Begin
- System.Move(GetInternalItem(fReadPos)^, GetInternalItem(0)^, SizeOf(T) * Count);
- fReadPos := 0;
- fWritePos := Count;
- end else if (fReadPos > fWritePos) then begin // ReadPos Behind WritePos
- cnt := Capacity - aValue;
- System.Move(GetInternalItem(fReadPos)^, GetInternalItem(fReadPos - cnt)^, SizeOf(T) * cnt);
- dec(fReadPos, cnt);
- end;
- end;
-
- inherited SetCapacity(aValue);
-
- // ReadPos After WritePos and Expanding
- if (fReadPos > fWritePos) and (aValue > Capacity) then begin
- cnt := aValue - Capacity;
- System.Move(GetInternalItem(fReadPos)^, GetInternalItem(fReadPos - cnt)^, SizeOf(T) * cnt);
- inc(fReadPos, cnt);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.GetEnumerator: specialize IEnumerator<T>;
- begin
- result := nil; // TODO
- raise ENotSupportedException.Create('not yet supported');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- {$IFDEF UTL_ENUMERATORS}
- function TutlQueue.GetUtlEnumerator: specialize IutlEnumerator<T>;
- begin
- result := nil; // TODO
- raise ENotSupportedException.Create('not yet supported');
- end;
- {$ENDIF}
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.Enqueue(constref aItem: T);
- begin
- if (Count = Capacity) then
- Expand;
- fWritePos := fWritePos mod Capacity;
- GetInternalItem(fWritePos)^ := aItem;
- inc(fCount);
- inc(fWritePos);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.Dequeue: T;
- begin
- result := Dequeue(false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.Dequeue(const aFreeItem: Boolean): T;
- var
- p: PT;
- begin
- if IsEmpty then
- raise EInvalidOperation.Create('queue is empty');
- p := GetInternalItem(fReadPos);
- if aFreeItem
- then FillByte(result{%H-}, SizeOf(result), 0)
- else result := p^;
- Release(p^, aFreeItem);
- dec(fCount);
- fReadPos := (fReadPos + 1) mod Capacity;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlQueue.Peek: T;
- begin
- if IsEmpty then
- raise EInvalidOperation.Create('queue is empty');
- result := GetInternalItem(fReadPos)^;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.ShrinkToFit;
- begin
- Shrink(true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlQueue.Clear;
- begin
- while (fReadPos <> fWritePos) do begin
- Release(GetInternalItem(fReadPos)^, true);
- fReadPos := (fReadPos + 1) mod Capacity;
- end;
- fCount := 0;
- if CanShrink then
- ShrinkToFit;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlQueue.Create(const aOwnsItems: Boolean);
- begin
- inherited Create(aOwnsItems);
- fCount := 0;
- fReadPos := 0;
- fWritePos := 0;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlQueue.Destroy;
- begin
- Clear;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlStack/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlStack.GetCount: Integer;
- begin
- result := fCount;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlStack.SetCount(const aValue: Integer);
- begin
- raise ENotSupportedException.Create('SetCount not supported');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlStack.GetEnumerator: specialize IEnumerator<T>;
- begin
- result := nil; // TODO
- raise ENotSupportedException.Create('not yet supported');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- {$IFDEF UTL_ENUMERATORS}
- function TutlStack.GetUtlEnumerator: specialize IutlEnumerator<T>;
- begin
- result := nil; // TODO
- raise ENotSupportedException.Create('not yet supported');
- end;
- {$ENDIF}
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlStack.Push(constref aItem: T);
- begin
- if (Count = Capacity) then
- Expand;
- GetInternalItem(fCount)^ := aItem;
- inc(fCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlStack.Pop: T;
- begin
- Pop(false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlStack.Pop(const aFreeItem: Boolean): T;
- var
- p: PT;
- begin
- if IsEmpty then
- raise EInvalidOperation.Create('stack is empty');
- p := GetInternalItem(fCount-1);
- if aFreeItem
- then FillByte(result{%H-}, SizeOf(result), 0)
- else result := p^;
- Release(p^, aFreeItem);
- dec(fCount);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlStack.Peek: T;
- begin
- if IsEmpty then
- raise EInvalidOperation.Create('stack is empty');
- result := GetInternalItem(fCount-1)^;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlStack.ShrinkToFit;
- begin
- Shrink(true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlStack.Clear;
- begin
- while (fCount > 0) do begin
- dec(fCount);
- Release(GetInternalItem(fCount)^, true);
- end;
- if CanShrink then
- ShrinkToFit;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlStack.Create(const aOwnsItems: Boolean);
- begin
- inherited Create(aOwnsItems);
- fCount := 0
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlStack.Destroy;
- begin
- Clear;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlSimpleList////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.GetFirst: T;
- begin
- if IsEmpty then
- raise EInvalidOperation.Create('list is empty');
- result := GetInternalItem(0)^;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.GetLast: T;
- begin
- if IsEmpty then
- raise EInvalidOperation.Create('list is empty');
- result := GetInternalItem(Count-1)^;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.Add(constref aItem: T): Integer;
- begin
- result := Count;
- InsertIntern(result, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Insert(const aIndex: Integer; constref aItem: T);
- begin
- InsertIntern(aIndex, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Exchange(const aIndex1, aIndex2: Integer);
- var
- tmp: T;
- p1, p2: PT;
- begin
- if (aIndex1 < 0) or (aIndex1 >= Count) then
- raise EOutOfRangeException.Create(aIndex1, 0, Count-1);
- if (aIndex2 < 0) or (aIndex2 >= Count) then
- raise EOutOfRangeException.Create(aIndex2, 0, Count-1);
- p1 := GetInternalItem(aIndex1);
- p2 := GetInternalItem(aIndex2);
- System.Move(p1^, tmp{%H-}, SizeOf(T));
- System.Move(p2^, p1^, SizeOf(T));
- System.Move(tmp, p2^, SizeOf(T));
- FillByte(tmp, SizeOf(tmp), 0)
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Move(const aCurrentIndex, aNewIndex: Integer);
- var
- tmp: T;
- cur, new: PT;
- begin
- if (aCurrentIndex < 0) or (aCurrentIndex >= Count) then
- raise EOutOfRangeException.Create(aCurrentIndex, 0, Count-1);
- if (aNewIndex < 0) or (aNewIndex >= Count) then
- raise EOutOfRangeException.Create(aNewIndex, 0, Count-1);
- if (aCurrentIndex = aNewIndex) then
- exit;
- cur := GetInternalItem(aCurrentIndex);
- new := GetInternalItem(aNewIndex);
- System.Move(cur^, tmp{%H-}, SizeOf(T));
- if (aNewIndex > aCurrentIndex) then begin
- System.Move((cur+1)^, cur^, SizeOf(T) * (aNewIndex - aCurrentIndex));
- end else begin
- System.Move(new^, (new+1)^, SizeOf(T) * (aCurrentIndex - aNewIndex));
- end;
- System.Move(tmp, new^, SizeOf(T));
- FillByte(tmp, SizeOf(tmp), 0);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.Delete(const aIndex: Integer);
- begin
- DeleteIntern(aIndex, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlSimpleList.Extract(const aIndex: Integer): T;
- begin
- result := GetItem(aIndex);
- DeleteIntern(aIndex, false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.PushFirst(constref 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 := GetItem(0);
- DeleteIntern(0, aFreeItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlSimpleList.PushLast(constref 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 := GetItem(Count-1);
- DeleteIntern(Count-1, aFreeItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomList////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomList.IndexOf(const aItem: T): Integer;
- begin
- result := Count-1;
- while (result >= 0)
- and not fEqualityComparer.EqualityCompare(Items[result], aItem)
- do
- dec(result);
- 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, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomList.Create(const aEqualityComparer: IEqualityComparer; const aOwnsItems: Boolean);
- begin
- if not Assigned(aEqualityComparer) then
- raise EArgumentNilException.Create('aEqualityComparer');
- inherited Create(aOwnsItems);
- fEqualityComparer := aEqualityComparer;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlCustomList.Destroy;
- begin
- fEqualityComparer := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlList//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlList.Create(const aOwnsItems: Boolean);
- begin
- inherited Create(TEqualityComparer.Create, aOwnsItems);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomHashSet/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomHashSet.SetCount(const aValue: Integer);
- begin
- raise ENotSupportedException.Create('SetCount not supported');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomHashSet.SetItem(const aIndex: Integer; aValue: T);
- begin
- if not fComparer.EqualityCompare(GetItem(aIndex), aValue) then
- EInvalidOperation.Create('values are not equal');
- inherited SetItem(aIndex, aValue);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomHashSet.Add(constref aItem: T): Boolean;
- var
- i: Integer;
- begin
- result := not TBinarySearch.Search(self, fComparer, aItem, i);
- if result then
- InsertIntern(i, aItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomHashSet.Contains(constref aItem: T): Boolean;
- var
- i: Integer;
- begin
- result := TBinarySearch.Search(self, fComparer, aItem, i);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomHashSet.IndexOf(constref aItem: T): Integer;
- begin
- if not TBinarySearch.Search(self, fComparer, aItem, result) then
- result := -1;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomHashSet.Remove(constref aItem: T): Boolean;
- var
- i: Integer;
- begin
- result := TBinarySearch.Search(self, fComparer, aItem, i);
- if result then
- DeleteIntern(i, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomHashSet.Delete(const aIndex: Integer);
- begin
- DeleteIntern(aIndex, true);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomHashSet.Create(const aComparer: IComparer; const aOwnsItems: Boolean);
- begin
- inherited Create(aOwnsItems);
- fComparer := aComparer;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlCustomHashSet.Destroy;
- begin
- fComparer := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlHastSet///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlHashSet.Create(const aOwnsItems: Boolean);
- begin
- inherited Create(TComparer.Create, aOwnsItems);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomMap.THashSet////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.THashSet.Release(var aItem: TKeyValuePair; const aFreeItem: Boolean);
- begin
- utlFinalizeObject(aItem.Key, TypeInfo(aItem.Key), fOwner.OwnsKeys and aFreeItem);
- utlFinalizeObject(aItem.Value, TypeInfo(aItem.Value), fOwner.OwnsValues and aFreeItem);
- inherited Release(aItem, aFreeItem);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.THashSet.Create(const aOwner: TutlCustomMap; const aComparer: IComparer);
- begin
- inherited Create(aComparer, true);
- fOwner := aOwner;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomMap.TKeyValuePairComparer///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyValuePairComparer.EqualityCompare(constref i1, i2: TKeyValuePair): Boolean;
- begin
- result := fComparer.EqualityCompare(i1.Key, i2.Key);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyValuePairComparer.Compare(constref i1, i2: TKeyValuePair): Integer;
- begin
- result := fComparer.Compare(i1.Key, i2.Key);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.TKeyValuePairComparer.Create(aComparer: IComparer);
- begin
- if not Assigned(aComparer) then
- raise EArgumentNilException.Create('aComparer');
- inherited Create;
- fComparer := aComparer;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlCustomMap.TKeyValuePairComparer.Destroy;
- begin
- fComparer := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomMap.TKeyCollection//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyCollection.GetEnumerator: specialize IEnumerator<TKey>;
- begin
- result := nil; // TODO
- raise ENotSupportedException.Create('not yet supported');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- {$IFDEF UTL_ENUMERATORS}
- function TutlCustomMap.TKeyCollection.GetUtlEnumerator: specialize IutlEnumerator<TKey>;
- begin
- result := nil; // TODO
- raise ENotSupportedException.Create('not yet supported');
- end;
- {$ENDIF}
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyCollection.GetCount: Integer;
- begin
- result := fHashSet.Count;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyCollection.GetItem(const aIndex: Integer): TKey;
- begin
- result := fHashSet[aIndex].Key;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.TKeyCollection.Create(const aHashSet: THashSet);
- begin
- inherited Create;
- fHashSet := aHashSet;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomMap.TKeyValuePairCollection/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyValuePairCollection.GetEnumerator: specialize IEnumerator<TKeyValuePair>;
- begin
- result := nil; // TODO
- raise ENotSupportedException.Create('not yet supported');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- {$IFDEF UTL_ENUMERATORS}
- function TutlCustomMap.TKeyValuePairCollection.GetUtlEnumerator: specialize IutlEnumerator<TKeyValuePair>;
- begin
- result := nil; // TODO
- raise ENotSupportedException.Create('not yet supported');
- end;
- {$ENDIF}
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyValuePairCollection.GetCount: Integer;
- begin
- result := fHashSet.Count;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TKeyValuePairCollection.GetItem(const aIndex: Integer): TKeyValuePair;
- begin
- result := fHashSet[aIndex];
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.TKeyValuePairCollection.Create(const aHashSet: THashSet);
- begin
- inherited Create;
- fHashSet := aHashSet;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlCustomMap/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetValue(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 TutlCustomMap.GetValueAt(const aIndex: Integer): TValue;
- begin
- result := fHashSetRef[aIndex].Value;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetCount: Integer;
- begin
- result := fHashSetRef.Count;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetIsEmpty: Boolean;
- begin
- result := fHashSetRef.IsEmpty;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetCapacity: Integer;
- begin
- result := fHashSetRef.Capacity;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetCanShrink: Boolean;
- begin
- result := fHashSetRef.CanShrink;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetCanExpand: Boolean;
- begin
- result := fHashSetRef.CanExpand;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.SetValue(aKey: TKey; const 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 EInvalidOperation.Create('key not found');
- fHashSetRef.Add(kvp);
- end else
- fHashSetRef[i] := kvp;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.SetValueAt(const aIndex: Integer; const aValue: TValue);
- var
- kvp: TKeyValuePair;
- begin
- kvp := fHashSetRef[aIndex];
- kvp.Value := aValue;
- fHashSetRef[aIndex] := kvp;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.SetCapacity(const aValue: Integer);
- begin
- fHashSetRef.Capacity := aValue;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.SetCanShrink(const aValue: Boolean);
- begin
- fHashSetRef.CanShrink := aValue;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.SetCanExpand(const aValue: Boolean);
- begin
- fHashSetRef.CanExpand := aValue;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.GetEnumerator: specialize IEnumerator<TValue>;
- begin
- result := nil; // TODO
- raise ENotSupportedException.Create('not yet supported');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- {$IFDEF UTL_ENUMERATORS}
- function TutlCustomMap.GetUtlEnumerator: specialize IutlEnumerator<TValue>;
- begin
- result := nil; // TODO
- raise ENotSupportedException.Create('not yet supported');
- end;
- {$ENDIF}
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.Add(constref aKey: TKey; constref aValue: TValue);
- begin
- if not TryAdd(aKey, aValue) then
- raise EInvalidOperation.Create('key already exists');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TryAdd(constref aKey: TKey; constref aValue: TValue): Boolean;
- var
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- kvp.Value := aValue;
- result := fHashSetRef.Add(kvp);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.TryGetValue(constref aKey: TKey; out aValue: TValue): Boolean;
- var
- i: Integer;
- begin
- i := IndexOf(aKey);
- result := (i >= 0);
- if result
- then aValue := fHashSetRef[i].Value
- else FillByte(result, SizeOf(result), 0);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.IndexOf(constref aKey: TKey): Integer;
- var
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- result := fHashSetRef.IndexOf(kvp);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlCustomMap.Contains(constref aKey: TKey): Boolean;
- begin
- result := (IndexOf(aKey) >= 0);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.Delete(constref aKey: TKey);
- var
- kvp: TKeyValuePair;
- begin
- kvp.Key := aKey;
- if not fHashSetRef.Remove(kvp) then
- raise EInvalidOperation.Create('key not found');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.DeleteAt(const aIndex: Integer);
- begin
- fHashSetRef.Delete(aIndex);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlCustomMap.Clear;
- begin
- fHashSetRef.Clear;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlCustomMap.Create(
- const aHashSet: THashSet;
- const aOwnsKeys: Boolean;
- const aOwnsValues: Boolean);
- begin
- if not Assigned(aHashSet) then
- EArgumentNilException.Create('aHashSet');
-
- inherited Create;
-
- fAutoCreate := false;
- fHashSetRef := aHashSet;
- fOwnsKeys := aOwnsKeys;
- fOwnsValues := aOwnsValues;
-
- fKeyCollection := TKeyCollection.Create(fHashSetRef);
- fKeyValuePairCollection := TKeyValuePairCollection.Create(fHashSetRef);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlCustomMap.Destroy;
- begin
- FreeAndNil(fKeyValuePairCollection);
- FreeAndNil(fKeyCollection);
- fHashSetRef := nil;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlMap///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TutlMap.Create(const aOwnsKeys: Boolean; const aOwnsValues: Boolean);
- begin
- fHashSetImpl := THashSet.Create(self, TKeyValuePairComparer.Create(TComparer.Create));
- inherited Create(fHashSetImpl, aOwnsKeys, aOwnsValues);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TutlMap.Destroy;
- begin
- Clear;
- 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;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlEnumHelper////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- 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.Names: TStringArray;
- begin
- result := fNames;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlEnumHelper.TypeInfo: PTypeInfo;
- begin
- result := fTypeInfo;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class constructor TutlEnumHelper.Initialize;
- var
- tiArray: PTypeInfo;
- tdArray, tdEnum: PTypeData;
- PName: 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 *PName* are always correct.
- }
- tdEnum := GetTypeData(FTypeInfo);
- PName := @tdEnum^.NameList;
- SetLength(fValues, 0);
- SetLength(fNames, 0);
- i:= 0;
- while Length(PName^) > 0 do begin
- SetLength(fValues, i+1);
- SetLength(fNames, 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).
- }
- fNames[i] := PName^;
- if TryToEnum(PName^, en) then
- fValues[i]:= en;
-
- inc(i);
- inc(PByte(PName), Length(PName^) + 1);
- end;
- // remove the EnumUnitName item
- SetLength(fValues, High(fValues));
- SetLength(fNames, High(fNames));
- end;
-
- end.
|