diff options
Diffstat (limited to 'src/corelib/gfx_strings.pas')
| -rw-r--r-- | src/corelib/gfx_strings.pas | 1024 |
1 files changed, 1024 insertions, 0 deletions
diff --git a/src/corelib/gfx_strings.pas b/src/corelib/gfx_strings.pas new file mode 100644 index 00000000..fe49fb40 --- /dev/null +++ b/src/corelib/gfx_strings.pas @@ -0,0 +1,1024 @@ +{ + fpGUI - Free Pascal GUI Library + + Unit to handle WideString (UTF-16) strings. + + Copyright (C) 2007 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +} + + + // ******* PLEASE DO NOT USE THIS UNIT!!!! ******* + + + // Graeme: I'm experimenting with something again. + + +unit gfx_strings; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils; + +type + // forward declarations + TWideStrings = class; + TWideStringList = class; + + // independant types that could be used in fpGUI + gfxString = WideString; // string + gfxChar = WideChar; // char + gfxPChar = PWideChar; // pchar + gfxStringList = TWideStringList; // TStringList + + +{$Warnings off} // because I'm hiding the TStrings String properties + + { A WideString version of the abstract TStrings class. } + TWideStrings = class(TStrings) + private + FUpdateCount: integer; + function GetCommaText: WideString; + function GetName(Index: integer): WideString; + function GetValue(const Name: WideString): WideString; + procedure ReadData(Reader: TReader); + procedure SetCommaText(const Value: WideString); + procedure SetValue(const Name, Value: WideString); + procedure WriteData(Writer: TWriter); + protected + procedure DefineProperties(Filer: TFiler); override; + procedure Error(const Msg: string; Data: integer); + function Get(Index: integer): WideString; virtual; abstract; + function GetCapacity: integer; virtual; + function GetCount: integer; virtual; abstract; + function GetObject(Index: integer): TObject; virtual; + function GetTextStr: WideString; virtual; + procedure Put(Index: integer; const S: WideString); virtual; + procedure PutObject(Index: integer; AObject: TObject); virtual; + procedure SetCapacity(NewCapacity: integer); virtual; + procedure SetTextStr(const Value: WideString); virtual; + procedure SetUpdateState(Updating: Boolean); virtual; + public + constructor Create; + function Add(const S: WideString): integer; virtual; + function AddObject(const S: WideString; AObject: TObject): integer; virtual; + procedure Append(const S: WideString); + procedure AddStrings(aStrings: TWideStrings); virtual; + procedure Assign(Source: TPersistent); override; + procedure BeginUpdate; + procedure Clear; virtual; abstract; + procedure Delete(Index: integer); virtual; abstract; + procedure EndUpdate; + function Equals(aStrings: TWideStrings): Boolean; + procedure Exchange(Index1, Index2: integer); virtual; + function GetText: PWideChar; virtual; + function IndexOf(const S: WideString): integer; virtual; + function IndexOfName(const Name: WideString): integer; + function IndexOfObject(AObject: TObject): integer; + procedure Insert(Index: integer; const S: WideString); virtual; abstract; + procedure InsertObject(Index: integer; const S: WideString; AObject: TObject); + procedure LoadFromFile(const FileName: string); virtual; + procedure LoadFromStream(Stream: TStream); virtual; + procedure Move(CurIndex, NewIndex: integer); virtual; + procedure SaveToFile(const FileName: string); virtual; + procedure SaveToStream(Stream: TStream); virtual; + procedure SetText(aText: PWideChar); virtual; + property Capacity: integer read GetCapacity write SetCapacity; + property CommaText: WideString read GetCommaText write SetCommaText; + property Count: integer read GetCount; + property Names[Index: integer]: WideString read GetName; + property Objects[Index: integer]: TObject read GetObject write PutObject; + property Values[const Name: WideString]: WideString read GetValue write SetValue; + property Strings[Index: integer]: WideString read Get write Put; default; + property Text: WideString read GetTextStr write SetTextStr; + end; + + + PWideStringItem = ^TWideStringItem; + + TWideStringItem = record + FString: WideString; + FObject: TObject; + end; + + + PWideStringItemList = ^TWideStringItemList; + TWideStringItemList = array[0..MaxListSize] of TWideStringItem; + + + { A WideString version of TStringList class. } + TWideStringList = class(TWideStrings) + private + FList: PStringItemList; + FCount: integer; + FCapacity: integer; + FSorted: Boolean; + FDuplicates: TDuplicates; + FOnChange: TNotifyEvent; + FOnChanging: TNotifyEvent; + procedure ExchangeItems(Index1, Index2: integer); + procedure Grow; + procedure QuickSort(L, R: integer); + procedure InsertItem(Index: integer; const S: WideString); + procedure SetSorted(Value: Boolean); + protected + procedure Changed; virtual; + procedure Changing; virtual; + function Get(Index: integer): WideString; override; + function GetCapacity: integer; override; + function GetCount: integer; override; + function GetObject(Index: integer): TObject; override; + procedure Put(Index: integer; const S: WideString); override; + procedure PutObject(Index: integer; AObject: TObject); override; + procedure SetCapacity(NewCapacity: integer); override; + procedure SetUpdateState(Updating: Boolean); override; + public + destructor Destroy; override; + function Add(const S: WideString): integer; override; + procedure Clear; override; + procedure Delete(Index: integer); override; + procedure Exchange(Index1, Index2: integer); override; + function Find(const S: WideString; var Index: integer): Boolean; virtual; + function IndexOf(const S: WideString): integer; override; + procedure Insert(Index: integer; const S: WideString); override; + procedure Sort; virtual; + property Duplicates: TDuplicates read FDuplicates write FDuplicates; + property Sorted: Boolean read FSorted write SetSorted; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; + end; + +{$Warnings on} + +function WideQuotedStr(const S: WideString; Quote: widechar): WideString; +function WideExtractQuotedStr(var S: WideString; Quote: widechar): WideString; +function utf8(const utf8str: string): widestring; +function u8(const utf8str: string): widestring; +function wsToUtf8(const wstr: widestring): string; + + +implementation + + +uses + RTLConsts; + +const + BOM: word = $FFFE; // Byte Order Mark + +function WideQuotedStr(const S: WideString; Quote: widechar): WideString; +var + slen: integer; + i: integer; +begin + Result := Quote + S + Quote; + slen := length(Result); + i := 2; + while i < slen do + begin + if Result[i] = quote then + begin + insert(quote, Result, i); + Inc(i); + Inc(slen); + end; + Inc(i); + end; +end; + +function WideExtractQuotedStr(var S: widestring; Quote: widechar): WideString; +var + i: integer; + slen: integer; +begin + if length(s) < 2 then + Result := s + else + begin + Result := copy(s, 2, length(s) - 2); + slen := length(Result); + i := 1; + while i < slen do + begin + if (Result[i] = quote) and (Result[i + 1] = quote) then + begin + Delete(Result, i, 1); + Dec(slen); + end; + Inc(i); + end; + end; +end; + +function utf8(const utf8str: string): widestring; +begin + Result := UTF8Decode(utf8str); +end; + +function u8(const utf8str: string): widestring; +begin + Result := UTF8Decode(utf8str); +end; + +function wsToUtf8(const wstr: widestring): string; +begin + Result := UTF8Encode(wstr); +end; + +constructor TWideStrings.Create; +begin + inherited; +end; + +function TWideStrings.Add(const S: WideString): integer; +begin + Result := GetCount; + Insert(Result, S); +end; + +function TWideStrings.AddObject(const S: WideString; AObject: TObject): integer; +begin + Result := Add(S); + PutObject(Result, AObject); +end; + +procedure TWideStrings.Append(const S: WideString); +begin + Add(S); +end; + +procedure TWideStrings.AddStrings(aStrings: TWideStrings); +var + I: integer; +begin + BeginUpdate; + try + for I := 0 to aStrings.Count - 1 do + AddObject(aStrings[I], aStrings.Objects[I]); + finally + EndUpdate; + end; +end; + +procedure TWideStrings.Assign(Source: TPersistent); +var + I: integer; +begin + if Source is TWideStrings then + begin + BeginUpdate; + try + Clear; + AddStrings(TWideStrings(Source)); + finally + EndUpdate; + end; + Exit; + end + else if Source is TStrings then + begin + BeginUpdate; + try + for I := 0 to TStrings(Source).Count - 1 do + AddObject(TStrings(Source)[I], TStrings(Source).Objects[I]); + finally + EndUpdate; + end; + end; + inherited Assign(Source); +end; + +procedure TWideStrings.BeginUpdate; +begin + if FUpdateCount = 0 then + SetUpdateState(True); + Inc(FUpdateCount); +end; + +procedure TWideStrings.DefineProperties(Filer: TFiler); + + function DoWrite: Boolean; + begin + if Filer.Ancestor <> nil then + begin + Result := True; + if Filer.Ancestor is TWideStrings then + Result := not Equals(TWideStrings(Filer.Ancestor)); + end + else + Result := Count > 0; + end; + +begin + Filer.DefineProperty('WideStrings', @ReadData, @WriteData, DoWrite); +end; + +procedure TWideStrings.EndUpdate; +begin + Dec(FUpdateCount); + if FUpdateCount = 0 then + SetUpdateState(False); +end; + +function TWideStrings.Equals(aStrings: TWideStrings): Boolean; +var + I, cnt: integer; +begin + Result := False; + cnt := GetCount; + if cnt <> aStrings.GetCount then + Exit; + for I := 0 to cnt - 1 do + if Get(I) <> aStrings.Get(I) then + Exit; + Result := True; +end; + +procedure TWideStrings.Error(const Msg: string; Data: integer); +begin + raise EStringListError.CreateFmt(Msg, [Data]); +end; + +procedure TWideStrings.Exchange(Index1, Index2: integer); +var + TempObject: TObject; + TempString: WideString; +begin + BeginUpdate; + try + TempString := Strings[Index1]; + TempObject := Objects[Index1]; + Strings[Index1] := Strings[Index2]; + Objects[Index1] := Objects[Index2]; + Strings[Index2] := TempString; + Objects[Index2] := TempObject; + finally + EndUpdate; + end; +end; + +function TWideStrings.GetCapacity: integer; +begin + Result := Count; +end; + +function TWideStrings.GetCommaText: WideString; +var + S: WideString; + P: PWideChar; + I, cnt: integer; +begin + cnt := GetCount; + if (cnt = 1) and (Get(0) = '') then + Result := '""' + else + begin + Result := ''; + for I := 0 to cnt - 1 do + begin + S := Get(I); + P := PWideChar(S); + while not (P^ in [widechar(#0)..widechar(' '), widechar('"'), widechar(',')]) do + Inc(P); + if (P^ <> #0) then + S := WideQuotedStr(S, '"'); + + if I > 0 then + Result := Result + ','; + Result := Result + S; + end; + end; +end; + +function TWideStrings.GetName(Index: integer): WideString; +var + P: integer; +begin + Result := Get(Index); + P := 1; + while Result[P] <> '=' do + Inc(P); + if P <> 0 then + SetLength(Result, P - 1) + else + SetLength(Result, 0); +end; + +function TWideStrings.GetObject(Index: integer): TObject; +begin + Result := nil; +end; + +function TWideStrings.GetText: PWideChar; +var + TempStr: WideString; +begin + TempStr := GetTextStr; + Result := AllocMem(2 * Length(TempStr) + 10); + System.Move(TempStr[1], Result^, 2 * Length(TempStr) + 2); +end; + +function TWideStrings.GetTextStr: WideString; +var + I, L, Size, cnt: integer; + P: PWideChar; + S: WideString; +begin + cnt := GetCount; + Size := 0; + for I := 0 to cnt - 1 do + Inc(Size, Length(Get(I)) + 2); + SetString(Result, nil, Size); + P := Pointer(Result); + for I := 0 to cnt - 1 do + begin + S := Get(I); + L := Length(S); + if L <> 0 then + begin + System.Move(Pointer(S)^, P^, L * 2); + Inc(P, L); + end; + P^ := #13; + Inc(P); + P^ := #10; + Inc(P); + end; +end; + +function TWideStrings.GetValue(const Name: WideString): WideString; +var + I: integer; +begin + I := IndexOfName(Name); + if I >= 0 then + Result := Copy(Get(I), Length(Name) + 2, MaxInt) + else + Result := ''; +end; + +function TWideStrings.IndexOf(const S: WideString): integer; +begin + for Result := 0 to GetCount - 1 do + if Get(Result) = S then + Exit; + Result := -1; +end; + +function TWideStrings.IndexOfName(const Name: WideString): integer; +var + P: integer; + S: string; +begin + for Result := 0 to GetCount - 1 do + begin + S := Get(Result); + P := 1; + + while S[P] <> '=' do + Inc(P); + + if (P <> 0) and (Copy(S, 1, P - 1) = Name) then + Exit; + end; + Result := -1; +end; + +function TWideStrings.IndexOfObject(AObject: TObject): integer; +begin + for Result := 0 to GetCount - 1 do + if GetObject(Result) = AObject then + Exit; + Result := -1; +end; + +procedure TWideStrings.InsertObject(Index: integer; const S: WideString; AObject: TObject); +begin + Insert(Index, S); + PutObject(Index, AObject); +end; + +procedure TWideStrings.LoadFromFile(const FileName: string); +var + Stream: TStream; +begin + Stream := TFileStream.Create(FileName, fmOpenRead); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TWideStrings.LoadFromStream(Stream: TStream); +var + Size: integer; + S: WideString; + Reverse: Boolean; + rBOM: word; + I: integer; +begin + BeginUpdate; + try + Stream.Read(rBOM, 2); + Reverse := False; + if rBOM = $FEFF then + Reverse := True + else if rBOM <> $FFFE then + Stream.Seek(-2, soFromCurrent); + + Size := Stream.Size - Stream.Position; + SetString(S, nil, Size div 2); + Stream.Read(Pointer(S)^, Size); + if Reverse then + for I := 1 to Length(S) do + S[I] := widechar(Swap(word(S[I]))); + SetTextStr(S); + finally + EndUpdate; + end; +end; + +procedure TWideStrings.Move(CurIndex, NewIndex: integer); +var + TempObject: TObject; + TempString: WideString; +begin + if CurIndex <> NewIndex then + begin + BeginUpdate; + try + TempString := Get(CurIndex); + TempObject := GetObject(CurIndex); + Delete(CurIndex); + InsertObject(NewIndex, TempString, TempObject); + finally + EndUpdate; + end; + end; +end; + +procedure TWideStrings.Put(Index: integer; const S: WideString); +var + TempObject: TObject; +begin + TempObject := GetObject(Index); + Delete(Index); + InsertObject(Index, S, TempObject); +end; + +procedure TWideStrings.PutObject(Index: integer; AObject: TObject); +begin + // Empty +end; + +procedure TWideStrings.ReadData(Reader: TReader); +var + S: string; + W: WideString; + I: integer; + Z: integer; + N: word; +begin + BeginUpdate; + try + Clear; + S := Reader.ReadString; + SetLength(W, Length(S) div 4); + for I := 1 to Length(S) div 4 do + begin + Val('$' + S[I * 4 - 3] + S[I * 4 - 2] + S[I * 4 - 1] + S[I * 2], N, Z); + W[I] := widechar(N); + end; + Text := W; + finally + EndUpdate; + end; +end; + +procedure TWideStrings.SaveToFile(const FileName: string); +var + Stream: TStream; +begin + Stream := TFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TWideStrings.SaveToStream(Stream: TStream); +var + S: WideString; +begin + S := GetTextStr; + Stream.Write(BOM, 2); + Stream.WriteBuffer(Pointer(S)^, Length(S) * 2); +end; + +procedure TWideStrings.SetCapacity(NewCapacity: integer); +begin + // do nothing - descendants may optionally implement this method +end; + +procedure TWideStrings.SetCommaText(const Value: WideString); +var + s: WideString; + i: integer; + inquote: boolean; +begin + BeginUpdate; + + try + Clear; + + inquote := False; + i := 1; + s := ''; + while i <= length(Value) do + begin + + if Value[i] = '"' then + begin + if inquote then + begin + if (i < length(Value)) and (Value[i] = '"') then + begin + s := s + '"'; + Inc(i); + end + else + inquote := False; + end + else + begin + inquote := True; + end; + end + else if (Value[i] = ',') and not inquote then + begin + Add(s); + s := ''; + end + else + s := s + Value[i]; + + Inc(i); + end; + + if s <> '' then + Add(s); + + finally + EndUpdate; + end; +end; + +procedure TWideStrings.SetText(aText: PWideChar); +begin + SetTextStr(aText); +end; + +procedure TWideStrings.SetTextStr(const Value: WideString); +var + P, Start: PWideChar; + S: WideString; +begin + BeginUpdate; + try + Clear; + P := Pointer(Value); + if P <> nil then + while P^ <> #0 do + begin + Start := P; + while not (P^ in [widechar(#0), widechar(#10), widechar(#13)]) do + Inc(P); + SetString(S, Start, P - Start); + Add(S); + if P^ = #13 then + Inc(P); + if P^ = #10 then + Inc(P); + end; + finally + EndUpdate; + end; +end; + +procedure TWideStrings.SetUpdateState(Updating: Boolean); +begin + // Empty +end; + +procedure TWideStrings.SetValue(const Name, Value: WideString); +var + I: integer; +begin + I := IndexOfName(Name); + if Value <> '' then + begin + if I < 0 then + I := Add(''); + Put(I, Name + '=' + Value); + end + else if I >= 0 then + Delete(I); +end; + +procedure TWideStrings.WriteData(Writer: TWriter); +var + I: integer; + S: string; + W: WideString; +begin + W := Text; + S := ''; + for I := 1 to Length(W) do + S := S + IntToHex(word(W[1]), 4); + Writer.WriteString(S); +end; + +{ TWideStringList } + +destructor TWideStringList.Destroy; +begin + FOnChange := nil; + FOnChanging := nil; + inherited Destroy; + if FCount <> 0 then + Finalize(FList^[0], FCount); + FCount := 0; + SetCapacity(0); +end; + +function TWideStringList.Add(const S: WideString): integer; +begin + if not Sorted then + Result := FCount + else if Find(S, Result) then + case Duplicates of + dupIgnore: Exit; + dupError: Error(SDuplicateString, 0); + end; + InsertItem(Result, S); +end; + +procedure TWideStringList.Changed; +begin + if (FUpdateCount = 0) and Assigned(FOnChange) then + FOnChange(Self); +end; + +procedure TWideStringList.Changing; +begin + if (FUpdateCount = 0) and Assigned(FOnChanging) then + FOnChanging(Self); +end; + +procedure TWideStringList.Clear; +begin + if FCount <> 0 then + begin + Changing; + Finalize(FList^[0], FCount); + FCount := 0; + SetCapacity(0); + Changed; + end; +end; + +procedure TWideStringList.Delete(Index: integer); +begin + if (Index < 0) or (Index >= FCount) then + Error(SListIndexError, Index); + Changing; + Finalize(FList^[Index]); + Dec(FCount); + if Index < FCount then + System.Move(FList^[Index + 1], FList^[Index], + (FCount - Index) * SizeOf(TStringItem)); + Changed; +end; + +procedure TWideStringList.Exchange(Index1, Index2: integer); +begin + if (Index1 < 0) or (Index1 >= FCount) then + Error(SListIndexError, Index1); + if (Index2 < 0) or (Index2 >= FCount) then + Error(SListIndexError, Index2); + Changing; + ExchangeItems(Index1, Index2); + Changed; +end; + +procedure TWideStringList.ExchangeItems(Index1, Index2: integer); +var + Temp: integer; + Item1, Item2: PWideStringItem; +begin + Item1 := @FList^[Index1]; + Item2 := @FList^[Index2]; + Temp := integer(Item1^.FString); + integer(Item1^.FString) := integer(Item2^.FString); + integer(Item2^.FString) := Temp; + Temp := integer(Item1^.FObject); + integer(Item1^.FObject) := integer(Item2^.FObject); + integer(Item2^.FObject) := Temp; +end; + +function TWideStringList.Find(const S: WideString; var Index: integer): Boolean; +var + L, H, I, C: integer; +begin + Result := False; + L := 0; + H := FCount - 1; + while L <= H do + begin + I := (L + H) shr 1; + C := WideCompareText(FList^[I].FString, S); + if C < 0 then + L := I + 1 + else + begin + H := I - 1; + if C = 0 then + begin + Result := True; + if Duplicates <> dupAccept then + L := I; + end; + end; + end; + Index := L; +end; + +function TWideStringList.Get(Index: integer): WideString; +begin + if (Index < 0) or (Index >= FCount) then + Error(SListIndexError, Index); + Result := FList^[Index].FString; +end; + +function TWideStringList.GetCapacity: integer; +begin + Result := FCapacity; +end; + +function TWideStringList.GetCount: integer; +begin + Result := FCount; +end; + +function TWideStringList.GetObject(Index: integer): TObject; +begin + if (Index < 0) or (Index >= FCount) then + Error(SListIndexError, Index); + Result := FList^[Index].FObject; +end; + +procedure TWideStringList.Grow; +var + Delta: integer; +begin + if FCapacity > 64 then + Delta := FCapacity div 4 + else if FCapacity > 8 then + Delta := 16 + else + Delta := 4; + SetCapacity(FCapacity + Delta); +end; + +function TWideStringList.IndexOf(const S: WideString): integer; +begin + if not Sorted then + Result := inherited IndexOf(S) + else if not Find(S, Result) then + Result := -1; +end; + +procedure TWideStringList.Insert(Index: integer; const S: WideString); +begin + if Sorted then + Error(SSortedListError, 0); + if (Index < 0) or (Index > FCount) then + Error(SListIndexError, Index); + InsertItem(Index, S); +end; + +procedure TWideStringList.InsertItem(Index: integer; const S: WideString); +begin + Changing; + if FCount = FCapacity then + Grow; + if Index < FCount then + System.Move(FList^[Index], FList^[Index + 1], + (FCount - Index) * SizeOf(TStringItem)); + with FList^[Index] do + begin + Pointer(FString) := nil; + FObject := nil; + FString := S; + end; + Inc(FCount); + Changed; +end; + +procedure TWideStringList.Put(Index: integer; const S: WideString); +begin + if Sorted then + Error(SSortedListError, 0); + if (Index < 0) or (Index >= FCount) then + Error(SListIndexError, Index); + Changing; + FList^[Index].FString := S; + Changed; +end; + +procedure TWideStringList.PutObject(Index: integer; AObject: TObject); +begin + if (Index < 0) or (Index >= FCount) then + Error(SListIndexError, Index); + Changing; + FList^[Index].FObject := AObject; + Changed; +end; + +procedure TWideStringList.QuickSort(L, R: integer); +var + I, J: integer; + P: WideString; +begin + repeat + I := L; + J := R; + P := FList^[(L + R) shr 1].FString; + repeat + while WideCompareText(FList^[I].FString, P) < 0 do + Inc(I); + while WideCompareText(FList^[J].FString, P) > 0 do + Dec(J); + if I <= J then + begin + ExchangeItems(I, J); + Inc(I); + Dec(J); + end; + until I > J; + if L < J then + QuickSort(L, J); + L := I; + until I >= R; +end; + +procedure TWideStringList.SetCapacity(NewCapacity: integer); +begin + ReallocMem(FList, NewCapacity * SizeOf(TStringItem)); + FCapacity := NewCapacity; +end; + +procedure TWideStringList.SetSorted(Value: Boolean); +begin + if FSorted <> Value then + begin + if Value then + Sort; + FSorted := Value; + end; +end; + +procedure TWideStringList.SetUpdateState(Updating: Boolean); +begin + if Updating then + Changing + else + Changed; +end; + +procedure TWideStringList.Sort; +begin + if not Sorted and (FCount > 1) then + begin + Changing; + QuickSort(0, FCount - 1); + Changed; + end; +end; + + +end. + |