You've already forked lazarus-ccr
+ Add date/time/datetime read/write support for BIFF8 xls format. No plans for earlier formats though the code could be adapted
+ 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
@ -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;
|
||||
|
||||
@ -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,10 +131,10 @@ 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 = (
|
||||
scBlack, // 000000H
|
||||
TsColor = ( // R G B color value:
|
||||
scBlack , // 000000H
|
||||
scWhite, // FFFFFFH
|
||||
scRed, // FF0000H
|
||||
scGREEN, // 00FF00H
|
||||
@ -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,7 +715,8 @@ begin
|
||||
case ACell^.ContentType of
|
||||
|
||||
//cctFormula
|
||||
cctNumber: Result := ACell^.NumberValue;
|
||||
cctDateTime : Result := ACell^.DateTimeValue; //this is in FPC TDateTime format, not Excel
|
||||
cctNumber : Result := ACell^.NumberValue;
|
||||
cctUTF8String:
|
||||
begin
|
||||
// The try is necessary to catch errors while converting the string
|
||||
@ -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
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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
5
components/fpspreadsheet/reference/MSODumper.txt
Normal 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
337
components/fpspreadsheet/tests/datetests.pas
Normal 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
75
components/fpspreadsheet/tests/internaltests.pas
Normal 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
162
components/fpspreadsheet/tests/manualtests.pas
Normal 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
263
components/fpspreadsheet/tests/numberstests.pas
Normal 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
46
components/fpspreadsheet/tests/readme.txt
Normal 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
160
components/fpspreadsheet/tests/spreadtestcli.lpi
Normal 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
267
components/fpspreadsheet/tests/spreadtestcli.lpr
Normal 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
155
components/fpspreadsheet/tests/spreadtestgui.lpi
Normal 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
15
components/fpspreadsheet/tests/spreadtestgui.lpr
Normal 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
BIN
components/fpspreadsheet/tests/spreadtestgui.res
Normal file
Binary file not shown.
327
components/fpspreadsheet/tests/stringtests.pas
Normal file
327
components/fpspreadsheet/tests/stringtests.pas
Normal 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
BIN
components/fpspreadsheet/tests/testbiff8.xls
Normal file
Binary file not shown.
BIN
components/fpspreadsheet/tests/testbiff8_1899.xls
Normal file
BIN
components/fpspreadsheet/tests/testbiff8_1899.xls
Normal file
Binary file not shown.
136
components/fpspreadsheet/tests/testdbwriter.ini
Normal file
136
components/fpspreadsheet/tests/testdbwriter.ini
Normal 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
1430
components/fpspreadsheet/tests/testdbwriter.pas
Normal file
File diff suppressed because it is too large
Load Diff
1
components/fpspreadsheet/tests/testdbwriter.rc
Normal file
1
components/fpspreadsheet/tests/testdbwriter.rc
Normal file
@ -0,0 +1 @@
|
||||
SQLSCRIPT RCDATA "testdbwriter_firebird.sql"
|
||||
BIN
components/fpspreadsheet/tests/testdbwriter.res
Normal file
BIN
components/fpspreadsheet/tests/testdbwriter.res
Normal file
Binary file not shown.
620
components/fpspreadsheet/tests/testdbwriter_firebird.sql
Normal file
620
components/fpspreadsheet/tests/testdbwriter_firebird.sql
Normal 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
222
components/fpspreadsheet/tests/testdbwriter_postgresql.sql
Normal 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
68
components/fpspreadsheet/tests/testsutility.pas
Normal 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.
|
||||
|
||||
@ -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;
|
||||
|
||||
{*******************************************************************
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -87,7 +87,11 @@ type
|
||||
FXFList: TFPList; // of TXFRecordData
|
||||
FFormatList: TFPList; // of TFormatRecordData
|
||||
function DecodeRKValue(const ARK: DWORD): Double;
|
||||
function ReadWideString(const AStream: TStream;const ALength: WORD): WideString; overload;
|
||||
// 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);
|
||||
procedure ReadWorksheet(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,22 +1935,24 @@ 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 }
|
||||
FWorksheet.WriteNumber(ARow, ACol, AValue);
|
||||
{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;
|
||||
|
||||
procedure TsSpreadBIFF8Reader.ReadRichString(const AStream: TStream);
|
||||
@ -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;
|
||||
|
||||
@ -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.
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
{
|
||||
|
||||
Reference in New Issue
Block a user