From 8c181f7e628efe6da4b31b3b09f8bc25a42ace70 Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Thu, 7 Jun 2018 08:42:11 +0000 Subject: [PATCH] fpspreadsheet: Install TFileName property editor for Laz < 1.9. Fix compilation of fps packages for Laz >= 1.0 (could not compile Laz 1.2, though). git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6471 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- .../fpspreadsheet/source/common/fpsfunc.pas | 2 +- .../source/common/fpsstringhashlist.pas | 377 ++++++++++++++++++ .../fpspreadsheet/source/common/xlsbiff5.pas | 6 +- .../fpspreadsheet/source/common/xlsbiff8.pas | 13 +- .../fpspreadsheet/source/common/xlscommon.pas | 2 + .../source/design/fpsvisualreg.pas | 8 +- components/fpspreadsheet/source/fps.inc | 8 +- 7 files changed, 400 insertions(+), 16 deletions(-) create mode 100644 components/fpspreadsheet/source/common/fpsstringhashlist.pas diff --git a/components/fpspreadsheet/source/common/fpsfunc.pas b/components/fpspreadsheet/source/common/fpsfunc.pas index 3b992e072..483a0c199 100644 --- a/components/fpspreadsheet/source/common/fpsfunc.pas +++ b/components/fpspreadsheet/source/common/fpsfunc.pas @@ -163,7 +163,7 @@ begin for i:=1 to n do res := res * i; Result := FloatResult(res); - except on E:EFPSpreadsheet do + except on E: EFPSpreadsheet do Result := ErrorResult(errOverflow); end; end else diff --git a/components/fpspreadsheet/source/common/fpsstringhashlist.pas b/components/fpspreadsheet/source/common/fpsstringhashlist.pas new file mode 100644 index 000000000..91975bbf7 --- /dev/null +++ b/components/fpspreadsheet/source/common/fpsstringhashlist.pas @@ -0,0 +1,377 @@ +{ + /*************************************************************************** + stringhashlist.pas + ------------------ + Component Library Code + + + ***************************************************************************/ + + ***************************************************************************** + This file is part of the Lazarus Component Library (LCL) + + See the file COPYING.modifiedLGPL.txt, included in this distribution, + for details about the license. + ***************************************************************************** + + Thanks to Markus Waldenburg. + +} +unit fpsStringHashList; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils; //, LCLStrConsts; + +type + PStringHashItem = ^TStringHashItem; + TStringHashItem = record + HashValue: Cardinal; + Key: String; + Data: Pointer; + end; + + PStringHashItemList = ^PStringHashItem; + + TStringHashList = class(TObject) + private + FList: PStringHashItemList; + FCount: Integer; + fCaseSensitive: Boolean; + function BinarySearch(HashValue: Cardinal): Integer; + function CompareString(const Value1, Value2: String): Boolean; + function CompareValue(const Value1, Value2: Cardinal): Integer; + procedure FindHashBoundaries(HashValue: Cardinal; StartFrom: Integer; out First, Last: Integer); + function GetData(const S: String): Pointer; + procedure SetCaseSensitive(const Value: Boolean); + procedure Delete(Index: Integer); + procedure SetData(const S: String; const AValue: Pointer); + protected + function HashOf(const Key: string): Cardinal; + procedure Insert(Index: Integer; Item: PStringHashItem); + public + constructor Create(CaseSensitivity: boolean); + destructor Destroy; override; + function Add(const S: String): Integer; + function Add(const S: String; ItemData: Pointer): Integer; + procedure Clear; + function Find(const S: String): Integer; + function Find(const S: String; Data: Pointer): Integer; + function Remove(const S: String): Integer; + function Remove(const S: String; Data: Pointer): Integer; + property CaseSensitive: Boolean read fCaseSensitive write SetCaseSensitive; + property Count: Integer read FCount; + property Data[const S: String]: Pointer read GetData write SetData; default; + property List: PStringHashItemList read FList; + end; + + +implementation + +const + strListMustBeEmpty = 'List must be empty'; + +var + UpperCaseChars: array[char] of char; + +{ TStringHashList } + +function TStringHashList.Add(const S: String): Integer; +begin + Result:=Add(S,nil); +end; + +function TStringHashList.Add(const S: String; ItemData: Pointer): Integer; +var + Item: PStringHashItem; + First, Last, I: Integer; + Val: Cardinal; + Larger: boolean; +begin + New(Item); + Val:= HashOf(S); + Item^.HashValue := Val; + Item^.Key := S; + Item^.Data := ItemData; + if FCount > 0 then + begin + First:=0; + Last:= FCount-1; + Larger:=False; + while First<=Last do + begin + I:=(First+Last)shr 1; + Case CompareValue(Val, fList[I]^.HashValue)<=0 of + True: + begin + Last:=I-1; + Larger:=False; + end; + False: + begin + First:=I+1; + Larger:=True; + end; + end; + end; + Case Larger of + True: Result:=I+1; + False: Result:=I; + end; + end else + Result:=0; + Insert(Result,Item); +end; + +function TStringHashList.BinarySearch(HashValue: Cardinal): Integer; +var + First, Last, Temp: Integer; +begin + Result:= -1; + First:= 0; + Last:= Count -1; + while First <= Last do + begin + Temp:= (First + Last) div 2; + case CompareValue(HashValue, FList[Temp]^.HashValue) of + 1: First:= Temp + 1; + 0: exit(Temp); + -1: Last:= Temp-1; + end; + end; +end; + +procedure TStringHashList.Clear; +var + I: Integer; +begin + for I:= 0 to fCount -1 do + Dispose(fList[I]); + if FList<>nil then begin + FreeMem(FList); + FList:=nil; + end; + fCount:= 0; +end; + +function TStringHashList.CompareString(const Value1, Value2: String): Boolean; +var + I, Len: Integer; + P1,P2: PChar; +begin + Result:= False; + P1:= PChar(Value1); + Len:= Length(Value1); + P2:= PChar(Value2); + if Len = Length(Value2) then + begin + Result:= True; + case fCaseSensitive of + True: + for I:= Len -1 downto 0 do + if P1[I] <> P2[I] then begin + Result:= False; + break; + end; + False: + for I:= Len -1 downto 0 do + if UpperCaseChars[P1[I]] <> UpperCaseChars[P2[I]] then begin + Result:= False; + break; + end; + end; + end; +end; + +function TStringHashList.CompareValue(const Value1, Value2: Cardinal): Integer; +begin + Result:= 0; + if Value1 > Value2 then + Result:= 1 + else if Value1 < Value2 then + Result:= -1; +end; + +function TStringHashList.GetData(const S: String): Pointer; +var i: integer; +begin + i:=Find(S); + if i>=0 then + Result:=FList[i]^.Data + else + Result:=nil; +end; + +procedure TStringHashList.Delete(Index: Integer); +begin + if (Index >= 0) and (Index < FCount) then + begin + dec(FCount); + if Index < FCount then + System.Move(FList[Index + 1], FList[Index], + (FCount - Index) * SizeOf(PStringHashItem)); + end; +end; + +procedure TStringHashList.SetData(const S: String; const AValue: Pointer); +var i: integer; +begin + i:=Find(S); + if i>=0 then + FList[i]^.Data:=AValue + else + Add(S,AValue); +end; + +destructor TStringHashList.Destroy; +begin + Clear; + inherited Destroy; +end; + +function TStringHashList.Find(const S: String): Integer; +var + Value: Cardinal; + First, Last, I: Integer; +begin + Value:= HashOf(s); + Result:= BinarySearch(Value); + if (Result <> -1) and not CompareString(S, FList[Result]^.Key) then + begin + FindHashBoundaries(Value, Result, First, Last); + Result:= -1; + for I := First to Last do + if CompareString(S, FList[I]^.Key) then + begin + Result:= I; + Exit; + end; + end; +end; + +function TStringHashList.Find(const S: String; Data: Pointer): Integer; +var + Value: Cardinal; + First, Last, I: Integer; +begin + Value:= HashOf(s); + Result:= BinarySearch(Value); + if (Result <> -1) and + not (CompareString(S, FList[Result]^.Key) and (FList[Result]^.Data = Data)) then + begin + FindHashBoundaries(Value, Result, First, Last); + Result:= -1; + for I := First to Last do + if CompareString(S, FList[I]^.Key) and (FList[I]^.Data = Data) then + begin + Result:= I; + Exit; + end; + end; +end; + +procedure TStringHashList.FindHashBoundaries(HashValue: Cardinal; StartFrom: Integer; out First, Last: Integer); +begin + First:= StartFrom -1; + //Find first matching hash index + while (First >= 0) and (CompareValue(HashValue, FList[First]^.HashValue) = 0) do + dec(First); + if (First < 0) or ((CompareValue(HashValue, FList[First]^.HashValue) <> 0)) then + inc(First); + //Find the last matching hash index + Last:= StartFrom +1; + while (Last <= (FCount - 1)) and (CompareValue(HashValue, FList[Last]^.HashValue) = 0) do + inc(Last); + if (Last > (FCount - 1)) or (CompareValue(HashValue, FList[Last]^.HashValue) <> 0) then + dec(Last); +end; + +function TStringHashList.HashOf(const Key: string): Cardinal; +var + P: PChar; + I, Len: Integer; +begin + P:= PChar(Key); + Len:= Length(Key); + Result := Len; + {$PUSH} + {$R-}{$Q-} // no range, no overflow checks + // use the last 30 characters to compute the hash + case fCaseSensitive of + True: + for I := Len - 1 downto 0 do + inc(Result, cardinal(ord(P[I])) shl I); + False: + for I := Len - 1 downto 0 do + inc(Result, cardinal(ord(UpperCaseChars[P[I]])) shl I); + end; + {$POP} +end; + +procedure TStringHashList.Insert(Index: Integer; Item: PStringHashItem); +begin + ReallocMem(FList, (fCount +1) * SizeOf(PStringHashItem)); + if Index > fCount then Index:= fCount; + if Index < 0 then Index:= 0; + if Index < FCount then + System.Move(FList[Index], FList[Index + 1], + (FCount - Index) * SizeOf(PStringHashItem)); + FList[Index] := Item; + Inc(FCount); +end; + +constructor TStringHashList.Create(CaseSensitivity: boolean); +begin + fCaseSensitive:=CaseSensitivity; + inherited Create; +end; + +function TStringHashList.Remove(const S: String): Integer; +begin + Result:= Find(S); + if Result > -1 then + begin + Dispose(fList[Result]); + Delete(Result); + end; +end; + +function TStringHashList.Remove(const S: String; Data: Pointer): Integer; +begin + Result:= Find(S, Data); + if Result > -1 then + begin + Dispose(fList[Result]); + Delete(Result); + end; +end; + +procedure TStringHashList.SetCaseSensitive(const Value: Boolean); +begin + if fCaseSensitive <> Value then + begin + if Count > 0 then + begin + raise EListError.Create(strListMustBeEmpty); + exit; + end; + fCaseSensitive := Value; + end; +end; + +//------------------------------------------------------------------------------ +procedure InternalInit; +var c: char; +begin + for c:=Low(char) to High(char) do begin + UpperCaseChars[c]:=upcase(c); + end; +end; + +initialization + InternalInit; + +end. diff --git a/components/fpspreadsheet/source/common/xlsbiff5.pas b/components/fpspreadsheet/source/common/xlsbiff5.pas index f8c4846e8..d3ef8f75c 100644 --- a/components/fpspreadsheet/source/common/xlsbiff5.pas +++ b/components/fpspreadsheet/source/common/xlsbiff5.pas @@ -653,7 +653,7 @@ end; } procedure TsSpreadBIFF5Reader.ReadRPNSheetIndex(AStream: TStream; out ADocumentURL: String; out ASheet1, ASheet2: Integer); var - idx: Int16; + idx: SmallInt; s: String; sheetList: TsBIFFExternSheetList; extsheet: TsBIFFExternSheet; @@ -674,7 +674,7 @@ begin AStream.Position := AStream.Position + 8; // zero-based index to first referenced sheet in workbook (-1 = deleted sheet) - ASheet1 := Int16(WordLEToN(AStream.ReadWord)); + ASheet1 := SmallInt(WordLEToN(AStream.ReadWord)); // zero-based index to last referenced sheet in workbook (-1 = deleted sheet) ASheet2 := WordLEToN(AStream.ReadWord); @@ -1472,7 +1472,7 @@ procedure TsSpreadBIFF5Writer.WriteDefinedName(AStream: TStream; if AKind = ebkInternal then begin { INTERNAL REFERENCE: 1-based sheet index, negative to indicate 3D reference } - idx := word(-int16(AIndexToRef + 1)); + idx := word(-SmallInt(AIndexToRef + 1)); MemStream.WriteWord(WordToLE(idx)); { 8 bytes not used } diff --git a/components/fpspreadsheet/source/common/xlsbiff8.pas b/components/fpspreadsheet/source/common/xlsbiff8.pas index ca7ab742c..cd1fb1d32 100644 --- a/components/fpspreadsheet/source/common/xlsbiff8.pas +++ b/components/fpspreadsheet/source/common/xlsbiff8.pas @@ -48,19 +48,18 @@ unit xlsbiff8; {$mode objfpc}{$H+} {$endif} +{$I fps.inc} + // The new OLE code is much better, so always use it {$define USE_NEW_OLE} interface uses - Classes, SysUtils, fpcanvas, DateUtils, contnrs, lazutf8, stringhashlist, + Classes, SysUtils, fpcanvas, DateUtils, contnrs, lazutf8, + {$IFDEF FPS_NEED_STRINGHASHLIST}fpsstringhashlist,{$ELSE}stringhashlist,{$ENDIF} fpstypes, xlscommon, - {$ifdef USE_NEW_OLE} - fpolebasic, - {$else} - fpolestorage, - {$endif} + {$IFDEF USE_NEW_OLE}fpolebasic,{$ELSE}fpolestorage,{$ENDIF} fpsutils; type @@ -1592,7 +1591,7 @@ end; procedure TsSpreadBIFF8Reader.ReadRPNSheetIndex(AStream: TStream; out ADocumentURL: String; out ASheet1, ASheet2: Integer); var - refIndex: Int16; + refIndex: SmallInt; ref: TsBiff8ExternSheet; book: TsBiff8ExternBook; begin diff --git a/components/fpspreadsheet/source/common/xlscommon.pas b/components/fpspreadsheet/source/common/xlscommon.pas index 6680a5b8f..2b00da924 100644 --- a/components/fpspreadsheet/source/common/xlscommon.pas +++ b/components/fpspreadsheet/source/common/xlscommon.pas @@ -7,6 +7,8 @@ OpenOffice Microsoft Excel File Format document } {$mode objfpc}{$H+} {$endif} +{$I fps.inc} + interface uses diff --git a/components/fpspreadsheet/source/design/fpsvisualreg.pas b/components/fpspreadsheet/source/design/fpsvisualreg.pas index a77065a3d..de8e96156 100644 --- a/components/fpspreadsheet/source/design/fpsvisualreg.pas +++ b/components/fpspreadsheet/source/design/fpsvisualreg.pas @@ -14,7 +14,7 @@ procedure Register; implementation uses - LResources, ActnList, + LResources, ActnList, PropEdits, fpspreadsheetctrls, fpspreadsheetgrid, fpspreadsheetchart, fpsactions; {@@ ---------------------------------------------------------------------------- @@ -51,7 +51,11 @@ begin TsCellCommentAction, TsCellHyperlinkAction, TsMergeAction ], nil); - + + RegisterPropertyEditor(TypeInfo(TFileName), + TsWorkbookSource, 'FileName', TFileNamePropertyEditor + ); + end; initialization diff --git a/components/fpspreadsheet/source/fps.inc b/components/fpspreadsheet/source/fps.inc index 10e42e1a0..c1721b47b 100644 --- a/components/fpspreadsheet/source/fps.inc +++ b/components/fpspreadsheet/source/fps.inc @@ -42,8 +42,10 @@ This is not yet available in fpc 2.6.0 } {.$DEFINE FPS_PTRINT} -{ RawByteString only has been available since fpc 3.0 - Activate this define to replace RawByteStringt by an ansistring } -{.$DEFINE NO_RAWBYTESTRING} +{ Unit stringhashlist belongs to LCL before Lazarus 1.8. To avoid a requirement + of LCL in laz_fpspreadsheet.lpk a copy in the fps directory is provided. + This copy is used when the define FPS_NEED_STRINGHASHLIST is active. + The define is not needed for Lazarus versions >= 1.8 } +{.$DEFINE FPS_NEED_STRINGHASHLIST}