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

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

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.

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 }

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}
+  {$IFDEF USE_NEW_OLE}fpolebasic,{$ELSE}fpolestorage,{$ENDIF}
-  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

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

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

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
+{ Unit stringhashlist belongs to LCL before Lazarus 1.8. To avoid a requirement
-  Activate this define to replace RawByteStringt by an ansistring }
+  of LCL in laz_fpspreadsheet.lpk a copy in the fps directory is provided.
-{.$DEFINE NO_RAWBYTESTRING}
+  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}