--- Merging r30307 into '.':

U    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30307 into '.':
 U   .
--- Merging r30308 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
U    packages/fcl-fpcunit/src/DUnitCompatibleInterface.inc
--- Recording mergeinfo for merge of r30308 into '.':
 G   .
--- Merging r30309 into '.':
U    packages/fcl-fpcunit/src/consoletestrunner.pas
--- Recording mergeinfo for merge of r30309 into '.':
 G   .
--- Merging r30310 into '.':
U    packages/fcl-fpcunit/src/tests/frameworktest.pp
--- Recording mergeinfo for merge of r30310 into '.':
 G   .
--- Merging r30311 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30311 into '.':
 G   .
--- Merging r30312 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30312 into '.':
 G   .
--- Merging r30313 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30313 into '.':
 G   .
--- Merging r30314 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30314 into '.':
 G   .
--- Merging r30315 into '.':
G    packages/fcl-fpcunit/src/DUnitCompatibleInterface.inc
G    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30315 into '.':
 G   .
--- Merging r30316 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30316 into '.':
 G   .
--- Merging r30317 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30317 into '.':
 G   .
--- Merging r30318 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30318 into '.':
 G   .
--- Merging r30319 into '.':
U    packages/fcl-fpcunit/src/plaintestreport.pp
--- Recording mergeinfo for merge of r30319 into '.':
 G   .
--- Merging r30320 into '.':
U    packages/fcl-fpcunit/src/tests/asserttest.pp
--- Recording mergeinfo for merge of r30320 into '.':
 G   .
--- Merging r30321 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
G    packages/fcl-fpcunit/src/tests/asserttest.pp
--- Recording mergeinfo for merge of r30321 into '.':
 G   .
--- Merging r30322 into '.':
G    packages/fcl-fpcunit/src/tests/frameworktest.pp
--- Recording mergeinfo for merge of r30322 into '.':
 G   .
--- Merging r30360 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30360 into '.':
 G   .
--- Merging r30361 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30361 into '.':
 G   .
--- Merging r30362 into '.':
G    packages/fcl-fpcunit/src/tests/frameworktest.pp
--- Recording mergeinfo for merge of r30362 into '.':
 G   .
--- Merging r30363 into '.':
G    packages/fcl-fpcunit/src/plaintestreport.pp
G    packages/fcl-fpcunit/src/consoletestrunner.pas
U    packages/fcl-fpcunit/src/fpcunitreport.pp
--- Recording mergeinfo for merge of r30363 into '.':
 G   .
--- Merging r30460 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30460 into '.':
 G   .
--- Merging r30461 into '.':
G    packages/fcl-fpcunit/src/fpcunit.pp
--- Recording mergeinfo for merge of r30461 into '.':
 G   .

# revisions: 30307,30308,30309,30310,30311,30312,30313,30314,30315,30316,30317,30318,30319,30320,30321,30322,30360,30361,30362,30363,30460,30461

git-svn-id: branches/fixes_3_0@31101 -

packages/fcl-fpcunit/src/DUnitCompatibleInterface.inc

@@ -21,7 +21,6 @@
     class procedure CheckNotNull(obj: IUnknown; msg: string = ''); overload; virtual;
     class procedure CheckIs(obj :TObject; pClass: TClass; msg: string = ''); overload;
     class procedure CheckSame(expected, actual: TObject; msg: string = ''); overload;
-    class procedure FailNotEquals(expected, actual: string; msg: string = ''; errorAddr: Pointer = nil); virtual;
     class procedure CheckTrue(condition: Boolean; msg: string = '');
     class procedure CheckFalse(condition: Boolean; msg: string = '');
     class procedure CheckException(AMethod: TRunMethod; AExceptionClass: ExceptClass; msg: string = '');
@@ -153,12 +152,6 @@ begin
    AssertSame(msg, expected, actual);
 end;
 
-class procedure TAssert.FailNotEquals(expected, actual: string; msg: string;
-  errorAddr: Pointer);
-begin
-  Fail(msg + ComparisonMsg(Expected, Actual));
-end;
-
 class procedure TAssert.CheckTrue(condition: Boolean; msg: string);
 begin
   if (not condition) then
@@ -181,9 +174,9 @@ class function TAssert.EqualsErrorMessage(const expected, actual: string;
     const ErrorMsg: string): string;
 begin
   if (ErrorMsg <> '') then
-    Result := Format(sMsgActualEqualsExpFmt, [ErrorMsg + ', ', expected, actual])
+    Result := Format(sExpectedButWasAndMessageFmt, [ErrorMsg + ', ', expected, actual])
   else
-    Result := Format(sActualEqualsExpFmt, [expected, actual])
+    Result := Format(sExpectedButWasFmt, [expected, actual])
 end;
 
 class function TAssert.NotEqualsErrorMessage(const expected, actual: string;

packages/fcl-fpcunit/src/consoletestrunner.pas

@@ -73,9 +73,9 @@ uses testdecorator;
 
 const
   ShortOpts = 'alhp';
-  DefaultLongOpts: array[1..9] of string =
+  DefaultLongOpts: array[1..11] of string =
      ('all', 'list', 'progress', 'help', 'skiptiming',
-      'suite:', 'format:', 'file:', 'stylesheet:');
+      'suite:', 'format:', 'file:', 'stylesheet:','sparse','no-addresses');
 
   { TProgressWriter }
 type
@@ -154,6 +154,8 @@ begin
     end;
   end;
   Result.SkipTiming:=HasOption('skiptiming');
+  Result.Sparse:=HasOption('sparse');
+  Result.SkipAddressInfo:=HasOption('no-addresses');
 end;
 
 procedure TTestRunner.DoTestRun(ATest: TTest);
@@ -213,6 +215,8 @@ begin
     writeln('  --format=plain            output as plain ASCII source');
     writeln('  --format=xml              output as XML source (default)');
     writeln('  --skiptiming              Do not output timings (useful for diffs of testruns)');
+    writeln('  --sparse                  Produce Less output (errors/failures only)');
+    writeln('  --no-addresses            Do not display address info');
     writeln('  --stylesheet=<reference>   add stylesheet reference');
     writeln('  --file=<filename>         output results to file');
     writeln;
@@ -280,6 +284,7 @@ Type
   { TDecoratorTestSuite }
 
   TDecoratorTestSuite = Class(TTestSuite)
+  public
     Procedure  FreeDecorators(T : TTest);
     Destructor Destroy; override;
   end;

packages/fcl-fpcunit/src/fpcunit.pp

@@ -79,16 +79,21 @@ type
 
   TAssert = class(TTest)
   public
-    class procedure Fail(const AMessage: string);
-    class procedure Fail(const AFmt: string; Args : Array of const);
-    class procedure AssertTrue(const AMessage: string; ACondition: boolean); overload;
+    class procedure Fail(const AMessage: string; AErrorAddrs: Pointer = nil);
+    class procedure Fail(const AFmt: string; Args : Array of const;  AErrorAddrs: Pointer = nil);
+    class procedure FailEquals(const expected, actual: string; const ErrorMsg: string = ''; AErrorAddrs: Pointer = nil);
+    class procedure FailNotEquals(const expected, actual: string; const ErrorMsg: string = ''; AErrorAddrs: Pointer = nil);
+
+    class procedure AssertTrue(const AMessage: string; ACondition: boolean; AErrorAddrs: Pointer = nil); overload;
     class procedure AssertTrue(ACondition: boolean); overload;
-    class procedure AssertFalse(const AMessage: string; ACondition: boolean); overload;
+    class procedure AssertFalse(const AMessage: string; ACondition: boolean; AErrorAddrs: Pointer = nil); overload;
     class procedure AssertFalse(ACondition: boolean); overload;
     class procedure AssertEquals(const AMessage: string; Expected, Actual: string); overload;
     class procedure AssertEquals(Expected, Actual: string); overload;
+    {$IFDEF UNICODE}
     class procedure AssertEquals(const AMessage: string; Expected, Actual: UnicodeString); overload;
     class procedure AssertEquals(Expected, Actual: UnicodeString); overload;
+    {$ENDIF}
     class procedure AssertEquals(const AMessage: string; Expected, Actual: integer); overload;
     class procedure AssertEquals(Expected, Actual: integer); overload;
     class procedure AssertEquals(const AMessage: string; Expected, Actual: int64); overload;
@@ -125,8 +130,8 @@ type
     class procedure AssertNull(APointer: Pointer); overload;
     class procedure AssertNotNull(const AMessage, AString: string); overload;
     class procedure AssertNotNull(const AString: string); overload;
-    class procedure AssertException(const AMessage: string; AExceptionClass: ExceptClass; AMethod: TRunMethod); overload;
-    class procedure AssertException(AExceptionClass: ExceptClass; AMethod: TRunMethod); overload;
+    class procedure AssertException(const AMessage: string; AExceptionClass: ExceptClass; AMethod: TRunMethod;AExceptionMessage : String = ''; AExceptionContext : Integer = 0; AErrorAddr : Pointer = Nil); overload;
+    class procedure AssertException(AExceptionClass: ExceptClass; AMethod: TRunMethod;AExceptionMessage : String = ''; AExceptionContext : Integer = 0); overload;
 
     {$IFDEF DUnit}
       {$I DUnitCompatibleInterface.inc}
@@ -142,15 +147,17 @@ type
     FRaisedExceptionClass: TClass;
     FRaisedExceptionMessage: string;
     FSourceUnitName: string;
+    FThrownExceptionAddress: Pointer;
     FTestLastStep: TTestStep;
     function GetAsString: string;
     function GetExceptionMessage: string;
     function GetIsFailure: boolean;
     function GetIsIgnoredTest: boolean;
     function GetExceptionClassName: string;
+    function GetLocationInfo: string;
     procedure SetTestLastStep(const Value: TTestStep);
   public
-    constructor CreateFailure(ATest: TTest; E: Exception; LastStep: TTestStep);
+    constructor CreateFailure(ATest: TTest; E: Exception; LastStep: TTestStep; ThrownExceptionAddrs: pointer = nil);
     property ExceptionClass: TClass read FRaisedExceptionClass;
   published
     property AsString: string read GetAsString;
@@ -160,6 +167,7 @@ type
     property ExceptionClassName: string read GetExceptionClassName;
     property SourceUnitName: string read FSourceUnitName write FSourceUnitName;
     property LineNumber: longint read FLineNumber write FLineNumber;
+    property LocationInfo: string read GetLocationInfo;
     property FailedMethodName: string read FFailedMethodName write FFailedMethodName;
     property TestLastStep: TTestStep read FTestLastStep write SetTestLastStep;
   end;
@@ -174,11 +182,18 @@ type
     procedure EndTestSuite(ATestSuite: TTestSuite);
   end;
 
+  { TTestCase }
+
   TTestCase = class(TAssert)
   private
     FName: string;
     FTestSuiteName: string;
     FEnableIgnores: boolean;
+    FExpectedExceptionFailMessage : String;
+    FExpectedException : TClass;
+    FExpectedExceptionMessage: String;
+    FExpectedExceptionContext: Integer;
+    FExpectedExceptionCaller : Pointer;
   protected
     function CreateResult: TTestResult; virtual;
     procedure SetUp; virtual;
@@ -195,11 +210,17 @@ type
     constructor Create; virtual;
     constructor CreateWith(const ATestName: string; const ATestSuiteName: string); virtual;
     constructor CreateWithName(const AName: string); virtual;
+    procedure ExpectException(AExceptionClass: TClass; AExceptionMessage: string=''; AExceptionHelpContext: Integer=0);
+    procedure ExpectException(const Msg: String; AExceptionClass: TClass; AExceptionMessage: string=''; AExceptionHelpContext: Integer=0);
     function CountTestCases: integer; override;
     function CreateResultAndRun: TTestResult; virtual;
     procedure Run(AResult: TTestResult); override;
     function AsString: string;
     property TestSuiteName: string read GetTestSuiteName write SetTestSuiteName;
+    Property ExpectedExceptionFailMessage  : String Read FExpectedExceptionFailMessage;
+    Property ExpectedException : TClass Read FExpectedException;
+    Property ExpectedExceptionMessage : String Read FExpectedExceptionMessage;
+    Property ExpectedExceptionContext: Integer Read FExpectedExceptionContext;
   published
     property TestName: string read GetTestName write SetTestName;
   end;
@@ -261,9 +282,8 @@ type
     destructor Destroy; override;
     procedure ClearErrorLists;
     procedure StartTest(ATest: TTest);
-    procedure AddFailure(ATest: TTest; E: EAssertionFailedError; aFailureList: TFPList);
-    procedure AddError(ATest: TTest; E: Exception; AUnitName: string;
-      AFailedMethodName: string; ALineNumber: longint);
+    procedure AddFailure(ATest: TTest; E: EAssertionFailedError; aFailureList: TFPList; AThrownExceptionAdrs: Pointer);
+    procedure AddError(ATest: TTest; E: Exception; AThrownExceptionAdrs: Pointer);
     procedure EndTest(ATest: TTest);
     procedure AddListener(AListener: ITestListener);
     procedure RemoveListener(AListener: ITestListener);
@@ -288,8 +308,14 @@ type
     property StartingTime: TDateTime read FStartingTime;
   end;
 
-  function ComparisonMsg(const aExpected: string; const aActual: string; const aCheckEqual: boolean=true): string;
-  function ComparisonMsg(const aExpected: UnicodeString; const aActual: UnicodeString; const aCheckEqual: boolean=true): string;
+  function ComparisonMsg(const aExpected: string; const aActual: string; const aCheckEqual: boolean=true): string; overload;
+  {$IFDEF UNICODE}
+  function ComparisonMsg(const aExpected: UnicodeString; const aActual: UnicodeString; const aCheckEqual: boolean=true): string; overload;
+  {$ENDIF}
+  function ComparisonMsg(const aMsg: string; const aExpected: string; const aActual: string; const aCheckEqual: boolean=true): string; overload;
+
+  // Made public for 3rd party developers extending TTestCase with new AssertXXX methods
+  function CallerAddr: Pointer;
 
   
 Resourcestring
@@ -298,6 +324,8 @@ Resourcestring
   SCompareNotEqual = ' expected: not equal to <%s> but was: <%s>';
   SExpectedNotSame = 'expected not same';
   SExceptionCompare = 'Exception %s expected but %s was raised';
+  SExceptionMessageCompare = 'Exception raised but exception property Message differs: ';
+  SExceptionHelpContextCompare = 'Exception raised but exception property HelpContext differs: ';
   SMethodNotFound = 'Method <%s> not found';
   SNoValidInheritance = ' does not inherit from TTestCase';
   SNoValidTests = 'No valid tests found in ';
@@ -311,8 +339,6 @@ uses
 Const
   sExpectedButWasFmt = 'Expected:' + LineEnding + '"%s"' + LineEnding + 'But was:' + LineEnding + '"%s"';
   sExpectedButWasAndMessageFmt = '%s' + LineEnding + sExpectedButWasFmt;
-  sMsgActualEqualsExpFmt = '%s' + LineEnding + 'Expected ' + LineEnding + '< %s > ' + LineEnding + 'equals actual ' + LineEnding + '< %s >';
-  sActualEqualsExpFmt = 'Expected ' + LineEnding + '< %s > ' + LineEnding + 'equals actual ' + LineEnding + '< %s >';
 
 
 { This lets us use a single include file for both the Interface and
@@ -321,6 +347,48 @@ Const
 {$define read_implementation}
 
 
+function CallerAddr: Pointer;
+
+Var
+  bp,pcaddr : pointer;
+  
+begin
+  Result:=Nil;
+  bp:=get_frame;
+  pcaddr:=get_pc_addr;
+  get_caller_stackinfo(bp,pcaddr);
+  if bp<>Nil then
+    get_caller_stackinfo(bp,pcaddr);
+  result:=pcaddr;
+end;
+
+function AddrsToStr(Addrs: Pointer): string;
+begin
+  if PtrUInt(Addrs) > 0 then
+    Result := '$'+Format('%p', [Addrs])
+  else
+    Result := 'n/a';
+end;
+
+
+function PointerToLocationInfo(Addrs: Pointer): string;
+
+begin
+  Result := BackTraceStrFunc(Addrs);
+  if Trim(Result) = '' then
+    Result := AddrsToStr(Addrs) + '  <no map file>';
+end;
+
+// Get the ClassName of C
+function GetN(C : TClass) : string;
+begin
+  if C=Nil then
+    Result:='<NIL>'
+  else
+    Result:=C.ClassName;
+end;
+
+
 type
 
   TTestWarning = class(TTestCase)
@@ -346,7 +414,7 @@ begin
     Result := format(SCompareNotEqual, [aExpected, aActual]);
 end;
 
-
+{$IFDEF UNICODE}
 function ComparisonMsg(const aExpected: UnicodeString; const aActual: UnicodeString; const aCheckEqual: boolean=true): string;
 // aCheckEqual=false gives the error message if the test does *not* expect the results to be the same.
 begin
@@ -355,6 +423,12 @@ begin
   else {check unequal requires opposite error message}
     Result := format(UnicodeString(SCompareNotEqual), [aExpected, aActual]);
 end;
+{$ENDIF}
+
+function ComparisonMsg(const aMsg: string; const aExpected: string; const aActual: string; const aCheckEqual: boolean): string;
+begin
+  Result := '"' + aMsg + '"' + ComparisonMsg(aExpected, aActual, aCheckEqual);
+end;
 
 
 constructor EAssertionFailedError.Create;
@@ -369,13 +443,14 @@ begin
 end;
 
 
-constructor TTestFailure.CreateFailure(ATest: TTest; E: Exception; LastStep: TTestStep);
+constructor TTestFailure.CreateFailure(ATest: TTest; E: Exception; LastStep: TTestStep; ThrownExceptionAddrs: pointer);
 begin
   inherited Create;
   FTestName := ATest.GetTestName;
   FTestSuiteName := ATest.GetTestSuiteName;
   FRaisedExceptionClass := E.ClassType;
   FRaisedExceptionMessage := E.Message;
+  FThrownExceptionAddress := ThrownExceptionAddrs;
   FTestLastStep := LastStep;
 end;
 
@@ -400,6 +475,11 @@ begin
     Result := '<NIL>'
 end;
 
+function TTestFailure.GetLocationInfo: string;
+begin
+  Result := PointerToLocationInfo(FThrownExceptionAddress);
+end;
+
 
 function TTestFailure.GetExceptionMessage: string;
 begin
@@ -463,65 +543,86 @@ end;
 
 { TAssert }
 
-class procedure TAssert.Fail(const AMessage: string);
+class procedure TAssert.Fail(const AMessage: string; AErrorAddrs: Pointer);
 begin
-  raise EAssertionFailedError.Create(AMessage);
+  if AErrorAddrs = nil then
+    raise EAssertionFailedError.Create(AMessage) at CallerAddr
+  else
+    raise EAssertionFailedError.Create(AMessage) at AErrorAddrs;
 end;
 
-class procedure TAssert.Fail(const AFmt: string; Args: array of const);
+class procedure TAssert.Fail(const AFmt: string; Args: array of const; AErrorAddrs: Pointer = nil);
 begin
-  raise EAssertionFailedError.CreateFmt(AFmt,Args);
+  if AErrorAddrs = nil then
+    raise EAssertionFailedError.CreateFmt(AFmt,Args) at CallerAddr
+  else    
+    raise EAssertionFailedError.CreateFmt(AFmt,Args) at AErrorAddrs;
 end;
 
+class procedure TAssert.FailEquals(const expected, actual: string; const ErrorMsg: string; AErrorAddrs: Pointer);
+begin
+  Fail(EqualsErrorMessage(expected, actual, ErrorMsg), AErrorAddrs);
+end;
+
+class procedure TAssert.FailNotEquals(const expected, actual: string; const ErrorMsg: string; AErrorAddrs: Pointer);
+begin
+  Fail(NotEqualsErrorMessage(expected, actual, ErrorMsg), AErrorAddrs);
+end;
 
-class procedure TAssert.AssertTrue(const AMessage: string; ACondition: boolean);
+class procedure TAssert.AssertTrue(const AMessage: string; ACondition: boolean; AErrorAddrs: Pointer = nil);
 begin
+  if AErrorAddrs=Nil then
+    AErrorAddrs:=CallerAddr;
   if (not ACondition) then
-    Fail(AMessage);
+    Fail(AMessage,AErrorAddrs);
 end;
 
 
 class procedure TAssert.AssertTrue(ACondition: boolean);
+
 begin
-  AssertTrue('', ACondition);
+  AssertTrue('', ACondition,CallerAddr);
 end;
 
 
-class procedure TAssert.AssertFalse(const AMessage: string; ACondition: boolean
+class procedure TAssert.AssertFalse(const AMessage: string; ACondition: boolean; AErrorAddrs: Pointer = nil
   );
 begin
-  AssertTrue(AMessage, not ACondition);
+  if AErrorAddrs=Nil then
+    AErrorAddrs:=CallerAddr;
+  AssertTrue(AMessage, not ACondition,AErrorAddrs);
 end;
 
 
 class procedure TAssert.AssertFalse(ACondition: boolean);
 begin
-  AssertFalse('', ACondition);
+  AssertFalse('', ACondition,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: string);
 begin
-  AssertTrue(AMessage + ComparisonMsg(Expected, Actual), AnsiCompareStr(Expected, Actual) = 0);
+  AssertTrue(ComparisonMsg(AMessage ,Expected, Actual), AnsiCompareStr(Expected, Actual) = 0,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: string);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(Expected, Actual), AnsiCompareStr(Expected, Actual) = 0,CallerAddr);
 end;
 
-class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: Unicodestring);
+{$IFDEF UNICODE}
+class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: UnicodeString);
 begin
-  AssertTrue(AMessage + ComparisonMsg(Expected, Actual), (Expected=Actual));
+  AssertTrue(ComparisonMsg(AMessage,Expected, Actual), (Expected=Actual),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: UnicodeString);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(Expected, Actual), (Expected=Actual),CallerAddr);
 end;
-
+{$ENDIF}
 
 class procedure TAssert.AssertNotNull(const AString: string);
 begin
@@ -531,254 +632,256 @@ end;
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: integer);
 begin
-  AssertTrue(AMessage + ComparisonMsg(IntToStr(Expected), IntToStr(Actual)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,IntToStr(Expected), IntToStr(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: integer);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(IntToStr(Expected), IntToStr(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: int64);
 begin
-  AssertTrue(AMessage + ComparisonMsg(IntToStr(Expected), IntToStr(Actual)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,IntToStr(Expected), IntToStr(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: int64);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(IntToStr(Expected), IntToStr(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: currency);
 begin
-  AssertTrue(AMessage + ComparisonMsg(FloatToStr(Expected), FloatToStr(Actual)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,FloatToStr(Expected), FloatToStr(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: currency);
 begin
-   AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(FloatToStr(Expected), FloatToStr(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual, Delta: double);
 begin
-  AssertTrue(AMessage + ComparisonMsg(FloatToStr(Expected),FloatToStr(Actual)),
-    (Abs(Expected - Actual) <= Delta));
+  AssertTrue(ComparisonMsg(AMessage,FloatToStr(Expected),FloatToStr(Actual)),
+    (Abs(Expected - Actual) <= Delta),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual, Delta: double);
 begin
-  AssertEquals('', Expected, Actual, Delta);
+  AssertTrue(ComparisonMsg(FloatToStr(Expected),FloatToStr(Actual)),
+    (Abs(Expected - Actual) <= Delta),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNull(const AMessage, AString: string);
 begin
-  AssertTrue(AMessage, AString <> '');
+  AssertTrue(AMessage, AString <> '',CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: boolean);
 begin
-  AssertTrue(AMessage + ComparisonMsg(BoolToStr(Expected, true), BoolToStr(Actual, true)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,BoolToStr(Expected, true), BoolToStr(Actual, true)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: boolean);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(BoolToStr(Expected, true), BoolToStr(Actual, true)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: char);
 begin
-  AssertTrue(AMessage + ComparisonMsg(Expected, Actual), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,Expected, Actual), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: char);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(Expected, Actual), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: TClass);
 
-  Function GetN(C : TClass) : string;
-  begin
-    if C=Nil then
-      Result:='<NIL>'
-    else
-      Result:=C.ClassName;
-  end;
-
 begin
-  AssertTrue(AMessage + ComparisonMsg(GetN(Expected), GetN(Actual)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,GetN(Expected), GetN(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: TClass);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(GetN(Expected), GetN(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertSame(const AMessage: string; Expected, Actual: TObject);
 begin
-  AssertTrue(AMessage + ComparisonMsg(IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))),
-    Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertSame(Expected, Actual: TObject);
 begin
-  AssertSame('', Expected, Actual);
+  AssertTrue(ComparisonMsg(IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertSame(const AMessage: string; Expected, Actual: Pointer);
 begin
-  AssertTrue(AMessage + ComparisonMsg(IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))),
-    Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertSame(Expected, Actual: Pointer);
 begin
-  AssertSame('', Expected, Actual);
+  AssertTrue(ComparisonMsg(IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotSame(const AMessage: string; Expected, Actual: TObject);
 begin
-  AssertFalse(SExpectedNotSame, Expected = Actual);
+  AssertFalse('"' + aMessage + '"' + SExpectedNotSame, Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotSame(Expected, Actual: TObject);
 begin
-  AssertNotSame('', Expected, Actual);
+  AssertFalse(SExpectedNotSame, Expected = Actual);
 end;
 
 
 class procedure TAssert.AssertNotSame(const AMessage: string; Expected, Actual: Pointer);
 begin
-  AssertFalse(SExpectedNotSame, Expected = Actual);
+  AssertFalse('"' + aMessage + '"' + SExpectedNotSame, Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotSame(Expected, Actual: Pointer);
 begin
-  AssertNotSame('', Expected, Actual);
+  AssertFalse(SExpectedNotSame, Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNull(const AMessage: string; AObject: TObject);
 begin
-  AssertTrue(AMessage, (AObject <> nil));
+  AssertTrue(AMessage, (AObject <> nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNull(AObject: TObject);
 begin
-  AssertNotNull('', AObject);
+  AssertTrue('',(AObject <> nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNullIntf(const AMessage: string; AInterface: IInterface);
 begin
-  AssertTrue(AMessage, (AInterface <> nil));
+  AssertTrue(AMessage, (AInterface <> nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNullIntf(AInterface: IInterface);
 begin
-  AssertNotNull('', AInterface);
+  AssertTrue('', (AInterface <> nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNull(const AMessage: string; APointer: Pointer);
 begin
-  AssertTrue(AMessage, (APointer <> nil));
+  AssertTrue(AMessage, (APointer <> nil),callerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNull(APointer: Pointer);
 begin
-  AssertNotNull('', APointer);
+  AssertTrue('', (APointer <> nil),callerAddr);
 end;
 
 
 class procedure TAssert.AssertNull(const AMessage: string; AObject: TObject);
 begin
-  AssertTrue(AMessage, (AObject = nil));
+  AssertTrue(AMessage, (AObject = nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNull(AObject: TObject);
 begin
-  AssertNull('', AObject);
+  AssertTrue('',(AObject = nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNullIntf(const AMessage: string; AInterface: IInterface);
 begin
-  AssertTrue(AMessage, (AInterface = nil));
+  AssertTrue(AMessage, (AInterface = nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNullIntf(AInterface: IInterface);
 begin
-  AssertNull('', AInterface);
+  AssertTrue('', (AInterface = nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNull(const AMessage: string; APointer: Pointer);
 begin
-  AssertTrue(AMessage, (APointer = nil));
+  AssertTrue(AMessage, (APointer = nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNull(APointer: Pointer);
 begin
-  AssertNull('', APointer);
+  AssertTrue('', (APointer = nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertException(const AMessage: string; AExceptionClass: ExceptClass;
-  AMethod: TRunMethod);
+  AMethod: TRunMethod;AExceptionMessage : String = ''; AExceptionContext : Integer = 0; AErrorAddr : Pointer = Nil);
+
+  Function MisMatch (AClassName : String) : String;
+
+  begin
+    Result:=Format(SExceptionCompare,[AExceptionClass.ClassName, AClassName])
+  end;
+
 var
-  Passed : Boolean;
-  ExceptionName: string;
+  FailMsg : string;
 begin
-  Passed := False;
+  If AErrorAddr=Nil then
+    AErrorAddr:=CallerAddr;
+  FailMsg:='';
   try
     AMethod;
-    ExceptionName:=SNoException;
+    FailMsg:=MisMatch(SNoException);
   except
     on E: Exception do
-    begin
-      ExceptionName := E.ClassName;
-      if E.ClassType.InheritsFrom(AExceptionClass) then
       begin
-        Passed := AExceptionClass.ClassName = E.ClassName;
+      if Not E.ClassType.InheritsFrom(AExceptionClass) then
+        FailMsg:=MisMatch(E.ClassName)
+      else if not (AExceptionClass.ClassName = E.ClassName) then
+        FailMsg:=MisMatch(E.ClassName)
+      else if (AExceptionMessage<>'') and (AExceptionMessage<>E.Message) then
+        FailMsg:=ComparisonMsg(SExceptionMessageCompare,AExceptionMessage,E.Message)
+      else if (AExceptionContext<>0) and (AExceptionContext<>E.HelpContext) then
+        FailMsg:=ComparisonMsg(SExceptionHelpContextCompare,IntToStr(AExceptionContext),IntToStr(E.HelpContext))
       end;
-    end;
   end;
-  AssertTrue(Format(SExceptionCompare, [AExceptionClass.ClassName, ExceptionName])+ ': ' + AMessage, Passed);
+  AssertTrue(AMessage + FailMsg, FailMsg='', AErrorAddr);
 end;
 
 
 class procedure TAssert.AssertException(AExceptionClass: ExceptClass;
-  AMethod: TRunMethod);
+  AMethod: TRunMethod;AExceptionMessage : String = ''; AExceptionContext : Integer = 0);
 begin
-  AssertException('', AExceptionClass, AMethod);
+  AssertException('', AExceptionClass, AMethod, AExceptionMessage, AExceptionContext, CallerAddr);
 end;
 
 
@@ -898,6 +1001,8 @@ var
   m: TMethod;
   RunMethod: TRunMethod;
   pMethod : Pointer;
+  FailMessage : String;
+
 begin
   AssertNotNull('name of the test not assigned', FName);
   pMethod := Self.MethodAddress(FName);
@@ -906,7 +1011,33 @@ begin
     m.Code := pMethod;
     m.Data := self;
     RunMethod := TRunMethod(m);
-    RunMethod;
+    ExpectException('',Nil,'',0);
+    try
+      FailMessage:='';
+      RunMethod;
+      if (FExpectedException<>Nil) then
+        FailMessage:=Format(SExceptionCompare, [FExpectedException.ClassName, SNoException])
+    except
+      On E : Exception do
+        begin
+        if FExpectedException=Nil then
+          Raise;
+        If not (E is FExpectedException) then
+          FailMessage:=Format(SExceptionCompare, [FExpectedException.ClassName, E.ClassName]);
+        if (FExpectedExceptionMessage<>'') then
+          if (FExpectedExceptionMessage<>E.Message) then
+            FailMessage:=Format(SExceptionmessageCompare+SCompare, [FExpectedExceptionMessage,E.Message]);
+        if (FExpectedExceptionContext<>0) then
+          if (FExpectedExceptionContext<>E.HelpContext) then
+            FailMessage:=Format(SExceptionHelpContextCompare+SCompare, [IntToStr(FExpectedExceptionContext),IntToStr(E.HelpContext)])
+        end;
+    end;
+    if (FailMessage<>'') then
+      begin
+      if (FExpectedExceptionFailMessage<>'') then
+        FailMessage:=' : '+FailMessage;
+      Fail(FExpectedExceptionFailMessage+FailMessage,FExpectedExceptionCaller);
+      end;
   end
   else
     begin
@@ -1057,6 +1188,26 @@ begin
   end;
 end;
 
+procedure TTestCase.ExpectException(const Msg: String;
+  AExceptionClass: TClass; AExceptionMessage: string = '';
+  AExceptionHelpContext: Integer =0 );
+begin
+  FExpectedExceptionFailMessage:=Msg;
+  FExpectedException:=AExceptionClass;
+  FExpectedExceptionMessage:=AExceptionMessage;
+  FExpectedExceptionContext:=AExceptionHelpContext;
+  FExpectedExceptionCaller:=CallerAddr;
+end;
+
+procedure TTestCase.ExpectException(AExceptionClass: TClass;
+  AExceptionMessage: string = ''; AExceptionHelpContext: Integer = 0);
+begin
+  FExpectedExceptionFailMessage:='';
+  FExpectedException:=AExceptionClass;
+  FExpectedExceptionMessage:=AExceptionMessage;
+  FExpectedExceptionContext:=AExceptionHelpContext;
+  FExpectedExceptionCaller:=CallerAddr;
+end;
 
 procedure TTestSuite.Run(AResult: TTestResult);
 var
@@ -1174,13 +1325,13 @@ begin
 end;
 
 
-procedure TTestResult.AddFailure(ATest: TTest; E: EAssertionFailedError; aFailureList: TFPList);
+procedure TTestResult.AddFailure(ATest: TTest; E: EAssertionFailedError; aFailureList: TFPList; AThrownExceptionAdrs: Pointer);
 var
   i: integer;
   f: TTestFailure;
 begin
   //lock mutex
-  f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep);
+  f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep, AThrownExceptionAdrs);
   aFailureList.Add(f);
   for i := 0 to FListeners.Count - 1 do
     ITestListener(FListeners[i]).AddFailure(ATest, f);
@@ -1188,17 +1339,13 @@ begin
 end;
 
 
-procedure TTestResult.AddError(ATest: TTest; E: Exception;
-  AUnitName: string; AFailedMethodName: string; ALineNumber: longint);
+procedure TTestResult.AddError(ATest: TTest; E: Exception; AThrownExceptionAdrs: Pointer);
 var
   i: integer;
   f: TTestFailure;
 begin
   //lock mutex
-  f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep);
-  f.SourceUnitName := AUnitName;
-  f.FailedMethodName := AFailedMethodName;
-  f.LineNumber := ALineNumber;
+  f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep, AThrownExceptionAdrs);
   FErrors.Add(f);
   for i := 0 to FListeners.Count - 1 do
     ITestListener(FListeners[i]).AddError(ATest, f);
@@ -1233,26 +1380,17 @@ end;
 
 
 procedure TTestResult.RunProtected(ATestCase: TTest; protect: TProtect);
-var
-  func, source: shortstring;
-  line: longint;
 begin
-  func := '';
-  source := '';
-  line := 0;
   try
     protect(ATestCase, Self);
   except
     on E: EIgnoredTest do
-      AddFailure(ATestCase, E, FIgnoredTests);
+      AddFailure(ATestCase, E, FIgnoredTests, ExceptAddr);
     on E: EAssertionFailedError do
-      AddFailure(ATestCase, E, FFailures);
+      AddFailure(ATestCase, E, FFailures, ExceptAddr);
     on E: Exception do
       begin
-      {$ifdef SHOWLINEINFO}
-        GetLineInfo(LongWord(ExceptAddr), func, source, line);
-      {$endif}
-        AddError(ATestCase, E, source, func, line);
+        AddError(ATestCase, E, ExceptAddr);
       end;
   end;
 end;
@@ -1279,7 +1417,7 @@ begin
 //unlock mutex
 end;
 
-function TTestResult.SkipTest(ATestCase: TTestCase): Boolean;
+function TTestResult.SkipTest(ATestCase: TTestCase): boolean;
 var
   i: integer;
 begin
@@ -1292,7 +1430,7 @@ begin
   else
     for i := 0 to FSkippedTests.Count - 1 do
     begin
-      if PtrInt(FSkippedTests[i]) = PtrInt(ATestCase) then
+      if PtrUInt(FSkippedTests[i]) = PtrUInt(ATestCase) then
       begin
         Result := true;
         Exit;

packages/fcl-fpcunit/src/fpcunitreport.pp

@@ -68,6 +68,8 @@ type
   private
     FLevel: integer;
     FCount: integer;
+    FSkipAddressInfo: Boolean;
+    FSparse: Boolean;
     FTestTime: TDateTime;
     FFileName: string;
     FSuiteResultsStack : TSuiteResultsStack;
@@ -83,6 +85,8 @@ type
     FOnEndTestSuite: TTestEvent;
     FSkipTiming: Boolean;
   protected
+    procedure SetSkipAddressInfo(AValue: Boolean); virtual;
+    procedure SetSparse(AValue: Boolean); virtual;
     procedure WriteTestHeader(ATest: TTest; ALevel: integer; ACount: integer); virtual;
     procedure WriteTestFooter(ATest: TTest; ALevel: integer; ATiming: TDateTime); virtual;
     procedure WriteSuiteHeader(ATestSuite: TTestSuite; ALevel: integer); virtual;
@@ -122,7 +126,9 @@ type
     property OnStartTestSuite: TTestEvent read FOnStartTestSuite write FOnStartTestSuite;
     property OnEndTestSuite: TTestEvent read FOnEndTestSuite write FOnEndTestSuite;
     Property SkipTiming : Boolean Read FSkipTiming Write FSkipTiming;
-  end; 
+    Property Sparse : Boolean Read FSparse Write SetSparse;
+    Property SkipAddressInfo : Boolean Read FSkipAddressInfo Write SetSkipAddressInfo;
+  end;
 
 implementation
 
@@ -272,6 +278,18 @@ begin
     FOnAddError(Self, ATest, AError);
 end;
 
+procedure TCustomResultsWriter.SetSkipAddressInfo(AValue: Boolean);
+begin
+  if FSkipAddressInfo=AValue then Exit;
+  FSkipAddressInfo:=AValue;
+end;
+
+procedure TCustomResultsWriter.SetSparse(AValue: Boolean);
+begin
+  if FSparse=AValue then Exit;
+  FSparse:=AValue;
+end;
+
 procedure TCustomResultsWriter.WriteTestHeader(ATest: TTest; ALevel: integer; ACount: integer);
 begin
   if Assigned(FOnWriteTestHeader) then 
@@ -291,9 +309,9 @@ begin
     FOnWriteSuiteHeader(Self, ATestSuite, ALevel);
 end;
 
-procedure TCustomResultsWriter.WriteSuiteFooter(ATestSuite: TTestSuite; ALevel: integer; 
-  ATiming: TDateTime; ANumRuns: integer; ANumErrors: integer; ANumFailures: integer;
-  ANumIgnores: integer);
+procedure TCustomResultsWriter.WriteSuiteFooter(ATestSuite: TTestSuite;
+  ALevel: integer; ATiming: TDateTime; ANumRuns: integer; ANumErrors: integer;
+  aNumFailures: integer; ANumIgnores: integer);
 begin
   if Assigned(FOnWriteSuiteFooter) then 
     FOnWriteSuiteFooter(Self, ATestSuite, ALevel, ATiming, ANumRuns, ANumErrors, 

packages/fcl-fpcunit/src/plaintestreport.pp

@@ -22,16 +22,21 @@ uses
   classes, SysUtils, fpcunit, fpcunitreport;
 
 type
+  TTestResultOption = (ttoSkipAddress,ttoSkipExceptionMessage,ttoErrorsOnly);
+  TTestResultOptions = set of TTestResultOption;
 
   { TPlainResultsWriter }
 
   TPlainResultsWriter = class(TCustomResultsWriter)
   private
+    FTestResultOptions : TTestResultOptions;
     FDoc: TStringList;
     FSuiteHeaderIdx: TFPList;
     FTempFailure: TTestFailure;
     function TimeFormat(ATiming: TDateTime): String;
   protected
+    procedure SetSkipAddressInfo(AValue: Boolean); override;
+    procedure SetSparse(AValue: Boolean); override;
     procedure WriteTestHeader(ATest: TTest; ALevel: integer; ACount: integer); override;
     procedure WriteTestFooter(ATest: TTest; ALevel: integer; ATiming: TDateTime); override;
     procedure WriteSuiteHeader(ATestSuite: TTestSuite; ALevel: integer); override;
@@ -47,9 +52,10 @@ type
     procedure AddError(ATest: TTest; AError: TTestFailure); override;
   end;
 
-function TestSuiteAsPlain(aSuite:TTestSuite): string;
-function GetSuiteAsPlain(aSuite: TTestSuite): string;
-function TestResultAsPlain(aTestResult: TTestResult): string;
+
+function TestSuiteAsPlain(aSuite:TTestSuite; Options : TTestResultOptions = []): string;
+function GetSuiteAsPlain(aSuite: TTestSuite; Options : TTestResultOptions = []): string;
+function TestResultAsPlain(aTestResult: TTestResult; Options : TTestResultOptions = []): string;
 
 implementation
 
@@ -83,7 +89,7 @@ begin
   system.Assign(f, FileName);
   rewrite(f);
   FDoc.Add('');
-  FDoc.Add(TestResultAsPlain(aResult));
+  FDoc.Add(TestResultAsPlain(aResult,FTestResultOptions));
   writeln(f, FDoc.Text);
   close(f);
 end;
@@ -116,6 +122,7 @@ begin
   if Not SkipTiming then
     S:=S + FormatDateTime(TimeFormat(ATiming), ATiming) + '  ';
   S:=S + ATest.TestName;
+  if Assigned(FTempFailure) or (not Sparse) then
   FDoc.Add(S);
   if Assigned(FTempFailure) then
   begin
@@ -124,10 +131,8 @@ begin
     begin
       FDoc[FDoc.Count -1] := FDoc[FDoc.Count -1] + '  Error: ' + FTempFailure.ExceptionClassName;
       FDoc.Add(StringOfChar(' ',ALevel*2) + '    Exception:   ' + FTempFailure.ExceptionMessage);
-      FDoc.Add(StringOfChar(' ',ALevel*2) + '    Source unit: ' + FTempFailure.SourceUnitName);
-      FDoc.Add(StringOfChar(' ',ALevel*2) + '    Method name: ' + FTempFailure.FailedMethodName);
-      FDoc.Add(StringOfChar(' ',ALevel*2) + '    Line number: ' 
-        + IntToStr(FTempFailure.LineNumber));
+      FDoc.Add(StringOfChar(' ',ALevel*2) + '    at ' + FTempFailure.LocationInfo);
+      // TODO: Add stack dump output info
     end
     else
       if FTempFailure.IsIgnoredTest then
@@ -136,14 +141,18 @@ begin
            + FTempFailure.ExceptionMessage;
       end
       else
+      begin
         //is a failure
         FDoc[FDoc.Count -1] := FDoc[FDoc.Count -1] + '  Failed: ' 
           + FTempFailure.ExceptionMessage;
+        FDoc.Add(StringOfChar(' ',ALevel*2) + '    Exception:   ' + FTempFailure.ExceptionMessage);
+        FDoc.Add(StringOfChar(' ',ALevel*2) + '    at ' + FTempFailure.LocationInfo);
+      end;
   end;
   FTempFailure := nil;
 end;
 
-Function TPlainResultsWriter.TimeFormat(ATiming : TDateTime) : String;
+function TPlainResultsWriter.TimeFormat(ATiming: TDateTime): String;
 
 Var
   M : Int64;
@@ -157,6 +166,24 @@ begin
    Result:='mm:'+Result;
 end;
 
+procedure TPlainResultsWriter.SetSkipAddressInfo(AValue: Boolean);
+begin
+  inherited SetSkipAddressInfo(AValue);
+  if AValue then
+    Include(FTestResultOptions,ttoSkipAddress)
+  else
+    Exclude(FTestResultOptions,ttoSkipAddress);
+end;
+
+procedure TPlainResultsWriter.SetSparse(AValue: Boolean);
+begin
+  inherited SetSparse(AValue);
+  if AValue then
+    FTestResultOptions:=FTestResultOptions+[ttoSkipExceptionMessage,ttoErrorsOnly]
+  else
+    FTestResultOptions:=FTestResultOptions-[ttoSkipExceptionMessage,ttoErrorsOnly];
+end;
+
 procedure TPlainResultsWriter.WriteSuiteFooter(ATestSuite: TTestSuite; ALevel: integer; 
   ATiming: TDateTime; ANumRuns: integer; ANumErrors: integer; ANumFailures: integer;
   ANumIgnores: integer);
@@ -181,28 +208,39 @@ begin
   FSuiteHeaderIdx.Add(Pointer(FDoc.Count - 1));
 end;
 
-function TestSuiteAsPlain(aSuite:TTestSuite): string;
+function TestSuiteAsPlain(aSuite:TTestSuite; Options : TTestResultOptions = []): string;
 var
   i: integer;
 begin
   Result := '';
   for i := 0 to aSuite.Tests.Count - 1 do
     if TTest(aSuite.Tests.Items[i]) is TTestSuite then
-      Result := Result + TestSuiteAsPlain(TTestSuite(aSuite.Tests.Items[i]))
+      Result := Result + TestSuiteAsPlain(TTestSuite(aSuite.Tests.Items[i]),Options)
     else
       if TTest(aSuite.Tests.Items[i]) is TTestCase then
         Result := Result + '  ' + ASuite.TestName+'.' + TTestcase(aSuite.Tests.Items[i]).TestName + System.sLineBreak;
 end;
 
-function GetSuiteAsPlain(aSuite: TTestSuite): string;
+function GetSuiteAsPlain(aSuite: TTestSuite; Options : TTestResultOptions = []): string;
 begin
   Result := '';
-
   if aSuite <> nil then
-    Result := 'TestSuites: ' + System.sLineBreak + TestSuiteAsPlain(aSuite);
+    Result := 'TestSuites: ' + System.sLineBreak + TestSuiteAsPlain(aSuite,Options);
 end;
 
-function TestResultAsPlain(aTestResult: TTestResult): string;
+function TestResultAsPlain(aTestResult: TTestResult; Options : TTestResultOptions = []): string;
+
+  Procedure WriteFailure(F : TTestFailure; SkipAddress : Boolean = False );
+
+  begin
+    Result := Result + '    Message:           ' + f.AsString + System.sLineBreak;
+    Result := Result + '    Exception class:   ' + f.ExceptionClassName + System.sLineBreak;
+    if not (ttoSkipExceptionMessage in options) then
+      Result := Result + '    Exception message: ' + f.ExceptionMessage + System.sLineBreak;
+    if not (SkipAddress or (ttoSkipAddress in options) )then
+      Result := Result + '        at ' + f.LocationInfo + System.sLineBreak;
+  end;
+
 var
   i: longint;
   f: TTestFailure;
@@ -221,13 +259,7 @@ begin
       begin
         Result := Result + System.sLineBreak;
         Result := Result + '  Error: ' + System.sLineBreak;
-        f := TTestFailure(Errors.Items[i]);
-        Result := Result + '    Message:           ' + f.AsString + System.sLineBreak;
-        Result := Result + '    Exception class:   ' + f.ExceptionClassName + System.sLineBreak;
-        Result := Result + '    Exception message: ' + f.ExceptionMessage + System.sLineBreak;
-        Result := Result + '    Source unitname:   ' + f.SourceUnitName + System.sLineBreak;
-        Result := Result + '    Line number:       ' + IntToStr(f.LineNumber) + System.sLineBreak;
-        Result := Result + '    Failed methodname: ' + f.FailedMethodName + System.sLineBreak;
+        WriteFailure(TTestFailure(Errors.Items[i]));
       end;
     end;
     if NumberOfFailures <> 0 then
@@ -238,10 +270,7 @@ begin
       for i := 0 to Failures.Count - 1 do
       begin
         Result := Result + '  Failure: ' + System.sLineBreak;
-        f := TTestFailure(Failures.Items[i]);
-        Result := Result + '    Message:           ' + f.AsString + System.sLineBreak;
-        Result := Result + '    Exception class:   ' + f.ExceptionClassName + System.sLineBreak;
-        Result := Result + '    Exception message: ' + f.ExceptionMessage + System.sLineBreak;
+        WriteFailure(TTestFailure(Failures.Items[i]));
       end;
     end;
    if NumberOfIgnoredTests <> 0 then
@@ -252,10 +281,7 @@ begin
       for i := 0 to IgnoredTests.Count - 1 do
       begin
         Result := Result + '  Ignored test: ' + System.sLineBreak;
-        f := TTestFailure(IgnoredTests.Items[i]);
-        Result := Result + '    Message:           ' + f.AsString + System.sLineBreak;
-        Result := Result + '    Exception class:   ' + f.ExceptionClassName + System.sLineBreak;
-        Result := Result + '    Exception message: ' + f.ExceptionMessage + System.sLineBreak;
+        WriteFailure(TTestFailure(IgnoredTests.Items[i]),True);
       end;
     end;
   end;

packages/fcl-fpcunit/src/tests/asserttest.pp

@@ -23,6 +23,8 @@ uses
 
 type
 
+  { TAssertTest }
+
   TAssertTest = class(TTestCase)
   published
     procedure TestFail;
@@ -37,11 +39,25 @@ type
     procedure TestAssertTrue;
     procedure TestAssertFalse;
     procedure TestAssertNotSame;
+    procedure TestExpectExceptionOK;
+    procedure TestExpectExceptionNoException;
+    procedure TestExpectExceptionWrongExceptionClass;
+    procedure TestExpectExceptionWrongExceptionMessage;
+    procedure TestExpectExceptionWrongExceptionContext;
   end;
 
+  EMyException = Class(Exception);
+
+  { TMyTest }
+
   TMyTest = class(TTestCase)
   published
     procedure RaiseIgnoreTest;
+    procedure TestExpectException;
+    procedure TestExpectExceptionNone;
+    procedure TestExpectExceptionWrongClass;
+    procedure TestExpectExceptionWrongMessage;
+    procedure TestExpectExceptionWrongHelpContext;
   end;
 
   TTestIgnore = class(TTestCase)
@@ -233,10 +249,115 @@ begin
   Fail('Error: Objects are the same!');
 end;
 
+procedure TAssertTest.TestExpectExceptionOK;
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectException');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 0, res.NumberOfFailures);
+  t.Free;
+  res.Free;
+end;
+
+procedure TAssertTest.TestExpectExceptionNoException;
+
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectExceptionNone');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 1, res.NumberOfFailures);
+  assertEquals('Correct error message','Error message : Exception EMyException expected but no exception was raised',TTestFailure(res.Failures[0]).ExceptionMessage);
+  t.Free;
+  res.Free;
+end;
+
+procedure TAssertTest.TestExpectExceptionWrongExceptionClass;
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectExceptionWrongClass');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 1, res.NumberOfFailures);
+  assertEquals('Correct error message','Error message : Exception EMyException expected but Exception was raised',TTestFailure(res.Failures[0]).ExceptionMessage);
+  t.Free;
+  res.Free;
+end;
+
+procedure TAssertTest.TestExpectExceptionWrongExceptionMessage;
+
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectExceptionWrongMessage');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 1, res.NumberOfFailures);
+  assertEquals('Correct error message','Error message : Exception raised but exception property Message differs:  expected: <A message> but was: <A wrong message>',TTestFailure(res.Failures[0]).ExceptionMessage);
+  t.Free;
+  res.Free;
+end;
+
+procedure TAssertTest.TestExpectExceptionWrongExceptionContext;
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectExceptionWrongHelpContext');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 1, res.NumberOfFailures);
+  assertEquals('Correct error message','Error message : Exception raised but exception property HelpContext differs:  expected: <123> but was: <124>',TTestFailure(res.Failures[0]).ExceptionMessage);
+  t.Free;
+  res.Free;
+end;
+
 procedure TMyTest.RaiseIgnoreTest;
 begin
   Ignore('This is an ignored test');
-  AssertEquals('the compiler can count', 3, 1+1); 
+  AssertEquals('the compiler can count', 3, 2);
+end;
+
+procedure TMyTest.TestExpectException;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+  Raise EMyException.CreateHelp('A message',123);
+end;
+
+procedure TMyTest.TestExpectExceptionNone;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+end;
+
+procedure TMyTest.TestExpectExceptionWrongClass;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+  Raise Exception.CreateHelp('A message',123);
+end;
+
+procedure TMyTest.TestExpectExceptionWrongMessage;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+  Raise EMyException.CreateHelp('A wrong message',123);
+end;
+
+procedure TMyTest.TestExpectExceptionWrongHelpContext;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+  Raise EMyException.CreateHelp('A message',124);
 end;
 
 procedure TTestIgnore.TestIgnoreResult;
@@ -262,14 +383,14 @@ var
 begin
   t := TMyTest.CreateWithName('RaiseIgnoreTest');
   t.EnableIgnores := false;
-  res := t.CreateResultandRun;
+  res := t.CreateResultAndRun;
   assertEquals('no test was run', 1, res.RunTests);
   assertEquals('Ignored Test reported even if the switch is not active', 0, res.NumberOfIgnoredTests);
   assertEquals('no failure caught', 1, res.NumberOfFailures);
   assertFalse('failure is signalled as Ignored Test and the switch is not active', 
     TTestFailure(res.Failures[0]).IsIgnoredTest);
   assertEquals('wrong failure name', 'EAssertionFailedError', TTestFailure(res.Failures[0]).ExceptionClassName);
-  assertEquals('wrong message', 'the compiler can count expected: <3> but was: <2>', TTestFailure(res.Failures[0]).ExceptionMessage);
+  assertEquals('wrong message', '"the compiler can count" expected: <3> but was: <2>', TTestFailure(res.Failures[0]).ExceptionMessage);
   t.Free;
   res.Free;
 end;

packages/fcl-fpcunit/src/tests/frameworktest.pp

@@ -17,122 +17,22 @@
 program frameworktest;
 
 uses
-  custapp, classes, SysUtils, fpcunit, testreport, asserttest, suitetest;
+  consoletestrunner, classes, SysUtils, fpcunit, testreport, asserttest,
+  suitetest;
 
-Const
-  ShortOpts = 'alh';
-  Longopts : Array[1..5] of String = (
-    'all','list','format:','suite:','help');
-  Version = 'Version 0.1';
 
 Type
-  TTestRunner = Class(TCustomApplication)
-  private
-    FSuite: TTestSuite;
-    FXMLResultsWriter: TXMLResultsWriter;
-  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);
-  FXMLResultsWriter := TXMLResultsWriter.Create;
-  FSuite := TTestSuite.Create;
-  FSuite.TestName := 'Framework test';
-  FSuite.AddTestSuiteFromClass(TAssertTest);
-  FSuite.AddTestSuiteFromClass(TTestIgnore);
-  FSuite.AddTest(TSuiteTest.Suite());
-end;
-
-destructor TTestRunner.Destroy;
-begin
-  FXMLResultsWriter.Free;
-  FSuite.Free;
-end;
-
-procedure TTestRunner.doTestRun(aTest: TTest);
-var
-  testResult: TTestResult;
-begin
-  testResult := TTestResult.Create;
-  try
-    testResult.AddListener(FXMLResultsWriter);
-    FXMLResultsWriter.WriteHeader;
-    aTest.Run(testResult);
-    FXMLResultsWriter.WriteResult(testResult);
-  finally
-    testResult.Free;
-  end;
-end;
-
-procedure TTestRunner.DoRun;
-var
-  I : Integer;
-  S : String;
-begin
-  S:=CheckOptions(ShortOpts,LongOpts);
-  If (S<>'') then
-    Writeln(S);
-  if HasOption('h', 'help') or (ParamCount = 0) then
-  begin
-    writeln(Title);
-    writeln(Version);
-    writeln('Usage: ');
-    writeln('-l or --list to show a list of registered tests');
-    writeln('default format is xml, add --format=latex to output the list as latex source');
-    writeln('-a or --all to run all the tests and show the results in xml format');
-    writeln('The results can be redirected to an xml file,');
-    writeln('for example: ./testrunner --all > results.xml');
-    writeln('use --suite=MyTestSuiteName to run only the tests in a single test suite class');
-  end
-  else;
-    if HasOption('l', 'list') then
-    begin
-      if HasOption('format') then
-      begin
-        if GetOptionValue('format') = 'latex' then
-          writeln(GetSuiteAsLatex(FSuite))
-        else
-          writeln(GetSuiteAsXML(FSuite));
-      end
-      else
-        writeln(GetSuiteAsXML(FSuite));
-    end;
-  if HasOption('a', 'all') then
-  begin
-    doTestRun(FSuite)
-  end
-  else
-    if HasOption('suite') then
-    begin
-      S := '';
-      S:=GetOptionValue('suite');
-      if S = '' then
-        for I := 0 to FSuite.Tests.count - 1 do
-          writeln(FSuite[i].TestName)
-      else
-      for I := 0 to FSuite.Tests.count - 1 do
-        if FSuite[i].TestName = S then
-        begin
-          doTestRun(FSuite.Test[i]);
-        end;
-    end;
-  Terminate;
-end;
+  TFPCUnitRunner = Class(TTestRunner);
 
 Var
-  App : TTestRunner;
+  App : TFPCUnitRunner;
 
 begin
-  App:=TTestRunner.Create(Nil);
+  DefaultFormat:=fPlain;
+  DefaultRunAllTests:=True;
+  App:=TFPCUnitRunner.Create(Nil);
   App.Initialize;
-  App.Title := 'FPCUnit Console Test Case runner.';
+  App.Title := 'FPCUnit Test Suite';
   App.Run;
   App.Free;
 end.