pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

fpspreadsheet: Make sure that biff writers do not write colors exceeding the maximum palette count. Add casse to error tests (passed, but the biff2 font color test fails now...)

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3470 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2014-08-11 15:53:06 +00:00
parent f92f0364d9
commit eaabdf67c1
7 changed files with 211 additions and 51 deletions
Download Patch File Download Diff File Expand all files Collapse all files

167
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -28,6 +28,7 @@ type
TsSpreadsheetFormatLimitations = record
MaxRowCount: Cardinal;
MaxColCount: Cardinal;
MaxPaletteSize: Cardinal;
end;
const
@ -859,7 +860,8 @@ type
{ Color handling }
function AddColorToPalette(AColorValue: TsColorValue): TsColor;
function FindClosestColor(AColorValue: TsColorValue): TsColor;
function FindClosestColor(AColorValue: TsColorValue;
AMaxPaletteCount: Integer): TsColor;
function FPSColorToHexString(AColor: TsColor; ARGBColor: TFPColor): String;
function GetColorName(AColorIndex: TsColor): string;
function GetPaletteColor(AColorIndex: TsColor): TsColorValue;
@ -869,6 +871,7 @@ type
procedure UseDefaultPalette;
procedure UsePalette(APalette: PsPalette; APaletteCount: Word;
ABigEndian: Boolean = false);
function UsesColor(AColorIndex: TsColor): Boolean;
{ Error messages }
procedure AddErrorMsg(const AMsg: String); overload;
@ -987,6 +990,8 @@ type
FWorkbook: TsWorkbook;
{@@ Instance of the worksheet which is currently being read. }
FWorksheet: TsWorksheet;
{@@ Limitations for the specific data file format }
FLimitations: TsSpreadsheetFormatLimitations;
protected
{@@ List of number formats found in the file }
FNumFormatList: TsCustomNumFormatList;
@ -994,6 +999,7 @@ type
public
constructor Create(AWorkbook: TsWorkbook); virtual; // to allow descendents to override it
destructor Destroy; override;
function Limitations: TsSpreadsheetFormatLimitations;
{@@ Instance of the workbook which is currently being read/written. }
property Workbook: TsWorkbook read FWorkbook;
{@@ List of number formats found in the workbook. }
@ -1048,13 +1054,13 @@ type
for each individual file format. }
TsCustomSpreadWriter = class(TsCustomSpreadReaderWriter)
protected
{@@ Limitations for the specific data file format }
FLimitations: TsSpreadsheetFormatLimitations;
{ Helper routines }
procedure AddDefaultFormats(); virtual;
procedure CheckLimitations;
function ExpandFormula(AFormula: TsFormula): TsExpandedFormula;
function FindFormattingInList(AFormat: PCell): Integer;
procedure FixCellColors(ACell: PCell);
function FixColor(AColor: TsColor): TsColor; virtual;
procedure FixFormat(ACell: PCell); virtual;
procedure GetSheetDimensions(AWorksheet: TsWorksheet;
out AFirstRow, ALastRow, AFirstCol, ALastCol: Cardinal); virtual;
@ -1089,7 +1095,6 @@ type
public
constructor Create(AWorkbook: TsWorkbook); override;
function Limitations: TsSpreadsheetFormatLimitations;
{ General writing methods }
procedure IterateThroughCells(AStream: TStream; ACells: TAVLTree; ACallback: TCellsCallback);
procedure WriteToFile(const AFileName: string; const AOverwriteExisting: Boolean = False); virtual;
@ -1169,8 +1174,13 @@ resourcestring
lpUnsupportedWriteFormat = 'Tried to write a spreadsheet using an unsupported format';
lpNoValidSpreadsheetFile = '"%s" is not a valid spreadsheet file';
lpUnknownSpreadsheetFormat = 'unknown format';
lpMaxRowsExceeded = 'This workbook contains %d rows, but the selected file format does not support more than %d rows.';
lpMaxColsExceeded = 'This workbook contains %d columns, but the selected file format does not support more than %d columns.';
lpMaxRowsExceeded = 'This workbook contains %d rows, but the selected ' +
'file format does not support more than %d rows.';
lpMaxColsExceeded = 'This workbook contains %d columns, but the selected ' +
'file format does not support more than %d columns.';
lpTooManyPaletteColors = 'This workbook contains more colors (%d) than are ' +
'supported by the file format (%d). The redundant colors are replaced by '+
'the best-matching palette colors.';
lpInvalidFontIndex = 'Invalid font index';
lpInvalidNumberFormat = 'Trying to use an incompatible number format.';
lpInvalidDateTimeFormat = 'Trying to use an incompatible date/time format.';
@ -5315,7 +5325,7 @@ begin
SameText(AFontName, fnt.FontName) and
(abs(ASize - fnt.Size) < 0.001) and // careful when comparing floating point numbers
(AStyle = fnt.Style) and
(AColor = fnt.Color)
(AColor = fnt.Color) // Take care of limited palette size!
then
exit;
end;
@ -5497,26 +5507,32 @@ end;
given color. "Close" means here smallest length of the rgb-difference vector.
@param AColorValue Rgb color value to be considered
@param AMaxPaletteCount Number of palette entries considered. Example:
BIFF5/BIFF8 can write only 64 colors, i.e
AMaxPaletteCount = 64
@return Palette index of the color closest to AColorValue
}
function TsWorkbook.FindClosestColor(AColorValue: TsColorValue): TsColor;
function TsWorkbook.FindClosestColor(AColorValue: TsColorValue;
AMaxPaletteCount: Integer): TsColor;
type
TRGBA = record r,g,b, a: Byte end;
var
rgb: TRGBA;
rgb0: TRGBA absolute AColorValue;
dist: Double;
mindist: Double;
minDist: Double;
i: Integer;
n: Integer;
begin
Result := scNotDefined;
mindist := 1E108;
for i:=0 to Length(FPalette)-1 do begin
minDist := 1E108;
n := Min(Length(FPalette), AMaxPaletteCount);
for i:=0 to n-1 do begin
rgb := TRGBA(GetPaletteColor(i));
dist := sqr(rgb.r - rgb0.r) + sqr(rgb.g - rgb0.g) + sqr(rgb.b - rgb0.b);
if dist < mindist then begin
if dist < minDist then begin
Result := i;
mindist := dist;
minDist := dist;
end;
end;
end;
@ -5685,6 +5701,45 @@ begin
{$ENDIF}
end;
{@@
Checks whether a given color is used somewhere within the entire workbook
@param AColorIndex Palette index of the color
@result True if the color is used by at least one cell, false if not.
}
function TsWorkbook.UsesColor(AColorIndex: TsColor): Boolean;
var
Node: TAVLTreeNode;
sheet: TsWorksheet;
cell: PCell;
i: Integer;
fnt: TsFont;
b: TsCellBorder;
begin
Result := true;
for i:=0 to GetWorksheetCount-1 do begin
sheet := GetWorksheetByIndex(i);
Node := sheet.Cells.FindLowest;
while Assigned(Node) do
begin
cell := PCell(Node.Data);
if (uffBackgroundColor in cell^.UsedFormattingFields) then
if cell^.BackgroundColor = AColorIndex then exit;
if (uffBorder in cell^.UsedFormattingFields) then
for b in TsCellBorders do
if cell^.BorderStyles[b].Color = AColorIndex then
exit;
if (uffFont in cell^.UsedFormattingFields) then
begin
fnt := GetFont(cell^.FontIndex);
if fnt.Color = AColorIndex then
exit;
end;
Node := sheet.Cells.FindSuccessor(Node);
end;
end;
Result := false;
end;
{ TsCustomNumFormatList }
@ -6073,6 +6128,11 @@ constructor TsCustomSpreadReaderWriter.Create(AWorkbook: TsWorkbook);
begin
inherited Create;
FWorkbook := AWorkbook;
{ A good starting point valid for many formats ... }
FLimitations.MaxColCount := 256;
FLimitations.MaxRowCount := 65536;
FLimitations.MaxPaletteSize := $FFFFFFFF;
// Number formats
CreateNumFormatList;
end;
@ -6097,6 +6157,14 @@ begin
// nothing to do here
end;
{@@
Returns a record containing limitations of the specific file format of the
writer.
}
function TsCustomSpreadReaderWriter.Limitations: TsSpreadsheetFormatLimitations;
begin
Result := FLimitations;
end;
{ TsCustomSpreadReader }
@ -6209,9 +6277,6 @@ end;
constructor TsCustomSpreadWriter.Create(AWorkbook: TsWorkbook);
begin
inherited Create(AWorkbook);
{ A good starting point valid for many formats... }
FLimitations.MaxColCount := 256;
FLimitations.MaxRowCount := 65536;
end;
{@@
@ -6226,6 +6291,7 @@ var
i, n: Integer;
b: TsCellBorder;
equ: Boolean;
clr: TsColor;
begin
Result := -1;
@ -6251,7 +6317,7 @@ begin
equ := false;
Break;
end;
if FFormattingStyles[i].BorderStyles[b].Color <> AFormat^.BorderStyles[b].Color
if FFormattingStyles[i].BorderStyles[b].Color <> FixColor(AFormat^.BorderStyles[b].Color)
then begin
equ := false;
Break;
@ -6261,7 +6327,7 @@ begin
end;
if uffBackgroundColor in AFormat^.UsedFormattingFields then
if (FFormattingStyles[i].BackgroundColor <> AFormat^.BackgroundColor) then Continue;
if (FFormattingStyles[i].BackgroundColor <> FixColor(AFormat^.BackgroundColor)) then Continue;
if uffNumberFormat in AFormat^.UsedFormattingFields then begin
if (FFormattingStyles[i].NumberFormat <> AFormat^.NumberFormat) then Continue;
@ -6276,6 +6342,41 @@ begin
end;
end;
{@@
Makes sure that all colors used in a given cell belong to the workbook's
color palette.
}
procedure TsCustomSpreadWriter.FixCellColors(ACell: PCell);
var
b: TsCellBorder;
begin
if ACell = nil then
exit;
ACell^.BackgroundColor := FixColor(ACell^.BackgroundColor);
for b in TsCellBorders do
ACell^.BorderStyles[b].Color := FixColor(ACell^.BorderStyles[b].Color);
// Font color is not corrected here because this would affect other writers.
// Font color is handled immediately before writing.
end;
{@@
If a color index is greater then the maximum palette color count this
color is replaced by the closest palette color.
The present implementation does not change the color. Must be overridden by
writers of formats with limited palette sizes.
@param AColor Color palette index to be checked
@return Closest color to AColor. If AColor belongs to the palette it must
be returned unchanged. }
function TsCustomSpreadWriter.FixColor(AColor: TsColor): TsColor;
begin
Result := AColor;
end;
{@@
If formatting features of a cell are not supported by the destination file
format of the writer, here is the place to apply replacements.
@ -6291,15 +6392,6 @@ begin
// to be overridden
end;
{@@
Returns a record containing limitations of the specific file format of the
writer.
}
function TsCustomSpreadWriter.Limitations: TsSpreadsheetFormatLimitations;
begin
Result := FLimitations;
end;
{@@
Determines the size of the worksheet to be written. VirtualMode is respected.
Is called when the writer needs the size for output. Column and row count
@ -6354,14 +6446,29 @@ end;
procedure TsCustomSpreadWriter.CheckLimitations;
var
lastCol, lastRow: Cardinal;
i, n: Integer;
fnt: TsFont;
begin
Workbook.GetLastRowColIndex(lastRow, lastCol);
// Check row count
if lastRow >= FLimitations.MaxRowCount then
Workbook.AddErrorMsg(lpMaxRowsExceeded, [lastRow+1, FLimitations.MaxRowCount]);
// Check column count
if lastCol >= FLimitations.MaxColCount then
Workbook.AddErrorMsg(lpMaxColsExceeded, [lastCol+1, FLimitations.MaxColCount]);
end;
// Check color count.
n := Workbook.GetPaletteSize;
if n > FLimitations.MaxPaletteSize then
for i:= FLimitations.MaxPaletteSize to n-1 do
if Workbook.UsesColor(i) then
begin
Workbook.AddErrorMsg(lpTooManyPaletteColors, [n, FLimitations.MaxPaletteSize]);
break;
end;
end;
{@@
Callback function for collecting all formatting styles found in the worksheet.
@ -6385,6 +6492,10 @@ begin
SetLength(FFormattingStyles, Len+1);
FFormattingStyles[Len] := ACell^;
// Make sure that all colors of the formatting style cell are used in the workbook's
// palette.
FixCellColors(@FFormattingStyles[Len]);
// We store the index of the XF record that will be assigned to this style in
// the "row" of the style. Will be needed when writing the XF record.
FFormattingStyles[Len].Row := NextXFIndex;

33
components/fpspreadsheet/tests/errortests.pas
View File

@ -35,7 +35,7 @@ type
implementation
uses
StrUtils;
StrUtils, xlsbiff5;
const
ERROR_SHEET = 'ErrorTest'; //worksheet name
@ -65,6 +65,7 @@ var
s: String;
TempFile: String;
ErrList: TStringList;
newColor: TsColor;
begin
formula.FormulaStr := '=A1';
formula.DoubleValue := 0.0;
@ -77,7 +78,7 @@ begin
MyWorkSheet:= MyWorkBook.AddWorksheet(ERROR_SHEET);
row1 := MAX_ROW_COUNT[TTestFormat(AFormat)] - 5;
row2 := MAX_ROW_COUNT[TTestFormat(AFormat)] + 5;
for row :=row1 to row2 do begin
for row := row1 to row2 do begin
MyWorksheet.WriteBlank(row, 0);
MyWorksheet.WriteNumber(row, 1, 1.0);
MyWorksheet.WriteUTF8Text(row, 2, 'A');
@ -117,7 +118,31 @@ begin
DeleteFile(TempFile);
end;
// Test 3: Too long cell label
// Test 3: Too many colors
if (TTestFormat(AFormat) in [sfExcel2, sfExcel5, sfExcel8]) then begin
MyWorkbook := TsWorkbook.Create;
try
// Prepare a full palette
MyWorkbook.UsePalette(@PALETTE_BIFF5[0], Length(PALETTE_BIFF5));
// Add 1 more color - this is one too many for BIFF5 and 8, and a lot
// too many for BIFF2 !
newColor := MyWorkbook.AddColorToPalette($FF7878);
MyWorkSheet:= MyWorkBook.AddWorksheet(ERROR_SHEET);
MyWorksheet.WriteUTF8Text(0, 0, s);
MyWorksheet.WriteFontColor(0, 0, newColor);
TempFile:=NewTempFile;
MyWorkBook.WriteToFile(TempFile, AFormat, true);
ErrList.Text := MyWorkbook.ErrorMsg;
CheckEquals(1, ErrList.Count, 'Error count mismatch in test 3');
finally
MyWorkbook.Free;
DeleteFile(TempFile);
end;
end;
// Test 4: Too long cell label
if MAX_CELL_LEN[TTestFormat(AFormat)] <> Cardinal(-1) then begin
s := DupeString('A', MAX_CELL_LEN[TTestFormat(AFormat)] + 10);
MyWorkbook := TsWorkbook.Create;
@ -127,7 +152,7 @@ begin
TempFile:=NewTempFile;
MyWorkBook.WriteToFile(TempFile, AFormat, true);
ErrList.Text := MyWorkbook.ErrorMsg;
CheckEquals(1, ErrList.Count, 'Error count mismatch in test 3');
CheckEquals(1, ErrList.Count, 'Error count mismatch in test 4');
finally
MyWorkbook.Free;
DeleteFile(TempFile);

1
components/fpspreadsheet/tests/spreadtestgui.lpi
View File

@ -82,6 +82,7 @@
<Unit8>
<Filename Value="colortests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="colortests"/>
</Unit8>
<Unit9>
<Filename Value="fonttests.pas"/>

16
components/fpspreadsheet/xlsbiff2.pas
View File

@ -77,6 +77,7 @@ type
procedure ReadWindow2(AStream: TStream); override;
procedure ReadXF(AStream: TStream);
public
constructor Create(AWorkbook: TsWorkbook); override;
{ General reading methods }
procedure ReadFromStream(AStream: TStream; AData: TsWorkbook); override;
end;
@ -124,6 +125,7 @@ type
procedure WriteWindow1(AStream: TStream); override;
procedure WriteWindow2(AStream: TStream; ASheet: TsWorksheet);
public
constructor Create(AWorkbook: TsWorkbook); override;
{ General writing methods }
procedure WriteToStream(AStream: TStream); override;
end;
@ -320,6 +322,12 @@ end;
{ TsSpreadBIFF2Reader }
constructor TsSpreadBIFF2Reader.Create(AWorkbook: TsWorkbook);
begin
inherited Create(AWorkbook);
FLimitations.MaxPaletteSize := 16;
end;
procedure TsSpreadBIFF2Reader.ApplyCellFormatting(ACell: PCell; XFIndex: Word);
var
xfData: TXFListData;
@ -925,6 +933,12 @@ end;
{ TsSpreadBIFF2Writer }
constructor TsSpreadBIFF2Writer.Create(AWorkbook: TsWorkbook);
begin
inherited Create(AWorkbook);
FLimitations.MaxPaletteSize := 16;
end;
{ Creates the correct version of the number format list.
It is for BIFF2 and BIFF3 file formats. }
procedure TsSpreadBIFF2Writer.CreateNumFormatList;
@ -1443,7 +1457,7 @@ begin
AStream.WriteWord(WordToLE(2));
{ Font color index, only first 8 palette entries allowed! }
AStream.WriteWord(WordToLE(word(font.Color)));
AStream.WriteWord(WordToLE(word(FixColor(font.Color))));
end;
procedure TsSpreadBiff2Writer.WriteFonts(AStream: TStream);

8
components/fpspreadsheet/xlsbiff5.pas
View File

@ -134,7 +134,6 @@ type
procedure WriteXFFieldsForFormattingStyles(AStream: TStream);
procedure WriteXFRecords(AStream: TStream);
public
constructor Create(AWorkbook: TsWorkbook); override;
{ General writing methods }
procedure WriteToFile(const AFileName: string;
const AOverwriteExisting: Boolean = False); override;
@ -329,11 +328,6 @@ type
{ TsSpreadBIFF5Writer }
constructor TsSpreadBIFF5Writer.Create(AWorkbook: TsWorkbook);
begin
inherited Create(AWorkbook);
end;
{*******************************************************************
* TsSpreadBIFF5Writer.WriteToFile ()
*
@ -634,7 +628,7 @@ begin
AStream.WriteWord(WordToLE(optn));
{ Colour index }
AStream.WriteWord(WordToLE(ord(AFont.Color)));
AStream.WriteWord(WordToLE(ord(FixColor(AFont.Color))));
{ Font weight }
if fssBold in AFont.Style then

2
components/fpspreadsheet/xlsbiff8.pas
View File

@ -665,7 +665,7 @@ begin
AStream.WriteWord(WordToLE(optn));
{ Colour index }
AStream.WriteWord(WordToLE(ord(AFont.Color)));
AStream.WriteWord(WordToLE(ord(FixColor(AFont.Color))));
{ Font weight }
if fssBold in AFont.Style then

33
components/fpspreadsheet/xlscommon.pas
View File

@ -457,6 +457,7 @@ type
procedure AddDefaultFormats; override;
procedure CreateNumFormatList; override;
function FindXFIndex(ACell: PCell): Integer;
function FixColor(AColor: TsColor): TsColor; override;
procedure GetLastRowCallback(ACell: PCell; AStream: TStream);
function GetLastRowIndex(AWorksheet: TsWorksheet): Integer;
procedure GetLastColCallback(ACell: PCell; AStream: TStream);
@ -685,11 +686,6 @@ const
INT_EXCEL_TOKEN_TATTR {fekOpSum}
);
resourcestring
rsTooManyPaletteColors = 'This workbook contains more colors (%d) than are ' +
'supported by the file format (%d). The redundant colors are replaced by '+
'the best-matching palette colors.';
type
TBIFF58BlankRecord = packed record
RecordID: Word;
@ -841,6 +837,10 @@ begin
FXFList := TFPList.Create;
// Initial base date in case it won't be read from file
FDateMode := dm1900;
// Limitations of BIFF5 and BIFF8 file format
FLimitations.MaxColCount := 256;
FLimitations.MaxRowCount := 65536;
FLimitations.MaxPaletteSize := 64;
end;
destructor TsSpreadBIFFReader.Destroy;
@ -1126,7 +1126,7 @@ begin
//BIFF2 BIFF3 BIFF4 BIFF5 BIFF8
//0022H 0022H 0022H 0022H 0022H
//This record specifies the base date for displaying date values. All dates are stored as count of days past this base date. In
//BIFF2-BIFF4 this record is part of the Calculation Settings Block (➜4.3). In BIFF5-BIFF8 it is stored in the Workbook
//BIFF2-BIFF4 this record is part of the Calculation Settings Block (➜4.3). In BIFF5-BIFF8 it is stored in the Workbookk
//Globals Substream.
//Record DATEMODE, BIFF2-BIFF8:
//Offset Size Contents
@ -1739,9 +1739,15 @@ end;
constructor TsSpreadBIFFWriter.Create(AWorkbook: TsWorkbook);
begin
inherited Create(AWorkbook);
// Initial base date in case it won't be set otherwise.
// Use 1900 to get a bit more range between 1900..1904.
FDateMode := dm1900;
// Limitations of BIFF5 and BIFF8 file formats
FLimitations.MaxColCount := 256;
FLimitations.MaxRowCount := 65536;
FLimitations.MaxPaletteSize := 64;
end;
destructor TsSpreadBIFFWriter.Destroy;
@ -1804,6 +1810,18 @@ begin
Result := FFormattingStyles[idx].Row;
end;
function TsSpreadBIFFWriter.FixColor(AColor: TsColor): TsColor;
var
rgb: TsColorValue;
begin
if AColor >= Limitations.MaxPaletteSize then begin
// if AColor >= 64 then begin
rgb := Workbook.GetPaletteColor(AColor);
Result := Workbook.FindClosestColor(rgb, FLimitations.MaxPaletteSize);
end else
Result := AColor;
end;
function TsSpreadBIFFWriter.FormulaElementKindToExcelTokenID(
AElementKind: TFEKind; out ASecondaryID: Word): Word;
begin
@ -2095,9 +2113,6 @@ begin
{ Take the colors from the palette of the Worksheet }
n := Workbook.GetPaletteSize;
if n > 64 then
Workbook.AddErrorMsg(rsTooManyPaletteColors, [n, 64]);
{ Skip the first 8 entries - they are hard-coded into Excel }
for i:=8 to 63 do
begin