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

fpspreadsheet: More calculation of rpn formulas, add TestCalcRPNFormulas cases to formulatests. Boolean results not working yet. And implementation only for BIFF8, so far.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3249 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2014-06-28 19:40:28 +00:00
parent 9bcb71a1fc
commit cd9e686804
7 changed files with 587 additions and 107 deletions
Download Patch File Download Diff File Expand all files Collapse all files

267
components/fpspreadsheet/fpsmath.pas
View File

@ -9,7 +9,6 @@ uses
type type
TsArgumentType = (atNumber, atString, atBool, atError); TsArgumentType = (atNumber, atString, atBool, atError);
TsArgumentError = (aeOK, aeWrongType, aeDivideByZero, aeFuncNotDefined);
TsArgument = record TsArgument = record
IsMissing: Boolean; IsMissing: Boolean;
@ -17,7 +16,7 @@ type
atNumber : (NumberValue: Double); atNumber : (NumberValue: Double);
atString : (StringValue: String); atString : (StringValue: String);
atBool : (BoolValue: Boolean); atBool : (BoolValue: Boolean);
atError : (ErrorValue: TsArgumentError); atError : (ErrorValue: TsErrorValue);
end; end;
PsArgument = ^TsArgument; PsArgument = ^TsArgument;
@ -34,10 +33,18 @@ type
procedure Delete(AIndex: Integer); procedure Delete(AIndex: Integer);
end; end;
procedure CheckMissingBool (var Arg: TsArgument; ABool: Boolean); procedure FixMissingBool (var Arg: TsArgument; ABool: Boolean);
procedure CheckMissingNumber(var Arg: TsArgument; ANumber: Double); procedure FixMissingNumber(var Arg: TsArgument; ANumber: Double);
procedure CheckMissingString(var Arg: TsArgument; AString: String); procedure FixMissingString(var Arg: TsArgument; AString: String);
function CreateBool(AValue: Boolean): TsArgument;
function CreateNumber(AValue: Double): TsArgument;
function CreateString(AValue: String): TsArgument;
function CreateError(AError: TsErrorValue): TsArgument;
{
These are the functions called when calculating an RPN formula.
}
type type
TsFormulaFunc = function(Args: TsArgumentStack): TsArgument; TsFormulaFunc = function(Args: TsArgumentStack): TsArgument;
@ -45,9 +52,18 @@ function fpsAdd(Args: TsArgumentStack): TsArgument;
function fpsSub (Args: TsArgumentStack): TsArgument; function fpsSub (Args: TsArgumentStack): TsArgument;
function fpsMul (Args: TsArgumentStack): TsArgument; function fpsMul (Args: TsArgumentStack): TsArgument;
function fpsDiv (Args: TsArgumentStack): TsArgument; function fpsDiv (Args: TsArgumentStack): TsArgument;
function fpsPercent(Args: TsArgumentStack): TsArgument;
function fpsPower (Args: TsArgumentStack): TsArgument;
function fpsUMinus (Args: TsArgumentStack): TsArgument;
function fpsUPlus (Args: TsArgumentStack): TsArgument;
function fpsConcat (Args: TsArgumentStack): TsArgument;
function fpsEqual (Args: TsArgumentStack): TsArgument;
implementation implementation
uses
Math;
{ TsArgumentStack } { TsArgumentStack }
@ -142,7 +158,7 @@ end;
@param Arg Argument to be considered @param Arg Argument to be considered
@param ABool Replacement for the missing value @param ABool Replacement for the missing value
} }
procedure CheckMissingBool(var Arg: TsArgument; ABool: Boolean); procedure FixMissingBool(var Arg: TsArgument; ABool: Boolean);
begin begin
if Arg.IsMissing then Arg.BoolValue := ABool; if Arg.IsMissing then Arg.BoolValue := ABool;
end; end;
@ -152,7 +168,7 @@ end;
@param Arg Argument to be considered @param Arg Argument to be considered
@param ANumber Replacement for the missing value @param ANumber Replacement for the missing value
} }
procedure CheckMissingNumber(var Arg: TsArgument; ANumber: Double); procedure FixMissingNumber(var Arg: TsArgument; ANumber: Double);
begin begin
if Arg.IsMissing then Arg.NumberValue := ANumber; if Arg.IsMissing then Arg.NumberValue := ANumber;
end; end;
@ -162,7 +178,7 @@ end;
@param Arg Argument to be considered @param Arg Argument to be considered
@param AString Replacement for the missing value @param AString Replacement for the missing value
} }
procedure CheckMissingString(var Arg: TsArgument; AString: String); procedure FixMissingString(var Arg: TsArgument; AString: String);
begin begin
if Arg.IsMissing then Arg.StringValue := AString; if Arg.IsMissing then Arg.StringValue := AString;
end; end;
@ -170,95 +186,254 @@ end;
{ Preparing arguments } { Preparing arguments }
function GetNumberFromArgument(Arg: TsArgument; var ANumber: Double): TsArgumentError; function GetBoolFromArgument(Arg: TsArgument; var AValue: Boolean): TsErrorValue;
begin begin
Result := aeOK; case Arg.ArgumentType of
atBool : begin
AValue := Arg.BoolValue;
Result := errOK;
end;
else Result := errWrongType;
end;
end;
function GetNumberFromArgument(Arg: TsArgument; var ANumber: Double): TsErrorValue;
begin
Result := errOK;
case Arg.ArgumentType of case Arg.ArgumentType of
atNumber : ANumber := Arg.NumberValue; atNumber : ANumber := Arg.NumberValue;
atString : if not TryStrToFloat(arg.StringValue, ANumber) then Result := aeWrongType; atString : if not TryStrToFloat(arg.StringValue, ANumber) then Result := errWrongType;
atBool : if Arg.BoolValue then ANumber := 1.0 else ANumber := 0.0; atBool : if Arg.BoolValue then ANumber := 1.0 else ANumber := 0.0;
end; end;
end; end;
function GetStringFromArgument(Arg: TsArgument; var AString: String): TsErrorValue;
begin
case Arg.ArgumentType of
atString : begin
AString := Arg.StringValue;
Result := errOK;
end;
else Result := errWrongType;
end;
end;
function CreateBool(AValue: Boolean): TsArgument;
begin
Result.ArgumentType := atBool;
Result.Boolvalue := AValue;
end;
function CreateNumber(AValue: Double): TsArgument; function CreateNumber(AValue: Double): TsArgument;
begin begin
Result.ArgumentType := atNumber; Result.ArgumentType := atNumber;
Result.NumberValue := AValue; Result.NumberValue := AValue;
end; end;
function CreateString(AValue: String): TsArgument;
begin
Result.ArgumentType := atString;
Result.StringValue := AValue;
end;
function CreateError(AError: TsArgumentError): TsArgument; function CreateError(AError: TsErrorValue): TsArgument;
begin begin
Result.ArgumentType := atError; Result.ArgumentType := atError;
Result.ErrorValue := AError; Result.ErrorValue := AError;
end; end;
function Pop_1Bool(Args: TsArgumentStack; out a: Boolean): TsErrorValue;
begin
Result := GetBoolFromArgument(Args.Pop, a);
end;
function Pop_1Float(Args: TsArgumentStack; out a: Double): TsErrorValue;
begin
Result := GetNumberFromArgument(Args.Pop, a);
end;
function Pop_1String(Args: TsArgumentStack; out a: String): TsErrorvalue;
begin
Result := GetStringFromArgument(Args.Pop, a);
end;
function Pop_2Bools(Args: TsArgumentStack; out a, b: Boolean): TsErrorValue;
var
erra, errb: TsErrorValue;
begin
// Pop the data in reverse order they were pushed! Otherwise they will be
// applied to the function in the wrong order.
errb := GetBoolFromArgument(Args.Pop, b);
erra := GetBoolFromArgument(Args.Pop, a);
if erra <> errOK then
Result := erra
else if errb <> errOK then
Result := errb
else
Result := errOK;
end;
function Pop_2Floats(Args: TsArgumentStack; out a, b: Double): TsErrorValue;
var
erra, errb: TsErrorValue;
begin
// Pop the data in reverse order they were pushed! Otherwise they will be
// applied to the function in the wrong order.
errb := GetNumberFromArgument(Args.Pop, b);
erra := GetNumberFromArgument(Args.Pop, a);
if erra <> errOK then
Result := erra
else if errb <> errOK then
Result := errb
else
Result := errOK;
end;
function Pop_2Strings(Args: TsArgumentStack; out a, b: String): TsErrorValue;
var
erra, errb: TsErrorValue;
begin
// Pop the data in reverse order they were pushed! Otherwise they will be
// applied to the function in the wrong order.
errb := GetStringFromArgument(Args.Pop, b);
erra := GetStringFromArgument(Args.Pop, a);
if erra <> errOK then
Result := erra
else if errb <> errOK then
Result := errb
else
Result := errOK;
end;
{ Operations } { Operations }
function fpsAdd(Args: TsArgumentStack): TsArgument; function fpsAdd(Args: TsArgumentStack): TsArgument;
var var
a, b: Double; a, b: Double;
erra, errb: TsArgumentError; err: TsErrorValue;
begin begin
errb := GetNumberFromArgument(Args.Pop, b); err := Pop_2Floats(Args, a, b);
erra := GetNumberFromArgument(Args.Pop, a); if err = errOK then
if erra <> aeOK then Result := CreateNumber(a + b)
Result := CreateError(erra)
else if errb <> aeOK then
Result := CreateError(errb)
else else
Result := CreateNumber(a + b); Result := CreateError(err);
end; end;
function fpsSub(Args: TsArgumentStack): TsArgument; function fpsSub(Args: TsArgumentStack): TsArgument;
var var
a, b: Double; a, b: Double;
erra, errb: TsArgumentError; err: TsErrorValue;
begin begin
// Pop the data in reverse order they were pushed! err := Pop_2Floats(Args, a, b);
errb := GetNumberFromArgument(Args.Pop, b); if err = errOK then
erra := GetNumberFromArgument(Args.Pop, a); Result := CreateNumber(a - b)
if erra <> aeOK then
Result := CreateError(erra)
else if errb <> aeOK then
Result := CreateError(errb)
else else
Result := CreateNumber(a - b); Result := CreateError(err);
end; end;
function fpsMul(Args: TsArgumentStack): TsArgument; function fpsMul(Args: TsArgumentStack): TsArgument;
var var
a, b: Double; a, b: Double;
erra, errb: TsArgumentError; err: TsErrorValue;
begin begin
errb := GetNumberFromArgument(Args.Pop, b); err := Pop_2Floats(Args, a, b);
erra := GetNumberFromArgument(Args.Pop, a); if err = errOK then
if erra <> aeOK then Result := CreateNumber(a * b)
Result := CreateError(erra)
else if errb <> aeOK then
Result := CreateError(errb)
else else
Result := CreateNumber(a * b); Result := CreateError(err);
end; end;
function fpsDiv(Args: TsArgumentStack): TsArgument; function fpsDiv(Args: TsArgumentStack): TsArgument;
var var
a, b: Double; a, b: Double;
erra, errb: TsArgumentError; err: TsErrorValue;
begin begin
// Pop the data in reverse order they were pushed! err := Pop_2Floats(Args, a, b);
errb := GetNumberFromArgument(Args.Pop, b); if err <> errOK then
erra := GetNumberFromArgument(Args.Pop, a); Result := CreateError(err)
if erra <> aeOK then
Result := CreateError(erra)
else if errb <> aeOK then
Result := CreateError(errb)
else if b = 0 then else if b = 0 then
Result := CreateError(aeDivideByZero) Result := CreateError(errDivideByZero)
else else
Result := CreateNumber(a / b); Result := CreateNumber(a / b);
end; end;
function fpsPercent(Args: TsArgumentStack): TsArgument;
var
a: Double;
err: TsErrorValue;
begin
err := Pop_1Float(Args, a);
if err = errOK then
Result := CreateNumber(a * 0.01)
else
Result := CreateError(err);
end;
function fpsPower(Args: TsArgumentStack): TsArgument;
var
a, b: Double;
err: TsErrorValue;
begin
err := Pop_2Floats(Args, a, b);
if err = errOK then begin
try
Result := CreateNumber(power(a, b));
except on E: EInvalidArgument do
Result := CreateError(errOverflow);
// this could happen, e.g., for "power( (neg value), (non-integer) )"
end;
end else
Result := CreateError(err);
end;
function fpsUMinus(Args: TsArgumentStack): TsArgument;
var
a: Double;
err: TsErrorValue;
begin
err := Pop_1Float(Args, a);
if err = errOK then
Result := CreateNumber(-a)
else
Result := CreateError(err);
end;
function fpsUPlus(Args: TsArgumentStack): TsArgument;
var
a: Double;
err: TsErrorValue;
begin
err := Pop_1Float(Args, a);
if err = errOK then
Result := CreateNumber(a)
else
Result := CreateError(err);
end;
function fpsConcat(Args: TsArgumentStack): TsArgument;
var
a, b: String;
err: TsErrorValue;
begin
err := Pop_2Strings(Args, a, b);
if err = errOK then
Result := CreateString(a + b)
else
Result := CreateError(err);
end;
function fpsEqual(Args: TsArgumentStack): TsArgument;
var
a, b: Boolean;
err: TsErrorValue;
begin
err := Pop_2Bools(Args, a, b);
if err = errOK then
Result := CreateBool(a = b)
else
Result := CreateError(err);
end;
end. end.

38
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -1107,11 +1107,11 @@ const
(Symbol:'-'; MinParams:2; MaxParams:2; Func:fpsSub), // fekSub (Symbol:'-'; MinParams:2; MaxParams:2; Func:fpsSub), // fekSub
(Symbol:'*'; MinParams:2; MaxParams:2; Func:fpsMul), // fekMul (Symbol:'*'; MinParams:2; MaxParams:2; Func:fpsMul), // fekMul
(Symbol:'/'; MinParams:2; MaxParams:2; Func:fpsDiv), // fekDiv (Symbol:'/'; MinParams:2; MaxParams:2; Func:fpsDiv), // fekDiv
(Symbol:'%'; MinParams:1; MaxParams:1; Func:nil), // fekPercent (Symbol:'%'; MinParams:1; MaxParams:1; Func:fpsPercent), // fekPercent
(Symbol:'^'; MinParams:2; MaxParams:2; Func:nil), // fekPower (Symbol:'^'; MinParams:2; MaxParams:2; Func:fpsPower), // fekPower
(Symbol:'-'; MinParams:1; MaxParams:1; Func:nil), // fekUMinus (Symbol:'-'; MinParams:1; MaxParams:1; Func:fpsUMinus), // fekUMinus
(Symbol:'+'; MinParams:1; MaxParams:1; Func:nil), // fekUPlus (Symbol:'+'; MinParams:1; MaxParams:1; Func:fpsUPlus), // fekUPlus
(Symbol:'&'; MinParams:2; MaxParams:2; Func:nil), // fekConcat (string concatenation) (Symbol:'&'; MinParams:2; MaxParams:2; Func:fpsConcat), // fekConcat (string concatenation)
(Symbol:'='; MinParams:2; MaxParams:2; Func:nil), // fekEqual (Symbol:'='; MinParams:2; MaxParams:2; Func:nil), // fekEqual
(Symbol:'>'; MinParams:2; MaxParams:2; Func:nil), // fekGreater (Symbol:'>'; MinParams:2; MaxParams:2; Func:nil), // fekGreater
(Symbol:'>='; MinParams:2; MaxParams:2; Func:nil), // fekGreaterEqual (Symbol:'>='; MinParams:2; MaxParams:2; Func:nil), // fekGreaterEqual
@ -1458,15 +1458,11 @@ begin
if not Assigned(func) then begin if not Assigned(func) then begin
// calculation of function not implemented // calculation of function not implemented
exit; exit;
end; { end;
if args.Count < FEProps[fe.ElementKind].MinParams then begin if args.Count < fe.ParamsNum then begin
// not enough parameters // not enough parameters
exit; exit;
end; end;
if args.Count > FEProps[fe.ElementKind].MaxParams then begin
// too many parameters
exit;
end; }
// Result of function // Result of function
val := func(args); val := func(args);
// Push valid result on stack, exit in case of error // Push valid result on stack, exit in case of error
@ -1474,8 +1470,11 @@ begin
atNumber, atString, atBool: atNumber, atString, atBool:
args.Push(val); args.Push(val);
atError: atError:
begin
WriteErrorValue(ACell, val.ErrorValue);
exit; exit;
end; end;
end;
end; // case end; // case
end; // for end; // for
if args.Count = 1 then begin if args.Count = 1 then begin
@ -1485,8 +1484,18 @@ begin
atBool : WriteNumber(ACell, 1.0*ord(val.BoolValue)); atBool : WriteNumber(ACell, 1.0*ord(val.BoolValue));
atString: WriteUTF8Text(ACell, val.StringValue); atString: WriteUTF8Text(ACell, val.StringValue);
end; end;
{
case val.ArgumentType of
atNumber: ACell^.NumberValue := val.NumberValue; //WriteNumber(ACell, val.NumberValue);
atBool : ACell^.NumberValue := 1.0 * ord(val.BoolValue); //WriteNumber(ACell, 1.0*ord(val.BoolValue));
atString: ACell^.UTF8StringValue := val.StringValue; //(ACell, val.StringValue);
end;
}
end else end else
WriteErrorValue(ACell, errArgError); // This case is a program error --> raise an exception
raise Exception.CreateFmt('Incorrect argument count of the formula in cell %s', [
GetCellString(ACell^.Row, ACell^.Col, [])
]);
finally finally
args.Free; args.Free;
end; end;
@ -5118,13 +5127,16 @@ end;
} }
procedure TsCustomSpreadWriter.WriteCellCallback(ACell: PCell; AStream: TStream); procedure TsCustomSpreadWriter.WriteCellCallback(ACell: PCell; AStream: TStream);
begin begin
if Length(ACell^.RPNFormulaValue) > 0 then
WriteRPNFormula(AStream, ACell^.Row, ACell^.Col, ACell^.RPNFormulaValue, ACell)
else
case ACell.ContentType of case ACell.ContentType of
cctEmpty : WriteBlank(AStream, ACell^.Row, ACell^.Col, ACell); cctEmpty : WriteBlank(AStream, ACell^.Row, ACell^.Col, ACell);
cctDateTime : WriteDateTime(AStream, ACell^.Row, ACell^.Col, ACell^.DateTimeValue, ACell); cctDateTime : WriteDateTime(AStream, ACell^.Row, ACell^.Col, ACell^.DateTimeValue, ACell);
cctNumber : WriteNumber(AStream, ACell^.Row, ACell^.Col, ACell^.NumberValue, ACell); cctNumber : WriteNumber(AStream, ACell^.Row, ACell^.Col, ACell^.NumberValue, ACell);
cctUTF8String : WriteLabel(AStream, ACell^.Row, ACell^.Col, ACell^.UTF8StringValue, ACell); cctUTF8String : WriteLabel(AStream, ACell^.Row, ACell^.Col, ACell^.UTF8StringValue, ACell);
cctFormula : WriteFormula(AStream, ACell^.Row, ACell^.Col, ACell^.FormulaValue, ACell); cctFormula : WriteFormula(AStream, ACell^.Row, ACell^.Col, ACell^.FormulaValue, ACell);
cctRPNFormula: WriteRPNFormula(AStream, ACell^.Row, ACell^.Col, ACell^.RPNFormulaValue, ACell); // cctRPNFormula: WriteRPNFormula(AStream, ACell^.Row, ACell^.Col, ACell^.RPNFormulaValue, ACell);
end; end;
end; end;

106
components/fpspreadsheet/tests/formulatests.pas
View File

@ -2,13 +2,19 @@ unit formulatests;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{ Deactivate this define in order to bypass tests which will raise an exception
when the corresponding rpn formula is calculated. }
{.$DEFINE ENABLE_CALC_RPN_EXCEPTIONS}
interface interface
uses uses
// Not using Lazarus package as the user may be working with multiple versions // Not using Lazarus package as the user may be working with multiple versions
// Instead, add .. to unit search path // Instead, add .. to unit search path
Classes, SysUtils, fpcunit, testutils, testregistry, Classes, SysUtils, fpcunit, testutils, testregistry,
fpsallformats, fpspreadsheet, xlsbiff8 {and a project requirement for lclbase for utf8 handling}, fpsallformats, fpspreadsheet, fpsmath,
xlsbiff8 {and a project requirement for lclbase for utf8 handling},
testsutility; testsutility;
type type
@ -22,6 +28,8 @@ type
procedure TearDown; override; procedure TearDown; override;
// Test formula strings // Test formula strings
procedure TestWriteReadFormulaStrings(AFormat: TsSpreadsheetFormat); procedure TestWriteReadFormulaStrings(AFormat: TsSpreadsheetFormat);
// Test calculation of rpn formulas
procedure TestCalcRPNFormulas(AFormat: TsSpreadsheetformat);
published published
// Writes out numbers & reads back. // Writes out numbers & reads back.
@ -32,12 +40,16 @@ type
procedure TestWriteRead_BIFF5_FormulaStrings; procedure TestWriteRead_BIFF5_FormulaStrings;
{ BIFF8 Tests } { BIFF8 Tests }
procedure TestWriteRead_BIFF8_FormulaStrings; procedure TestWriteRead_BIFF8_FormulaStrings;
// Writes out and calculates formulas, read back
{ BIFF8 Tests }
procedure TestWriteRead_BIFF8_CalcRPNFormula;
end; end;
implementation implementation
uses uses
fpsUtils, rpnFormulaUnit; math, typinfo, fpsUtils, rpnFormulaUnit;
{ TSpreadWriteReadFormatTests } { TSpreadWriteReadFormatTests }
@ -115,6 +127,96 @@ begin
TestWriteReadFormulaStrings(sfExcel8); TestWriteReadFormulaStrings(sfExcel8);
end; end;
{ Test calculation of rpn formulas }
procedure TSpreadWriteReadFormulaTests.TestCalcRPNFormulas(AFormat: TsSpreadsheetFormat);
const
SHEET = 'Sheet1';
var
MyWorksheet: TsWorksheet;
MyWorkbook: TsWorkbook;
Row: Integer;
TempFile: string; //write xls/xml to this file and read back from it
actual: TsArgument;
expected: TsArgument;
cell: PCell;
sollValues: array of TsArgument;
a, b: Double;
begin
TempFile := GetTempFileName;
// Create test workbook
MyWorkbook := TsWorkbook.Create;
MyWorkSheet:= MyWorkBook.AddWorksheet(SHEET);
MyWorkSheet.Options := MyWorkSheet.Options + [soCalcBeforeSaving];
// Calculation of rpn formulas must be activated expicitely!
{ Write out test formulas.
This include file creates various rpn formulas and stores the expected
results in array "sollValues".
The test file contains the text representation in column A, and the
formula in column B. }
Row := 0;
{$I testcases_calcrpnformula.inc}
MyWorkBook.WriteToFile(TempFile, AFormat, true);
MyWorkbook.Free;
// Open the workbook
MyWorkbook := TsWorkbook.Create;
MyWorkbook.ReadFromFile(TempFile, AFormat);
if AFormat = sfExcel2 then
MyWorksheet := MyWorkbook.GetFirstWorksheet
else
MyWorksheet := GetWorksheetByName(MyWorkBook, SHEET);
if MyWorksheet=nil then
fail('Error in test code. Failed to get named worksheet');
for Row := 0 to MyWorksheet.GetLastRowIndex do begin
cell := MyWorksheet.FindCell(Row, 1);
if (cell = nil) then
fail('Error in test code: Failed to get cell ' + CellNotation(MyWorksheet, Row, 1));
case cell^.ContentType of
cctBool : actual := CreateBool(cell^.NumberValue <> 0);
cctNumber : actual := CreateNumber(cell^.NumberValue);
cctError : actual := CreateError(cell^.ErrorValue);
cctUTF8String : actual := CreateString(cell^.UTF8StringValue);
else fail('ContentType not supported');
end;
expected := SollValues[row];
CheckEquals(ord(expected.ArgumentType), ord(actual.ArgumentType),
'Test read calculated formula data type mismatch, cell '+CellNotation(MyWorkSheet,Row,1));
case actual.ArgumentType of
atBool:
CheckEquals(BoolToStr(expected.BoolValue), BoolToStr(actual.BoolValue),
'Test read calculated formula result mismatch, cell '+CellNotation(MyWorkSheet,Row,1));
atNumber:
CheckEquals(expected.NumberValue, actual.NumberValue,
'Test read calculated formula result mismatch, cell '+CellNotation(MyWorkSheet,Row,1));
atString:
CheckEquals(expected.StringValue, actual.StringValue,
'Test read calculated formula result mismatch, cell '+CellNotation(MyWorkSheet,Row,1));
atError:
CheckEquals(
GetEnumName(TypeInfo(TsErrorValue), ord(expected.ErrorValue)),
GetEnumname(TypeInfo(TsErrorValue), ord(actual.ErrorValue)),
'Test read calculated formula error value mismatch, cell '+CellNotation(MyWorkSheet,Row,1));
end;
end;
// Finalization
MyWorkbook.Free;
DeleteFile(TempFile);
end;
procedure TSpreadWriteReadFormulaTests.TestWriteRead_BIFF8_CalcRPNFormula;
begin
TestCalcRPNFormulas(sfExcel8);
end;
initialization initialization
// Register so these tests are included in a full run // Register so these tests are included in a full run
RegisterTest(TSpreadWriteReadFormulaTests); RegisterTest(TSpreadWriteReadFormulaTests);

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

@ -47,9 +47,6 @@
<UseExternalDbgSyms Value="True"/> <UseExternalDbgSyms Value="True"/>
</Debugging> </Debugging>
</Linking> </Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions> </CompilerOptions>
</Item2> </Item2>
</BuildModes> </BuildModes>
@ -88,7 +85,6 @@
<Unit2> <Unit2>
<Filename Value="stringtests.pas"/> <Filename Value="stringtests.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="stringtests"/>
</Unit2> </Unit2>
<Unit3> <Unit3>
<Filename Value="numberstests.pas"/> <Filename Value="numberstests.pas"/>
@ -98,42 +94,34 @@
<Unit4> <Unit4>
<Filename Value="manualtests.pas"/> <Filename Value="manualtests.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="manualtests"/>
</Unit4> </Unit4>
<Unit5> <Unit5>
<Filename Value="testsutility.pas"/> <Filename Value="testsutility.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="testsutility"/>
</Unit5> </Unit5>
<Unit6> <Unit6>
<Filename Value="internaltests.pas"/> <Filename Value="internaltests.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="internaltests"/>
</Unit6> </Unit6>
<Unit7> <Unit7>
<Filename Value="formattests.pas"/> <Filename Value="formattests.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="formattests"/>
</Unit7> </Unit7>
<Unit8> <Unit8>
<Filename Value="colortests.pas"/> <Filename Value="colortests.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="colortests"/>
</Unit8> </Unit8>
<Unit9> <Unit9>
<Filename Value="fonttests.pas"/> <Filename Value="fonttests.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="fonttests"/>
</Unit9> </Unit9>
<Unit10> <Unit10>
<Filename Value="optiontests.pas"/> <Filename Value="optiontests.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="optiontests"/>
</Unit10> </Unit10>
<Unit11> <Unit11>
<Filename Value="numformatparsertests.pas"/> <Filename Value="numformatparsertests.pas"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="numformatparsertests"/>
</Unit11> </Unit11>
<Unit12> <Unit12>
<Filename Value="rpnformulaunit.pas"/> <Filename Value="rpnformulaunit.pas"/>
@ -168,9 +156,6 @@
<OptimizationLevel Value="0"/> <OptimizationLevel Value="0"/>
</Optimizations> </Optimizations>
</CodeGeneration> </CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions> </CompilerOptions>
<Debugging> <Debugging>
<Exceptions Count="6"> <Exceptions Count="6">

147
components/fpspreadsheet/tests/testcases_calcrpnformula.inc Normal file
View File

@ -0,0 +1,147 @@
{ include file for "formulatests.pas", containing the test cases for the
calcrpnformula test. }
// Addition
Row := 0;
MyWorksheet.WriteUTF8Text(Row, 0, '=1+1');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(1.0,
RPNNumber(1.0,
RPNFunc(fekAdd, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(1.0+1.0);
// Subtraction
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=1-10');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(1,
RPNNumber(10,
RPNFunc(fekSub, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(1-10);
// Multiplication
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=10*-3');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(10,
RPNNumber(-3,
RPNFunc(fekMul, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(10*(-3));
// Multiplication w/Parenthesis
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=10*(-3)');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(10,
RPNNumber(-3,
RPNParenthesis(
RPNFunc(fekMul, nil))))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(10*(-3));
// Division
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=10/200');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(10,
RPNNumber(200,
RPNFunc(fekDiv, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(10/200);
// Division: Error case - divide by zero
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=10/0');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(10,
RPNNumber(0,
RPNFunc(fekDiv, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateError(errDivideByZero);
// Percentage
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=10%');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(10,
RPNFunc(fekPercent, nil))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(10*0.01);
// Power
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=power(2.0, 0.5)');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(2.0,
RPNNumber(0.5,
RPNFunc(fekPower, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(power(2, 0.5));
{$IFDEF ENABLE_CALC_RPN_EXCEPTIONS}
// Power: Error case "power( (negative number), (fractional number) )"
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=power(-2.0, 0.5)');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(-2.0,
RPNNumber(0.5,
RPNFunc(fekPower, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateError(errOverflow);
{$ENDIF}
// Unary minus
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=-(-1)');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(-1,
RPNParenthesis(
RPNFunc(fekUMinus, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(1);
// Unary plus
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=+(-1)');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(-1,
RPNParenthesis(
RPNFunc(fekUPlus, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateNumber(-1);
// String concatenation
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '="Hallo"&" world"');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNString('Hallo',
RPNString(' world',
RPNFunc(fekConcat, nil)))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateString('Hallo' + ' world');
(*
// Equal (strings)
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=("Hallo"="world")');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNString('Hallo',
RPNString('world',
RPNParenthesis(
RPNFunc(fekConcat, nil))))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateBool('Hallo' = 'world');
// Equal (numbers)
inc(Row);
MyWorksheet.WriteUTF8Text(Row, 0, '=(1=1)');
MyWorksheet.WriteRPNFormula(Row, 1, CreateRPNFormula(
RPNNumber(1.0,
RPNNumber(1.0,
RPNParenthesis(
RPNFunc(fekEqual, nil))))));
SetLength(sollValues, Row+1);
sollValues[Row] := CreateBool(1=1);
*)

59
components/fpspreadsheet/xlsbiff8.pas
View File

@ -125,6 +125,7 @@ type
const AValue: string; ACell: PCell); override; const AValue: string; ACell: PCell); override;
procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Cardinal; procedure WriteRPNFormula(AStream: TStream; const ARow, ACol: Cardinal;
const AFormula: TsRPNFormula; ACell: PCell); override; const AFormula: TsRPNFormula; ACell: PCell); override;
procedure WriteStringRecord(AStream: TStream; AString: string);
procedure WriteStyle(AStream: TStream); procedure WriteStyle(AStream: TStream);
procedure WriteWindow2(AStream: TStream; ASheet: TsWorksheet); procedure WriteWindow2(AStream: TStream; ASheet: TsWorksheet);
procedure WriteXF(AStream: TStream; AFontIndex: Word; procedure WriteXF(AStream: TStream; AFontIndex: Word;
@ -798,6 +799,7 @@ procedure TsSpreadBIFF8Writer.WriteRPNFormula(AStream: TStream; const ARow,
ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell); ACol: Cardinal; const AFormula: TsRPNFormula; ACell: PCell);
var var
FormulaResult: double; FormulaResult: double;
FormulaResultWords: array[0..3] of word absolute FormulaResult;
i: Integer; i: Integer;
len: Integer; len: Integer;
RPNLength: Word; RPNLength: Word;
@ -809,6 +811,38 @@ var
begin begin
RPNLength := 0; RPNLength := 0;
FormulaResult := 0.0; FormulaResult := 0.0;
case ACell^.ContentType of
cctNumber:
FormulaResult := ACell^.NumberValue;
cctDateTime:
FormulaResult := ACell^.DateTimeValue;
cctUTF8String:
begin
if ACell^.UTF8StringValue = '' then
FormulaResultWords[0] := 3;
FormulaResultWords[3] := $FFFF;
end;
cctBool:
begin
FormulaResultWords[0] := 1;
FormulaResultWords[1] := word(ACell^.NumberValue <> 0);
FormulaResultWords[3] := $FFFF;
end;
cctError:
begin
FormulaResultWords[0] := 2;
case ACell^.ErrorValue of
errEmptyIntersection: FormulaResultWords[1] := ERR_INTERSECTION_EMPTY;// #NULL!
errDivideByZero : FormulaResultWords[1] := ERR_DIVIDE_BY_ZERO; // #DIV/0!
errWrongType : FormulaResultWords[1] := ERR_WRONG_TYPE_OF_OPERAND; // #VALUE!
errIllegalRef : FormulaResultWords[1] := ERR_ILLEGAL_REFERENCE; // #REF!
errWrongName : FormulaResultWords[1] := ERR_WRONG_NAME; // #NAME?
errOverflow : FormulaResultWords[1] := ERR_OVERFLOW; // #NUM!
errArgError : FormulaResultWords[1] := ERR_ARG_ERROR; // #N/A;
end;
FormulaResultWords[3] := $FFFF;
end;
end;
{ BIFF Record header } { BIFF Record header }
AStream.WriteWord(WordToLE(INT_EXCEL_ID_FORMULA)); AStream.WriteWord(WordToLE(INT_EXCEL_ID_FORMULA));
@ -950,6 +984,31 @@ begin
AStream.Position := RecordSizePos; AStream.Position := RecordSizePos;
AStream.WriteWord(WordToLE(22 + RPNLength)); AStream.WriteWord(WordToLE(22 + RPNLength));
AStream.position := FinalPos; AStream.position := FinalPos;
{ Write following STRING record if formula result is a non-empty string }
if (ACell^.ContentType = cctUTF8String) and (ACell^.UTF8StringValue <> '') then
WriteStringRecord(AStream, ACell^.UTF8StringValue);
end;
procedure TsSpreadBIFF8Writer.WriteStringRecord(AStream: TStream;
AString: String);
var
wideStr: widestring;
len: Integer;
begin
wideStr := AString;
len := Length(wideStr);
{ BIFF Record header }
AStream.WriteWord(WordToLE(INT_EXCEL_ID_STRING));
AStream.WriteWord(WordToLE(3 + len*SizeOf(widechar)));
{ Write widestring length }
AStream.WriteWord(WordToLE(len));
{ Widestring flags, 1=regular unicode LE string }
AStream.WriteByte(1);
{ Write characters }
AStream.WriteBuffer(WideStringToLE(wideStr)[1], len * SizeOf(WideChar));
end; end;
{******************************************************************* {*******************************************************************

2
components/fpspreadsheet/xlscommon.pas
View File

@ -37,7 +37,7 @@ const
INT_EXCEL_ID_BLANK = $0201; // BIFF2: $0001 INT_EXCEL_ID_BLANK = $0201; // BIFF2: $0001
INT_EXCEL_ID_NUMBER = $0203; // BIFF2: $0003 INT_EXCEL_ID_NUMBER = $0203; // BIFF2: $0003
INT_EXCEL_ID_LABEL = $0204; // BIFF2: $0004 INT_EXCEL_ID_LABEL = $0204; // BIFF2: $0004
INT_EXCEL_ID_STRING = $0207; // BIFF2: $0007; INT_EXCEL_ID_STRING = $0207; // BIFF2: $0007
INT_EXCEL_ID_ROW = $0208; // BIFF2: $0008 INT_EXCEL_ID_ROW = $0208; // BIFF2: $0008
INT_EXCEL_ID_INDEX = $020B; // BIFF2: $000B INT_EXCEL_ID_INDEX = $020B; // BIFF2: $000B
INT_EXCEL_ID_WINDOW2 = $023E; // BIFF2: $003E INT_EXCEL_ID_WINDOW2 = $023E; // BIFF2: $003E