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

+ Add date/time/datetime read/write support for BIFF8 xls format. No plans for earlier formats though the code could be adapted

Browse Source 
+ XLS BIFF8: added DATE and TIME worksheet functions to RPN formula
* Allow writing formulas,numbers etc using cardinals increasing row/column limits for formats that support it.
* Add checks for text cell size limits when writing xls, xml. If exceeded, cell text will be truncated (better than corrupting the xls file - e.g. try to open it with Excel 2002 - as happens now with xls format)
* Formats that use fpspreadsheet zip have extra checks to prevent crashes for invalid zip dates
+ Use FPC built-in zip format when using FPC 2.7.1+ as it has fixes/improvements (e.g. zip64 support)
+ Added FPCUnit test suite to test reading and reading writing files. For now uses BIFF8 xls; contributions for other formats and more tests welcome. See the tests subdirectory.
+ Add link to msodumper tool for reference/debugging/troubleshooting .xls output

Fixes Mantis bugtracker issue #25388



git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2857 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
bigchimp
2013-12-07 13:42:22 +00:00
parent 08230c6ccb
commit abd8d0bea8
30 changed files with 4952 additions and 195 deletions
Download Patch File Download Diff File Expand all files Collapse all files

15
components/fpspreadsheet/fpsopendocument.pas
View File

@ -28,7 +28,11 @@ interface
uses
Classes, SysUtils,
fpszipper, {NOTE: fpszipper is the latest zipper.pp Change to standard zipper when FPC 2.8 is released}
{$IFDEF FPC_FULLVERSION >= 20701}
zipper,
{$ELSE}
fpszipper,
{$ENDIF}
fpspreadsheet,
xmlread, DOM, AVL_Tree,
math,
@ -81,8 +85,9 @@ type
const AOverwriteExisting: Boolean = False); override;
procedure WriteToStream(AStream: TStream; AData: TsWorkbook); override;
{ Record writing methods }
procedure WriteFormula(AStream: TStream; const ARow, ACol: Word; const AFormula: TsFormula; ACell: PCell); override;
procedure WriteLabel(AStream: TStream; const ARow, ACol: Word; const AValue: string; ACell: PCell); override;
//todo: add WriteDate
procedure WriteFormula(AStream: TStream; const ARow, ACol: Cardinal; const AFormula: TsFormula; ACell: PCell); override;
procedure WriteLabel(AStream: TStream; const ARow, ACol: Cardinal; const AValue: string; ACell: PCell); override;
procedure WriteNumber(AStream: TStream; const ARow, ACol: Cardinal; const AValue: double; ACell: PCell); override;
end;
@ -639,7 +644,7 @@ begin
end;
procedure TsSpreadOpenDocWriter.WriteFormula(AStream: TStream; const ARow,
ACol: Word; const AFormula: TsFormula; ACell: PCell);
ACol: Cardinal; const AFormula: TsFormula; ACell: PCell);
begin
{ // The row should already be the correct one
FContent := FContent +
@ -658,7 +663,7 @@ end;
See bug with patch 19422
}
procedure TsSpreadOpenDocWriter.WriteLabel(AStream: TStream; const ARow,
ACol: Word; const AValue: string; ACell: PCell);
ACol: Cardinal; const AValue: string; ACell: PCell);
var
lStyle: string = '';
lIndex: Integer;

127
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -63,8 +63,8 @@ type
fekCell, fekCellRange, fekNum,
{ Basic operations }
fekAdd, fekSub, fekDiv, fekMul,
{ Build-in Functions}
fekABS, fekROUND,
{ Built-in/Worksheet Functions}
fekABS, fekDATE, fekROUND, fekTIME,
{ Other operations }
fekOpSUM
);
@ -92,12 +92,18 @@ type
{@@ List of possible formatting fields }
TsUsedFormattingField = (uffTextRotation, uffBold, uffBorder, uffBackgroundColor,
uffWordWrap);
uffNumberFormat, uffWordWrap);
{@@ Describes which formatting fields are active }
TsUsedFormattingFields = set of TsUsedFormattingField;
{@@ Number/cell formatting. Only uses a subset of the default formats,
enough to be able to read/write date values.
}
TsNumberFormat = (nfGeneral, nfShortDate, nfShortDateTime);
{@@ Text rotation formatting. The text is rotated relative to the standard
orientation, which is from left to right horizontal: --->
ABC
@ -125,9 +131,9 @@ type
TsCellBorders = set of TsCellBorder;
{@@ Colors in FPSpreadsheet as given by a pallete to be compatible with Excel }
{@@ Colors in FPSpreadsheet as given by a palette to be compatible with Excel }
TsColor = (
TsColor = ( // R G B color value:
scBlack , // 000000H
scWhite, // FFFFFFH
scRed, // FF0000H
@ -147,11 +153,11 @@ type
//
scGrey10pct,// E6E6E6H
scGrey20pct,// CCCCCCH
scOrange, // ffa500
scDarkBrown,// a0522d
scBrown, // cd853f
scBeige, // f5f5dc
scWheat, // f5deb3
scOrange, // ffa500H
scDarkBrown,// a0522dH
scBrown, // cd853fH
scBeige, // f5f5dcH
scWheat, // f5deb3H
//
scRGBCOLOR // Defined via TFPColor
);
@ -180,6 +186,7 @@ type
TextRotation: TsTextRotation;
Border: TsCellBorders;
BackgroundColor: TsColor;
NumberFormat: TsNumberFormat;
RGBBackgroundColor: TFPColor; // only valid if BackgroundColor=scRGBCOLOR
end;
@ -238,6 +245,7 @@ type
procedure WriteNumber(ARow, ACol: Cardinal; ANumber: double);
procedure WriteDateTime(ARow, ACol: Cardinal; AValue: TDateTime);
procedure WriteFormula(ARow, ACol: Cardinal; AFormula: TsFormula);
procedure WriteNumberFormat(ARow, ACol: Cardinal; ANumberFormat: TsNumberFormat);
procedure WriteRPNFormula(ARow, ACol: Cardinal; AFormula: TsRPNFormula);
procedure WriteTextRotation(ARow, ACol: Cardinal; ARotation: TsTextRotation);
procedure WriteUsedFormatting(ARow, ACol: Cardinal; AUsedFormatting: TsUsedFormattingFields);
@ -284,6 +292,7 @@ type
function AddWorksheet(AName: string): TsWorksheet;
function GetFirstWorksheet: TsWorksheet;
function GetWorksheetByIndex(AIndex: Cardinal): TsWorksheet;
function GetWorksheetByName(AName: String): TsWorksheet;
function GetWorksheetCount: Cardinal;
procedure RemoveAllWorksheets;
{@@ This property is only used for formats which don't support unicode
@ -346,9 +355,10 @@ type
procedure WriteToStream(AStream: TStream; AData: TsWorkbook); virtual;
procedure WriteToStrings(AStrings: TStrings; AData: TsWorkbook); virtual;
{ Record writing methods }
procedure WriteFormula(AStream: TStream; const ARow, ACol: Word; const AFormula: TsFormula; ACell: PCell); virtual;
procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Word; const AFormula: TsRPNFormula; ACell: PCell); virtual;
procedure WriteLabel(AStream: TStream; const ARow, ACol: Word; const AValue: string; ACell: PCell); virtual; abstract;
procedure WriteDateTime(AStream: TStream; const ARow, ACol: Cardinal; const AValue: TDateTime; ACell: PCell); virtual; abstract;
procedure WriteFormula(AStream: TStream; const ARow, ACol: Cardinal; const AFormula: TsFormula; ACell: PCell); virtual;
procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell); virtual;
procedure WriteLabel(AStream: TStream; const ARow, ACol: Cardinal; const AValue: string; ACell: PCell); virtual; abstract;
procedure WriteNumber(AStream: TStream; const ARow, ACol: Cardinal; const AValue: double; ACell: PCell); virtual; abstract;
end;
@ -485,7 +495,7 @@ begin
end;
{@@
Tryes to locate a Cell in the list of already
Tries to locate a Cell in the list of already
written Cells
@param ARow The row of the cell
@ -705,6 +715,7 @@ begin
case ACell^.ContentType of
//cctFormula
cctDateTime : Result := ACell^.DateTimeValue; //this is in FPC TDateTime format, not Excel
cctNumber : Result := ACell^.NumberValue;
cctUTF8String:
begin
@ -832,6 +843,21 @@ begin
ACell^.NumberValue := ANumber;
end;
{@@
Writes a date/time value to a determined cell
@param ARow The row of the cell
@param ACol The column of the cell
@param AValue The date/time/datetime to be written
Note: at least Excel xls does not recognize a separate datetime cell type:
a datetime is stored as a (floating point) Number, and the cell is formatted
as a date (either built-in or a custom format).
This procedure automatically sets the cell format to short date/time. You may
change this format to another date/time format, but changing it to another
format (e.g. General) will likely lead to the cell being written out as a
plain number.
}
procedure TsWorksheet.WriteDateTime(ARow, ACol: Cardinal; AValue: TDateTime);
var
ACell: PCell;
@ -840,6 +866,15 @@ begin
ACell^.ContentType := cctDateTime;
ACell^.DateTimeValue := AValue;
// Date/time is actually a number field in Excel.
// To make sure it gets saved correctly, set a date format (instead of General).
// The user can choose another date format if he wants to
if not(uffNumberFormat in ACell^.UsedFormattingFields) or
((uffNumberFormat in ACell^.UsedFormattingFields) and (ACell^.NumberFormat = nfGeneral)) then
begin
Include(ACell^.UsedFormattingFields, uffNumberFormat);
ACell^.NumberFormat := nfShortDateTime;
end;
end;
{@@
@ -859,6 +894,26 @@ begin
ACell^.FormulaValue := AFormula;
end;
{@@
Adds number format to the formatting of a cell
@param ARow The row of the cell
@param ACol The column of the cell
@param TsNumberFormat What format to apply
@see TsNumberFormat
}
procedure TsWorksheet.WriteNumberFormat(ARow, ACol: Cardinal;
ANumberFormat: TsNumberFormat);
var
ACell: PCell;
begin
ACell := GetCell(ARow, ACol);
Include(ACell^.UsedFormattingFields, uffNumberFormat);
ACell^.NumberFormat := ANumberFormat;
end;
procedure TsWorksheet.WriteRPNFormula(ARow, ACol: Cardinal;
AFormula: TsRPNFormula);
var
@ -1226,7 +1281,8 @@ end;
{@@
Writes the document to file based on the extension. If this was an earlier sfExcel type file, it will be upgraded to sfExcel8,
}
procedure TsWorkbook.WriteToFile(const AFileName: string; const AOverwriteExisting: Boolean = False); overload;
procedure TsWorkbook.WriteToFile(const AFileName: String;
const AOverwriteExisting: Boolean);
var
SheetType: TsSpreadsheetFormat;
valid: Boolean;
@ -1280,6 +1336,7 @@ end;
nil otherwise.
@see TsWorkbook.GetWorksheetByIndex
@see TsWorkbook.GetWorksheetByName
@see TsWorksheet
}
function TsWorkbook.GetFirstWorksheet: TsWorksheet;
@ -1299,6 +1356,7 @@ end;
nil otherwise.
@see TsWorkbook.GetFirstWorksheet
@see TsWorkbook.GetWorksheetByName
@see TsWorksheet
}
function TsWorkbook.GetWorksheetByIndex(AIndex: Cardinal): TsWorksheet;
@ -1307,6 +1365,33 @@ begin
else Result := nil;
end;
{@@
Gets the worksheet with a given worksheet name
@param AName The name of the worksheet
@return A TsWorksheet instance if one is found with that name,
nil otherwise.
@see TsWorkbook.GetFirstWorksheet
@see TsWorkbook.GetWorksheetByIndex
@see TsWorksheet
}
function TsWorkbook.GetWorksheetByName(AName: String): TsWorksheet;
var
i:integer;
begin
Result := nil;
for i:=0 to FWorksheets.Count-1 do
begin
if TsWorkSheet(FWorkSheets.Items[i]).Name=AName then
begin
Result := TsWorksheet(FWorksheets.Items[i]);
exit;
end;
end;
end;
{@@
The number of worksheets on the workbook
@ -1411,6 +1496,9 @@ begin
if uffBackgroundColor in AFormat^.UsedFormattingFields then
if (FFormattingStyles[i].BackgroundColor <> AFormat^.BackgroundColor) then Continue;
if uffNumberFormat in AFormat^.UsedFormattingFields then
if (FFormattingStyles[i].NumberFormat <> AFormat^.NumberFormat) then Continue;
// If we arrived here it means that the styles match
Exit(i);
end;
@ -1537,6 +1625,7 @@ end;
procedure TsCustomSpreadWriter.WriteCellCallback(ACell: PCell; AStream: TStream);
begin
case ACell.ContentType of
cctDateTime: WriteDateTime(AStream, ACell^.Row, ACell^.Col, ACell^.DateTimeValue, ACell);
cctNumber: WriteNumber(AStream, ACell^.Row, ACell^.Col, ACell^.NumberValue, ACell);
cctUTF8String: WriteLabel(AStream, ACell^.Row, ACell^.Col, ACell^.UTF8StringValue, ACell);
cctFormula: WriteFormula(AStream, ACell^.Row, ACell^.Col, ACell^.FormulaValue, ACell);
@ -1628,15 +1717,15 @@ begin
end;
procedure TsCustomSpreadWriter.WriteFormula(AStream: TStream; const ARow,
ACol: Word; const AFormula: TsFormula; ACell: PCell);
ACol: Cardinal; const AFormula: TsFormula; ACell: PCell);
begin
// Silently dump the formula; child classes should implement their own support
end;
procedure TsCustomSpreadWriter.WriteRPNFormula(AStream: TStream; const ARow,
ACol: Word; const AFormula: TsRPNFormula; ACell: PCell);
ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell);
begin
// Silently dump the formula; child classes should implement their own support
end;
finalization

28
components/fpspreadsheet/fpszipper.pp
View File

@ -20,6 +20,18 @@
{$h+}
unit fpszipper;
{$IF FPC_FULLVERSION >= 20701}
// Empty shell; just load fpc zipper unit
Interface
Uses
zipper;
Implementation
End.
{$ELSE}
// FPC 2.6.x or lower: use this custom version
Interface
Uses
@ -522,14 +534,27 @@ end;
{$ENDIF FPC_BIG_ENDIAN}
Procedure DateTimeToZipDateTime(DT : TDateTime; out ZD,ZT : Word);
Var
Y,M,D,H,N,S,MS : Word;
begin
DecodeDate(DT,Y,M,D);
DecodeTime(DT,H,N,S,MS);
if Y<1980 then
begin
// Invalid date/time; set to earliest possible
Y:=0;
M:=1;
D:=1;
H:=0;
N:=0;
S:=0;
MS:=0;
end
else
begin
Y:=Y-1980;
end;
ZD:=d+(32*M)+(512*Y);
ZT:=(S div 2)+(32*N)+(2048*h);
end;
@ -2092,3 +2117,4 @@ begin
end;
End.
{$ENDIF}

4
components/fpspreadsheet/laz_fpspreadsheet.pas
View File

@ -8,7 +8,9 @@ interface
uses
fpolestorage, fpsallformats, fpsopendocument, fpspreadsheet, xlsbiff2,
xlsbiff5, xlsbiff8, xlsxooxml, fpsutils, fpszipper, uvirtuallayer_types,
xlsbiff5, xlsbiff8, xlsxooxml, fpsutils,
fpszipper,
uvirtuallayer_types,
uvirtuallayer, uvirtuallayer_ole, uvirtuallayer_ole_helpers,
uvirtuallayer_ole_types, uvirtuallayer_stream, fpolebasic, xlscommon,
wikitable, LazarusPackageIntf;

5
components/fpspreadsheet/reference/MSODumper.txt Normal file
View File

@ -0,0 +1,5 @@
Excel xls and PowerPoint ppt file dumper written in Python - very handy to list all contents of BIFF files (e.g. ./xls-dump.py file.xls)
cd ~
git clone http://cgit.freedesktop.org/libreoffice/contrib/mso-dumper/
mso-dumper/xls-dump.py yourfile.xls

337
components/fpspreadsheet/tests/datetests.pas Normal file
View File

@ -0,0 +1,337 @@
unit datetests;
{$mode objfpc}{$H+}
{
Adding tests/test data:
1. Add a new value to column A in the relevant worksheet, and save the spreadsheet read-only
(for dates, there are 2 files, with different datemodes. Use them both...)
2. Increase SollDates array size
3. Add value from 1) to InitNormVariables so you can test against it
4. Add your read test(s), read and check read value against SollDates[<added number>]
}
interface
uses
// Not using lazarus package as the user may be working with multiple versions
// Instead, add .. to unit search path
Classes, SysUtils, fpcunit, testutils, testregistry,
fpsallformats, fpspreadsheet, xlsbiff8 {and a project requirement for lclbase for utf8 handling},
testsutility;
var
// Norm to test against - list of dates/times that should occur in spreadsheet
SollDates: array[0..11] of TDateTime; //"Soll" is a German word in Dutch accountancy circles meaning "normative value to check against". There ;)
// Initializes Soll*/normative variables.
// Useful in test setup procedures to make sure the norm is correct.
procedure InitSollDates;
type
{ TSpreadReadDateTests }
// Read from xls/xml file with known values
TSpreadReadDateTests= class(TTestCase)
private
// Tries to read date in column A, specified (0-based) row
procedure TestReadDate(FileName: string; Row: integer);
protected
// Set up expected values:
procedure SetUp; override;
procedure TearDown; override;
published
// Reads dates, date/time and time values from spreadsheet and checks against list
// One cell per test so some tests can fail and those further below may still work
procedure TestReadDate0; //date tests
procedure TestReadDate1; //date and time
procedure TestReadDate2;
procedure TestReadDate3;
procedure TestReadDate4; //time only tests start here
procedure TestReadDate5;
procedure TestReadDate6;
procedure TestReadDate7;
procedure TestReadDate8;
procedure TestReadDate9;
procedure TestReadDate10;
procedure TestReadDate11;
procedure TestReadDate1899_0; //same as above except with the 1899/1900 date system set
procedure TestReadDate1899_1;
procedure TestReadDate1899_2;
procedure TestReadDate1899_3;
procedure TestReadDate1899_4;
procedure TestReadDate1899_5;
procedure TestReadDate1899_6;
procedure TestReadDate1899_7;
procedure TestReadDate1899_8;
procedure TestReadDate1899_9;
procedure TestReadDate1899_10;
procedure TestReadDate1899_11;
end;
{ TSpreadWriteReadDateTests }
//Write to xls/xml file and read back
TSpreadWriteReadDateTests= class(TTestCase)
private
protected
// Set up expected values:
procedure SetUp; override;
procedure TearDown; override;
published
// Reads dates, date/time and time values from spreadsheet and checks against list
// One cell per test so some tests can fail and those further below may still work
procedure TestWriteReadDates;
end;
implementation
const
TestFileBIFF8='testbiff8.xls'; //with 1904 datemode date system
TestFileBIFF8_1899='testbiff8_1899.xls'; //with 1899/1900 datemode date system
DatesSheet = 'Dates'; //worksheet name
// Initialize array with variables that represent the values
// we expect to be in the test spreadsheet files.
//
// When adding tests, add values to this array
// and increase array size in variable declaration
procedure InitSollDates;
begin
// Set up norm - MUST match spreadsheet cells exactly
SollDates[0]:=EncodeDate(1905,09,12); //FPC number 2082
SollDates[1]:=EncodeDate(1908,09,12)+EncodeTime(12,0,0,0); //noon
SollDates[2]:=EncodeDate(2013,11,24);
SollDates[3]:=EncodeDate(2030,12,31);
SollDates[4]:=EncodeTime(0,0,0,0);
SollDates[5]:=EncodeTime(0,0,1,0);
SollDates[6]:=EncodeTime(1,0,0,0);
SollDates[7]:=EncodeTime(3,0,0,0);
SollDates[8]:=EncodeTime(12,0,0,0);
SollDates[9]:=EncodeTime(18,0,0,0);
SollDates[10]:=EncodeTime(23,59,0,0);
SollDates[11]:=EncodeTime(23,59,59,0);
end;
{ TSpreadWriteReadDateTests }
procedure TSpreadWriteReadDateTests.SetUp;
begin
inherited SetUp;
InitSollDates;
end;
procedure TSpreadWriteReadDateTests.TearDown;
begin
inherited TearDown;
end;
procedure TSpreadWriteReadDateTests.TestWriteReadDates;
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
ActualDateTime: TDateTime;
Row: Cardinal;
TempFile: string; //write xls/xml to this file and read back from it
begin
TempFile:=GetTempFileName;
{// Not needed: use workbook.writetofile with overwrite=true
if fileexists(TempFile) then
DeleteFile(TempFile);
}
// Write out all test values
MyWorkbook := TsWorkbook.Create;
MyWorkSheet:=MyWorkBook.AddWorksheet(DatesSheet);
for Row := Low(SollDates) to High(SollDates) do
begin
MyWorkSheet.WriteDateTime(Row,0,SollDates[Row]);
// Some checks inside worksheet itself
if not(MyWorkSheet.ReadAsDateTime(Row,0,ActualDateTime)) then
Fail('Failed writing date time for cell '+CellNotation(Row));
CheckEquals(SollDates[Row],ActualDateTime,'Test date/time value mismatch cell '+CellNotation(Row));
end;
MyWorkBook.WriteToFile(TempFile,sfExcel8,true);
MyWorkbook.Free;
// Open the spreadsheet, as biff8
MyWorkbook := TsWorkbook.Create;
MyWorkbook.ReadFromFile(TempFile, sfExcel8);
MyWorksheet:=GetWorksheetByName(MyWorkBook,DatesSheet);
if MyWorksheet=nil then
fail('Error in test code. Failed to get named worksheet');
// Read test data from A column & compare if written=original
for Row := Low(SollDates) to High(SollDates) do
begin
if not(MyWorkSheet.ReadAsDateTime(Row,0,ActualDateTime)) then
Fail('Could not read date time for cell '+CellNotation(Row));
CheckEquals(SollDates[Row],ActualDateTime,'Test date/time value mismatch cell '+CellNotation(Row));
end;
// Finalization
MyWorkbook.Free;
DeleteFile(TempFile);
end;
procedure TSpreadReadDateTests.TestReadDate(FileName: string; Row: integer);
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
ActualDateTime: TDateTime;
begin
if Row>High(SollDates) then
fail('Error in test code: array bounds overflow. Check array size is correct.');
// Open the spreadsheet, as biff8
MyWorkbook := TsWorkbook.Create;
MyWorkbook.ReadFromFile(FileName, sfExcel8);
MyWorksheet:=GetWorksheetByName(MyWorkBook,DatesSheet);
if MyWorksheet=nil then
fail('Error in test code. Failed to get named worksheet');
if not(MyWorkSheet.ReadAsDateTime(Row, 0, ActualDateTime)) then
Fail('Could not read date time for cell '+CellNotation(Row));
CheckEquals(SollDates[Row],ActualDateTime,'Test date/time value mismatch '
+'cell '+CellNotation(Row));
// Finalization
MyWorkbook.Free;
end;
procedure TSpreadReadDateTests.SetUp;
begin
InitSollDates;
end;
procedure TSpreadReadDateTests.TearDown;
begin
end;
procedure TSpreadReadDateTests.TestReadDate0;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,0);
end;
procedure TSpreadReadDateTests.TestReadDate1;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,1);
end;
procedure TSpreadReadDateTests.TestReadDate2;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,2);
end;
procedure TSpreadReadDateTests.TestReadDate3;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,3);
end;
procedure TSpreadReadDateTests.TestReadDate4;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,4);
end;
procedure TSpreadReadDateTests.TestReadDate5;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,5);
end;
procedure TSpreadReadDateTests.TestReadDate6;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,6);
end;
procedure TSpreadReadDateTests.TestReadDate7;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,7);
end;
procedure TSpreadReadDateTests.TestReadDate8;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,8);
end;
procedure TSpreadReadDateTests.TestReadDate9;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,9);
end;
procedure TSpreadReadDateTests.TestReadDate10;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,10);
end;
procedure TSpreadReadDateTests.TestReadDate11;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,11);
end;
procedure TSpreadReadDateTests.TestReadDate1899_0;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8_1899,0);
end;
procedure TSpreadReadDateTests.TestReadDate1899_1;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8_1899,1);
end;
procedure TSpreadReadDateTests.TestReadDate1899_2;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8_1899,2);
end;
procedure TSpreadReadDateTests.TestReadDate1899_3;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8_1899,3);
end;
procedure TSpreadReadDateTests.TestReadDate1899_4;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8_1899,4);
end;
procedure TSpreadReadDateTests.TestReadDate1899_5;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8_1899,5);
end;
procedure TSpreadReadDateTests.TestReadDate1899_6;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8_1899,6);
end;
procedure TSpreadReadDateTests.TestReadDate1899_7;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8_1899,7);
end;
procedure TSpreadReadDateTests.TestReadDate1899_8;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8_1899,8);
end;
procedure TSpreadReadDateTests.TestReadDate1899_9;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8_1899,9);
end;
procedure TSpreadReadDateTests.TestReadDate1899_10;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8_1899,10);
end;
procedure TSpreadReadDateTests.TestReadDate1899_11;
begin
TestReadDate(ExtractFilePath(ParamStr(0)) + TestFileBIFF8_1899,11);
end;
initialization
// Register so these tests are included in a full run
RegisterTest(TSpreadReadDateTests);
RegisterTest(TSpreadWriteReadDateTests);
InitSollDates; //useful to have norm data if other code want to use this unit
end.

75
components/fpspreadsheet/tests/internaltests.pas Normal file
View File

@ -0,0 +1,75 @@
unit internaltests;
{ Other units test file read/write capability.
This unit tests functions, procedures and properties that fpspreadsheet provides.
}
{$mode objfpc}{$H+}
interface
{
Adding tests/test data:
- just add your new test procedure
}
uses
// Not using lazarus package as the user may be working with multiple versions
// Instead, add .. to unit search path
Classes, SysUtils, fpcunit, testutils, testregistry,
fpsallformats, fpspreadsheet, xlsbiff8 {and a project requirement for lclbase for utf8 handling},
testsutility;
type
{ TSpreadReadInternalTests }
// Read from xls/xml file with known values
TSpreadInternalTests= class(TTestCase)
private
protected
// Set up expected values:
procedure SetUp; override;
procedure TearDown; override;
published
//todo: add more calls, rename sheets, try to get sheets with invalid indexes etc
//(see strings tests for how to deal with expected exceptions)
procedure GetSheetByIndex;
end;
implementation
const
InternalSheet = 'Internal'; //worksheet name
procedure TSpreadInternalTests.GetSheetByIndex;
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
Row: Cardinal;
begin
MyWorkbook := TsWorkbook.Create;
MyWorkSheet:=MyWorkBook.AddWorksheet(InternalSheet);
MyWorkSheet:=nil;
MyWorkSheet:=MyWorkBook.GetWorksheetByIndex(0);
CheckFalse((MyWorksheet=nil),'GetWorksheetByIndex should return a valid index');
MyWorkbook.Free;
end;
procedure TSpreadInternalTests.SetUp;
begin
end;
procedure TSpreadInternalTests.TearDown;
begin
end;
initialization
// Register so these tests are included in a full run
RegisterTest(TSpreadInternalTests);
end.

162
components/fpspreadsheet/tests/manualtests.pas Normal file
View File

@ -0,0 +1,162 @@
unit manualtests;
{
Tests that can be run but need a human to check results.
Examples are color output, rotation, bold etc
Of course, you could write Excel macros to do this for you; patches welcome ;)
}
{$mode objfpc}{$H+}
{
Adding tests/test data:
1. Increase Soll* array size
2. Add desired normative value InitNormVariables so you can test against it
3. Add your write test(s) including instructions for the humans check the resulting file
}
interface
uses
// Not using lazarus package as the user may be working with multiple versions
// Instead, add .. to unit search path
Classes, SysUtils, fpcunit, testutils, testregistry,
fpsallformats, fpspreadsheet, xlsbiff8 {and a project requirement for lclbase for utf8 handling},
testsutility;
var
// Norm to test against - list of dates/times that should occur in spreadsheet
SollColors: array[0..22] of tsColor; //"Soll" is a German word in Dutch accountancy circles meaning "normative value to check against". There ;)
SollColorNames: array[0..22] of string; //matching names for SollColors
// Initializes Soll*/normative variables.
// Useful in test setup procedures to make sure the norm is correct.
procedure InitSollColors;
type
{ TSpreadManualTests }
// Writes to file and let humans figure out if the correct output was generated
TSpreadManualTests= class(TTestCase)
private
protected
// Set up expected values:
procedure SetUp; override;
procedure TearDown; override;
published
// Writes all background colors in A1..A16
procedure TestBiff8CellBackgroundColor;
end;
implementation
// Initialize array with variables that represent the values
// we expect to be in the test spreadsheet files.
//
// When adding tests, add values to this array
// and increase array size in variable declaration
procedure InitSollColors;
begin
// Set up norm - MUST match spreadsheet cells exactly
// Follows fpspreadsheet.TsColor, except custom colors
SollColors[0]:=scBlack;
SollColors[1]:=scWhite;
SollColors[2]:=scRed;
SollColors[3]:=scGREEN;
SollColors[4]:=scBLUE;
SollColors[5]:=scYELLOW;
SollColors[6]:=scMAGENTA;
SollColors[7]:=scCYAN;
SollColors[8]:=scDarkRed;
SollColors[9]:=scDarkGreen;
SollColors[10]:=scDarkBlue;
SollColors[11]:=scOLIVE;
SollColors[12]:=scPURPLE;
SollColors[13]:=scTEAL;
SollColors[14]:=scSilver;
SollColors[15]:=scGrey;
SollColors[16]:=scGrey10pct;
SollColors[17]:=scGrey20pct;
SollColors[18]:=scOrange;
SollColors[19]:=scDarkBrown;
SollColors[20]:=scBrown;
SollColors[21]:=scBeige;
SollColors[22]:=scWheat;
// Corresponding names for display in cells:
SollColorNames[0]:='scBlack';
SollColorNames[1]:='scWhite';
SollColorNames[2]:='scRed';
SollColorNames[3]:='scGREEN';
SollColorNames[4]:='scBLUE';
SollColorNames[5]:='scYELLOW';
SollColorNames[6]:='scMAGENTA';
SollColorNames[7]:='scCYAN';
SollColorNames[8]:='scDarkRed';
SollColorNames[9]:='scDarkGreen';
SollColorNames[10]:='scDarkBlue';
SollColorNames[11]:='scOLIVE';
SollColorNames[12]:='scPURPLE';
SollColorNames[13]:='scTEAL';
SollColorNames[14]:='scSilver';
SollColorNames[15]:='scGrey';
SollColorNames[16]:='scGrey10pct';
SollColorNames[17]:='scGrey20pct';
SollColorNames[18]:='scOrange';
SollColorNames[19]:='scDarkBrown';
SollColorNames[20]:='scBrown';
SollColorNames[21]:='scBeige';
SollColorNames[22]:='scWheat';
end;
{ TSpreadManualTests }
procedure TSpreadManualTests.SetUp;
begin
InitSollColors;
end;
procedure TSpreadManualTests.TearDown;
begin
end;
procedure TSpreadManualTests.TestBiff8CellBackgroundColor();
// source: forum post
// http://forum.lazarus.freepascal.org/index.php/topic,19887.msg134114.html#msg134114
// possible fix for values there too
const
OUTPUT_FORMAT = sfExcel8;
var
Workbook: TsWorkbook;
Worksheet: TsWorksheet;
Cell : PCell;
i: cardinal;
RowOffset: cardinal;
begin
Workbook := TsWorkbook.Create;
Worksheet := Workbook.AddWorksheet('colorsheet');
WorkSheet.WriteUTF8Text(0,1,'TSpreadManualTests.TestBiff8CellBackgroundColor');
RowOffset:=1;
for i:=Low(SollColors) to High(SollColors) do
begin
WorkSheet.WriteUTF8Text(i+RowOffset,0,'BACKGROUND COLOR TEST');
Cell := Worksheet.GetCell(i+RowOffset, 0);
Cell^.BackgroundColor := SollColors[i];
if not (uffBackgroundColor in Cell^.UsedFormattingFields) then
include (Cell^.UsedFormattingFields,uffBackgroundColor);
WorkSheet.WriteUTF8Text(i+RowOffset,1,'Cell to the left should be tsColor value '+SollColorNames[i]+'. Please check.');
end;
// todo: move to a shared workbook object, write at tests suite finish
// http://wiki.lazarus.freepascal.org/fpcunit#Test_decorator:_OneTimeSetup_and_OneTimeTearDown
Workbook.WriteToFile(TestFileManual, OUTPUT_FORMAT, TRUE);
Workbook.Free;
end;
initialization
// Register so these tests are included in a full run
RegisterTest(TSpreadManualTests);
// Initialize the norm variables in case other units want to use it:
InitSollColors;
end.

263
components/fpspreadsheet/tests/numberstests.pas Normal file
View File

@ -0,0 +1,263 @@
unit numberstests;
{$mode objfpc}{$H+}
interface
{
Adding tests/test data:
1. Add a new value to column A in the relevant worksheet, and save the spreadsheet read-only
(for dates, there are 2 files, with different datemodes. Use them both...)
2. Increase SollNumbers array size
3. Add value from 1) to InitNormVariables so you can test against it
4. Add your read test(s), read and check read value against SollDates[<added number>]
}
uses
// Not using lazarus package as the user may be working with multiple versions
// Instead, add .. to unit search path
Classes, SysUtils, fpcunit, testutils, testregistry,
fpsallformats, fpspreadsheet, xlsbiff8 {and a project requirement for lclbase for utf8 handling},
testsutility;
var
// Norm to test against - list of numbers/times that should occur in spreadsheet
SollNumbers: array[0..12] of double; //"Soll" is a German word in Dutch accountancy circles meaning "normative value to check against". There ;)
// Initializes Soll*/normative variables.
// Useful in test setup procedures to make sure the norm is correct.
procedure InitSollNumbers;
type
{ TSpreadReadNumberTests }
// Read from xls/xml file with known values
TSpreadReadNumberTests= class(TTestCase)
private
// Tries to read number in column A, specified (0-based) row
procedure TestReadNumber(FileName: string; Row: integer);
protected
// Set up expected values:
procedure SetUp; override;
procedure TearDown; override;
published
// Reads numbers values from spreadsheet and checks against list
// One cell per test so some tests can fail and those further below may still work
procedure TestReadNumber0; //number tests
procedure TestReadNumber1; //number and time
procedure TestReadNumber2;
procedure TestReadNumber3;
procedure TestReadNumber4; //time only tests start here
procedure TestReadNumber5;
procedure TestReadNumber6;
procedure TestReadNumber7;
procedure TestReadNumber8;
procedure TestReadNumber9;
procedure TestReadNumber10;
procedure TestReadNumber11;
end;
{ TSpreadWriteReadNumberTests }
//Write to xls/xml file and read back
TSpreadWriteReadNumberTests= class(TTestCase)
private
protected
// Set up expected values:
procedure SetUp; override;
procedure TearDown; override;
published
// Reads numbers values from spreadsheet and checks against list
// One cell per test so some tests can fail and those further below may still work
procedure TestWriteReadNumbers;
end;
implementation
const
TestFileBIFF8='testbiff8.xls'; //with 1904 numbermode number system
TestFileBIFF8_1899='testbiff8_1899.xls'; //with 1899/1900 numbermode number system
NumbersSheet = 'Numbers'; //worksheet name
// Initialize array with variables that represent the values
// we expect to be in the test spreadsheet files.
//
// When adding tests, add values to this array
// and increase array size in variable declaration
procedure InitSollNumbers;
begin
// Set up norm - MUST match spreadsheet cells exactly
SollNumbers[0]:=-59000000; //minus 59 million
SollNumbers[1]:=-988;
SollNumbers[2]:=-124.23432;
SollNumbers[3]:=-81.9028508730274;
SollNumbers[4]:=-15;
SollNumbers[5]:=-0.002934; //minus small fraction
SollNumbers[6]:=-0; //minus zero
SollNumbers[7]:=0; //zero
SollNumbers[8]:=0.000000005; //small fraction
SollNumbers[9]:=0.982394; //almost 1
SollNumbers[10]:=3.14159265358979; //some parts of pi
SollNumbers[11]:=59000000; //59 million
SollNumbers[12]:=59000000.1; //same + a tenth
end;
{ TSpreadWriteReadNumberTests }
procedure TSpreadWriteReadNumberTests.SetUp;
begin
inherited SetUp;
InitSollNumbers;
end;
procedure TSpreadWriteReadNumberTests.TearDown;
begin
inherited TearDown;
end;
procedure TSpreadWriteReadNumberTests.TestWriteReadNumbers;
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
ActualNumber: double;
Row: Cardinal;
TempFile: string; //write xls/xml to this file and read back from it
begin
TempFile:=GetTempFileName;
{// Not needed: use workbook.writetofile with overwrite=true
if fileexists(TempFile) then
DeleteFile(TempFile);
}
// Write out all test values
MyWorkbook := TsWorkbook.Create;
MyWorkSheet:=MyWorkBook.AddWorksheet(NumbersSheet);
for Row := Low(SollNumbers) to High(SollNumbers) do
begin
MyWorkSheet.WriteNumber(Row,0,SollNumbers[Row]);
// Some checks inside worksheet itself
ActualNumber:=MyWorkSheet.ReadAsNumber(Row,0);
CheckEquals(SollNumbers[Row],ActualNumber,'Test value mismatch cell '+CellNotation(Row));
end;
MyWorkBook.WriteToFile(TempFile,sfExcel8,true);
MyWorkbook.Free;
// Open the spreadsheet, as biff8
MyWorkbook := TsWorkbook.Create;
MyWorkbook.ReadFromFile(TempFile, sfExcel8);
MyWorksheet:=GetWorksheetByName(MyWorkBook,NumbersSheet);
if MyWorksheet=nil then
fail('Error in test code. Failed to get named worksheet');
// Read test data from A column & compare if written=original
for Row := Low(SollNumbers) to High(SollNumbers) do
begin
ActualNumber:=MyWorkSheet.ReadAsNumber(Row,0);
CheckEquals(SollNumbers[Row],ActualNumber,'Test value mismatch cell '+CellNotation(Row));
end;
// Finalization
MyWorkbook.Free;
DeleteFile(TempFile);
end;
procedure TSpreadReadNumberTests.TestReadNumber(FileName: string; Row: integer);
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
ActualNumber: double;
begin
if Row>High(SollNumbers) then
fail('Error in test code: array bounds overflow. Check array size is correct.');
// Open the spreadsheet, as biff8
MyWorkbook := TsWorkbook.Create;
MyWorkbook.ReadFromFile(FileName, sfExcel8);
MyWorksheet:=GetWorksheetByName(MyWorkBook,NumbersSheet);
if MyWorksheet=nil then
fail('Error in test code. Failed to get named worksheet');
ActualNumber:=MyWorkSheet.ReadAsNumber(Row, 0);
CheckEquals(SollNumbers[Row],ActualNumber,'Test value mismatch '
+'cell '+CellNotation(Row));
// Finalization
MyWorkbook.Free;
end;
procedure TSpreadReadNumberTests.SetUp;
begin
InitSollNumbers;
end;
procedure TSpreadReadNumberTests.TearDown;
begin
end;
procedure TSpreadReadNumberTests.TestReadNumber0;
begin
TestReadNumber(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,0);
end;
procedure TSpreadReadNumberTests.TestReadNumber1;
begin
TestReadNumber(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,1);
end;
procedure TSpreadReadNumberTests.TestReadNumber2;
begin
TestReadNumber(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,2);
end;
procedure TSpreadReadNumberTests.TestReadNumber3;
begin
TestReadNumber(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,3);
end;
procedure TSpreadReadNumberTests.TestReadNumber4;
begin
TestReadNumber(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,4);
end;
procedure TSpreadReadNumberTests.TestReadNumber5;
begin
TestReadNumber(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,5);
end;
procedure TSpreadReadNumberTests.TestReadNumber6;
begin
TestReadNumber(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,6);
end;
procedure TSpreadReadNumberTests.TestReadNumber7;
begin
TestReadNumber(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,7);
end;
procedure TSpreadReadNumberTests.TestReadNumber8;
begin
TestReadNumber(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,8);
end;
procedure TSpreadReadNumberTests.TestReadNumber9;
begin
TestReadNumber(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,9);
end;
procedure TSpreadReadNumberTests.TestReadNumber10;
begin
TestReadNumber(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,10);
end;
procedure TSpreadReadNumberTests.TestReadNumber11;
begin
TestReadNumber(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,11);
end;
initialization
// Register so these tests are included in a full run
RegisterTest(TSpreadReadNumberTests);
RegisterTest(TSpreadWriteReadNumberTests);
InitSollNumbers; //useful to have norm data if other code want to use this unit
end.

46
components/fpspreadsheet/tests/readme.txt Normal file
View File

@ -0,0 +1,46 @@
Tests for fpspreadsheet
spreadtestgui
=============
Lets you quickly run tests in a GUI.
If there are problems, you can open the spreadtestgui.lpr in Lazarus, compile it with debug mode, and trace through the offending test and the fpspreadsheet code it calls.
More details: FPCUnit documentation
spreadtestcli
=============
Command line version of the above, extended with database output. Useful for scripting use (use e.g. --all --format=plain.
For output to an embedded Firebird database, make sure the required dlls/packages are present and run the program, e.g:
spreadtestcli --comment="Hoped to have fixed that string issue" --revision="482"
(the revision is the SVN revision number, so you can keep track of regresssions)
More details: FPCUnit documentation and
https://bitbucket.org/reiniero/testdbwriter
The tests
=========
Basic tests read XLS files and check the retrieved values against a list. This tests whether reading dates, text etc works.
Another test is to take that list of normative values, write it to an xls file, then read back and compare with the original list. This basically tests whether write support is correct.
The files are written to the temp directory. They are deleted on succesful test completion; otherwise they are kept so you can open them up with a spreadsheet application/mso dumper tool/hex editor and check what exactly got written.
Finally, there is a manual test unit: these tests write out cells to a spreadsheet file (testmanual.xls) that the user should inspect himself. Examples are tests for colors, formatting etc.
Adding tests
============
For most tests:
- Add new cells to the A column in the relevant xls files; see comments in files.
- Add corresponding normative/expected value in the relevant test unit; increase array size
- Add your tests that read the data from xls and checks against the norm array.
Note that tests that check for known failures are quite valuable. You can indicate you expect an exception etc.
Ideas for more tests:
- add more tests to internaltests to explicitly tests fpspreadsheet functions/procedures/properties that don't read/write to xls/xml files
- writing RPN formulas in the manualtests unit
- more xls/xml file formats tested
- more corner cases
- writing all data available to various sheets and reading it back to test whether complex sheets work
- reading faulty files to test exception handling
For more details, please see the FPCUnit documentation.

160
components/fpspreadsheet/tests/spreadtestcli.lpi Normal file
View File

@ -0,0 +1,160 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="spreadtestcli"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="2">
<Item1 Name="Default" Default="True"/>
<Item2 Name="Debug">
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="spreadtestcli"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value=".."/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<IncludeAssertionCode Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
<StackChecks Value="True"/>
</Checks>
</CodeGeneration>
<Other>
<Verbosity>
<ShowAllProcsOnError Value="True"/>
</Verbosity>
<WriteFPCLogo Value="False"/>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CustomOptions Value="-dDEBUG -dDEBUGCONSOLE -O-1"/>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</Item2>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCLBase"/>
</Item1>
</RequiredPackages>
<Units Count="7">
<Unit0>
<Filename Value="spreadtestcli.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="spreadtestcli"/>
</Unit0>
<Unit1>
<Filename Value="testdbwriter.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="testdbwriter"/>
</Unit1>
<Unit2>
<Filename Value="datetests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="datetests"/>
</Unit2>
<Unit3>
<Filename Value="testsutility.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="testsutility"/>
</Unit3>
<Unit4>
<Filename Value="manualtests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="manualtests"/>
</Unit4>
<Unit5>
<Filename Value="stringtests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="stringtests"/>
</Unit5>
<Unit6>
<Filename Value="internaltests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="internaltests"/>
</Unit6>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="spreadtestcli"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value=".."/>
</SearchPaths>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
</Debugging>
</Linking>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="5">
<Item1>
<Name Value="ECodetoolError"/>
<Enabled Value="False"/>
</Item1>
<Item2>
<Name Value="EFOpenError"/>
<Enabled Value="False"/>
</Item2>
<Item3>
<Name Value="EAssertionFailedError"/>
</Item3>
<Item4>
<Name Value="Exception"/>
</Item4>
<Item5>
<Name Value="EIBDatabaseError"/>
</Item5>
</Exceptions>
</Debugging>
</CONFIG>

267
components/fpspreadsheet/tests/spreadtestcli.lpr Normal file
View File

@ -0,0 +1,267 @@
program spreadtestcli;
{$mode objfpc}
{$h+}
uses
custapp, Classes, SysUtils, fpcunit,
plaintestreport {results output to plain text},
xmltestreport {used to get results into XML format},
testregistry,
testdbwriter {used to get results into db},
datetests, manualtests, numberstests, stringtests, internaltests,
testsutility, testutils {the actual tests};
const
ShortOpts = 'ac:dhlpr:x';
Longopts: Array[1..11] of String = (
'all','comment:','db', 'database', 'help','list','revision:','revisionid:','suite:','plain','xml');
Version = 'Version 1';
type
{ TTestRunner }
TTestOutputFormat = (tDB, tXMLAdvanced, tPlainText);
TTestRunner = Class(TCustomApplication)
private
FFormat: TTestOutputFormat;
FDBResultsWriter: TDBResultsWriter;
FPlainResultsWriter: TPlainResultsWriter;
FXMLResultsWriter: TXMLResultsWriter;
procedure WriteHelp;
protected
procedure DoRun ; Override;
procedure doTestRun(aTest: TTest); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
constructor TTestRunner.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFormat:=tPlainText;
//FDBResultsWriter := TDBResultsWriter.Create; //done in procedures
FPlainResultsWriter:=TPlainResultsWriter.Create(nil);
//Don't write out timing info, makes it more difficult to run a diff.
//If you want to use timing, use the XML or db output:
{$if FPC_FULLVERSION>=20701}
FPlainResultsWriter.SkipTiming:=true;
{$endif}
FXMLResultsWriter:=TXMLResultsWriter.Create(nil);
end;
destructor TTestRunner.Destroy;
begin
//FDBResultsWriter.Free; //done in procedures
FPlainResultsWriter.Free;
FXMLResultsWriter.Free;
end;
procedure TTestRunner.doTestRun(aTest: TTest);
var
RevisionID: string;
testResult: TTestResult;
begin
testResult := TTestResult.Create;
try
case FFormat of
tDB:
begin
testResult.AddListener(FDBResultsWriter);
RevisionID:=GetOptionValue('r','revisionid');
if RevisionID='' then
RevisionID:=GetOptionValue('revision');
if RevisionID<>'' then
FDBResultsWriter.RevisionID:=RevisionID;
FDBResultsWriter.Comment:=GetOptionValue('c','comment');
{
// Depending on the application, you may want to add some fake test suite hierarchy
// at the top of the test project.
// Why? This makes it easier to avoid comparing apples to oranges when you have
// various platforms, editions, configurations, database connectors etc of your program/test set.
// Here, we demonstrate this with a Latin language edition of the code in its Enterprise edition:
FDBResultsWriter.TestSuiteRoot.Add('Enterprise');
FDBResultsWriter.TestSuiteRoot.Add('Latin');
}
{
// Normally, we would edit the testdbwriter.ini file and select our db
// where the tests are stored that way.... or omit any ini file and let it
// fallback to a Firebird embedded database.
// However, if needed, that can be overridden here:
FDBResultsWriter.DatabaseType:=TDBW_POSTGRESQLCONN_NAME;
FDBResultsWriter.DatabaseHostname:='dbserver';
FDBResultsWriter.DatabaseName:='dbtests';
FDBResultsWriter.DatabaseUser:='postgres';
FDBResultsWriter.DatabasePassword:='password';
FDBResultsWriter.DatabaseCharset:='UTF8';
}
end;
tPlainText:
begin
testResult.AddListener(FPlainResultsWriter);
end;
tXMLAdvanced:
begin
testResult.AddListener(FXMLResultsWriter);
// if filename='null', no console output is generated...
//FXMLResultsWriter.FileName:='';
end;
end;
aTest.Run(testResult);
case FFormat of
tDB: testResult.RemoveListener(FDBResultsWriter);
tPlainText:
begin
// This actually generates the plain text output:
FPlainResultsWriter.WriteResult(TestResult);
testResult.RemoveListener(FPlainResultsWriter);
end;
tXMLAdvanced:
begin
// This actually generates the XML output:
FXMLResultsWriter.WriteResult(TestResult);
// You can use fcl-xml's xmlwrite.WriteXMLFile to write the results
// to a stream or file...
testResult.RemoveListener(FXMLResultsWriter);
end;
end;
finally
testResult.Free;
end;
end;
procedure TTestRunner.WriteHelp;
begin
writeln(Title);
writeln(Version);
writeln(ExeName+': console test runner for fpspreadsheet tests');
writeln('Runs test set for fpspreadsheet and');
writeln('- stores the results in a database, or');
writeln('- outputs to screen');
writeln('');
writeln('Usage: ');
writeln('-c <comment>, --comment=<comment>');
writeln(' add comment to test run info.');
writeln(' (if database output is used)');
writeln('-d or --db or --database: run all tests, output to database');
writeln('-l or --list to show a list of registered tests');
writeln('-p or --plain: run all tests, output in plain text (default)');
writeln('-r <id> --revision=<id>, --revisionid=<id>');
writeln(' add revision id/application version ID to test run info.');
writeln(' (if database output is used)');
writeln('-x or --xml to run all tests and show the output in XML (new '
+'DUnit style)');
writeln('');
writeln('--suite=MyTestSuiteName to run only the tests in a single test '
+'suite class');
writeln('Example: --suite=TSpreadWriteReadStringTests');
end;
procedure TTestRunner.DoRun;
const
RepeatInterval=10;
var
FoundTest: boolean;
I : Integer;
S : String;
begin
S:=CheckOptions(ShortOpts,LongOpts);
If (S<>'') then
begin
Writeln(StdErr,S);
WriteHelp;
halt(1);
end;
// Default to plain text output:
FFormat:=tPlainText;
if HasOption('d', 'database') or HasOption('db') then
FFormat:=tDB;
if HasOption('h', 'help') then
begin
WriteHelp;
halt(0);
end;
if HasOption('l', 'list') then
begin
writeln(GetSuiteAsPlain(GetTestRegistry));
halt(0);
end;
if HasOption('p', 'plain') then
FFormat:=tPlainText;
if HasOption('x', 'xml') then
FFormat:=tXMLAdvanced;
if HasOption('suite') then
begin
S := '';
S:=GetOptionValue('suite');
// For the db writer: recreate test objects so we get new runs each time
FoundTest:=false;
FDBResultsWriter:=TDBResultsWriter.Create;
try
if S = '' then
begin
writeln('Error');
writeln('You have to specify a test(suite). Valid test suite names:');
for I := 0 to GetTestRegistry.Tests.count - 1 do
writeln(GetTestRegistry[i].TestName)
end
else
begin
for I := 0 to GetTestRegistry.Tests.count - 1 do
begin
if GetTestRegistry[i].TestName = S then
begin
doTestRun(GetTestRegistry[i]);
FoundTest:=true;
end;
end;
if not(FoundTest) then
begin
writeln('Error: the testsuite "',S,'" you specified does not exist.');
end;
end;
finally
FDBResultsWriter.Free;
end;
end
else
begin
// No suite
// For the db writer: recreate test objects so we get new runs each time
FDBResultsWriter:=TDBResultsWriter.Create;
try
doTestRun(GetTestRegistry);
finally
FDBResultsWriter.Free;
end;
end;
Terminate;
end;
var
App: TTestRunner;
begin
App := TTestRunner.Create(nil);
App.Initialize;
App.Title := 'spreadtestcli';
App.Run;
App.Free;
end.

155
components/fpspreadsheet/tests/spreadtestgui.lpi Normal file
View File

@ -0,0 +1,155 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="spreadtestgui"/>
<ResourceType Value="res"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="2">
<Item1 Name="Release" Default="True"/>
<Item2 Name="Debug">
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value=".."/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<IncludeAssertionCode Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
<StackChecks Value="True"/>
</Checks>
</CodeGeneration>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf2Set"/>
<UseExternalDbgSyms Value="True"/>
</Debugging>
</Linking>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</Item2>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="4">
<Item1>
<PackageName Value="LCLBase"/>
</Item1>
<Item2>
<PackageName Value="FPCUnitTestRunner"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
<Item4>
<PackageName Value="FCL"/>
</Item4>
</RequiredPackages>
<Units Count="7">
<Unit0>
<Filename Value="spreadtestgui.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="spreadtestgui"/>
</Unit0>
<Unit1>
<Filename Value="datetests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="datetests"/>
</Unit1>
<Unit2>
<Filename Value="stringtests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="stringtests"/>
</Unit2>
<Unit3>
<Filename Value="numberstests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="numberstests"/>
</Unit3>
<Unit4>
<Filename Value="manualtests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="manualtests"/>
</Unit4>
<Unit5>
<Filename Value="testsutility.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="testsutility"/>
</Unit5>
<Unit6>
<Filename Value="internaltests.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="internaltests"/>
</Unit6>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value=".."/>
</SearchPaths>
<CodeGeneration>
<SmartLinkUnit Value="True"/>
<Optimizations>
<OptimizationLevel Value="0"/>
</Optimizations>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
</Debugging>
<LinkSmart Value="True"/>
</Linking>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

15
components/fpspreadsheet/tests/spreadtestgui.lpr Normal file
View File

@ -0,0 +1,15 @@
program spreadtestgui;
{$mode objfpc}{$H+}
uses
Interfaces, Forms, GuiTestRunner,
datetests, stringtests,
numberstests, manualtests, testsutility, internaltests;
begin
Application.Initialize;
Application.CreateForm(TGuiTestRunner, TestRunner);
Application.Run;
end.

BIN
components/fpspreadsheet/tests/spreadtestgui.res Normal file
View File

Binary file not shown.

327
components/fpspreadsheet/tests/stringtests.pas Normal file
View File

@ -0,0 +1,327 @@
unit stringtests;
{$mode objfpc}{$H+}
{
Adding tests/test data:
1. Add a new value to column A in the relevant worksheet, and save the spreadsheet read-only
(for dates, there are 2 files, with different datemodes. Use them both...)
2. Increase SollStrings array size
3. Add value from 1) to InitNormVariables so you can test against it
4. Add your read test(s), read and check read value against SollStrings[<added number>]
}
interface
uses
// Not using lazarus package as the user may be working with multiple versions
// Instead, add .. to unit search path
Classes, SysUtils, fpcunit, testutils, testregistry,
fpsallformats, fpspreadsheet, xlsbiff8 {and a project requirement for lclbase for utf8 handling},
testsutility;
var
// Norm to test against - list of strings that should occur in spreadsheet
SollStrings: array[0..6] of string; //"Soll" is a German word in Dutch accountancy circles meaning "normative value to check against". There ;)
// Initializes Soll*/normative variables.
// Useful in test setup procedures to make sure the norm is correct.
procedure InitSollStrings;
type
{ TSpreadReadStringTests }
// Read from xls/xml file with known values
TSpreadReadStringTests= class(TTestCase)
private
// Tries to read string in column A, specified (0-based) row
procedure TestReadString(FileName: string; Row: integer);
protected
// Set up expected values:
procedure SetUp; override;
procedure TearDown; override;
published
// Reads string values from spreadsheet and checks against list
// One cell per test so some tests can fail and those further below may still work
procedure TestReadString0; //empty string
procedure TestReadString1;
procedure TestReadString2;
procedure TestReadString3;
procedure TestReadString4;
procedure TestReadString5;
procedure TestReadString6;
end;
{ TSpreadWriteReadStringTests }
//Write to xls/xml file and read back
TSpreadWriteReadStringTests= class(TTestCase)
private
protected
// Set up expected values:
procedure SetUp; override;
procedure TearDown; override;
published
// Writes out norm strings & reads back.
// If previous read tests are ok, this effectively tests writing.
procedure TestWriteReadStrings;
// Testing some limits & exception handling
procedure TestWriteReadStringsLimits;
end;
implementation
// Initialize array with variables that represent the values
// we expect to be in the test spreadsheet files.
//
// When adding tests, add values to this array
// and increase array size in variable declaration
procedure InitSollStrings;
begin
// Set up norm - MUST match spreadsheet cells exactly
SollStrings[0]:='';
SollStrings[1]:='a';
SollStrings[2]:='1';
SollStrings[3]:='The quick brown fox jumps over the lazy dog';
SollStrings[4]:='café au lait'; //accent aigue on the e
SollStrings[5]:='водка'; //cyrillic
SollStrings[6]:='wódka'; //Polish o accent aigue
end;
{ TSpreadWriteReadStringTests }
procedure TSpreadWriteReadStringTests.SetUp;
begin
inherited SetUp;
InitSollStrings; //just for security: make sure the variables are reset to default
end;
procedure TSpreadWriteReadStringTests.TearDown;
begin
inherited TearDown;
end;
procedure TSpreadWriteReadStringTests.TestWriteReadStrings;
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
ActualString: String;
Row: Cardinal;
TempFile: string; //write xls/xml to this file and read back from it
begin
TempFile:=GetTempFileName;
{// Not needed: use workbook.writetofile with overwrite=true
if fileexists(TempFile) then
DeleteFile(TempFile);
}
// Write out all test values
MyWorkbook := TsWorkbook.Create;
MyWorkSheet:=MyWorkBook.AddWorksheet(StringsSheet);
for Row := Low(SollStrings) to High(SollStrings) do
begin
MyWorkSheet.WriteUTF8Text(Row,0,SollStrings[Row]);
// Some checks inside worksheet itself
ActualString:=MyWorkSheet.ReadAsUTF8Text(Row,0);
CheckEquals(SollStrings[Row],ActualString,'Test value mismatch cell '+CellNotation(Row));
end;
MyWorkBook.WriteToFile(TempFile,sfExcel8,true);
MyWorkbook.Free;
// Open the spreadsheet, as biff8
MyWorkbook := TsWorkbook.Create;
MyWorkbook.ReadFromFile(TempFile, sfExcel8);
MyWorksheet:=GetWorksheetByName(MyWorkBook,StringsSheet);
if MyWorksheet=nil then
fail('Error in test code. Failed to get named worksheet');
// Read test data from A column & compare if written=original
for Row := Low(SollStrings) to High(SollStrings) do
begin
ActualString:=MyWorkSheet.ReadAsUTF8Text(Row,0);
CheckEquals(SollStrings[Row],ActualString,'Test value mismatch cell '+CellNotation(Row));
end;
// Finalization
MyWorkbook.Free;
DeleteFile(TempFile);
end;
procedure TSpreadWriteReadStringTests.TestWriteReadStringsLimits;
const
MaxBytesBIFF8=32758; //limit for strings in this file format
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
ActualString: String;
ExceptionMessage: string;
LocalNormStrings: array[0..3] of string;
Row: Cardinal;
TempFile: string; //write xls/xml to this file and read back from it
TestResult: boolean;
begin
LocalNormStrings[0]:=StringOfChar('a',MaxBytesBIFF8-1);
LocalNormStrings[1]:=StringOfChar('b',MaxBytesBIFF8);
LocalNormStrings[2]:=StringOfChar('z',MaxBytesBiff8+1); //problems should occur here
LocalNormStrings[3]:='this text should be readable'; //whatever happens, this text should be ok
TempFile:=GetTempFileName;
{// Not needed: use workbook.writetofile with overwrite=true
if fileexists(TempFile) then
DeleteFile(TempFile);
}
// Write out all test values
MyWorkbook := TsWorkbook.Create;
MyWorkSheet:=MyWorkBook.AddWorksheet(StringsSheet);
for Row := Low(LocalNormStrings) to High(LocalNormStrings) do
begin
// We could use CheckException but then you can't pass parameters
TestResult:=true;
try
MyWorkSheet.WriteUTF8Text(Row,0,LocalNormStrings[Row]);
// Some checks inside worksheet itself
ActualString:=MyWorkSheet.ReadAsUTF8Text(Row,0);
CheckEquals(length(LocalNormStrings[Row]),length(ActualString),
'Test value mismatch cell '+CellNotation(Row)+
' for string length.');
except
{ When over size limit we expect to hit this:
if TextTooLong then
Raise Exception.CreateFmt('Text value exceeds %d character limit in cell [%d,%d]. Text has been truncated.',[MaxBytes,ARow,ACol]);
}
//todo: rewrite when/if the fpspreadsheet exception class changes
on E: Exception do
begin
if Row=2 then
TestResult:=true
else
begin
TestResult:=false;
ExceptionMessage:=E.Message;
end;
end;
end;
// Notify user of exception if it happened where we didn't expect it:
CheckTrue(TestResult,'Exception: '+ExceptionMessage);
end;
TestResult:=true;
try
MyWorkBook.WriteToFile(TempFile,sfExcel8,true);
except
//todo: rewrite when/if the fpspreadsheet exception class changes
on E: Exception do
begin
if Row=2 then
TestResult:=true
else
begin
TestResult:=false;
ExceptionMessage:=E.Message;
end;
end;
end;
// Notify user of exception if it happened where we didn't expect it:
CheckTrue(TestResult,'Exception: '+ExceptionMessage);
MyWorkbook.Free;
// Open the spreadsheet, as biff8
MyWorkbook := TsWorkbook.Create;
MyWorkbook.ReadFromFile(TempFile, sfExcel8);
MyWorksheet:=GetWorksheetByName(MyWorkBook,StringsSheet);
if MyWorksheet=nil then
fail('Error in test code. Failed to get named worksheet');
// Read test data from A column & compare if written=original
for Row := Low(LocalNormStrings) to High(LocalNormStrings) do
begin
ActualString:=MyWorkSheet.ReadAsUTF8Text(Row,0);
// Allow for truncation of excessive strings by fpspreadsheet
if length(LocalNormStrings[Row])>MaxBytesBIFF8 then
CheckEquals(MaxBytesBIFF8,length(ActualString),
'Test value mismatch cell '+CellNotation(Row)+
' for string length.')
else
CheckEquals(length(LocalNormStrings[Row]),length(ActualString),
'Test value mismatch cell '+CellNotation(Row)+
' for string length.');
end;
// Finalization
MyWorkbook.Free;
DeleteFile(TempFile);
end;
procedure TSpreadReadStringTests.TestReadString(FileName: string; Row: integer);
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
ActualString: string;
begin
if Row>High(SollStrings) then
fail('Error in test code: array bounds overflow. Check array size is correct.');
// Open the spreadsheet, as biff8
MyWorkbook := TsWorkbook.Create;
MyWorkbook.ReadFromFile(FileName, sfExcel8);
MyWorksheet:=GetWorksheetByName(MyWorkBook,StringsSheet);
if MyWorksheet=nil then
fail('Error in test code: could not retrieve worksheet.');
ActualString:=MyWorkSheet.ReadAsUTF8Text(Row,0);
CheckEquals(SollStrings[Row],ActualString,'Test value mismatch '
+'cell '+CellNotation(Row));
// Finalization
MyWorkbook.Free;
end;
procedure TSpreadReadStringTests.SetUp;
begin
InitSollStrings;
end;
procedure TSpreadReadStringTests.TearDown;
begin
end;
procedure TSpreadReadStringTests.TestReadString0;
begin
TestReadString(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,0);
end;
procedure TSpreadReadStringTests.TestReadString1;
begin
TestReadString(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,1);
end;
procedure TSpreadReadStringTests.TestReadString2;
begin
TestReadString(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,2);
end;
procedure TSpreadReadStringTests.TestReadString3;
begin
TestReadString(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,3);
end;
procedure TSpreadReadStringTests.TestReadString4;
begin
TestReadString(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,4);
end;
procedure TSpreadReadStringTests.TestReadString5;
begin
TestReadString(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,5);
end;
procedure TSpreadReadStringTests.TestReadString6;
begin
TestReadString(ExtractFilePath(ParamStr(0)) + TestFileBIFF8,6);
end;
initialization
// Register so these tests are included in a full run
RegisterTest(TSpreadReadStringTests);
RegisterTest(TSpreadWriteReadStringTests);
// Initialize the norm variables in case other units want to use it:
InitSollStrings;
end.

BIN
components/fpspreadsheet/tests/testbiff8.xls Normal file
View File

Binary file not shown.

BIN
components/fpspreadsheet/tests/testbiff8_1899.xls Normal file
View File

Binary file not shown.

136
components/fpspreadsheet/tests/testdbwriter.ini Normal file
View File

@ -0,0 +1,136 @@
; testdbwriter.ini
; Database output selection for the testdbwriter fpcunit listener
; customized for fpspreadsheet tests (db names
;
; Specify the details for the connection to the database server or embedded database
; that has the database where your fpcunit test results need to be stored.
; This file contains several sections, one for each database type.
[Database]
; Select which profile you want to use:
profile=firebirdembedded
; The following sections contain the profiles you can use
; Please feel free to add/modify these:
[firebird]
; Interbase or Firebird database:
; Specify which TSQLConnection descendant you want to use - i.e. what database
; type you are using (use the spelling that the tsqlconnection uses)
type=firebird
; The name of the database:
name=/opt/firebird/data/fpspreadsheettest.fdb
; Default username/password for Interbase/Firebird
; is sysdba/masterkey. Change to your situation.
user=sysdba
password=masterkey
; hostname of the database server (or empty for embedded):
hostname=localhost
charset=UTF8
[firebirdembedded]
; Firebird embedded
; Same as Firebird, except we leave the host name blank
; and specify a db without path.
; Make sure your Firebird embedded library files (.dll/.so/.dylib)
; are installed; e.g. on Windows, you can put them in this
; directory.
type=firebird
name=fpspreadsheettest.fdb
user=sysdba
password=masterkey
hostname=
charset=UTF8
[mssql]
; MS SQL Server database:
type=mssql
name=fpspreadsheettest
user=sa
password=
hostname=127.0.0.1
[mysql40]
; MySQL 4.0 database:
type=mysql40
name=fpspreadsheettest
user=root
password=
hostname=127.0.0.1
[mysql41]
; MySQL 4.1 database:
type=mysql41
name=fpspreadsheettest
user=root
password=
hostname=127.0.0.1
[mysql50]
; MySQL 5.0 database:
type=mysql50
name=fpspreadsheettest
user=root
password=
hostname=127.0.0.1
[mysql51]
; MySQL 5.1 database:
type=mysql51
name=fpspreadsheettest
user=root
password=
hostname=127.0.0.1
[mysql55]
; MySQL 5.5 database (available since FPC 2.6.1):
type=mysql55
name=fpspreadsheettest
user=root
password=
hostname=127.0.0.1
[oracle]
; Oracle database:
; set up for a default Oracle express install
type=oracle
name=xe
user=system
password=
hostname=127.0.0.1
[odbc]
; ODBC database:
type=odbc
name=fpspreadsheettest
user=root
password=
hostname=127.0.0.1
[postgresql]
; PostgreSQL database:
type=postgresql
name=fpspreadsheettest
user=
password=
hostname=127.0.0.1
[sqlite]
; SQLite database:
type=sqlite3
name=fpspreadsheettest.db
[sybase]
; Sybase database:
type=sybase
name=fpspreadsheettest
user=sa
password=
hostname=127.0.0.1

1430
components/fpspreadsheet/tests/testdbwriter.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1
components/fpspreadsheet/tests/testdbwriter.rc Normal file
View File

@ -0,0 +1 @@
SQLSCRIPT RCDATA "testdbwriter_firebird.sql"

BIN
components/fpspreadsheet/tests/testdbwriter.res Normal file
View File

Binary file not shown.

620
components/fpspreadsheet/tests/testdbwriter_firebird.sql Normal file
View File

@ -0,0 +1,620 @@
/********************* ROLES **********************/
/********************* UDFS ***********************/
/****************** GENERATORS ********************/
CREATE GENERATOR GEN_APPLICATIONS_ID;
CREATE GENERATOR GEN_CPU_ID;
CREATE GENERATOR GEN_EXCEPTIONCLASSES_ID;
CREATE GENERATOR GEN_EXCEPTIONMESSAGES_ID;
CREATE GENERATOR GEN_METHODNAMES_ID;
CREATE GENERATOR GEN_OS_ID;
CREATE GENERATOR GEN_RESULTVALUES_ID;
CREATE GENERATOR GEN_SOURCELOCATIONS_ID;
CREATE GENERATOR GEN_SOURCEUNITS_ID;
CREATE GENERATOR GEN_TESTRESULTS_ID;
CREATE GENERATOR GEN_TESTRUNS_ID;
CREATE GENERATOR GEN_TESTSUITES_ID;
CREATE GENERATOR GEN_TESTS_ID;
/******************** DOMAINS *********************/
/******************* PROCEDURES ******************/
SET TERM ^ ;
CREATE PROCEDURE RECALCINDEXES
AS
BEGIN SUSPEND; END^
SET TERM ; ^
/******************** TABLES **********************/
CREATE TABLE APPLICATIONS
(
ID INTEGER NOT NULL,
NAME VARCHAR(800) NOT NULL,
CONSTRAINT APPPK PRIMARY KEY (ID),
CONSTRAINT APPNAMEUNIQ UNIQUE (NAME)
);
CREATE TABLE CPU
(
ID INTEGER NOT NULL,
CPUNAME VARCHAR(128) NOT NULL,
CONSTRAINT CPUPK PRIMARY KEY (ID),
CONSTRAINT CPUUNIQUE UNIQUE (CPUNAME)
);
CREATE TABLE EXCEPTIONCLASSES
(
ID INTEGER NOT NULL,
EXCEPTIONCLASS VARCHAR(128) NOT NULL,
CONSTRAINT EXCEPTIONSPK PRIMARY KEY (ID),
CONSTRAINT UNQ_EXCEPTIONCLASSES_CLASS UNIQUE (EXCEPTIONCLASS)
);
CREATE TABLE EXCEPTIONMESSAGES
(
ID INTEGER NOT NULL,
EXCEPTIONCLASS INTEGER NOT NULL,
EXCEPTIONMESSAGE VARCHAR(800) NOT NULL,
CONSTRAINT EXCEPTIONMESSAGESPK PRIMARY KEY (ID),
CONSTRAINT EXCEPTIONMESSAGEUNIQUE UNIQUE (EXCEPTIONMESSAGE)
);
CREATE TABLE METHODNAMES
(
ID INTEGER NOT NULL,
NAME VARCHAR(128) NOT NULL,
CONSTRAINT METHODNAMESPK PRIMARY KEY (ID),
CONSTRAINT METHODNAMESUNIQUENAME UNIQUE (NAME)
);
CREATE TABLE OPTIONS
(
OPTIONNAME VARCHAR(255) NOT NULL,
OPTIONVALUE VARCHAR(255),
REMARKS VARCHAR(255),
CONSTRAINT OPTIONSPK PRIMARY KEY (OPTIONNAME)
);
CREATE TABLE OS
(
ID INTEGER NOT NULL,
OSNAME VARCHAR(128) NOT NULL,
CONSTRAINT OSPK PRIMARY KEY (ID),
CONSTRAINT OSUNIQUE UNIQUE (OSNAME)
);
CREATE TABLE RESULTVALUES
(
ID INTEGER NOT NULL,
NAME VARCHAR(64) NOT NULL,
CONSTRAINT RESULTVALUESPK PRIMARY KEY (ID),
CONSTRAINT UNQ_RESULTVALUES_NAME UNIQUE (NAME)
);
CREATE TABLE SOURCELOCATIONS
(
ID INTEGER NOT NULL,
SOURCEUNIT INTEGER NOT NULL,
LINE INTEGER,
CONSTRAINT SOURCELOCATIONSPK PRIMARY KEY (ID),
CONSTRAINT SOURCELOCATIONSUNIQUE UNIQUE (SOURCEUNIT,LINE)
);
CREATE TABLE SOURCEUNITS
(
ID INTEGER NOT NULL,
NAME VARCHAR(128) NOT NULL,
CONSTRAINT SOURCEUNITS_PK PRIMARY KEY (ID),
CONSTRAINT SOURCEUNITS_NAME_UNIQUE UNIQUE (NAME)
);
CREATE TABLE TESTRESULTS
(
ID INTEGER NOT NULL,
TESTRUN INTEGER NOT NULL,
TEST INTEGER NOT NULL,
RESULTVALUE INTEGER,
EXCEPTIONMESSAGE INTEGER,
METHODNAME INTEGER,
SOURCELOCATION INTEGER,
RESULTCOMMENT VARCHAR(800),
ELAPSEDTIME TIME,
CONSTRAINT TESTRESULTSPK PRIMARY KEY (ID)
);
CREATE TABLE TESTRUNS
(
ID INTEGER NOT NULL,
DATETIMERAN TIMESTAMP,
APPLICATIONID INTEGER,
CPU INTEGER,
OS INTEGER,
REVISIONID VARCHAR(64),
RUNCOMMENT VARCHAR(800),
TOTALELAPSEDTIME TIME,
CONSTRAINT TESTRUNSPK PRIMARY KEY (ID)
);
CREATE TABLE TESTS
(
ID INTEGER NOT NULL,
TESTSUITE INTEGER NOT NULL,
NAME VARCHAR(128) NOT NULL,
CONSTRAINT TESTSPK PRIMARY KEY (ID),
CONSTRAINT UNQ_TESTS UNIQUE (TESTSUITE,NAME)
);
CREATE TABLE TESTSUITES
(
ID INTEGER NOT NULL,
PARENTSUITE INTEGER,
NAME VARCHAR(128) NOT NULL,
DEPTH INTEGER,
CONSTRAINT TESTSUITESPK PRIMARY KEY (ID),
CONSTRAINT UNQ_TESTSUITES_NAMEPAR UNIQUE (PARENTSUITE,NAME)
);
/********************* VIEWS **********************/
CREATE VIEW TESTSUITESFLAT (TESTSUITEID, TESTSUITENAME, DEPTH)
AS
with recursive suite_tree as (
select id as testsuiteid, name as testsuitename, depth from TESTSUITES
where parentsuite is null
union all
select chi.id as testsuiteid, par.testsuitename||'/'||chi.name as testsuitename, chi.depth from testsuites chi
join suite_tree par on chi.parentsuite=par.testsuiteid
)
select testsuiteid,testsuitename,depth from suite_tree;
CREATE VIEW FLAT (TESTRUNID, TESTRESULTID, TESTID, APPLICATION, REVISIONID, RUNCOMMENT, TESTRUNDATE, OS, CPU, TESTSUITE, TESTSUITEDEPTH, TESTNAME, TESTRESULT, EXCEPTIONCLASS, EXCEPTIONMESSAGE, METHOD, SOURCELINE, SOURCEUNIT, ELAPSEDTIME)
AS
SELECT
R.ID as TESTRUNID,
TR.ID as TESTRESULTID,
T.ID as TESTID,
AP.NAME as APPLICATION,
R.REVISIONID,
R.RUNCOMMENT,
R.DATETIMERAN as TESTRUNDATE,
OS.OSNAME,
CP.CPUNAME,
S.TESTSUITENAME as TESTSUITE,
S.DEPTH as TESTSUITEDEPTH,
T.NAME as TESTNAME,
RV.NAME as RESULT,
E.EXCEPTIONCLASS,
EM.EXCEPTIONMESSAGE as EXCEPTIONMESSAGE,
M.NAME as METHOD,
SL.LINE as SOURCELINE,
SU.NAME as SOURCEUNIT,
TR.ELAPSEDTIME as ELAPSEDTIME
FROM TESTRUNS R inner join TESTRESULTS TR on R.ID=TR.TESTRUN
inner join TESTS T on TR.TEST=T.ID
inner join TESTSUITESFLAT S on T.TESTSUITE=S.TESTSUITEID
inner join RESULTVALUES RV on TR.RESULTVALUE=RV.ID
left join APPLICATIONS AP on R.APPLICATIONID=AP.ID
left join
EXCEPTIONMESSAGES EM on TR.EXCEPTIONMESSAGE=EM.ID
left join EXCEPTIONCLASSES E on EM.EXCEPTIONCLASS=E.ID
left join METHODNAMES M on TR.METHODNAME=M.ID
left join SOURCELOCATIONS SL on TR.SOURCELOCATION=SL.ID
left join SOURCEUNITS SU on SL.SOURCEUNIT=SU.ID
left join OS on R.OS=OS.ID
left join CPU CP on R.CPU=CP.ID;
CREATE VIEW FLATSORTED (TESTRUNID, TESTRESULTID, TESTID, APPLICATION, REVISIONID, RUNCOMMENT, TESTRUNDATE, OS, CPU, TESTSUITE, TESTSUITEDEPTH, TESTNAME, TESTRESULT, EXCEPTIONCLASS, EXCEPTIONMESSAGE, METHOD, SOURCELINE, SOURCEUNIT)
AS
select
f.TESTRUNID, f.TESTRESULTID, f.TESTID,
f.APPLICATION, f.REVISIONID,
f.RUNCOMMENT, f.TESTRUNDATE, f.OS, f.CPU,
f.TESTSUITE, f.TESTSUITEDEPTH, f.TESTNAME, f.TESTRESULT,
f.EXCEPTIONCLASS, f.EXCEPTIONMESSAGE,
f.METHOD, f.SOURCELINE, f.SOURCEUNIT from
flat f
order by f.TESTRUNDATE desc, f.application, f.revisionid, f.TESTSUITEDEPTH, f.TESTSUITE, f.TESTNAME;
CREATE VIEW LASTFAILURE (APPLICATIONID, OSID, CPUID, TESTID, LASTFAILURE)
AS
SELECT tr.applicationid, tr.os, tr.cpu, r.test,
max(cast(tr.revisionid as integer)) lastsuccess
FROM testresults r inner join resultvalues rv
on r.RESULTVALUE=rv.id
inner join testruns tr
on r.testrun=tr.ID
where (rv.name='Failed') or (rv.name='Error')
group by tr.applicationid, tr.os, tr.cpu, r.test;
CREATE VIEW LASTSUCCESS (APPLICATIONID, OSID, CPUID, TESTID, LASTSUCCESS)
AS
SELECT tr.applicationid, tr.os, tr.cpu, r.test,
max(cast(tr.revisionid as integer)) lastsuccess
FROM testresults r inner join resultvalues rv
on r.RESULTVALUE=rv.id
inner join testruns tr
on r.testrun=tr.ID
where rv.name='OK'
group by tr.applicationid, tr.os, tr.cpu, r.test;
CREATE VIEW OKRESULTS (RUNID, APPLICATION, OS, CPU, OKCOUNT, OKPERCENTAGE)
AS
SELECT run.id, a.name, o.osname, c.cpuname, count(rv.name),
((count(tr.resultvalue))*100)/(SELECT COUNT(resultvalue) FROM testresults where testresults.testrun=run.id)
from
testresults tr inner join
testruns run on tr.TESTRUN=run.id inner JOIN
resultvalues rv on tr.resultvalue=rv.id
inner join applications a on run.applicationid=a.ID
inner join cpu c on run.cpu=c.ID
inner join os o on run.os=o.id
group by run.id, a.name, o.osname, c.cpuname, rv.name
having rv.name='OK';
CREATE VIEW REGRESSIONS (APPLICATIONID, CPUID, OSID, TESTID, LASTSUCCESFULREVISION)
AS
select
s.applicationid, s.cpuid, s.osid, s.testid, s.lastsuccess as lastsuccessfulrevision
from
lastfailure f inner join lastsuccess s on
(f.osid=s.osid) and
(f.cpuid=s.cpuid) and
(f.applicationid=s.applicationid) and (f.testid=s.testid)
where f.lastfailure>s.lastsuccess;
CREATE VIEW REGRESSIONSFLAT (TESTRUNID, APPLICATION, LASTSUCCESFULREVISION, TESTRUNDATE, OS, CPU, TESTSUITE, TESTNAME)
AS
select
run.id,
a.NAME,
r.LASTSUCCESFULREVISION,
run.DATETIMERAN,
o.OSNAME,
c.CPUNAME,
ts.TESTSUITENAME,
t.NAME
from
regressions r inner join testresults tr on
(r.testid=tr.test)
inner join testruns run on
(r.applicationid=run.APPLICATIONID) AND
(r.osid=run.os) AND
(r.cpuid=run.cpu) AND
(tr.testrun=run.id) AND
(r.lastsuccesfulrevision=run.revisionid)
inner join applications a on run.applicationid=a.ID
inner join cpu c on run.cpu=c.ID
inner join os o on run.os=o.id
inner join tests t on tr.test=t.ID
inner join TESTSUITESFLAT ts on t.TESTSUITE=ts.TESTSUITEID;
/******************* EXCEPTIONS *******************/
/******************** TRIGGERS ********************/
SET TERM ^ ;
CREATE TRIGGER APPLICATIONS_BI FOR APPLICATIONS ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_APPLICATIONS_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_APPLICATIONS_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_APPLICATIONS_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
CREATE TRIGGER CPU_BI FOR CPU ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_CPU_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_CPU_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_CPU_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
CREATE TRIGGER EXCEPTIONCLASSES_BI FOR EXCEPTIONCLASSES ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_EXCEPTIONCLASSES_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_EXCEPTIONCLASSES_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_EXCEPTIONCLASSES_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
CREATE TRIGGER EXCEPTIONMESSAGES_BI FOR EXCEPTIONMESSAGES ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_EXCEPTIONMESSAGES_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_EXCEPTIONMESSAGES_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_EXCEPTIONMESSAGES_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
CREATE TRIGGER METHODNAMES_BI FOR METHODNAMES ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_METHODNAMES_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_METHODNAMES_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_METHODNAMES_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
CREATE TRIGGER OS_BI FOR OS ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_OS_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_OS_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_OS_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
CREATE TRIGGER RESULTVALUES_BI FOR RESULTVALUES ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_RESULTVALUES_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_RESULTVALUES_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_RESULTVALUES_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
CREATE TRIGGER SOURCELOCATIONS_BI FOR SOURCELOCATIONS ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_SOURCELOCATIONS_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_SOURCELOCATIONS_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_SOURCELOCATIONS_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
CREATE TRIGGER SOURCEUNITS_BI FOR SOURCEUNITS ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_SOURCEUNITS_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_SOURCEUNITS_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_SOURCEUNITS_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
CREATE TRIGGER TESTRESULTS_BI FOR TESTRESULTS ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_TESTRESULTS_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_TESTRESULTS_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_TESTRESULTS_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
CREATE TRIGGER TESTRUNS_BI FOR TESTRUNS ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_TESTRUNS_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_TESTRUNS_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_TESTRUNS_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
CREATE TRIGGER TESTSUITES_BI FOR TESTSUITES ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_TESTSUITES_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_TESTSUITES_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_TESTSUITES_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
CREATE TRIGGER TESTS_BI FOR TESTS ACTIVE
BEFORE INSERT POSITION 0
AS
DECLARE VARIABLE tmp DECIMAL(18,0);
BEGIN
IF (NEW.ID IS NULL) THEN
NEW.ID = GEN_ID(GEN_TESTS_ID, 1);
ELSE
BEGIN
tmp = GEN_ID(GEN_TESTS_ID, 0);
if (tmp < new.ID) then
tmp = GEN_ID(GEN_TESTS_ID, new.ID-tmp);
END
END^
SET TERM ; ^
SET TERM ^ ;
ALTER PROCEDURE RECALCINDEXES
AS
declare variable index_name VARCHAR(31);
BEGIN
for select RDB$INDEX_NAME from RDB$INDICES into :index_name do
execute statement 'SET statistics INDEX ' || :index_name || ';';
END^
SET TERM ; ^
UPDATE RDB$PROCEDURES set
RDB$DESCRIPTION = 'Recalculates index selectivity for all tables. This is normally only done during backup/restore etc, and can be useful after adding or removing a lot of data.'
where RDB$PROCEDURE_NAME = 'RECALCINDEXES';
ALTER TABLE EXCEPTIONMESSAGES ADD CONSTRAINT FK_EXCEPTIONCLASSES_CLASS
FOREIGN KEY (EXCEPTIONCLASS) REFERENCES EXCEPTIONCLASSES (ID) ON UPDATE CASCADE ON DELETE CASCADE;
UPDATE RDB$RELATIONS set
RDB$DESCRIPTION = 'Stores schema version and any application-specific options.'
where RDB$RELATION_NAME = 'OPTIONS';
ALTER TABLE SOURCELOCATIONS ADD CONSTRAINT SOURCELOCATIONSFK_UNIT
FOREIGN KEY (SOURCEUNIT) REFERENCES SOURCEUNITS (ID) ON UPDATE CASCADE ON DELETE CASCADE;
UPDATE RDB$RELATION_FIELDS set RDB$DESCRIPTION = 'Name of the pascal unit' where RDB$FIELD_NAME = 'NAME' and RDB$RELATION_NAME = 'SOURCEUNITS';
UPDATE RDB$RELATIONS set
RDB$DESCRIPTION = 'Pascal units where errrors occurred'
where RDB$RELATION_NAME = 'SOURCEUNITS';
UPDATE RDB$RELATION_FIELDS set RDB$DESCRIPTION = 'Note: let''s not use COMMENT as it is reserved in Firebird' where RDB$FIELD_NAME = 'RESULTCOMMENT' and RDB$RELATION_NAME = 'TESTRESULTS';
ALTER TABLE TESTRESULTS ADD CONSTRAINT FK_TESTRES_EXCEPTION
FOREIGN KEY (EXCEPTIONMESSAGE) REFERENCES EXCEPTIONMESSAGES (ID) ON UPDATE CASCADE ON DELETE CASCADE;
ALTER TABLE TESTRESULTS ADD CONSTRAINT FK_TESTRES_RESULT
FOREIGN KEY (RESULTVALUE) REFERENCES RESULTVALUES (ID) ON UPDATE CASCADE ON DELETE CASCADE;
ALTER TABLE TESTRESULTS ADD CONSTRAINT FK_TESTRES_SOURCELOCATION
FOREIGN KEY (SOURCELOCATION) REFERENCES SOURCELOCATIONS (ID) ON UPDATE CASCADE ON DELETE CASCADE;
ALTER TABLE TESTRESULTS ADD CONSTRAINT FK_TESTRES_TEST
FOREIGN KEY (TEST) REFERENCES TESTS (ID) ON UPDATE CASCADE ON DELETE CASCADE;
ALTER TABLE TESTRESULTS ADD CONSTRAINT FK_TESTRES_TESTRUN
FOREIGN KEY (TESTRUN) REFERENCES TESTRUNS (ID) ON UPDATE CASCADE ON DELETE CASCADE;
ALTER TABLE TESTRESULTS ADD CONSTRAINT FK_TESTSRES_METHODNAME
FOREIGN KEY (METHODNAME) REFERENCES METHODNAMES (ID) ON UPDATE CASCADE ON DELETE CASCADE;
UPDATE RDB$RELATION_FIELDS set RDB$DESCRIPTION = 'Identifies operating system the test application runs on' where RDB$FIELD_NAME = 'OS' and RDB$RELATION_NAME = 'TESTRUNS';
UPDATE RDB$RELATION_FIELDS set RDB$DESCRIPTION = 'String that uniquely identifies the revision/version of the code that is tested. Useful when running regression tests, identifying when an error occurred first etc.' where RDB$FIELD_NAME = 'REVISIONID' and RDB$RELATION_NAME = 'TESTRUNS';
UPDATE RDB$RELATION_FIELDS set RDB$DESCRIPTION = 'Comment provided by user/test run suite on this test run (e.g. used compiler flags)' where RDB$FIELD_NAME = 'RUNCOMMENT' and RDB$RELATION_NAME = 'TESTRUNS';
ALTER TABLE TESTRUNS ADD CONSTRAINT FK_TESTRUNSCPU
FOREIGN KEY (CPU) REFERENCES CPU (ID) ON UPDATE CASCADE ON DELETE CASCADE;
ALTER TABLE TESTRUNS ADD CONSTRAINT FK_TESTRUNSOS
FOREIGN KEY (OS) REFERENCES OS (ID) ON UPDATE CASCADE ON DELETE CASCADE;
ALTER TABLE TESTRUNS ADD CONSTRAINT FK_TESTRUNS_APPLICATIONS
FOREIGN KEY (APPLICATIONID) REFERENCES APPLICATIONS (ID) ON UPDATE CASCADE ON DELETE CASCADE;
CREATE INDEX IDX_TESTRUNSCOMM ON TESTRUNS (RUNCOMMENT);
CREATE DESCENDING INDEX IDX_TESTRUNSDTREV ON TESTRUNS (DATETIMERAN);
CREATE INDEX IDX_TESTRUNSREV ON TESTRUNS (REVISIONID);
UPDATE RDB$RELATIONS set
RDB$DESCRIPTION = 'Represents a run by a single program of one or more testsuites'
where RDB$RELATION_NAME = 'TESTRUNS';
ALTER TABLE TESTS ADD CONSTRAINT TESTSTESTSUITESFK
FOREIGN KEY (TESTSUITE) REFERENCES TESTSUITES (ID) ON UPDATE CASCADE ON DELETE CASCADE;
UPDATE RDB$RELATIONS set
RDB$DESCRIPTION = 'Name and testsuite (hierarchy) for a specific test.
This table uniquely identifies tests, no need to add joins to testsuite.'
where RDB$RELATION_NAME = 'TESTS';
UPDATE RDB$RELATION_FIELDS set RDB$DESCRIPTION = 'Level in the hierarchy this testsuite has.' where RDB$FIELD_NAME = 'DEPTH' and RDB$RELATION_NAME = 'TESTSUITES';
ALTER TABLE TESTSUITES ADD CONSTRAINT FK_TESTSUITES_PARENT
FOREIGN KEY (PARENTSUITE) REFERENCES TESTSUITES (ID) ON UPDATE CASCADE ON DELETE CASCADE;
UPDATE RDB$RELATIONS set
RDB$DESCRIPTION = 'Flattens the hierarchical tree of the testsuites and displays the name much like a path, including it depth in the hierarchy, for display and selection purposes.'
where RDB$RELATION_NAME = 'TESTSUITESFLAT';
GRANT EXECUTE
ON PROCEDURE RECALCINDEXES TO SYSDBA;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON APPLICATIONS TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON CPU TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON EXCEPTIONCLASSES TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON EXCEPTIONMESSAGES TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON METHODNAMES TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON OPTIONS TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON OS TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON RESULTVALUES TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON SOURCELOCATIONS TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON SOURCEUNITS TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON TESTRESULTS TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON TESTRUNS TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON TESTS TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON TESTSUITES TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON FLAT TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON FLATSORTED TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON LASTFAILURE TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON LASTSUCCESS TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON OKRESULTS TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON REGRESSIONS TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON REGRESSIONSFLAT TO SYSDBA WITH GRANT OPTION;
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON TESTSUITESFLAT TO SYSDBA WITH GRANT OPTION;

222
components/fpspreadsheet/tests/testdbwriter_postgresql.sql Normal file
View File

@ -0,0 +1,222 @@
CREATE TABLE APPLICATIONS
(
ID serial NOT NULL,
NAME VARCHAR(800),
CONSTRAINT APPPK PRIMARY KEY (ID),
CONSTRAINT APPNAMEUNIQ UNIQUE (NAME)
);
CREATE TABLE CPU
(
ID serial NOT NULL,
CPUNAME VARCHAR(255),
CONSTRAINT CPUPK PRIMARY KEY (ID),
CONSTRAINT CPUUNIQUE UNIQUE (CPUNAME)
);
CREATE TABLE EXCEPTIONCLASSES
(
ID serial NOT NULL,
EXCEPTIONCLASS VARCHAR(800),
CONSTRAINT EXCEPTIONSPK PRIMARY KEY (ID),
CONSTRAINT UNQ_EXCEPTIONCLASSES_CLASS UNIQUE (EXCEPTIONCLASS)
);
CREATE TABLE EXCEPTIONMESSAGES
(
ID serial NOT NULL,
EXCEPTIONCLASS INTEGER,
EXCEPTIONMESSAGE VARCHAR(800),
CONSTRAINT EXCEPTIONMESSAGESPK PRIMARY KEY (ID),
CONSTRAINT EXCEPTIONMESSAGEUNIQUE UNIQUE (EXCEPTIONMESSAGE)
);
CREATE TABLE METHODNAMES
(
ID serial NOT NULL,
NAME VARCHAR(800),
CONSTRAINT METHODNAMESPK PRIMARY KEY (ID),
CONSTRAINT METHODNAMESUNIQUENAME UNIQUE (NAME)
);
CREATE TABLE OPTIONS
(
OPTIONNAME VARCHAR(255) NOT NULL,
OPTIONVALUE VARCHAR(255),
REMARKS VARCHAR(255),
CONSTRAINT OPTIONSPK PRIMARY KEY (OPTIONNAME)
);
CREATE TABLE OS
(
ID serial NOT NULL,
OSNAME VARCHAR(255),
CONSTRAINT OSPK PRIMARY KEY (ID),
CONSTRAINT OSUNIQUE UNIQUE (OSNAME)
);
CREATE TABLE RESULTVALUES
(
ID serial NOT NULL,
NAME VARCHAR(800),
CONSTRAINT RESULTVALUESPK PRIMARY KEY (ID),
CONSTRAINT UNQ_RESULTVALUES_NAME UNIQUE (NAME)
);
CREATE TABLE SOURCELOCATIONS
(
ID serial NOT NULL,
SOURCEUNIT INTEGER,
LINE INTEGER,
CONSTRAINT SOURCELOCATIONSPK PRIMARY KEY (ID),
CONSTRAINT SOURCELOCATIONSUNIQUE UNIQUE (SOURCEUNIT,LINE)
);
CREATE TABLE SOURCEUNITS
(
ID serial NOT NULL,
NAME VARCHAR(800),
CONSTRAINT SOURCEUNITS_PK PRIMARY KEY (ID),
CONSTRAINT SOURCEUNITS_NAME_UNIQUE UNIQUE (NAME)
);
CREATE TABLE TESTS
(
ID serial NOT NULL,
TESTSUITE INTEGER,
NAME VARCHAR(800),
CONSTRAINT TESTSPK PRIMARY KEY (ID),
CONSTRAINT UNQ_TESTS_SUITENAME UNIQUE (TESTSUITE,NAME)
);
CREATE TABLE TESTRUNS
(
ID serial NOT NULL,
DATETIMERAN TIMESTAMP,
APPLICATIONID INTEGER,
CPU INTEGER,
OS INTEGER,
REVISIONID VARCHAR(800),
RUNCOMMENT VARCHAR(800),
TOTALELAPSEDTIME TIME,
CONSTRAINT TESTRUNSPK PRIMARY KEY (ID)
);
CREATE TABLE TESTRESULTS
(
ID serial NOT NULL,
TESTRUN INTEGER,
TEST INTEGER,
RESULTVALUE INTEGER,
EXCEPTIONMESSAGE INTEGER,
METHODNAME INTEGER,
SOURCELOCATION INTEGER,
RESULTCOMMENT VARCHAR(800),
ELAPSEDTIME TIME,
CONSTRAINT TESTRESULTSPK PRIMARY KEY (ID)
);
CREATE TABLE TESTSUITES
(
ID serial NOT NULL,
PARENTSUITE INTEGER,
NAME VARCHAR(800),
DEPTH INTEGER,
CONSTRAINT TESTSUITESPK PRIMARY KEY (ID),
CONSTRAINT UNQ_TESTSUITES_NAMEPAR UNIQUE (PARENTSUITE,NAME)
);
CREATE VIEW TESTSUITESFLAT (TESTSUITEID, TESTSUITENAME, DEPTH)
AS
with recursive suite_tree as (
select id as testsuiteid, ''||name as testsuitename, depth from TESTSUITES
where parentsuite is null
-- to do: find a better way to cast testsuitename from varchar(800) to character varying without limits
union all
select chi.id as testsuiteid, par.testsuitename||'/'||chi.name as testsuitename, chi.depth from testsuites chi
join suite_tree par on chi.parentsuite=par.testsuiteid
)
select testsuiteid,testsuitename,depth from suite_tree;
CREATE VIEW FLAT (TESTRUNID, TESTRESULTID, TESTID, APPLICATION, REVISIONID, RUNCOMMENT, TESTRUNDATE, OS, CPU, TESTSUITE, TESTSUITEDEPTH, TESTNAME, TESTRESULT, EXCEPTIONCLASS, EXCEPTIONMESSAGE, METHOD, SOURCELINE, SOURCEUNIT, ELAPSEDTIME)
AS
SELECT
R.ID as TESTRUNID,
TR.ID as TESTRESULTID,
T.ID as TESTID,
AP.NAME as APPLICATION,
R.REVISIONID,
R.RUNCOMMENT,
R.DATETIMERAN as TESTRUNDATE,
OS.OSNAME,
CP.CPUNAME,
S.TESTSUITENAME as TESTSUITE,
S.DEPTH as TESTSUITEDEPTH,
T.NAME as TESTNAME,
RV.NAME as RESULT,
E.EXCEPTIONCLASS,
EM.EXCEPTIONMESSAGE as EXCEPTIONMESSAGE,
M.NAME as METHOD,
SL.LINE as SOURCELINE,
SU.NAME as SOURCEUNIT,
TR.ELAPSEDTIME as ELAPSEDTIME
FROM TESTRUNS R inner join TESTRESULTS TR on R.ID=TR.TESTRUN
inner join TESTS T on TR.TEST=T.ID
inner join TESTSUITESFLAT S on T.TESTSUITE=S.TESTSUITEID
inner join RESULTVALUES RV on TR.RESULTVALUE=RV.ID
left join APPLICATIONS AP on R.APPLICATIONID=AP.ID
left join
EXCEPTIONMESSAGES EM on TR.EXCEPTIONMESSAGE=EM.ID
left join EXCEPTIONCLASSES E on EM.EXCEPTIONCLASS=E.ID
left join METHODNAMES M on TR.METHODNAME=M.ID
left join SOURCELOCATIONS SL on TR.SOURCELOCATION=SL.ID
left join SOURCEUNITS SU on SL.SOURCEUNIT=SU.ID
left join OS on R.OS=OS.ID
left join CPU CP on R.CPU=CP.ID;
CREATE VIEW FLATSORTED (TESTRUNID, TESTRESULTID, TESTID, APPLICATION, REVISIONID, RUNCOMMENT, TESTRUNDATE, OS, CPU, TESTSUITE, TESTSUITEDEPTH, TESTNAME, TESTRESULT, EXCEPTIONCLASS, EXCEPTIONMESSAGE, METHOD, SOURCELINE, SOURCEUNIT)
AS
select
f.TESTRUNID, f.TESTRESULTID, f.TESTID,
f.APPLICATION, f.REVISIONID,
f.RUNCOMMENT, f.TESTRUNDATE, f.OS, f.CPU,
f.TESTSUITE, f.TESTSUITEDEPTH, f.TESTNAME, f.TESTRESULT,
f.EXCEPTIONCLASS, f.EXCEPTIONMESSAGE,
f.METHOD, f.SOURCELINE, f.SOURCEUNIT from
flat f
order by f.TESTRUNDATE desc, f.application, f.revisionid, f.TESTSUITEDEPTH, f.TESTSUITE, f.TESTNAME;
ALTER TABLE EXCEPTIONMESSAGES ADD CONSTRAINT FK_EXCEPTIONCLASSES_CLASS
FOREIGN KEY (EXCEPTIONCLASS) REFERENCES EXCEPTIONCLASSES (ID) ON UPDATE
CASCADE ON DELETE CASCADE;
ALTER TABLE SOURCELOCATIONS ADD CONSTRAINT SOURCELOCATIONSFK_UNIT
FOREIGN KEY (SOURCEUNIT) REFERENCES SOURCEUNITS (ID) ON UPDATE CASCADE ON
DELETE CASCADE;
ALTER TABLE TESTS ADD CONSTRAINT TESTSTESTSUITESFK
FOREIGN KEY (TESTSUITE) REFERENCES TESTSUITES (ID) ON UPDATE CASCADE
ON DELETE CASCADE;
ALTER TABLE TESTRUNS ADD CONSTRAINT FK_TESTRUNSCPU
FOREIGN KEY (CPU) REFERENCES CPU (ID) ON UPDATE CASCADE ON DELETE CASCADE;
ALTER TABLE TESTRUNS ADD CONSTRAINT FK_TESTRUNSOS
FOREIGN KEY (OS) REFERENCES OS (ID) ON UPDATE CASCADE ON DELETE CASCADE;
ALTER TABLE TESTRUNS ADD CONSTRAINT FK_TESTRUNS_APPLICATIONS
FOREIGN KEY (APPLICATIONID) REFERENCES APPLICATIONS (ID) ON UPDATE CASCADE ON DELETE CASCADE;
ALTER TABLE TESTRESULTS ADD CONSTRAINT FK_TESTRES_EXCEPTION
FOREIGN KEY (EXCEPTIONMESSAGE) REFERENCES EXCEPTIONMESSAGES (ID) ON UPDATE
CASCADE ON DELETE CASCADE;
ALTER TABLE TESTRESULTS ADD CONSTRAINT FK_TESTRES_METHODNAME
FOREIGN KEY (METHODNAME) REFERENCES METHODNAMES (ID) ON UPDATE CASCADE ON
DELETE CASCADE;
ALTER TABLE TESTRESULTS ADD CONSTRAINT FK_TESTRES_RESULT
FOREIGN KEY (RESULTVALUE) REFERENCES RESULTVALUES (ID) ON UPDATE CASCADE
ON DELETE CASCADE;
ALTER TABLE TESTRESULTS ADD CONSTRAINT FK_TESTRES_SOURCELOC
FOREIGN KEY (SOURCELOCATION) REFERENCES SOURCELOCATIONS (ID) ON UPDATE
CASCADE ON DELETE CASCADE;
ALTER TABLE TESTRESULTS ADD CONSTRAINT FK_TESTRES_TEST
FOREIGN KEY (TEST) REFERENCES TESTS (ID) ON UPDATE CASCADE ON
DELETE CASCADE;
ALTER TABLE TESTRESULTS ADD CONSTRAINT FK_TESTRES_TESTRUN
FOREIGN KEY (TESTRUN) REFERENCES TESTRUNS (ID) ON UPDATE CASCADE ON DELETE
CASCADE;
ALTER TABLE TESTSUITES ADD CONSTRAINT FK_TESTSUITES_PARENT
FOREIGN KEY (PARENTSUITE) REFERENCES TESTSUITES (ID) ON UPDATE CASCADE ON DELETE CASCADE;
COMMENT ON TABLE options
IS 'Stores schema version and any application-specific options.';
COMMENT ON TABLE sourceunits
IS 'Pascal units where errrors occurred';
COMMENT ON COLUMN testruns.revisionid IS 'String that uniquely identifies
the revision/version of the code that is tested. Useful when running
regression tests, identifying when an error occurred first etc.';
COMMENT ON COLUMN testruns.runcomment IS 'Comment provided by user/test run
suite on this test run (e.g. used compiler flags)';
COMMENT ON COLUMN tests.name IS 'Identifies both the name (and following
the FK), the test suite. This means that multiple test suites with the same
test name text are allowed.';

68
components/fpspreadsheet/tests/testsutility.pas Normal file
View File

@ -0,0 +1,68 @@
unit testsutility;
{ Utility unit with general functions for tests,
e.g. getting temporary files }
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpspreadsheet;
const
TestFileBIFF8='testbiff8.xls'; //with 1904 datemode date system
TestFileBIFF8_1899='testbiff8_1899.xls'; //with 1899/1900 datemode date system
TestFileManual='testmanual.xls';
DatesSheet = 'Dates'; //worksheet name
FormulasSheet = 'Formulas'; //worksheet name
ManualSheet = 'ManualTests'; //worksheet names
NumbersSheet = 'Numbers'; //worksheet name
StringsSheet = 'Texts'; //worksheet name
// Returns an A.. notation based on row (e.g. A1).
// Useful as all test values should be put in the A column of the spreadsheet
function CellNotation(Row: integer): string;
// Note: using this function instead of GetWorkSheetByName for compatibility with
// older fpspreadsheet versions that don't have that function
function GetWorksheetByName(AWorkBook: TsWorkBook; AName: String): TsWorksheet;
implementation
function GetWorksheetByName(AWorkBook: TsWorkBook; AName: String): TsWorksheet;
var
i:integer;
Worksheets: cardinal;
begin
Result := nil;
if AWorkBook=nil then
exit;
Worksheets:=AWorkBook.GetWorksheetCount;
try
for i:=0 to Worksheets-1 do
begin
if AWorkBook.GetWorksheetByIndex(i).Name=AName then
begin
Result := AWorkBook.GetWorksheetByIndex(i);
exit;
end;
end;
except
Result := nil; //e.g. Getworksheetbyindex unexpectedly gave nil
exit;
end;
end;
function CellNotation(Row: integer): string;
begin
// From 0-based to Excel A1 notation
// Note: we're only testing in the A column, that's why we hardcode the value
result:=DatesSheet+'!A'+inttostr(Row+1);
end;
end.

46
components/fpspreadsheet/xlsbiff2.pas
View File

@ -67,8 +67,8 @@ type
{ Record writing methods }
procedure WriteBOF(AStream: TStream);
procedure WriteEOF(AStream: TStream);
procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Word; const AFormula: TsRPNFormula; ACell: PCell); override;
procedure WriteLabel(AStream: TStream; const ARow, ACol: Word; const AValue: string; ACell: PCell); override;
procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell); override;
procedure WriteLabel(AStream: TStream; const ARow, ACol: Cardinal; const AValue: string; ACell: PCell); override;
procedure WriteNumber(AStream: TStream; const ARow, ACol: Cardinal; const AValue: double; ACell: PCell); override;
end;
@ -108,19 +108,31 @@ begin
fekSub: Result := INT_EXCEL_TOKEN_TSUB;
fekDiv: Result := INT_EXCEL_TOKEN_TDIV;
fekMul: Result := INT_EXCEL_TOKEN_TMUL;
{ Build-in functions }
{ Built-in/worksheet functions }
fekABS:
begin
Result := INT_EXCEL_TOKEN_FUNCVAR_V;
AParamsNum := 1;
AFuncNum := INT_EXCEL_SHEET_FUNC_ABS;
end;
fekDATE:
begin
Result := INT_EXCEL_TOKEN_FUNCVAR_V;
AParamsNum := 3;
AFuncNum := INT_EXCEL_SHEET_FUNC_DATE;
end;
fekROUND:
begin
Result := INT_EXCEL_TOKEN_FUNCVAR_V;
AParamsNum := 2;
AFuncNum := INT_EXCEL_SHEET_FUNC_ROUND;
end;
fekTIME:
begin
Result := INT_EXCEL_TOKEN_FUNCVAR_V;
AParamsNum := 3;
AFuncNum := INT_EXCEL_SHEET_FUNC_TIME;
end;
end;
end;
@ -220,7 +232,7 @@ end;
MyFormula[2].TokenID := INT_EXCEL_TOKEN_TADD; +
}
procedure TsSpreadBIFF2Writer.WriteRPNFormula(AStream: TStream; const ARow,
ACol: Word; const AFormula: TsRPNFormula; ACell: PCell);
ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell);
var
FormulaResult: double;
i: Integer;
@ -314,17 +326,33 @@ end;
* DESCRIPTION: Writes an Excel 2 LABEL record
*
* Writes a string to the sheet
* If the string length exceeds 255 bytes, the string
* will be truncated and an exception will be raised as
* a warning.
*
*******************************************************************}
procedure TsSpreadBIFF2Writer.WriteLabel(AStream: TStream; const ARow,
ACol: Word; const AValue: string; ACell: PCell);
ACol: Cardinal; const AValue: string; ACell: PCell);
const
MaxBytes=255; //limit for this format
var
L: Byte;
AnsiText: ansistring;
TextTooLong: boolean=false;
begin
if AValue = '' then Exit; // Writing an empty text doesn't work
AnsiText := UTF8ToISO_8859_1(AValue);
if Length(AnsiText)>MaxBytes then
begin
// BIFF 5 does not support labels/text bigger than 255 chars,
// so BIFF2 won't either
// Rather than lose data when reading it, let the application programmer deal
// with the problem or purposefully ignore it.
TextTooLong:=true;
AnsiText := Copy(AnsiText,1,MaxBytes);
end;
L := Length(AnsiText);
{ BIFF Record header }
@ -341,6 +369,14 @@ begin
{ String with 8-bit size }
AStream.WriteByte(L);
AStream.WriteBuffer(AnsiText[1], L);
{
//todo: keep a log of errors and show with an exception after writing file or something.
We can't just do the following
if TextTooLong then
Raise Exception.CreateFmt('Text value exceeds %d character limit in cell [%d,%d]. Text has been truncated.',[MaxBytes,ARow,ACol]);
because the file wouldn't be written.
}
end;
{*******************************************************************

51
components/fpspreadsheet/xlsbiff5.pas
View File

@ -121,9 +121,9 @@ type
procedure WriteDimensions(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteEOF(AStream: TStream);
procedure WriteFont(AStream: TStream; AFont: TFPCustomFont);
procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Word; const AFormula: TsRPNFormula; ACell: PCell); override;
procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell); override;
procedure WriteIndex(AStream: TStream);
procedure WriteLabel(AStream: TStream; const ARow, ACol: Word; const AValue: string; ACell: PCell); override;
procedure WriteLabel(AStream: TStream; const ARow, ACol: Cardinal; const AValue: string; ACell: PCell); override;
procedure WriteNumber(AStream: TStream; const ARow, ACol: Cardinal; const AValue: double; ACell: PCell); override;
procedure WriteStyle(AStream: TStream);
procedure WriteWindow1(AStream: TStream);
@ -273,19 +273,31 @@ begin
fekSub: Result := INT_EXCEL_TOKEN_TSUB;
fekDiv: Result := INT_EXCEL_TOKEN_TDIV;
fekMul: Result := INT_EXCEL_TOKEN_TMUL;
{ Build-in Function }
{ Built-in/Worksheet Function }
fekABS:
begin
Result := INT_EXCEL_TOKEN_FUNCVAR_V;
AParamsNum := 1;
AExtra := INT_EXCEL_SHEET_FUNC_ABS;
end;
fekDATE:
begin
Result := INT_EXCEL_TOKEN_FUNCVAR_V;
AParamsNum := 3;
AExtra := INT_EXCEL_SHEET_FUNC_DATE;
end;
fekROUND:
begin
Result := INT_EXCEL_TOKEN_FUNCVAR_V;
AParamsNum := 2;
AExtra := INT_EXCEL_SHEET_FUNC_ROUND;
end;
fekTIME:
begin
Result := INT_EXCEL_TOKEN_FUNCVAR_V;
AParamsNum := 3;
AExtra := INT_EXCEL_SHEET_FUNC_TIME;
end;
end;
end;
@ -628,7 +640,7 @@ end;
*
*******************************************************************}
procedure TsSpreadBIFF5Writer.WriteRPNFormula(AStream: TStream; const ARow,
ACol: Word; const AFormula: TsRPNFormula; ACell: PCell);
ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell);
var
FormulaResult: double;
i: Integer;
@ -765,16 +777,22 @@ end;
{*******************************************************************
* TsSpreadBIFF5Writer.WriteLabel ()
*
* DESCRIPTION: Writes an Excel 8 LABEL record
* DESCRIPTION: Writes an Excel 5 LABEL record
*
* Writes a string to the sheet
* If the string length exceeds 255 bytes, the string
* will be truncated and an exception will be raised as
* a warning.
*
*******************************************************************}
procedure TsSpreadBIFF5Writer.WriteLabel(AStream: TStream; const ARow,
ACol: Word; const AValue: string; ACell: PCell);
ACol: Cardinal; const AValue: string; ACell: PCell);
const
MaxBytes=255; //limit for this format
var
L: Word;
AnsiValue: ansistring;
TextTooLong: boolean=false;
begin
case WorkBookEncoding of
seLatin2: AnsiValue := UTF8ToCP1250(AValue);
@ -797,11 +815,15 @@ begin
end;
Exit;
end;
L := Length(AnsiValue);
if L>255 then begin
//BIFF 5 does not support labels/text bigger than 255 chars.
L:=255;
if Length(AnsiValue)>MaxBytes then
begin
// Rather than lose data when reading it, let the application programmer deal
// with the problem or purposefully ignore it.
TextTooLong := true;
AnsiValue := Copy(AnsiValue,1,MaxBytes);
end;
L := Length(AnsiValue);
{ BIFF Record header }
AStream.WriteWord(WordToLE(INT_EXCEL_ID_LABEL));
@ -817,6 +839,14 @@ begin
{ Byte String with 16-bit size }
AStream.WriteWord(WordToLE(L));
AStream.WriteBuffer(AnsiValue[1], L);
{
//todo: keep a log of errors and show with an exception after writing file or something.
We can't just do the following
if TextTooLong then
Raise Exception.CreateFmt('Text value exceeds %d character limit in cell [%d,%d]. Text has been truncated.',[MaxBytes,ARow,ACol]);
because the file wouldn't be written.
}
end;
{*******************************************************************
@ -1194,6 +1224,7 @@ begin
{Check RK codes}
Number:=DecodeRKValue(L);
FWorksheet.WriteNumber(ARow,ACol,Number);
end;

307
components/fpspreadsheet/xlsbiff8.pas
View File

@ -87,6 +87,10 @@ type
FXFList: TFPList; // of TXFRecordData
FFormatList: TFPList; // of TFormatRecordData
function DecodeRKValue(const ARK: DWORD): Double;
// Tries to find if a number cell is actually a date/datetime/time cell
// and retrieve the value
function IsDate(Number: Double; ARow: WORD;
ACol: WORD; AXFIndex: WORD; var ADateTime: TDateTime): boolean;
function ReadWideString(const AStream: TStream; const ALength: WORD): WideString; overload;
function ReadWideString(const AStream: TStream; const AUse8BitLength: Boolean): WideString; overload;
procedure ReadWorkbookGlobals(AStream: TStream; AData: TsWorkbook);
@ -100,14 +104,16 @@ type
procedure ReadRichString(const AStream: TStream);
procedure ReadSST(const AStream: TStream);
procedure ReadLabelSST(const AStream: TStream);
//
// Read XF record
procedure ReadXF(const AStream: TStream);
// Read FORMAT record (cell formatting)
procedure ReadFormat(const AStream: TStream);
function FindFormatRecordForCell(const AFXIndex: Integer): TFormatRecordData;
class function ConvertExcelDateToTDateTime(const AExcelDateNum: Double; ABaseDate: TDateTime): TDateTime;
// Finds format record for XF record pointed to by cell
// Will not return info for built-in formats
function FindFormatRecordForCell(const AXFIndex: Integer): TFormatRecordData;
// Workbook Globals records
// procedure ReadCodepage in xlscommon
// procedure ReadDateMode in xlscommon
procedure ReadFont(const AStream: TStream);
public
constructor Create; override;
@ -125,6 +131,7 @@ type
TsSpreadBIFF8Writer = class(TsSpreadBIFFWriter)
private
// Writes index to XF record according to cell's formatting
procedure WriteXFIndex(AStream: TStream; ACell: PCell);
procedure WriteXFFieldsForFormattingStyles(AStream: TStream);
protected
@ -139,21 +146,23 @@ type
{ Record writing methods }
procedure WriteBOF(AStream: TStream; ADataType: Word);
function WriteBoundsheet(AStream: TStream; ASheetName: string): Int64;
// procedure WriteCodepage in xlscommon
// procedure WriteCodepage in xlscommon; Workbook Globals record
procedure WriteDateTime(AStream: TStream; const ARow, ACol: Cardinal; const AValue: TDateTime; ACell: PCell); override;
// procedure WriteDateMode in xlscommon; Workbook Globals record
procedure WriteDimensions(AStream: TStream; AWorksheet: TsWorksheet);
procedure WriteEOF(AStream: TStream);
procedure WriteFont(AStream: TStream; AFont: TFPCustomFont);
procedure WriteFormula(AStream: TStream; const ARow, ACol: Word; const AFormula: TsFormula; ACell: PCell); override;
procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Word; const AFormula: TsRPNFormula; ACell: PCell); override;
procedure WriteFormula(AStream: TStream; const ARow, ACol: Cardinal; const AFormula: TsFormula; ACell: PCell); override;
procedure WriteIndex(AStream: TStream);
procedure WriteLabel(AStream: TStream; const ARow, ACol: Word; const AValue: string; ACell: PCell); override;
procedure WriteLabel(AStream: TStream; const ARow, ACol: Cardinal; const AValue: string; ACell: PCell); override;
procedure WriteNumber(AStream: TStream; const ARow, ACol: Cardinal; const AValue: double; ACell: PCell); override;
procedure WritePalette(AStream: TStream);
procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell); override;
procedure WriteStyle(AStream: TStream);
procedure WriteWindow1(AStream: TStream);
procedure WriteWindow2(AStream: TStream; ASheetSelected: Boolean);
procedure WriteXF(AStream: TStream; AFontIndex: Word;
AXF_TYPE_PROT, ATextRotation: Byte; ABorders: TsCellBorders;
AFormatIndex: Word; AXF_TYPE_PROT, ATextRotation: Byte; ABorders: TsCellBorders;
AddBackground: Boolean = False; ABackgroundColor: TsColor = scSilver);
end;
@ -261,7 +270,6 @@ const
MASK_XF_VERT_ALIGN_JUSTIFIED = $30;
{ XF_ROTATION }
XF_ROTATION_HORIZONTAL = 0;
XF_ROTATION_90_DEGREE_COUNTERCLOCKWISE = 90;
XF_ROTATION_90_DEGREE_CLOCKWISE = 180;
@ -287,29 +295,42 @@ begin
// First try the fast methods for default formats
if ACell^.UsedFormattingFields = [] then
begin
AStream.WriteWord(WordToLE(15));
AStream.WriteWord(WordToLE(15)); //XF15; see TsSpreadBIFF8Writer.AddDefaultFormats
Exit;
end;
if ACell^.UsedFormattingFields = [uffTextRotation] then
begin
case ACell^.TextRotation of
rt90DegreeCounterClockwiseRotation: AStream.WriteWord(WordToLE(16));
rt90DegreeClockwiseRotation: AStream.WriteWord(WordToLE(17));
rt90DegreeCounterClockwiseRotation: AStream.WriteWord(WordToLE(16)); //XF_16
rt90DegreeClockwiseRotation: AStream.WriteWord(WordToLE(17)); //XF_17
else
AStream.WriteWord(WordToLE(15));
AStream.WriteWord(WordToLE(15)); //XF_15
end;
Exit;
end;
{
uffNumberFormat does not seem to have default XF indexes, but perhaps look at XF_21
if ACell^.UsedFormattingFields = [uffNumberFormat] then
begin
case ACell^.NumberFormat of
nfShortDate: AStream.WriteWord(WordToLE(???)); //what XF index?
nfShortDateTime: AStream.WriteWord(WordToLE(???)); //what XF index?
else
AStream.WriteWord(WordToLE(15)); //e.g. nfGeneral: XF_15
end;
Exit;
end;
}
if ACell^.UsedFormattingFields = [uffBold] then
begin
AStream.WriteWord(WordToLE(18));
AStream.WriteWord(WordToLE(18)); //XF_18
Exit;
end;
// If not, then we need to search in the list of dynamic formats
lIndex := FindFormattingInList(ACell);
// Carefully check the index
if (lIndex < 0) or (lIndex > Length(FFormattingStyles)) then
@ -324,6 +345,7 @@ procedure TsSpreadBIFF8Writer.WriteXFFieldsForFormattingStyles(AStream: TStream)
var
i: Integer;
lFontIndex: Word;
lFormatIndex: Word; //number format
lTextRotation: Byte;
lBorders: TsCellBorders;
lAddBackground: Boolean;
@ -334,12 +356,22 @@ begin
begin
// Default styles
lFontIndex := 0;
lFormatIndex := 0; //General format (one of the built-in number formats)
lTextRotation := XF_ROTATION_HORIZONTAL;
lBorders := [];
lAddBackground := False;
lBackgroundColor := FFormattingStyles[i].BackgroundColor;
// Now apply the modifications
// Now apply the modifications.
if uffNumberFormat in FFormattingStyles[i].UsedFormattingFields then
begin
case FFormattingStyles[i].NumberFormat of
nfGeneral: lFormatIndex := FORMAT_GENERAL;
nfShortDate: lFormatIndex := FORMAT_SHORT_DATE;
nfShortDateTime: lFormatIndex := FORMAT_SHORT_DATETIME;
end;
end;
if uffBorder in FFormattingStyles[i].UsedFormattingFields then
lBorders := FFormattingStyles[i].Border;
@ -359,21 +391,24 @@ begin
lAddBackground := True;
// And finally write the style
WriteXF(AStream, lFontIndex, 0, lTextRotation, lBorders, lAddBackground, lBackgroundColor);
WriteXF(AStream, lFontIndex, lFormatIndex, 0, lTextRotation, lBorders, lAddBackground, lBackgroundColor);
end;
end;
{@@
These are default formats which are added as XF fields regardless of being used
These are default style formats which are added as XF fields regardless of being used
in the document or not.
}
procedure TsSpreadBIFF8Writer.AddDefaultFormats();
begin
NextXFIndex := 19;
NextXFIndex := 21;
SetLength(FFormattingStyles, 4);
SetLength(FFormattingStyles, 6);
// XF15 - Default, no formatting
// XF0..XF14: Normal style, Row Outline level 1..7,
// Column Outline level 1..7.
// XF15 - Default cell format, no formatting (4.6.2)
FFormattingStyles[0].UsedFormattingFields := [];
FFormattingStyles[0].Row := 15;
@ -476,44 +511,44 @@ begin
WritePalette(AStream);
// XF0
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF1
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF2
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF3
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF4
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF5
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF6
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF7
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF8
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF9
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF10
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF11
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF12
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF13
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF14
WriteXF(AStream, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, MASK_XF_TYPE_PROT_STYLE_XF, XF_ROTATION_HORIZONTAL, []);
// XF15 - Default, no formatting
WriteXF(AStream, 0, 0, XF_ROTATION_HORIZONTAL, []);
WriteXF(AStream, 0, 0, 0, XF_ROTATION_HORIZONTAL, []);
// XF16 - Rotated
WriteXF(AStream, 0, 0, XF_ROTATION_90_DEGREE_COUNTERCLOCKWISE, []);
WriteXF(AStream, 0, 0, 0, XF_ROTATION_90_DEGREE_COUNTERCLOCKWISE, []);
// XF17 - Rotated
WriteXF(AStream, 0, 0, XF_ROTATION_90_DEGREE_CLOCKWISE, []);
WriteXF(AStream, 0, 0, 0, XF_ROTATION_90_DEGREE_CLOCKWISE, []);
// XF18 - Bold
WriteXF(AStream, 1, 0, XF_ROTATION_HORIZONTAL, []);
// Add further all non-standard formatting styles
WriteXF(AStream, 1, 0, 0, XF_ROTATION_HORIZONTAL, []);
// Add all further non-standard/built-in formatting styles
ListAllFormattingStyles(AData);
WriteXFFieldsForFormattingStyles(AStream);
@ -570,7 +605,7 @@ procedure TsSpreadBIFF8Writer.WriteBOF(AStream: TStream; ADataType: Word);
begin
{ BIFF Record header }
AStream.WriteWord(WordToLE(INT_EXCEL_ID_BOF));
AStream.WriteWord(WordToLE(16));
AStream.WriteWord(WordToLE(16)); //total record size
{ BIFF version. Should only be used if this BOF is for the workbook globals }
{ OpenOffice rejects to correctly read xls files if this field is
@ -637,6 +672,25 @@ begin
AStream.WriteBuffer(WideStringToLE(WideSheetName)[1], Len * Sizeof(WideChar));
end;
{*******************************************************************
* TsSpreadBIFF8Writer.WriteDateTime ()
*
* DESCRIPTION: Writes a date/time/datetime to an
* Excel 8 NUMBER record, with a date/time format
* (There is no separate date record type in xls)
*******************************************************************}
procedure TsSpreadBIFF8Writer.WriteDateTime(AStream: TStream; const ARow,
ACol: Cardinal; const AValue: TDateTime; ACell: PCell);
var
ExcelDateSerial: double;
begin
ExcelDateSerial:=ConvertDateTimeToExcelDateTime(AValue,FDateMode);
// fpspreadsheet must already have set formatting to a date/datetime format, so
// this will get written out as a pointer to the relevant XF record.
// In the end, dates in xls are just numbers with a format. Pass it on to WriteNumber:
WriteNumber(AStream,ARow,ACol,ExcelDateSerial,ACell);
end;
{
Writes an Excel 8 DIMENSIONS record
@ -756,7 +810,7 @@ end;
*
*******************************************************************}
procedure TsSpreadBIFF8Writer.WriteFormula(AStream: TStream; const ARow,
ACol: Word; const AFormula: TsFormula; ACell: PCell);
ACol: Cardinal; const AFormula: TsFormula; ACell: PCell);
{var
FormulaResult: double;
i: Integer;
@ -836,7 +890,7 @@ begin
end;
procedure TsSpreadBIFF8Writer.WriteRPNFormula(AStream: TStream; const ARow,
ACol: Word; const AFormula: TsRPNFormula; ACell: PCell);
ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell);
var
FormulaResult: double;
i: Integer;
@ -982,7 +1036,7 @@ begin
{ Array of nm absolute stream positions of the DBCELL record of each Row Block }
{ OBS: It seams to be no problem just ignoring this part of the record }
{ OBS: It seems to be no problem just ignoring this part of the record }
end;
{*******************************************************************
@ -991,29 +1045,44 @@ end;
* DESCRIPTION: Writes an Excel 8 LABEL record
*
* Writes a string to the sheet
* If the string length exceeds 32758 bytes, the string
* will be silently truncated.
*
*******************************************************************}
procedure TsSpreadBIFF8Writer.WriteLabel(AStream: TStream; const ARow,
ACol: Word; const AValue: string; ACell: PCell);
ACol: Cardinal; const AValue: string; ACell: PCell);
const
//limit for this format: 32767 bytes - header (see reclen below):
//37267-8-1=32758
MaxBytes=32758;
var
L, RecLen: Word;
TextTooLong: boolean=false;
WideValue: WideString;
begin
WideValue := UTF8Decode(AValue);
WideValue := UTF8Decode(AValue); //to UTF16
if WideValue = '' then
begin
// Bad formatted UTF8String (maybe ANSI?)
// Badly formatted UTF8String (maybe ANSI?)
if Length(AValue)<>0 then begin
//It was an ANSI string written as UTF8 quite sure, so raise exception.
//Quite sure it was an ANSI string written as UTF8, so raise exception.
Raise Exception.CreateFmt('Expected UTF8 text but probably ANSI text found in cell [%d,%d]',[ARow,ACol]);
end;
Exit;
end;
if Length(WideValue)>MaxBytes then
begin
// Rather than lose data when reading it, let the application programmer deal
// with the problem or purposefully ignore it.
TextTooLong := true;
SetLength(WideValue,MaxBytes); //may corrupt the string (e.g. in surrogate pairs), but... too bad.
end;
L := Length(WideValue);
{ BIFF Record header }
AStream.WriteWord(WordToLE(INT_EXCEL_ID_LABEL));
RecLen := 8 + 1 + L * Sizeof(WideChar);
RecLen := 8 + 1 + L * SizeOf(WideChar);
AStream.WriteWord(WordToLE(RecLen));
{ BIFF Record data }
@ -1029,6 +1098,14 @@ begin
{ Byte flags. 1 means regular Unicode LE encoding}
AStream.WriteByte(1);
AStream.WriteBuffer(WideStringToLE(WideValue)[1], L * Sizeof(WideChar));
{
//todo: keep a log of errors and show with an exception after writing file or something.
We can't just do the following
if TextTooLong then
Raise Exception.CreateFmt('Text value exceeds %d character limit in cell [%d,%d]. Text has been truncated.',[MaxBytes,ARow,ACol]);
because the file wouldn't be written.
}
end;
{*******************************************************************
@ -1044,7 +1121,7 @@ procedure TsSpreadBIFF8Writer.WriteNumber(AStream: TStream; const ARow,
begin
{ BIFF Record header }
AStream.WriteWord(WordToLE(INT_EXCEL_ID_NUMBER));
AStream.WriteWord(WordToLE(14));
AStream.WriteWord(WordToLE(14)); //total record size
{ BIFF Record data }
AStream.WriteWord(WordToLE(ARow));
@ -1086,8 +1163,8 @@ begin
{ Now some colors which we define ourselves }
AStream.WriteDWord(DWordToLE($E6E6E6)); //$18
AStream.WriteDWord(DWordToLE($CCCCCC)); //$19
AStream.WriteDWord(DWordToLE($E6E6E6)); //$18 //todo: shouldn't we write $18..$3F and add this color later? see 5.74.3 Built-In Default Colour Tables
AStream.WriteDWord(DWordToLE($CCCCCC)); //$19 //todo: shouldn't we write $18..$3F and add this color later? see 5.74.3 Built-In Default Colour Tables
{ And padding }
AStream.WriteDWord(DWordToLE($FFFFFF));
@ -1274,7 +1351,7 @@ end;
*
*******************************************************************}
procedure TsSpreadBIFF8Writer.WriteXF(AStream: TStream; AFontIndex: Word;
AXF_TYPE_PROT, ATextRotation: Byte; ABorders: TsCellBorders;
AFormatIndex: Word; AXF_TYPE_PROT, ATextRotation: Byte; ABorders: TsCellBorders;
AddBackground: Boolean = False; ABackgroundColor: TsColor = scSilver);
var
XFOptions: Word;
@ -1289,7 +1366,7 @@ begin
AStream.WriteWord(WordToLE(AFontIndex));
{ Index to FORMAT record }
AStream.WriteWord(WordToLE($00));
AStream.WriteWord(WordToLE(AFormatIndex));
{ XF type, cell protection and parent style XF }
XFOptions := AXF_TYPE_PROT and MASK_XF_TYPE_PROT;
@ -1339,7 +1416,7 @@ begin
if AddBackground then XFBorderDWord2 := XFBorderDWord2 or $4000000;
AStream.WriteDWord(DWordToLE(XFBorderDWord2));
// Background Pattern Color, always zeroed
if AddBackground then AStream.WriteWord(WordToLE(FPSColorToEXCELPallete(ABackgroundColor)))
if AddBackground then AStream.WriteWord(WordToLE(FPSColorToEXCELPalette(ABackgroundColor)))
else AStream.WriteWord(0);
end;
@ -1374,6 +1451,49 @@ begin
Result:=Number;
end;
function TsSpreadBIFF8Reader.IsDate(Number: Double;
ARow: WORD; ACol: WORD; AXFIndex: WORD; var ADateTime: TDateTime): boolean;
// Try to find out if a cell has a date/time and return
// TheDate if it is
var
lFormatData: TFormatRecordData;
lXFData: TXFRecordData;
begin
result := false;
// Try to figure out if the number is really a number of a date or time value
// See: http://www.gaia-gis.it/FreeXL/freexl-1.0.0a-doxy-doc/Format.html
// Unfornately Excel doesnt give us a direct way to find this,
// we need to guess by the FORMAT field
// Note FindFormatRecordForCell will not retrieve default format numbers
lFormatData := FindFormatRecordForCell(AXFIndex);
{Record FORMAT, BIFF8 (5.49):
Offset Size Contents
0 2 Format index used in other records
}
if lFormatData=nil then
begin
// No custom format, so first test for default formats
lXFData := TXFRecordData(FXFList.Items[AXFIndex]);
if (lXFData.FormatIndex in [14..22, 27..36, 45, 46, 47, 50..58]) then
begin
ADateTime := ConvertExcelDateTimeToDateTime(Number, FDateMode);
Exit(true);
end;
end
else
begin
// Check custom formats if they
// have / in format string (this can fail for custom text formats)
if (Pos('/', lFormatData.FormatString) > 0) then
begin
ADateTime := ConvertExcelDateTimeToDateTime(Number, FDateMode);
Exit(true);
end;
end;
ADateTime := 0;
end;
function TsSpreadBIFF8Reader.ReadWideString(const AStream: TStream;
const ALength: WORD): WideString;
var
@ -1486,7 +1606,7 @@ var
RecordType: Word;
CurStreamPos: Int64;
begin
if Assigned(FSharedStringTable) then FreeAndNIL(FSharedStringTable);
if Assigned(FSharedStringTable) then FreeAndNil(FSharedStringTable);
while (not SectionEOF) do
begin
{ Read the record header }
@ -1596,10 +1716,10 @@ procedure TsSpreadBIFF8Reader.ReadRKValue(const AStream: TStream);
var
RK: DWORD;
ARow, ACol, XF: WORD;
Number: Double;
lFormatData: TFormatRecordData;
lDateTime: TDateTime;
Number: Double;
begin
{Retrieve XF record, row and column}
ReadRowColXF(AStream,ARow,ACol,XF);
{Encoded RK value}
@ -1608,28 +1728,17 @@ begin
{Check RK codes}
Number:=DecodeRKValue(RK);
// Now try to figure out if the number is really a number of a date or time value
// See: http://www.gaia-gis.it/FreeXL/freexl-1.0.0a-doxy-doc/Format.html
// Unfornately Excel doesnt give us a direct way to find this,
// we need to guess by the FORMAT field
lFormatData := FindFormatRecordForCell(XF);
if lFormatData <> nil then
begin
// Dates have /
if Pos('/', lFormatData.FormatString) > 0 then
begin
lDateTime := ConvertExcelDateToTDateTime(Number, FBaseDate);
FWorksheet.WriteDateTime(ARow,ACol,lDateTime);
Exit;
end;
end;
{Find out what cell type, set contenttype and value}
if IsDate(Number, ARow, ACol, XF, lDateTime) then
FWorksheet.WriteDateTime(ARow, ACol, lDateTime)
else
FWorksheet.WriteNumber(ARow,ACol,Number);
end;
procedure TsSpreadBIFF8Reader.ReadMulRKValues(const AStream: TStream);
var
ARow, fc,lc,XF: Word;
lDateTime: TDateTime;
Pending: integer;
RK: DWORD;
Number: Double;
@ -1638,9 +1747,13 @@ begin
fc:=WordLEtoN(AStream.ReadWord);
Pending:=RecordSize-sizeof(fc)-Sizeof(ARow);
while Pending > (sizeof(XF)+sizeof(RK)) do begin
XF:=AStream.ReadWord; //XF record (not used)
XF:=AStream.ReadWord; //XF record (used for date checking)
RK:=DWordLEtoN(AStream.ReadDWord);
Number:=DecodeRKValue(RK);
{Find out what cell type, set contenttype and value}
if IsDate(Number, ARow, fc, XF, lDateTime) then
FWorksheet.WriteDateTime(ARow, fc, lDateTime)
else
FWorksheet.WriteNumber(ARow,fc,Number);
inc(fc);
dec(Pending,(sizeof(XF)+sizeof(RK)));
@ -1782,7 +1895,7 @@ begin
{ Formula size }
FormulaSize := WordLEtoN(AStream.ReadWord);
{ Formula data, outputed as debug info }
{ Formula data, output as debug info }
{ Write('Formula Element: ');
for i := 1 to FormulaSize do
Write(IntToHex(AStream.ReadByte, 2) + ' ');
@ -1822,21 +1935,23 @@ begin
end;
procedure TsSpreadBIFF8Reader.ReadNumber(AStream: TStream);
// Tries to read number from stream and write result to worksheet.
// Needs to check if a number is actually a date format
var
ARow, ACol: Word;
ARow, ACol, XF: Word;
AValue: Double;
lDateTime: TDateTime;
begin
{ BIFF Record data }
ARow := WordLEToN(AStream.ReadWord);
ACol := WordLEToN(AStream.ReadWord);
{ Index to XF record, not used }
AStream.ReadWord();
{Retrieve XF record, row and column}
ReadRowColXF(AStream,ARow,ACol,XF);
{ IEE 754 floating-point value }
AStream.ReadBuffer(AValue, 8);
{ Save the data }
{Find out what cell type, set contenttype and value}
if IsDate(AValue, ARow, ACol, XF, lDateTime) then
FWorksheet.WriteDateTime(ARow, ACol, lDateTime)
else
FWorksheet.WriteNumber(ARow,ACol,AValue);
end;
@ -1951,13 +2066,14 @@ begin
// Record XF, BIFF8:
// Offset Size Contents
// 0 2 Index to FONT record (➜5.45)
// 0 2 Index to FONT record (➜5.45))
WordLEtoN(AStream.ReadWord);
// 2 2 Index to FORMAT record (➜5.49)
// 2 2 Index to FORMAT record (➜5.49))
lData.FormatIndex := WordLEtoN(AStream.ReadWord);
{4 2 XF type, cell protection, and parent style XF:
{ Offset Size Contents
4 2 XF type, cell protection, and parent style XF:
Bit Mask Contents
2-0 0007H XF_TYPE_PROT – XF type, cell protection (see above)
15-4 FFF0H Index to parent style XF (always FFFH in style XFs)
@ -1989,9 +2105,10 @@ var
begin
lData := TFormatRecordData.Create;
// Record FORMAT, BIFF8:
// Record FORMAT, BIFF8 (5.49):
// Offset Size Contents
// 0 2 Format index used in other records
// From BIFF5 on: indexes 0..163 are built in
lData.Index := WordLEtoN(AStream.ReadWord);
// 2 var. Number format string (Unicode string, 16-bit string length, ➜2.5.3)
@ -2001,7 +2118,7 @@ begin
FFormatList.Add(lData);
end;
function TsSpreadBIFF8Reader.FindFormatRecordForCell(const AFXIndex: Integer
function TsSpreadBIFF8Reader.FindFormatRecordForCell(const AXFIndex: Integer
): TFormatRecordData;
var
lXFData: TXFRecordData;
@ -2009,7 +2126,7 @@ var
i: Integer;
begin
Result := nil;
lXFData := TXFRecordData(FXFList.Items[AFXIndex]);
lXFData := TXFRecordData(FXFList.Items[AXFIndex]);
for i := 0 to FFormatList.Count-1 do
begin
lFormatData := TFormatRecordData(FFormatList.Items[i]);
@ -2017,12 +2134,6 @@ begin
end;
end;
class function TsSpreadBIFF8Reader.ConvertExcelDateToTDateTime(
const AExcelDateNum: Double; ABaseDate: TDateTime): TDateTime;
begin
Result := IncDay(ABaseDate, Round(AExcelDateNum));
end;
procedure TsSpreadBIFF8Reader.ReadFont(const AStream: TStream);
var
lCodePage: Word;

218
components/fpspreadsheet/xlscommon.pas
View File

@ -1,5 +1,8 @@
unit xlscommon;
{ Comments often have links to sections in the
OpenOffice Microsoft Excel File Format document }
{$ifdef fpc}
{$mode delphi}
{$endif}
@ -18,13 +21,13 @@ const
{ Formula constants TokenID values }
{ Binary Operator Tokens }
{ Binary Operator Tokens 3.6}
INT_EXCEL_TOKEN_TADD = $03;
INT_EXCEL_TOKEN_TSUB = $04;
INT_EXCEL_TOKEN_TMUL = $05;
INT_EXCEL_TOKEN_TDIV = $06;
INT_EXCEL_TOKEN_TPOWER = $07; // Power Exponentiation
INT_EXCEL_TOKEN_TCONCAT = $08;
INT_EXCEL_TOKEN_TCONCAT = $08; // Concatenation
INT_EXCEL_TOKEN_TLT = $09; // Less than
INT_EXCEL_TOKEN_TLE = $0A; // Less than or equal
INT_EXCEL_TOKEN_TEQ = $0B; // Equal
@ -35,27 +38,36 @@ const
INT_EXCEL_TOKEN_TLIST = $10; // Cell range list
INT_EXCEL_TOKEN_TRANGE = $11; // Cell range
{ Constant Operand Tokens }
INT_EXCEL_TOKEN_TNUM = $1F;
{ Constant Operand Tokens, 3.8}
INT_EXCEL_TOKEN_TSTR = $17; //string
INT_EXCEL_TOKEN_TBOOL = $1D; //boolean
INT_EXCEL_TOKEN_TINT = $1E; //integer
INT_EXCEL_TOKEN_TNUM = $1F; //floating-point
{ Operand Tokens }
// _R: reference; _V: value; _A: array
INT_EXCEL_TOKEN_TREFR = $24;
INT_EXCEL_TOKEN_TREFV = $44;
INT_EXCEL_TOKEN_TREFA = $64;
{ Function Tokens }
// _R: reference; _V: value; _A: array
// Offset 0: token; offset 1: index to a built-in sheet function ( ➜ 3.111)
INT_EXCEL_TOKEN_FUNC_R = $21;
INT_EXCEL_TOKEN_FUNC_V = $41;
INT_EXCEL_TOKEN_FUNC_A = $61;
//VAR: variable number of arguments:
INT_EXCEL_TOKEN_FUNCVAR_R = $22;
INT_EXCEL_TOKEN_FUNCVAR_V = $42;
INT_EXCEL_TOKEN_FUNCVAR_A = $62;
INT_EXCEL_TOKEN_TAREA_R = $25;
{ Built-in functions }
{ Built-in/worksheet functions }
INT_EXCEL_SHEET_FUNC_ABS = 24; // $18
INT_EXCEL_SHEET_FUNC_ROUND = 27;
INT_EXCEL_SHEET_FUNC_ROUND = 27; // $1B
INT_EXCEL_SHEET_FUNC_DATE = 65; // $41
INT_EXCEL_SHEET_FUNC_TIME = 66; // $42
{ Control Tokens, Special Tokens }
// 01H tExp Matrix formula or shared formula
@ -66,29 +78,47 @@ const
// 1AH tSheet Start of external sheet reference (BIFF2-BIFF4)
// 1BH tEndSheet End of external sheet reference (BIFF2-BIFF4)
{ Built In Color Pallete Indexes }
BUILT_IN_COLOR_PALLETE_BLACK = $08; // 000000H
BUILT_IN_COLOR_PALLETE_WHITE = $09; // FFFFFFH
BUILT_IN_COLOR_PALLETE_RED = $0A; // FF0000H
BUILT_IN_COLOR_PALLETE_GREEN = $0B; // 00FF00H
BUILT_IN_COLOR_PALLETE_BLUE = $0C; // 0000FFH
BUILT_IN_COLOR_PALLETE_YELLOW = $0D; // FFFF00H
BUILT_IN_COLOR_PALLETE_MAGENTA = $0E; // FF00FFH
BUILT_IN_COLOR_PALLETE_CYAN = $0F; // 00FFFFH
BUILT_IN_COLOR_PALLETE_DARK_RED = $10; // 800000H
BUILT_IN_COLOR_PALLETE_DARK_GREEN= $11; // 008000H
BUILT_IN_COLOR_PALLETE_DARK_BLUE = $12; // 000080H
BUILT_IN_COLOR_PALLETE_OLIVE = $13; // 808000H
BUILT_IN_COLOR_PALLETE_PURPLE = $14; // 800080H
BUILT_IN_COLOR_PALLETE_TEAL = $15; // 008080H
BUILT_IN_COLOR_PALLETE_SILVER = $16; // C0C0C0H
BUILT_IN_COLOR_PALLETE_GREY = $17; // 808080H
{ Built In Color Palette Indexes }
// Proper spelling
BUILT_IN_COLOR_PALETTE_BLACK = $08; // 000000H
BUILT_IN_COLOR_PALETTE_WHITE = $09; // FFFFFFH
BUILT_IN_COLOR_PALETTE_RED = $0A; // FF0000H
BUILT_IN_COLOR_PALETTE_GREEN = $0B; // 00FF00H
BUILT_IN_COLOR_PALETTE_BLUE = $0C; // 0000FFH
BUILT_IN_COLOR_PALETTE_YELLOW = $0D; // FFFF00H
BUILT_IN_COLOR_PALETTE_MAGENTA = $0E; // FF00FFH
BUILT_IN_COLOR_PALETTE_CYAN = $0F; // 00FFFFH
BUILT_IN_COLOR_PALETTE_DARK_RED = $10; // 800000H
BUILT_IN_COLOR_PALETTE_DARK_GREEN= $11; // 008000H
BUILT_IN_COLOR_PALETTE_DARK_BLUE = $12; // 000080H
BUILT_IN_COLOR_PALETTE_OLIVE = $13; // 808000H
BUILT_IN_COLOR_PALETTE_PURPLE = $14; // 800080H
BUILT_IN_COLOR_PALETTE_TEAL = $15; // 008080H
BUILT_IN_COLOR_PALETTE_SILVER = $16; // C0C0C0H
BUILT_IN_COLOR_PALETTE_GREY = $17; // 808080H
EXTRA_COLOR_PALETTE_GREY10PCT = $18; // E6E6E6H
EXTRA_COLOR_PALETTE_GREY20PCT = $19; // E6E6E6H
// Spelling mistake; kept for compatibility
BUILT_IN_COLOR_PALLETE_BLACK = $08 deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_WHITE = $09 deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_RED = $0A deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_GREEN = $0B deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_BLUE = $0C deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_YELLOW = $0D deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_MAGENTA = $0E deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_CYAN = $0F deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_DARK_RED = $10 deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_DARK_GREEN= $11 deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_DARK_BLUE = $12 deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_OLIVE = $13 deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_PURPLE = $14 deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_TEAL = $15 deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_SILVER = $16 deprecated 'Please use the *_PALETTE version';
BUILT_IN_COLOR_PALLETE_GREY = $17 deprecated 'Please use the *_PALETTE version';
EXTRA_COLOR_PALETTE_GREY10PCT = $18; // E6E6E6H //todo: is $18 correct? see 5.74.3 Built-In Default Colour Tables
EXTRA_COLOR_PALETTE_GREY20PCT = $19; // CCCCCCH //todo: is $19 correct? see 5.74.3 Built-In Default Colour Tables
{ CODEPAGE record constants }
WORD_ASCII = 367;
WORD_UTF_16 = 1200; // BIFF 8
WORD_CP_1250_Latin2 = 1250;
@ -102,18 +132,39 @@ const
WORD_CP_1258_Vietnamese = 1258;
WORD_CP_1258_Latin1_BIFF2_3 = 32769; // BIFF2-BIFF3
{ DATEMODE record, 5.28 }
DATEMODE_1900_BASE=1; //1/1/1900 minus 1 day in FPC TDateTime
DATEMODE_1904_BASE=1462; //1/1/1904 in FPC TDateTime
{ FORMAT record constants }
// Just a subset; needed for output to date/time records
FORMAT_GENERAL = 0; //general/default format
FORMAT_SHORT_DATE = 14; //short date
FORMAT_SHORT_DATETIME = 22; //short date+time
type
TDateMode=(dm1900,dm1904); //DATEMODE values, 5.28
// Adjusts Excel float (date, date/time, time) with the file's base date to get a TDateTime
function ConvertExcelDateTimeToDateTime
(const AExcelDateNum: Double; ADateMode: TDateMode): TDateTime;
// Adjusts TDateTime with the file's base date to get
// an Excel float value representing a time/date/datetime
function ConvertDateTimeToExcelDateTime
(const ADateTime: TDateTime; ADateMode: TDateMode): Double;
type
{ TsSpreadBIFFReader }
TsSpreadBIFFReader = class(TsCustomSpreadReader)
protected
FCodepage: string; // in a format prepared for lconvencoding.ConvertEncoding
FBaseDate: TDateTime;
FDateMode: TDateMode;
constructor Create; override;
// Here we can add reading of records which didn't change across BIFF2-8 versions
// Workbook Globals records
procedure ReadCodePage(AStream: TStream);
// Figures out what the base year for dates is for this file
procedure ReadDateMode(AStream: TStream);
end;
@ -121,9 +172,10 @@ type
TsSpreadBIFFWriter = class(TsCustomSpreadWriter)
protected
FDateMode: TDateMode;
FLastRow: Integer;
FLastCol: Word;
function FPSColorToEXCELPallete(AColor: TsColor): Word;
function FPSColorToExcelPalette(AColor: TsColor): Word;
procedure GetLastRowCallback(ACell: PCell; AStream: TStream);
function GetLastRowIndex(AWorksheet: TsWorksheet): Integer;
procedure GetLastColCallback(ACell: PCell; AStream: TStream);
@ -131,19 +183,73 @@ type
function FormulaElementKindToExcelTokenID(AElementKind: TFEKind; out ASecondaryID: Word): Byte;
// Other records which didn't change
// Workbook Globals records
// Write out used codepage for character encoding
procedure WriteCodepage(AStream: TStream; AEncoding: TsEncoding);
// Writes out DATEMODE record depending on FDateMode
procedure WriteDateMode(AStream: TStream);
public
constructor Create; override;
end;
implementation
function ConvertExcelDateTimeToDateTime(
const AExcelDateNum: Double; ADateMode: TDateMode): TDateTime;
begin
// Time only:
if (AExcelDateNum<1) and (AExcelDateNum>=0) then
begin
Result:=AExcelDateNum;
end
else
begin
case ADateMode of
dm1900:
begin
// Check for Lotus 1-2-3 bug with 1900 leap year
if AExcelDateNum=61.0 then
// 29 feb does not exist, change to 28
// Spell out that we remove a day for ehm "clarity".
result:=61.0-1.0+DATEMODE_1900_BASE-1.0
else
result:=AExcelDateNum+DATEMODE_1900_BASE-1.0;
end;
dm1904:
result:=AExcelDateNum+DATEMODE_1904_BASE;
else
raise Exception.CreateFmt('ConvertExcelDateTimeToDateTime: unknown datemode %d. Please correct fpspreadsheet source code. ', [ADateMode]);
end;
end;
end;
function ConvertDateTimeToExcelDateTime(const ADateTime: TDateTime;
ADateMode: TDateMode): Double;
begin
// Time only:
if (ADateTime<1) and (ADateTime>=0) then
begin
Result:=ADateTime;
end
else
begin
case ADateMode of
dm1900:
result:=ADateTime-DATEMODE_1900_BASE+1.0;
dm1904:
result:=ADateTime-DATEMODE_1904_BASE;
else
raise Exception.CreateFmt('ConvertDateTimeToExcelDateTime: unknown datemode %d. Please correct fpspreadsheet source code. ', [ADateMode]);
end;
end;
end;
{ TsSpreadBIFFReader }
constructor TsSpreadBIFFReader.Create;
begin
inherited Create;
// Initial base date in case it wont be informed
FBaseDate := DateUtils.EncodeDateDay(1900, 1);
FBaseDate := DateUtils.IncDay(FBaseDate, -1);
// Initial base date in case it won't be read from file
FDateMode := dm1900;
end;
// In BIFF 8 it seams to always use the UTF-16 codepage
@ -216,16 +322,14 @@ begin
//0 2 0 = Base date is 1899-Dec-31 (the cell value 1 represents 1900-Jan-01)
// 1 = Base date is 1904-Jan-01 (the cell value 1 represents 1904-Jan-02)
lBaseMode := WordLEtoN(AStream.ReadWord);
if lBaseMode = 0 then
begin
FBaseDate := DateUtils.EncodeDateDay(1900, 1);
FBaseDate := DateUtils.IncDay(FBaseDate, -1);
end
else
FBaseDate := DateUtils.EncodeDateDay(1904, 1);
case lBaseMode of
0: FDateMode := dm1900;
1: FDateMode := dm1904;
else raise Exception.CreateFmt('Error reading file. Got unknown date mode number %d.',[lBaseMode]);
end;
end;
function TsSpreadBIFFWriter.FPSColorToEXCELPallete(AColor: TsColor): Word;
function TsSpreadBIFFWriter.FPSColorToExcelPalette(AColor: TsColor): Word;
begin
case AColor of
scBlack: Result := BUILT_IN_COLOR_PALLETE_BLACK;
@ -289,17 +393,27 @@ begin
fekSub: Result := INT_EXCEL_TOKEN_TSUB;
fekDiv: Result := INT_EXCEL_TOKEN_TDIV;
fekMul: Result := INT_EXCEL_TOKEN_TMUL;
{ Build-in Functions}
{ Built-in Functions}
fekABS:
begin
Result := INT_EXCEL_TOKEN_FUNC_V;
ASecondaryID := INT_EXCEL_SHEET_FUNC_ABS;
end;
fekDATE:
begin
Result := INT_EXCEL_TOKEN_FUNC_V;
ASecondaryID := INT_EXCEL_SHEET_FUNC_DATE;
end;
fekROUND:
begin
Result := INT_EXCEL_TOKEN_FUNC_V;
ASecondaryID := INT_EXCEL_SHEET_FUNC_ROUND;
end;
fekTIME:
begin
Result := INT_EXCEL_TOKEN_FUNC_V;
ASecondaryID := INT_EXCEL_SHEET_FUNC_TIME;
end;
{ Other operations }
fekOpSUM: Result := INT_EXCEL_TOKEN_TATTR;
else
@ -331,5 +445,27 @@ begin
AStream.WriteWord(WordToLE(lCodepage));
end;
procedure TsSpreadBIFFWriter.WriteDateMode(AStream: TStream);
begin
{ BIFF Record header }
// todo: check whether this is in the right place. should end up in workbook globals stream
AStream.WriteWord(WordToLE(INT_EXCEL_ID_DATEMODE));
AStream.WriteWord(WordToLE(2));
case FDateMode of
dm1900: AStream.WriteWord(WordToLE(0));
dm1904: AStream.WriteWord(WordToLE(1));
else raise Exception.CreateFmt('Unknown datemode number %d. Please correct fpspreadsheet code.', [FDateMode]);
end;
end;
constructor TsSpreadBIFFWriter.Create;
begin
inherited Create;
// Initial base date in case it won't be set otherwise.
// Use 1900 to get a bit more range between 1900..1904.
FDateMode := dm1900;
end;
end.

46
components/fpspreadsheet/xlsxooxml.pas
View File

@ -31,7 +31,11 @@ interface
uses
Classes, SysUtils,
fpszipper, {NOTE: fpszipper is the latest zipper.pp Change to standard zipper when FPC 2.8 is released }
{$IFDEF FPC_FULLVERSION >= 20701}
zipper,
{$ELSE}
fpszipper,
{$ENDIF}
{xmlread, DOM,} AVL_Tree,
fpspreadsheet;
@ -68,7 +72,8 @@ type
const AOverwriteExisting: Boolean = False); override;
procedure WriteToStream(AStream: TStream; AData: TsWorkbook); override;
{ Record writing methods }
procedure WriteLabel(AStream: TStream; const ARow, ACol: Word; const AValue: string; ACell: PCell); override;
//todo: add WriteDate
procedure WriteLabel(AStream: TStream; const ARow, ACol: Cardinal; const AValue: string; ACell: PCell); override;
procedure WriteNumber(AStream: TStream; const ARow, ACol: Cardinal; const AValue: double; ACell: PCell); override;
end;
@ -448,18 +453,37 @@ begin
end;
end;
{
Writes a string to the sheet
}
{*******************************************************************
* TsSpreadOOXMLWriter.WriteLabel ()
*
* DESCRIPTION: Writes a string to the sheet
* If the string length exceeds 32767 bytes, the string
* will be truncated and an exception will be raised as
* a warning.
*
*******************************************************************}
procedure TsSpreadOOXMLWriter.WriteLabel(AStream: TStream; const ARow,
ACol: Word; const AValue: string; ACell: PCell);
ACol: Cardinal; const AValue: string; ACell: PCell);
const
MaxBytes=32767; //limit for this format
var
CellPosText: string;
lStyleIndex: Cardinal;
TextTooLong: boolean=false;
ResultingValue: string;
begin
// Office 2007-2010 (at least) support no more characters in a cell;
if Length(AValue)>MaxBytes then
begin
TextTooLong:=true;
ResultingValue:=Copy(AValue,1,MaxBytes); //may chop off multicodepoint UTF8 characters but well...
end
else
ResultingValue:=AValue;
FSharedStrings := FSharedStrings +
' <si>' + LineEnding +
Format(' <t>%s</t>', [AValue]) + LineEnding +
Format(' <t>%s</t>', [ResultingValue]) + LineEnding +
' </si>' + LineEnding;
CellPosText := TsWorksheet.CellPosToText(ARow, ACol);
@ -468,6 +492,14 @@ begin
Format(' <c r="%s" s="%d" t="s"><v>%d</v></c>', [CellPosText, lStyleIndex, FSharedStringsCount]) + LineEnding;
Inc(FSharedStringsCount);
{
//todo: keep a log of errors and show with an exception after writing file or something.
We can't just do the following
if TextTooLong then
Raise Exception.CreateFmt('Text value exceeds %d character limit in cell [%d,%d]. Text has been truncated.',[MaxBytes,ARow,ACol]);
because the file wouldn't be written.
}
end;
{