开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Internet/网络编程 > Email服务器 > 查看源码
GUITestRunner.pas
资源名称：EMailMasterbysuperroyor.rar　[点击查看]
上传用户：yjb1804
上传日期：2021-01-30
资源大小：3105k
文件大小：66k
源码类别：

Email服务器

开发平台：

Delphi

GUITestRunner.pas：源码内容
  1. { $Id: GUITestRunner.pas,v 1.129 2007/01/06 02:17:23 judc Exp $ }
  2. {: DUnit: An XTreme testing framework for Delphi programs.
  3.    @author  The DUnit Group.
  4.    @version $Revision: 1.129 $ 2001/03/08 uberto
  5. }
  6. (*
  7.  * The contents of this file are subject to the Mozilla Public
  8.  * License Version 1.1 (the "License"); you may not use this file
  9.  * except in compliance with the License. You may obtain a copy of
  10.  * the License at http://www.mozilla.org/MPL/
  11.  *
  12.  * Software distributed under the License is distributed on an "AS
  13.  * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
  14.  * implied. See the License for the specific language governing
  15.  * rights and limitations under the License.
  16.  *
  17.  * The Original Code is DUnit.
  18.  *
  19.  * The Initial Developers of the Original Code are Kent Beck, Erich Gamma,
  20.  * and Juancarlo A眅z.
  21.  * Portions created The Initial Developers are Copyright (C) 1999-2000.
  22.  * Portions created by The DUnit Group are Copyright (C) 2000-2004.
  23.  * All rights reserved.
  24.  *
  25.  * Contributor(s):
  26.  * Kent Beck <kentbeck@csi.com>
  27.  * Erich Gamma <Erich_Gamma@oti.com>
  28.  * Juanco A馿z <juanco@users.sourceforge.net>
  29.  * Chris Morris <chrismo@users.sourceforge.net>
  30.  * Jeff Moore <JeffMoore@users.sourceforge.net>
  31.  * Kenneth Semeijn <dunit@designtime.demon.nl>
  32.  * Uberto Barbini <uberto@usa.net>
  33.  * Brett Shearer <BrettShearer@users.sourceforge.net>
  34.  * Kris Golko <neuromancer@users.sourceforge.net>
  35.  * The DUnit group at SourceForge <http://dunit.sourceforge.net>
  36.  *
  37.  *)
  38. unit GUITestRunner;
  39. interface
  41. uses
  42.   TestFramework,
  44.   Windows,
  45.   Math,
  46.   Graphics, Controls, Forms, 
  47.   ComCtrls, ExtCtrls, StdCtrls, ImgList, Buttons, Menus, ActnList,
  48.   Classes, IniFiles, ToolWin;
  50. const
  51.   {: Section of the dunit.ini file where GUI information will be stored }
  52.   cnConfigIniSection = 'GUITestRunner Config';
  54.   {: Color constants for the progress bar and failure details panel }
  55.   clOK      = clGreen;
  56.   clFAILURE = clFuchsia;
  57.   clERROR   = clRed;
  59.   {: Indexes of the color images used in the test tree and failure list }
  60.   imgNONE     = 0;
  61.   imgRUNNING  = 1;
  62.   imgRUN      = 2;
  63.   imgHASPROPS = 3;
  64.   imgFAILED   = 4;
  65.   imgERROR    = 5;
  67.   {: Indexes of the images used for test tree checkboxes }
  68.   imgDISABLED        = 1;
  69.   imgPARENT_DISABLED = 2;
  70.   imgENABLED         = 3;
  72. type
  73.   {: Function type used by the TDUnitDialog.ApplyToTests method
  74.      @param item  The ITest instance on which to act
  75.      @return true if processing should continue, false otherwise
  76.   }
  77.   TTestFunc = function (item :ITest):Boolean of object;
  79.   TGUITestRunner = class(TForm, ITestListener, ITestListenerX)
  80.     StateImages: TImageList;
  81.     RunImages: TImageList;
  82.     DialogActions: TActionList;
  83.     SelectAllAction: TAction;
  84.     DeselectAllAction: TAction;
  85.     SelectFailedAction: TAction;
  86.     MainMenu: TMainMenu;
  87.     TestTreeMenu: TMenuItem;
  88.     SelectAllItem: TMenuItem;
  89.     DeselectAllItem: TMenuItem;
  90.     SelectFailedItem: TMenuItem;
  91.     FileMenu: TMenuItem;
  92.     SaveConfigurationAction: TAction;
  93.     AutoSaveAction: TAction;
  94.     SaveConfigurationItem: TMenuItem;
  95.     AutoSaveItem: TMenuItem;
  96.     RestoreSavedAction: TAction;
  97.     RestoreSavedConfigurationItem: TMenuItem;
  98.     ViewMenu: TMenuItem;
  99.     HideErrorBoxItem: TMenuItem;
  100.     BodyPanel: TPanel;
  101.     ErrorBoxVisibleAction: TAction;
  102.     TopPanel: TPanel;
  103.     TreePanel: TPanel;
  104.     TestTree: TTreeView;
  105.     ResultsPanel: TPanel;
  106.     ProgressPanel: TPanel;
  107.     ResultsView: TListView;
  108.     FailureListView: TListView;
  109.     ErrorBoxPanel: TPanel;
  110.     ErrorBoxSplitter: TSplitter;
  111.     ResultsSplitter: TSplitter;
  112.     AutoChangeFocusItem: TMenuItem;
  113.     TopProgressPanel: TPanel;
  114.     ProgressBar: TProgressBar;
  115.     pnlProgresslabel: TPanel;
  116.     ScorePanel: TPanel;
  117.     ScoreLabel: TPanel;
  118.     ScoreBar: TProgressBar;
  119.     pmTestTree: TPopupMenu;
  120.     pmiSelectAll: TMenuItem;
  121.     pmiDeselectAll: TMenuItem;
  122.     pmiSelectFailed: TMenuItem;
  123.     HideTestNodesAction: TAction;
  124.     CollapseLowestSuiteNodesItem: TMenuItem;
  125.     CollapseLowestSuiteNodes1: TMenuItem;
  126.     HideTestNodesOnOpenAction: TAction;
  127.     HideTestNodesItem: TMenuItem;
  128.     ExpandAllNodesAction: TAction;
  129.     TestTreeMenuSeparator: TMenuItem;
  130.     ExpandAllItem: TMenuItem;
  131.     TestTreeLocalMenuSeparator: TMenuItem;
  132.     ExpandAll2: TMenuItem;
  133.     lblTestTree: TLabel;
  134.     RunAction: TAction;
  135.     ExitAction: TAction;
  136.     BreakOnFailuresAction: TAction;
  137.     BreakonFailuresItem: TMenuItem;
  138.     ShowTestedNodeAction: TAction;
  139.     SelectTestedNodeItem: TMenuItem;
  140.     ErrorMessagePopup: TPopupMenu;
  141.     CopyFailureMessage: TMenuItem;
  142.     CopyMessageToClipboardAction: TAction;
  143.     ActionsMenu: TMenuItem;
  144.     CopyMessagetoCllipboardItem: TMenuItem;
  145.     LbProgress: TLabel;
  146.     UseRegistryAction: TAction;
  147.     UseRegistryItem: TMenuItem;
  148.     ErrorMessageRTF: TRichEdit;
  149.     SelectCurrentAction: TAction;
  150.     DeselectCurrentAction: TAction;
  151.     SelectCurrent1: TMenuItem;
  152.     DeselectCurrent1: TMenuItem;
  153.     ActionsImages: TImageList;
  154.     CloseItem: TMenuItem;
  155.     RunItem: TMenuItem;
  156.     StopAction: TAction;
  157.     StopActionItem: TMenuItem;
  158.     ToolBar1: TToolBar;
  159.     SelectAllButton: TToolButton;
  160.     DeselectAllButton: TToolButton;
  161.     ToolButton1: TToolButton;
  162.     SelectFailedButton: TToolButton;
  163.     ToolButton2: TToolButton;
  164.     SelectCurrentButton: TToolButton;
  165.     DeselectCurrentButton: TToolButton;
  166.     ToolButton3: TToolButton;
  167.     ToolButton4: TToolButton;
  168.     ToolButton5: TToolButton;
  169.     Alt_R_RunAction: TAction;
  170.     Alt_S_StopAction: TAction;
  171.     N1: TMenuItem;
  172.     DeselectCurrent2: TMenuItem;
  173.     SelectCurrent2: TMenuItem;
  174.     N2: TMenuItem;
  175.     CopyProcnameToClipboardAction: TAction;
  176.     N3: TMenuItem;
  177.     Copytestnametoclipboard1: TMenuItem;
  178.     N4: TMenuItem;
  179.     Copytestnametoclipboard2: TMenuItem;
  180.     RunSelectedTestAction: TAction;
  181.     N5: TMenuItem;
  182.     Runcurrenttest1: TMenuItem;
  183.     N6: TMenuItem;
  184.     Runcurrenttest2: TMenuItem;
  185.     RunSelectedTestItem: TMenuItem;
  186.     RunSelectedTestButton: TToolButton;
  187.     GoToNextSelectedTestAction: TAction;
  188.     GoToPrevSelectedTestAction: TAction;
  189.     N7: TMenuItem;
  190.     GoToNextSelectedNode1: TMenuItem;
  191.     GoToPreviousSelectedNode1: TMenuItem;
  192.     N8: TMenuItem;
  193.     GoToNextSelectedNode2: TMenuItem;
  194.     GoToPreviousSelectedNode2: TMenuItem;
  195.     FailIfNoChecksExecuted: TMenuItem;
  196.     FailIfNoChecksExecutedAction: TAction;
  197.     FailTestCaseIfMemoryLeaked: TMenuItem;
  198.     FailTestCaseIfMemoryLeakedAction: TAction;
  199.     TestCaseProperty: TPopupMenu;
  200.     TestCaseProperties: TMenuItem;
  201.     N10: TMenuItem;
  202.     FailNoCheckExecutedMenuItem: TMenuItem;
  203.     FailsOnMemoryLeakMenuItem: TMenuItem;
  204.     N11: TMenuItem;
  205.     TestCasePopup: TMenuItem;
  206.     FailsOnMemoryRecoveryMenuItem: TMenuItem;
  207.     AllowedLeakSizeMemuItem: TMenuItem;
  208.     ShowTestCaseswithRunTimeProperties: TMenuItem;
  209.     ShowTestCasesWithRunTimePropertiesAction: TAction;
  210.     N9: TMenuItem;
  211.     WarnOnFailTestOverride: TMenuItem;
  212.     WarnOnFailTestOverrideAction: TAction;
  213.     N12: TMenuItem;
  214.     TestCasePropertiesAction: TAction;
  215.     PropertyPopUpAction: TAction;
  216.     N13: TMenuItem;
  217.     Previous1: TMenuItem;
  218.     Next1: TMenuItem;
  219.     RunSelectedTest1: TMenuItem;
  220.     RunSelectedTestAltAction: TAction;
  221.     N14: TMenuItem;
  222.     ReportMemoryLeakTypeOnShutdown: TMenuItem;
  223.     IgnoreMemoryLeakInSetUpTearDown: TMenuItem;
  224.     IgnoreMemoryLeakInSetUpTearDownAction: TAction;
  225.     ReportMemoryLeakTypeOnShutdownAction: TAction;
  226.     TestCaseIgnoreSetUpTearDownLeaksMenuItem: TMenuItem;
  227.     procedure FormCreate(Sender: TObject);
  228.     procedure TestTreeClick(Sender: TObject);
  229.     procedure FailureListViewSelectItem(Sender: TObject; Item: TListItem;
  230.       Selected: Boolean);
  231.     procedure FailureListViewClick(Sender: TObject);
  232.     procedure TestTreeKeyPress(Sender: TObject; var Key: Char);
  233.     procedure SelectAllActionExecute(Sender: TObject);
  234.     procedure DeselectAllActionExecute(Sender: TObject);
  235.     procedure SelectFailedActionExecute(Sender: TObject);
  236.     procedure SaveConfigurationActionExecute(Sender: TObject);
  237.     procedure RestoreSavedActionExecute(Sender: TObject);
  238.     procedure AutoSaveActionExecute(Sender: TObject);
  239.     procedure ErrorBoxVisibleActionExecute(Sender: TObject);
  240.     procedure ErrorBoxSplitterMoved(Sender: TObject);
  241.     procedure ErrorBoxPanelResize(Sender: TObject);
  242.     procedure HideTestNodesActionExecute(Sender: TObject);
  243.     procedure HideTestNodesOnOpenActionExecute(Sender: TObject);
  244.     procedure ExpandAllNodesActionExecute(Sender: TObject);
  245.     procedure RunActionExecute(Sender: TObject);
  246.     procedure ExitActionExecute(Sender: TObject);
  247.     procedure BreakOnFailuresActionExecute(Sender: TObject);
  248.     procedure FormDestroy(Sender: TObject);
  249.     procedure ShowTestedNodeActionExecute(Sender: TObject);
  250.     procedure CopyMessageToClipboardActionExecute(Sender: TObject);
  251.     procedure UseRegistryActionExecute(Sender: TObject);
  252.     procedure RunActionUpdate(Sender: TObject);
  253.     procedure CopyMessageToClipboardActionUpdate(Sender: TObject);
  254.     procedure SelectCurrentActionExecute(Sender: TObject);
  255.     procedure DeselectCurrentActionExecute(Sender: TObject);
  256.     procedure StopActionExecute(Sender: TObject);
  257.     procedure StopActionUpdate(Sender: TObject);
  258.     procedure TestTreeChange(Sender: TObject; Node: TTreeNode);
  259.     procedure CopyProcnameToClipboardActionExecute(Sender: TObject);
  260.     procedure CopyProcnameToClipboardActionUpdate(Sender: TObject);
  261.     procedure RunSelectedTestActionExecute(Sender: TObject);
  262.     procedure RunSelectedTestActionUpdate(Sender: TObject);
  263.     procedure TestTreeMouseDown(Sender: TObject; Button: TMouseButton;
  264.       Shift: TShiftState; X, Y: Integer);
  265.     procedure GoToNextSelectedTestActionExecute(Sender: TObject);
  266.     procedure GoToPrevSelectedTestActionExecute(Sender: TObject);
  267.     procedure FormShow(Sender: TObject);
  268.     procedure FailIfNoChecksExecutedActionExecute(Sender: TObject);
  269.     procedure FailTestCaseIfMemoryLeakedActionExecute(Sender: TObject);
  270.     procedure ShowTestCasesWithRunTimePropertiesActionExecute(
  271.       Sender: TObject);
  272.     procedure WarnOnFailTestOverrideActionExecute(Sender: TObject);
  273.     procedure TestCasePropertiesActionExecute(Sender: TObject);
  274.     procedure Previous1Click(Sender: TObject);
  275.     procedure Next1Click(Sender: TObject);
  276.     procedure TestCasePropertiesMeasureItem(Sender: TObject;
  277.       ACanvas: TCanvas; var Width, Height: Integer);
  278.     procedure TestCasePropertiesDrawItem(Sender: TObject; ACanvas: TCanvas;
  279.       ARect: TRect; Selected: Boolean);
  280.     procedure FailNoCheckExecutedMenuItemDrawItem(Sender: TObject;
  281.       ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  282.     procedure AllowedLeakSizeMemuItemDrawItem(Sender: TObject;
  283.       ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  284.     procedure FailsOnMemoryRecoveryMenuItemDrawItem(Sender: TObject;
  285.       ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  286.     procedure FailsOnMemoryLeakMenuItemDrawItem(Sender: TObject;
  287.       ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  288.     procedure pmTestTreePopup(Sender: TObject);
  289.     procedure FailNoCheckExecutedMenuItemClick(Sender: TObject);
  290.     procedure AllowedLeakSizeMemuItemClick(Sender: TObject);
  291.     procedure FailsOnMemoryLeakMenuItemClick(Sender: TObject);
  292.     procedure FailsOnMemoryRecoveryMenuItemClick(Sender: TObject);
  293.     procedure RunSelectedTestAltActionExecute(Sender: TObject);
  294.     procedure Previous1DrawItem(Sender: TObject; ACanvas: TCanvas;
  295.       ARect: TRect; Selected: Boolean);
  296.     procedure RunSelectedTest1DrawItem(Sender: TObject; ACanvas: TCanvas;
  297.       ARect: TRect; Selected: Boolean);
  298.     procedure Next1DrawItem(Sender: TObject; ACanvas: TCanvas;
  299.       ARect: TRect; Selected: Boolean);
  300.     procedure ReportMemoryLeakTypeOnShutdownActionExecute(Sender: TObject);
  301.     procedure IgnoreMemoryLeakInSetUpTearDownActionExecute(
  302.       Sender: TObject);
  303.     procedure TestCaseIgnoreSetUpTearDownLeaksMenuItemClick(Sender: TObject);
  304.     procedure TestCaseIgnoreSetUpTearDownLeaksMenuItemDrawItem(Sender: TObject;
  305.       ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  306.   private
  307.     FNoCheckExecutedPtyOverridden: Boolean;
  308.     FMemLeakDetectedPtyOverridden: Boolean;
  309.     FIgnoreSetUpTearDownLeakPtyOverridden: Boolean;
  310.     FPopupY: Integer;
  311.     FPopupX: Integer;
  312.     procedure ResetProgress;
  313.     procedure MenuLooksInactive(ACanvas: TCanvas; ARect: TRect; Selected: Boolean;
  314.       ATitle: string; TitlePosn: UINT; PtyOveridesGUI: boolean);
  315.     procedure MenuLooksActive(ACanvas: TCanvas; ARect: TRect; Selected: Boolean;
  316.       ATitle: string; TitlePosn: UINT);
  317.     function  GetPropertyName(const Caption: string): string;
  318.   protected
  319.     FSuite:         ITest;
  320.     FTestResult:    TTestResult;
  321.     FRunning:       Boolean;
  322.     FTests:         TInterfaceList;
  323.     FSelectedTests: TInterfaceList;
  324.     FTotalTime:     Int64;
  325.     FRunTimeStr:    string;
  326.     FNoChecksStr:   string;
  327.     FMemLeakStr:    string;
  328.     FMemGainStr:    string;
  329.     FMemBytesStr:   string;
  330.     FIgnoreLeakStr: string;
  331.     FBytes:         string;
  332.     FErrorCount:    Integer;
  333.     FFailureCount:  Integer;
  334.     FStrMaxLen:     Integer;
  335.     FValMaxLen:     Integer;
  336.     FUpdateTimer:   TTimer;
  337.     FTimerExpired:  Boolean;
  338.     FTotalTestsCount: Integer;
  340.     procedure Setup;
  341.     procedure SetUpStateImages;
  342.     procedure SetSuite(value: ITest);
  343.     procedure ClearResult;
  344.     procedure DisplayFailureMessage(Item :TListItem);
  345.     procedure ClearFailureMessage;
  347.     function  AddFailureItem(failure: TTestFailure): TListItem;
  348.     procedure UpdateStatus(const fullUpdate:Boolean);
  350.     procedure FillTestTree(RootNode: TTreeNode; ATest: ITest); overload;
  351.     procedure FillTestTree(ATest: ITest);                      overload;
  353.     procedure UpdateNodeImage(node: TTreeNode);
  354.     procedure UpdateNodeState(node: TTreeNode);
  355.     procedure SetNodeState(node: TTreeNode; enabled :boolean);
  356.     procedure SwitchNodeState(node: TTreeNode);
  357.     procedure UpdateTestTreeState;
  359.     procedure MakeNodeVisible(node :TTreeNode);
  360.     procedure SetTreeNodeImage(Node :TTReeNode; imgIndex :Integer);
  361.     procedure SelectNode(node: TTreeNode);
  363.     function  NodeToTest(node :TTreeNode) :ITest;
  364.     function  TestToNode(test :ITest) :TTreeNode;
  365.     function  SelectedTest :ITest;
  366.     procedure ListSelectedTests;
  368.     function  EnableTest(test :ITest) : boolean;
  369.     function  DisableTest(test :ITest) : boolean;
  370.     procedure ApplyToTests(root :TTreeNode; const func :TTestFunc);
  372.     procedure EnableUI(enable :Boolean);
  373.     procedure RunTheTest(aTest: ITest);
  375.     procedure InitTree; virtual;
  377.     function  IniFileName :string;
  378.     function  GetIniFile( const FileName : string ) : tCustomIniFile;
  380.     procedure LoadRegistryAction;
  381.     procedure SaveRegistryAction;
  383.     procedure LoadFormPlacement;
  384.     procedure SaveFormPlacement;
  386.     procedure SaveConfiguration;
  387.     procedure LoadConfiguration;
  389.     procedure LoadSuiteConfiguration;
  390.     procedure AutoSaveConfiguration;
  392.     function NodeIsGrandparent(ANode: TTreeNode): boolean;
  393.     procedure CollapseNonGrandparentNodes(RootNode: TTreeNode);
  395.     procedure ProcessClickOnStateIcon;
  396.     procedure ClearStatusMessage;
  398.     procedure CopyTestNametoClipboard(ANode: TTreeNode);
  400.     procedure SetupCustomShortcuts;
  401.     procedure SetupGUINodes;
  403.     function SelectNodeIfTestEnabled(ANode: TTreeNode): boolean;
  405.     procedure OnUpdateTimer(Sender: TObject);
  406.   public
  407.     {: implement the ITestListener interface }
  408.     procedure AddSuccess(test: ITest);
  409.     procedure AddError(failure: TTestFailure);
  410.     procedure AddFailure(failure: TTestFailure);
  411.     function  ShouldRunTest(test :ITest):boolean;
  412.     procedure StartSuite(suite: ITest); virtual;
  413.     procedure EndSuite(suite: ITest); virtual;
  414.     procedure StartTest(test: ITest); virtual;
  415.     procedure EndTest(test: ITest); virtual;
  416.     procedure TestingStarts;
  417.     procedure TestingEnds(TestResult :TTestResult);
  418.     procedure Status(test :ITest; const Msg :string);
  419.     procedure Warning(test :ITest; const Msg :string);
  421.     {: The number of errors in the last test run }
  422.     property ErrorCount: Integer read FErrorCount;
  423.     {: The number of failures in the last test run }
  424.     property FailureCount: Integer read FFailureCount;
  425.     {: The test suite to be run in this runner }
  426.     property Suite: ITest read FSuite write SetSuite;
  427.     {: The result of the last test run }
  428.     property TestResult : TTestResult read FTestResult write FTestResult;
  430.     class procedure RunTest(test: ITest);
  431.     class procedure RunRegisteredTests;
  432.   end;
  434. procedure RunTest(test: ITest);
  435. procedure RunRegisteredTests;
  437. procedure RunTestModeless(test: ITest);
  438. procedure RunRegisteredTestsModeless;
  440. // Run all tests in unattended mode, i.e. automatically
  441. function RunRegisteredTestsModelessUnattended: Integer;
  443. implementation
  445. uses
  446. {$IFDEF FASTMM}
  447.   {$IFNDEF VER180}
  448.     {$IFNDEF CLR}
  449.       {$IFNDEF ManualLeakReportingControl}
  450.         {$I FastMM4Options.inc}
  451.       {$ENDIF}
  452.       FastMM4,
  453.     {$ENDIF}
  454.   {$ENDIF}
  455. {$ENDIF}
  456.   Registry,
  457.   SysUtils,
  458.   Clipbrd;
  460. {$BOOLEVAL OFF}  // Required or you'll get an AV
  461. {$R *.DFM}
  463. type
  464.   TProgressBarCrack = class(TProgressBar);
  466. procedure RunTest(test: ITest);
  467. begin
  468.   with TGUITestRunner.Create(nil) do
  469.   begin
  470.     try
  471.       Suite := test;
  472.       ShowModal;
  473.     finally
  474.       Free;
  475.     end;
  476.   end;
  477. end;
  479. procedure RunTestModeless(test: ITest);
  480. var
  481.   GUI :TGUITestRunner;
  482. begin
  483.   Application.CreateForm(TGUITestRunner, GUI);
  484.   GUI.Suite := test;
  485.   GUI.Show;
  486. end;
  488. procedure RunRegisteredTests;
  489. begin
  490.    RunTest(registeredTests)
  491. end;
  493. procedure RunRegisteredTestsModeless;
  494. begin
  495.    RunTestModeless(registeredTests)
  496. end;
  498. // Run all tests in unattended mode, i.e. automatically
  499. function RunRegisteredTestsModelessUnattended: Integer;
  500. var
  501.   GUI :TGUITestRunner;
  502. begin
  503.   // Create and show the GUI runner form
  505.   Application.CreateForm(TGUITestRunner, GUI);
  506.   GUI.Suite := registeredTests;
  507.   GUI.Show;
  509.   GUI.RunActionExecute(GUI.RunItem);
  511.   // Process messages until the tests have finished
  513.   repeat
  514.     try
  515.       Application.HandleMessage;
  516.     except
  517.       Application.HandleException(Application);
  518.     end;
  519.   until TGUITestRunner(Application.MainForm).RunAction.Enabled;
  521.   // Return the number of errors and failures and free the runner form
  523.   Result := GUI.ErrorCount + GUI.FailureCount;
  525.   GUI.Free;
  526. end;
  528. { TGUITestRunner }
  530. procedure TGUITestRunner.InitTree;
  531. begin
  532.   FTests.Clear;
  533.   FillTestTree(Suite);
  534.   Setup;
  535.   if HideTestNodesOnOpenAction.Checked then
  536.     HideTestNodesAction.Execute
  537.   else
  538.     ExpandAllNodesAction.Execute;
  539.   TestTree.Selected := TestTree.Items.GetFirstNode;
  540. end;
  542. function TGUITestRunner.NodeToTest(Node: TTreeNode): ITest;
  543. var
  544.   idx: Integer;
  545. begin
  546.   assert(assigned(Node));
  548.   idx  := Integer(Node.data);
  549.   assert((idx >= 0) and (idx < FTests.Count));
  550.   result := FTests[idx] as ITest;
  551. end;
  553. procedure TGUITestRunner.OnUpdateTimer(Sender: TObject);
  554. begin
  555.   FTimerExpired := True;
  556.   FUpdateTimer.Enabled := False;
  557. end;
  559. function TGUITestRunner.TestToNode(test: ITest): TTreeNode;
  560. begin
  561.   assert(assigned(test));
  563.   Result := test.GUIObject as TTreeNode;
  565.   assert(assigned(Result));
  566. end;
  568. function TGUITestRunner.ShouldRunTest(test: ITest): boolean;
  569. begin
  570.   if FSelectedTests = nil then
  571.     Result := test.Enabled
  572.   else
  573.     Result := FSelectedTests.IndexOf(test as ITest) >= 0;
  574. end;
  576. procedure TGUITestRunner.StartTest(test: ITest);
  577. var
  578.   node :TTreeNode;
  579. begin
  580.   assert(assigned(TestResult));
  581.   assert(assigned(test));
  582.   node := TestToNode(test);
  583.   assert(assigned(node));
  584.   SetTreeNodeImage(node, imgRunning);
  585.   if ShowTestedNodeAction.Checked then
  586.   begin
  587.     MakeNodeVisible(node);
  588.     TestTree.Update;
  589.   end;
  590.   ClearStatusMessage;
  591.   UpdateStatus(False);
  592. end;
  594. procedure TGUITestRunner.EndTest(test: ITest);
  595. begin
  596.   UpdateStatus(False);
  597. end;
  599. procedure TGUITestRunner.TestingStarts;
  600. begin
  601.   FTotalTime := 0;
  602.   UpdateStatus(True);
  603.   TProgressBarCrack(ScoreBar).Color := clOK;
  604.   TProgressBarCrack(ScoreBar).RecreateWnd;
  605. end;
  607. procedure TGUITestRunner.AddSuccess(test: ITest);
  608. var
  609.   OverridesGUI: Boolean;
  610.   HasRunTimePropsSet: Boolean;
  611. begin
  612.   assert(assigned(test));
  613.   if not IsTestMethod(test) then
  614.     SetTreeNodeImage(TestToNode(Test), imgRun)
  615.   else
  616.   begin
  617.     OverridesGUI :=
  618.       ((FailIfNoChecksExecuted.Checked and not Test.FailsOnNoChecksExecuted) or
  619.        (FailTestCaseIfMemoryLeaked.Checked and not Test.FailsOnMemoryLeak)) or
  620.        (FailTestCaseIfMemoryLeaked.Checked and Test.IgnoreSetUpTearDownLeaks and
  621.          not IgnoreMemoryLeakInSetUpTearDown.Checked);
  622.     HasRunTimePropsSet :=
  623.       ((Test.FailsOnNoChecksExecuted and not FailIfNoChecksExecuted.Checked) or
  624.        (Test.FailsOnMemoryLeak and not FailTestCaseIfMemoryLeaked.Checked) or
  625.        (FailTestCaseIfMemoryLeaked.Checked and Test.IgnoreSetUpTearDownLeaks) or
  626.        (Test.AllowedMemoryLeakSize <> 0));
  628.     if OverridesGUI then
  629.       FTestResult.Overrides := FTestResult.Overrides + 1;
  631.     if (WarnOnFailTestOverride.Checked and OverridesGUI) or
  632.        (ShowTestCaseswithRunTimeProperties.Checked and HasRunTimePropsSet) then
  633.       SetTreeNodeImage(TestToNode(Test), imgHASPROPS)
  634.     else
  635.       SetTreeNodeImage(TestToNode(Test), imgRun);
  636.   end;
  637. end;
  639. procedure TGUITestRunner.AddError(failure: TTestFailure);
  640. var
  641.   ListItem: TListItem;
  642. begin
  643.   ListItem := AddFailureItem(failure);
  644.   ListItem.ImageIndex := imgERROR;
  645.   TProgressBarCrack(ScoreBar).Color := clERROR;
  646.   TProgressBarCrack(ScoreBar).RecreateWnd;
  648.   SetTreeNodeImage(TestToNode(failure.failedTest), imgERROR);
  649.   UpdateStatus(False);
  650. end;
  652. procedure TGUITestRunner.AddFailure(failure: TTestFailure);
  653. var
  654.   ListItem: TListItem;
  655. begin
  656.   ListItem := AddFailureItem(failure);
  657.   ListItem.ImageIndex := imgFAILED;
  658.   if TestResult.errorCount = 0 then
  659.   begin
  660.     TProgressBarCrack(ScoreBar).Color := clFAILURE;
  661.     TProgressBarCrack(ScoreBar).RecreateWnd;
  662.   end;
  663.   SetTreeNodeImage(TestToNode(failure.failedTest), imgFAILED);
  664.   UpdateStatus(False);
  665. end;
  667. function TGUITestRunner.IniFileName: string;
  668. const
  669.   TEST_INI_FILE = 'dunit.ini';
  670. begin
  671.     result := ExtractFilePath(Application.ExeName) + TEST_INI_FILE
  672. end;
  674. procedure TGUITestRunner.LoadFormPlacement;
  675. begin
  676.   with GetIniFile( IniFileName ) do
  677.   try
  678.     Self.SetBounds(
  679.                    ReadInteger(cnConfigIniSection, 'Left',   Left),
  680.                    ReadInteger(cnConfigIniSection, 'Top',    Top),
  681.                    ReadInteger(cnConfigIniSection, 'Width',  Width),
  682.                    ReadInteger(cnConfigIniSection, 'Height', Height)
  683.                    );
  684.     if ReadBool(cnConfigIniSection, 'Maximized', False ) then
  685.       WindowState := wsMaximized;
  686.   finally
  687.     Free;
  688.   end;
  689. end;
  691. procedure TGUITestRunner.SaveFormPlacement;
  692. begin
  693.   with GetIniFile(IniFileName) do
  694.     try
  695.       WriteBool(cnConfigIniSection, 'AutoSave', AutoSaveAction.Checked);
  697.       if WindowState <> wsMaximized then
  698.       begin
  699.         WriteInteger(cnConfigIniSection, 'Left',   Left);
  700.         WriteInteger(cnConfigIniSection, 'Top',    Top);
  701.         WriteInteger(cnConfigIniSection, 'Width',  Width);
  702.         WriteInteger(cnConfigIniSection, 'Height', Height );
  703.       end;
  705.       WriteBool(cnConfigIniSection, 'Maximized', WindowState = wsMaximized );
  706.     finally
  707.       Free
  708.     end;
  709. end;
  711. procedure TGUITestRunner.LoadConfiguration;
  712. var
  713.   i :Integer;
  714. begin
  715.   LoadRegistryAction;
  716.   LoadFormPlacement;
  717.   LoadSuiteConfiguration;
  718.   with GetIniFile(IniFileName) do
  719.   try
  720.     with AutoSaveAction do
  721.       Checked := ReadBool(cnConfigIniSection, 'AutoSave', Checked);
  723.     { center splitter location }
  724.     with ResultsPanel do
  725.       Height := ReadInteger(cnConfigIniSection, 'ResultsPanel.Height', Height);
  727.     { error splitter location }
  728.     with ErrorBoxPanel do
  729.       Height := ReadInteger(cnConfigIniSection, 'ErrorMessage.Height', Height);
  730.     with ErrorBoxVisibleAction do
  731.       Checked := ReadBool(cnConfigIniSection, 'ErrorMessage.Visible', Checked);
  733.     ErrorBoxSplitter.Visible := ErrorBoxVisibleAction.Checked;
  734.     ErrorBoxPanel.Visible    := ErrorBoxVisibleAction.Checked;
  736.     { failure list configuration }
  737.     with FailureListView do begin
  738.       for i := 0 to Columns.Count-1 do
  739.       begin
  740.         Columns[i].Width := Max(4, ReadInteger(cnConfigIniSection,
  741.                                         Format('FailureList.ColumnWidth[%d]', [i]),
  742.                                         Columns[i].Width)
  743.                                         );
  744.       end;
  745.     end;
  747.     { other options }
  748.     HideTestNodesOnOpenAction.Checked := ReadBool(cnConfigIniSection,
  749.       'HideTestNodesOnOpen', HideTestNodesOnOpenAction.Checked);
  750.     BreakOnFailuresAction.Checked := ReadBool(cnConfigIniSection,
  751.       'BreakOnFailures', BreakOnFailuresAction.Checked);
  752.     FailIfNoChecksExecutedAction.Checked := ReadBool(cnConfigIniSection,
  753.       'FailOnNoChecksExecuted', FailIfNoChecksExecutedAction.Checked);
  754.     FailTestCaseIfMemoryLeakedAction.Checked := ReadBool(cnConfigIniSection,
  755.       'FailOnMemoryLeaked', FailTestCaseIfMemoryLeakedAction.Checked);
  756.     IgnoreMemoryLeakInSetUpTearDownAction.Checked := ReadBool(cnConfigIniSection,
  757.       'IgnoreSetUpTearDownLeaks', IgnoreMemoryLeakInSetUpTearDownAction.Checked);
  758.     ReportMemoryLeakTypeOnShutdownAction.Checked := ReadBool(cnConfigIniSection,
  759.       'ReportMemoryLeakTypes', ReportMemoryLeakTypeOnShutdownAction.Checked);
  760.     WarnOnFailTestOverrideAction.Checked := ReadBool(cnConfigIniSection,
  761.       'WarnOnFailTestOverride', WarnOnFailTestOverrideAction.Checked);
  762.     ShowTestedNodeAction.Checked := ReadBool(cnConfigIniSection,
  763.       'SelectTestedNode', ShowTestedNodeAction.Checked);
  764.     FPopupX := ReadInteger(cnConfigIniSection,'PopupX', 350);
  765.     FPopupY := ReadInteger(cnConfigIniSection,'PopupY', 30);
  766.   finally
  767.     Free;
  768.   end;
  770.   if Suite <> nil then
  771.     UpdateTestTreeState;
  772. end;
  774. procedure TGUITestRunner.AutoSaveConfiguration;
  775. begin
  776.   if AutoSaveAction.Checked then
  777.     SaveConfiguration;
  778. end;
  780. procedure TGUITestRunner.SaveConfiguration;
  781. var
  782.   i :Integer;
  783. begin
  784.   if Suite <> nil then
  785.     Suite.SaveConfiguration(IniFileName, UseRegistryAction.Checked, True);
  787.   SaveFormPlacement;
  788.   SaveRegistryAction;
  790.   with GetIniFile(IniFileName) do
  791.   try
  792.     { center splitter location }
  793.     WriteInteger(cnConfigIniSection, 'ResultsPanel.Height',
  794.       ResultsPanel.Height);
  796.     { error box }
  797.     WriteInteger(cnConfigIniSection, 'ErrorMessage.Height',
  798.       ErrorBoxPanel.Height);
  799.     WriteBool(cnConfigIniSection, 'ErrorMessage.Visible',
  800.       ErrorBoxVisibleAction.Checked);
  802.     { failure list configuration }
  803.     with FailureListView do begin
  804.       for i := 0 to Columns.Count-1 do
  805.       begin
  806.        WriteInteger( cnConfigIniSection,
  807.                      Format('FailureList.ColumnWidth[%d]', [i]),
  808.                      Columns[i].Width);
  809.       end;
  810.     end;
  812.     { other options }
  813.     WriteBool(cnConfigIniSection, 'HideTestNodesOnOpen',      HideTestNodesOnOpenAction.Checked);
  814.     WriteBool(cnConfigIniSection, 'BreakOnFailures',          BreakOnFailuresAction.Checked);
  815.     WriteBool(cnConfigIniSection, 'FailOnNoChecksExecuted',   FailIfNoChecksExecutedAction.Checked);
  816.     WriteBool(cnConfigIniSection, 'FailOnMemoryLeaked',       FailTestCaseIfMemoryLeakedAction.Checked);
  817.     WriteBool(cnConfigIniSection, 'IgnoreSetUpTearDownLeaks', IgnoreMemoryLeakInSetUpTearDownAction.Checked);
  818.     WriteBool(cnConfigIniSection, 'ReportMemoryLeakTypes',    ReportMemoryLeakTypeOnShutdownAction.Checked);
  819.     WriteBool(cnConfigIniSection, 'SelectTestedNode',         ShowTestedNodeAction.Checked);
  820.     WriteBool(cnConfigIniSection, 'WarnOnFailTestOverride',   WarnOnFailTestOverrideAction.Checked);
  821.     WriteInteger(cnConfigIniSection, 'PopupX',                FPopupX);
  822.     WriteInteger(cnConfigIniSection, 'PopupY',                FPopupY);
  824.   finally
  825.     Free;
  826.   end;
  827. end;
  829. procedure TGUITestRunner.TestingEnds(TestResult :TTestResult);
  830. begin
  831.   FTotalTime := TestResult.TotalTime;
  832. end;
  834. procedure TGUITestRunner.UpdateNodeState(node: TTreeNode);
  835. var
  836.   test: ITest;
  837. begin
  838.   assert(assigned(node));
  839.   test := NodeToTest(node);
  840.   assert(assigned(test));
  842.   UpdateNodeImage(node);
  844.   if node.HasChildren then
  845.   begin
  846.     node := node.getFirstChild;
  847.     while node <> nil do
  848.     begin
  849.       UpdateNodeState(node);
  850.       node := node.getNextSibling;
  851.     end;
  852.   end;
  853. end;
  855. procedure TGUITestRunner.SetNodeState(node: TTreeNode; enabled :boolean);
  856. var
  857.   MostSeniorChanged :TTReeNode;
  858. begin
  859.    assert(node <> nil);
  861.    // update ancestors if enabling
  862.    NodeToTest(Node).Enabled := enabled;
  864.    MostSeniorChanged := Node;
  865.    if enabled then
  866.    begin
  867.      while Node.Parent <> nil do
  868.      begin
  869.        Node := Node.Parent;
  870.        if not NodeToTest(Node).Enabled then
  871.        begin // changed
  872.           NodeToTest(Node).Enabled := true;
  873.           MostSeniorChanged := Node;
  874.           UpdateNodeImage(Node);
  875.        end
  876.      end;
  877.    end;
  878.    TestTree.Items.BeginUpdate;
  879.    try
  880.      UpdateNodeState(MostSeniorChanged);
  881.    finally
  882.      TestTree.Items.EndUpdate;
  883.    end
  884. end;
  886. procedure TGUITestRunner.SwitchNodeState(node: TTreeNode);
  887. begin
  888.    assert(node <> nil);
  890.    SetNodeState(node, not NodeToTest(node).enabled);
  891. end;
  893. procedure TGUITestRunner.UpdateTestTreeState;
  894. var
  895.   node :TTreeNode;
  896. begin
  897.   if TestTree.Items.Count > 0 then
  898.   begin
  899.     TestTree.Items.BeginUpdate;
  900.     try
  901.       node := TestTree.Items.GetFirstNode;
  902.       while node <> nil do
  903.       begin
  904.         UpdateNodeState(node);
  905.         node := node.getNextSibling;
  906.       end
  907.     finally
  908.       TestTree.Items.EndUpdate;
  909.     end;
  910.   end;
  911. end;
  913. procedure TGUITestRunner.UpdateStatus(const fullUpdate:Boolean);
  914. var
  915.   i :Integer;
  916.   TestNumber: Integer;
  918.    function FormatElapsedTime(milli: Int64):string;
  919.    var
  920.      h,nn,ss,zzz: Cardinal;
  921.    begin
  922.      h := milli div 3600000;
  923.      milli := milli mod 3600000;
  924.      nn := milli div 60000;
  925.      milli := milli mod 60000;
  926.      ss := milli div 1000;
  927.      milli := milli mod 1000;
  928.      zzz := milli;
  929.      Result := Format('%d:%2.2d:%2.2d.%3.3d', [h, nn, ss, zzz]);
  930.    end;
  931. begin
  932.   if ResultsView.Items.Count = 0 then
  933.     Exit;
  935.   if fullUpdate then
  936.   begin
  937.     FTotalTestsCount := Suite.countEnabledTestCases;
  938.     if Assigned(Suite) then
  939.       ResultsView.Items[0].SubItems[0] := IntToStr(FTotalTestsCount)
  940.     else
  941.       ResultsView.Items[0].SubItems[0] := '';
  942.   end;
  943.   
  944.   if TestResult <> nil then
  945.   begin
  946.     // Save the test number as we use it a lot
  947.     TestNumber := TestResult.runCount;
  949.     if fullUpdate or FTimerExpired or ((TestNumber and 15) = 0) then
  950.     begin
  951.       with ResultsView.Items[0] do
  952.       begin
  953.         SubItems[1] := IntToStr(TestNumber);
  954.         SubItems[2] := IntToStr(TestResult.failureCount);
  955.         SubItems[3] := IntToStr(TestResult.errorCount);
  956.         SubItems[4] := IntToStr(TestResult.Overrides);
  957.         SubItems[5] := FormatElapsedTime(TestResult.TotalTime);
  958.         SubItems[6] := FormatElapsedTime(max(TestResult.TotalTime, FTotalTime));
  959.       end;
  960.       with TestResult do
  961.       begin
  962.         ScoreBar.Position  := TestNumber - (failureCount + errorCount);
  963.         ProgressBar.Position := TestNumber;
  965.         // There is a possibility for zero tests
  966.         if (TestNumber = 0) and (Suite.CountEnabledTestCases = 0) then
  967.           LbProgress.Caption := '100%'
  968.         else
  969.           LbProgress.Caption := IntToStr((100 * ScoreBar.Position) div ScoreBar.Max) + '%';
  970.       end;
  971.       if FTimerExpired and (TestNumber < FTotalTestsCount) then
  972.       begin
  973.         FTimerExpired := False;
  974.         FUpdateTimer.Enabled := True;
  975.       end;
  976.     end;
  977.     // Allow just the results pane to catch up
  979.     ResultsPanel.Update;
  980.   end
  981.   else
  982.   begin
  983.     with ResultsView.Items[0] do
  984.     begin
  985.       if (SubItems[0] = '0') or (subItems[0] = '') then
  986.       begin
  987.         for i := 1 to 6 do
  988.           SubItems[i] := ''
  989.       end
  990.       else
  991.       begin
  992.         if SubItems[0] <> subItems[1] then
  993.           for i := 1 to 6 do
  994.             SubItems[i] := ''
  995.         else
  996.         begin
  997.           SubItems[5] := FormatElapsedTime(SelectedTest.ElapsedTestTime);
  998.           SubItems[6] := FormatElapsedTime(Max(SelectedTest.ElapsedTestTime, FTotalTime));
  999.         end;
  1000.       end;
  1001.     end;
  1003.     ResetProgress;
  1004.   end;
  1006.   if fullUpdate then
  1007.   begin
  1008.     // Allow the whole display to catch up and check for key strokes
  1010.     Update;
  1011.     Application.ProcessMessages;
  1012.   end;
  1013. end;
  1015. procedure TGUITestRunner.ResetProgress;
  1016. begin
  1017.   TProgressBarCrack(ScoreBar).ParentColor := True;
  1018.   TProgressBarCrack(ScoreBar).RecreateWnd;
  1019.   ScoreBar.Position := 0;
  1020.   ProgressBar.Position := 0;
  1021.   LbProgress.Caption := '';
  1022. end;
  1024. function TGUITestRunner.AddFailureItem(failure: TTestFailure): TListItem;
  1025. var
  1026.   item : TListItem;
  1027.   node : TTreeNode;
  1028. begin
  1029.   assert(assigned(failure));
  1030.   item := FailureListView.Items.Add;
  1031.   item.data := Pointer(TestToNode(failure.failedTest));
  1032.   item.Caption := failure.failedTest.Name;
  1033.   item.SubItems.Add(failure.thrownExceptionName);
  1034.   item.SubItems.Add(failure.thrownExceptionMessage);
  1035.   item.SubItems.Add( failure.LocationInfo
  1036.                      + ' ' +
  1037.                      failure.AddressInfo
  1038.                      );
  1039.   item.SubItems.Add(failure.StackTrace);
  1041.   node := testToNode(failure.failedTest);
  1042.   while node <> nil do
  1043.   begin
  1044.     node.Expand(false);
  1045.     node := node.Parent;
  1046.   end;
  1048.   Result := item;
  1049. end;
  1051. procedure TGUITestRunner.FillTestTree(RootNode: TTreeNode; ATest: ITest);
  1052. var
  1053.   TestTests: IInterfaceList;
  1054.   i: Integer;
  1055. begin
  1056.   if ATest = nil then
  1057.     EXIT;
  1059.   RootNode := TestTree.Items.AddChild(RootNode, ATest.Name);
  1060.   RootNode.data := TObject(FTests.Add(ATest));
  1062.   TestTests := ATest.Tests;
  1063.   for i := 0 to TestTests.count - 1 do
  1064.   begin
  1065.     FillTestTree(RootNode, TestTests[i] as ITest);
  1066.   end;
  1067. end;
  1069. procedure TGUITestRunner.FillTestTree(ATest: ITest);
  1070. begin
  1071.   TestTree.Items.Clear;
  1072.   FTests.Clear;
  1073.   fillTestTree(nil, Suite);
  1074. end;
  1076. procedure TGUITestRunner.SetTreeNodeImage(Node :TTReeNode; imgIndex :Integer);
  1077. begin
  1078.   while Node <> nil do
  1079.   begin
  1080.     if imgIndex > Node.ImageIndex then
  1081.     begin
  1082.        Node.ImageIndex    := imgIndex;
  1083.        Node.SelectedIndex := imgIndex;
  1084.     end;
  1085.     if imgIndex = imgRunning then
  1086.       Node := nil
  1087.     else
  1088.       Node := Node.Parent;
  1089.   end;
  1090. end;
  1092. procedure TGUITestRunner.SetSuite(value: ITest);
  1093. begin
  1094.   FSuite := value;
  1095.   if FSuite <> nil then
  1096.   begin
  1097.     LoadSuiteConfiguration;
  1098.     EnableUI(True);
  1099.     InitTree;
  1100.   end
  1101.   else
  1102.     EnableUI(False)
  1103. end;
  1105. procedure TGUITestRunner.DisplayFailureMessage(Item: TListItem);
  1106. var
  1107.   hlColor :TColor;
  1108.   Test    :ITest;
  1109.   Status  :string;
  1110. begin
  1111.   TestTree.Selected := TTreeNode(Item.data);
  1112.   Test := NodeToTest(TestTree.Selected);
  1113.   hlColor := clFAILURE;
  1114.   if Item.ImageIndex >= imgERROR then
  1115.      hlColor := clERROR;
  1116.   with ErrorMessageRTF do
  1117.     begin
  1118.       Clear;
  1119.       SelAttributes.Size  := self.Font.Size;
  1120.       SelAttributes.Style := [fsBold];
  1121.       SelText := Item.Caption + ': ';
  1123.       SelAttributes.Color := hlColor;
  1124.       SelAttributes.Style := [fsBold];
  1125.       SelText := Item.SubItems[0];
  1127.       Lines.Add('');
  1128.       SelAttributes.Color := clWindowText;
  1129.       SelAttributes.Style := [];
  1130.       SelText := 'at ' + Item.SubItems[2];
  1132.       if Item.SubItems[1] <> '' then
  1133.       begin
  1134.         SelAttributes.Color := clWindowText;
  1135.         Lines.Add('');
  1136.         SelAttributes.Size  := 12;
  1137.         SelAttributes.Style := [];
  1138.         SelText := Item.SubItems[1];
  1139.         SelAttributes.Size  := self.Font.Size;
  1140.       end;
  1142.       Status := Test.Status;
  1143.       if Status <> '' then
  1144.       begin
  1145.         Lines.Add('');
  1146.         Lines.Add('');
  1147.         SelAttributes.Style := [fsBold];
  1148.         Lines.Add('Status Messages');
  1149.         SelAttributes.Style := [];
  1150.         Lines.Add(Status);
  1151.       end;
  1153.       if Item.SubItems[3] <> '' then
  1154.       begin
  1155.         Lines.Add('');
  1156.         SelAttributes.Style := [fsBold];
  1157.         Lines.Add('StackTrace');
  1158.         SelAttributes.Style := [];
  1159.         SelText := Item.SubItems[3];
  1160.       end;
  1161.     end
  1162. end;
  1164. procedure TGUITestRunner.ClearFailureMessage;
  1165. begin
  1166.   ErrorMessageRTF.Clear;
  1167. end;
  1169. procedure TGUITestRunner.ClearResult;
  1170. begin
  1171.   if FTestResult <> nil then
  1172.   begin
  1173.     FTestResult.Free;
  1174.     FTestResult := nil;
  1175.     ClearFailureMessage;
  1176.   end;
  1177. end;
  1179. procedure TGUITestRunner.SetUp;
  1180. var
  1181.   i: Integer;
  1182.   node: TTreeNode;
  1183. begin
  1184.   FailureListView.Items.Clear;
  1185.   ResetProgress;
  1186.   Update;
  1188.   with ResultsView.Items[0] do
  1189.   begin
  1190.     if Suite <> nil then
  1191.     begin
  1192.       i := Suite.countEnabledTestCases;
  1193.       SubItems[0] := IntToStr(i);
  1194.       ProgressBar.Max := i
  1195.     end
  1196.     else
  1197.     begin
  1198.       SubItems[0] := '';
  1199.       ProgressBar.Max:= 10000;
  1200.     end;
  1201.     ScoreBar.Max := ProgressBar.Max;
  1203.     SubItems[1] := '';
  1204.     SubItems[2] := '';
  1205.     SubItems[3] := '';
  1206.     SubItems[4] := '';
  1207.     SubItems[5] := '';
  1208.     SubItems[6] := '';
  1209.   end;
  1211.   for i := 0 to TestTree.Items.Count - 1 do
  1212.   begin
  1213.     node := TestTree.Items[i];
  1214.     node.ImageIndex    := imgNONE;
  1215.     node.SelectedIndex := imgNONE;
  1216.   end;
  1217.   UpdateTestTreeState;
  1218. end;
  1220. procedure TGUITestRunner.EnableUI(enable: Boolean);
  1221. begin
  1222.   SelectAllAction.Enabled    := enable;
  1223.   DeselectAllAction.Enabled  := enable;
  1224.   SelectFailedAction.Enabled := enable;
  1225.   SelectCurrentAction.Enabled := enable;
  1226.   DeselectCurrentAction.Enabled := enable;
  1227.   HideTestNodesAction.Enabled   := enable;
  1228.   ExpandAllNodesAction.Enabled  := enable;
  1229. end;
  1231. procedure TGUITestRunner.FormCreate(Sender: TObject);
  1232. begin
  1233.   inherited;
  1234.   FTests := TInterfaceList.Create;
  1235.   LoadConfiguration;
  1237.   TimeSeparator := ':';
  1238.   SetUpStateImages;
  1239.   SetupCustomShortcuts;
  1240.   TestTree.Items.Clear;
  1241.   EnableUI(false);
  1242.   ClearFailureMessage;
  1243.   FUpdateTimer := TTimer.Create(Self);
  1244.   FUpdateTimer.Interval := 200;
  1245.   FUpdateTimer.Enabled := False;
  1246.   FUpdateTimer.OnTimer := OnUpdateTimer;
  1247.   Setup;
  1249.   {$IFDEF VER180} //FastMM built in already
  1250.     FailTestCaseIfMemoryLeakedAction.Enabled := True;
  1251.     ReportMemoryLeaksOnShutdown := ReportMemoryLeakTypeOnShutdownAction.Checked;
  1252.   {$ELSE}
  1253.     {$IFDEF FASTMM}
  1254.       FailTestCaseIfMemoryLeakedAction.Enabled := True;
  1255.       {$IFDEF ManualLeakReportingControl}
  1256.         ReportMemoryLeaksOnShutdown := ReportMemoryLeakTypeOnShutdownAction.Checked;
  1257.       {$ELSE}
  1258.         ReportMemoryLeakTypeOnShutdownAction.Checked := False;
  1259.         ReportMemoryLeakTypeOnShutdownAction.Enabled := False;
  1260.       {$ENDIF}
  1261.     {$ELSE}
  1262.       FailTestCaseIfMemoryLeakedAction.Enabled := False;
  1263.       ReportMemoryLeakTypeOnShutdownAction.Checked := False;
  1264.       ReportMemoryLeakTypeOnShutdownAction.Enabled := False;
  1265.     {$ENDIF}
  1266.   {$ENDIF}
  1268.   if not FailTestCaseIfMemoryLeakedAction.Enabled then
  1269.     FailTestCaseIfMemoryLeakedAction.Checked := False;
  1270.   IgnoreMemoryLeakInSetUpTearDownAction.Enabled :=
  1271.     FailTestCaseIfMemoryLeakedAction.Checked;
  1272.   if not IgnoreMemoryLeakInSetUpTearDownAction.Enabled then
  1273.     IgnoreMemoryLeakInSetUpTearDownAction.Checked := False;
  1274. end;
  1276. procedure TGUITestRunner.FormDestroy(Sender: TObject);
  1277. begin
  1278.   FreeAndNil(FUpdateTimer);
  1279.   ClearResult;
  1280.   AutoSaveConfiguration;
  1281.   Suite := nil;
  1282.   FTests.Free;
  1283.   FTests := nil;
  1284.   inherited;
  1285. end;
  1287. procedure TGUITestRunner.FormShow(Sender: TObject);
  1288. begin
  1289.   { Set up the GUI nodes in the test nodes. We do it here because the form,
  1290.     the tree and all its tree nodes get recreated in TCustomForm.ShowModal
  1291.     in D8+ so we cannot do it sooner. }
  1293.   SetupGUINodes;
  1294. end;
  1296. procedure TGUITestRunner.TestTreeClick(Sender: TObject);
  1297. begin
  1298.   if FRunning then
  1299.     EXIT;
  1301.   ProcessClickOnStateIcon;
  1302.   TestTreeChange(Sender, TestTree.Selected);
  1303. end;
  1305. procedure TGUITestRunner.TestTreeChange(Sender: TObject; Node: TTreeNode);
  1306. var
  1307.   i : Integer;
  1308. begin
  1309.   if (Node <> nil) and (Node = TestTree.Selected) then
  1310.   begin
  1311.     FailureListView.Selected := nil;
  1312.     for i := 0 to FailureListView.Items.count - 1 do
  1313.     begin
  1314.       if TTreeNode(FailureListView.Items[i].Data) = Node then
  1315.       begin
  1316.         FailureListView.Selected := FailureListView.Items[i];
  1317.         break;
  1318.       end;
  1319.     end;
  1320.     UpdateStatus(True);
  1321.   end;
  1322. end;
  1324. procedure TGUITestRunner.FailureListViewClick(Sender: TObject);
  1325. begin
  1326.   if FailureListView.Selected <> nil then
  1327.   begin
  1328.     TestTree.Selected := TTreeNode(FailureListView.Selected.data);
  1329.   end;
  1330. end;
  1332. procedure TGUITestRunner.FailureListViewSelectItem(Sender: TObject; Item: TListItem; Selected: Boolean);
  1333. begin
  1334.   if not Selected then
  1335.     ClearFailureMessage
  1336.   else
  1337.     DisplayFailureMessage(Item);
  1338. end;
  1340. function TGUITestRunner.DisableTest(test: ITest): boolean;
  1341. begin
  1342.   test.enabled := false;
  1343.   result := true;
  1344. end;
  1346. function TGUITestRunner.EnableTest(test: ITest): boolean;
  1347. begin
  1348.   test.enabled := true;
  1349.   result := true;
  1350. end;
  1352. procedure TGUITestRunner.ApplyToTests(root :TTreeNode; const func :TTestFunc);
  1354.   procedure DoApply(rootnode :TTreeNode);
  1355.   var
  1356.     test: ITest;
  1357.     node: TTreeNode;
  1358.   begin
  1359.     if rootnode <> nil then
  1360.     begin
  1361.       test := NodeToTest(rootnode);
  1362.       if func(test) then
  1363.       begin
  1364.         node := rootnode.getFirstChild;
  1365.         while node <> nil do
  1366.         begin
  1367.           DoApply(node);
  1368.           node := node.getNextSibling;
  1369.         end;
  1370.       end;
  1371.     end;
  1372.   end;
  1373. begin
  1374.   TestTree.Items.BeginUpdate;
  1375.   try
  1376.     DoApply(root)
  1377.   finally
  1378.     TestTree.Items.EndUpdate
  1379.   end;
  1380.   UpdateTestTreeState;
  1381. end;
  1383. procedure TGUITestRunner.TestTreeKeyPress(Sender: TObject; var Key: Char);
  1384. begin
  1385.   if (Key = ' ') and (TestTree.Selected <> nil) then
  1386.   begin
  1387.     SwitchNodeState(TestTree.Selected);
  1388.     UpdateStatus(True);
  1389.     Key := #0
  1390.   end;
  1391. end;
  1393. procedure TGUITestRunner.SelectAllActionExecute(Sender: TObject);
  1394. begin
  1395.   ApplyToTests(TestTree.Items.GetFirstNode, EnableTest);
  1396.   UpdateStatus(True);
  1397. end;
  1399. procedure TGUITestRunner.DeselectAllActionExecute(Sender: TObject);
  1400. begin
  1401.   ApplyToTests(TestTree.Items.GetFirstNode, DisableTest);
  1402.   UpdateStatus(True);
  1403. end;
  1405. procedure TGUITestRunner.SelectFailedActionExecute(Sender: TObject);
  1406. var
  1407.   i: integer;
  1408.   ANode: TTreeNode;
  1409. begin
  1410.   { deselect all }
  1411.   ApplyToTests(TestTree.Items[0], DisableTest);
  1413.   { select failed }
  1414.   for i := 0 to FailureListView.Items.Count - 1 do
  1415.   begin
  1416.     ANode := TTreeNode(FailureListView.Items[i].Data);
  1417.     SetNodeState(ANode, true);
  1418.   end;
  1419.   UpdateStatus(True);
  1420. end;
  1422. procedure TGUITestRunner.SaveConfigurationActionExecute(Sender: TObject);
  1423. begin
  1424.   SaveConfiguration
  1425. end;
  1427. procedure TGUITestRunner.RestoreSavedActionExecute(Sender: TObject);
  1428. begin
  1429.   LoadConfiguration
  1430. end;
  1432. procedure TGUITestRunner.AutoSaveActionExecute(Sender: TObject);
  1433. begin
  1434.   with AutoSaveAction do
  1435.   begin
  1436.     Checked := not Checked
  1437.   end;
  1438.   AutoSaveConfiguration;
  1439. end;
  1441. procedure TGUITestRunner.ErrorBoxVisibleActionExecute(Sender: TObject);
  1442. begin
  1443.    with ErrorBoxVisibleAction do
  1444.    begin
  1445.      Checked := not Checked;
  1446.      ErrorBoxSplitter.Visible := Checked;
  1447.      ErrorBoxPanel.Visible    := Checked;
  1448.      if Checked then
  1449.      begin
  1450.       // Solve bugs with Delphi4 resizing with constraints
  1451.        ErrorBoxSplitter.Top := ErrorBoxPanel.Top-8;
  1452.      end
  1453.    end;
  1454. end;
  1456. procedure TGUITestRunner.ErrorBoxSplitterMoved(Sender: TObject);
  1457. begin
  1458.   // Solve bugs with Delphi4 resizing with constraints
  1459.   ErrorBoxSplitter.Top := ErrorBoxPanel.Top-8;
  1460.   self.Update;
  1461. end;
  1463. procedure TGUITestRunner.ErrorBoxPanelResize(Sender: TObject);
  1464. begin
  1465.   // Solve bugs with Delphi4 resizing with constraints
  1466.   ErrorBoxSplitter.Top := ErrorBoxPanel.Top-8;
  1467. end;
  1469. function TGUITestRunner.NodeIsGrandparent(ANode: TTreeNode): boolean;
  1470. var
  1471.   AChildNode: TTreeNode;
  1472. begin
  1473.   Result := false;
  1474.   if ANode.HasChildren then
  1475.   begin
  1476.     AChildNode := ANode.GetFirstChild;
  1477.     while AChildNode <> nil do
  1478.     begin
  1479.       Result := AChildNode.HasChildren or Result;
  1480.       AChildNode := ANode.GetNextChild(AChildNode);
  1481.     end;
  1482.   end;
  1483. end;
  1485. procedure TGUITestRunner.CollapseNonGrandparentNodes(RootNode: TTreeNode);
  1486. var
  1487.   AChildNode: TTreeNode;
  1488. begin
  1489.   if not NodeIsGrandparent(RootNode) then
  1490.     RootNode.Collapse(false);
  1492.   AChildNode := RootNode.GetFirstChild;
  1493.   while AChildNode <> nil do
  1494.   begin
  1495.     CollapseNonGrandparentNodes(AChildNode);
  1496.     AChildNode := RootNode.GetNextChild(AChildNode);
  1497.   end;
  1498. end;
  1500. procedure TGUITestRunner.HideTestNodesActionExecute(Sender: TObject);
  1501. var
  1502.   ANode: TTreeNode;
  1503. begin
  1504.   inherited;
  1505.   if TestTree.Items.Count = 0 then
  1506.     EXIT;
  1508.   TestTree.Items.BeginUpdate;
  1509.   try
  1510.     ANode := TestTree.Items[0];
  1511.     if ANode <> nil then
  1512.     begin
  1513.       ANode.Expand(true);
  1514.       CollapseNonGrandparentNodes(ANode);
  1515.       SelectNode(ANode);
  1516.     end;
  1517.   finally
  1518.     TestTree.Items.EndUpdate;
  1519.   end;
  1520. end;
  1522. procedure TGUITestRunner.HideTestNodesOnOpenActionExecute(Sender: TObject);
  1523. begin
  1524.   HideTestNodesOnOpenAction.Checked := not HideTestNodesOnOpenAction.Checked;
  1525. end;
  1527. procedure TGUITestRunner.ExpandAllNodesActionExecute(Sender: TObject);
  1528. begin
  1529.   TestTree.FullExpand;
  1530.   if (TestTree.Selected <> nil) then
  1531.     MakeNodeVisible(TestTree.Selected)
  1532.   else if(TestTree.Items.Count > 0) then
  1533.     TestTree.Selected := TestTree.Items[0];
  1534. end;
  1536. procedure TGUITestRunner.RunTheTest(aTest : ITest);
  1537. begin
  1538.   if aTest = nil then
  1539.     EXIT;
  1540.   if FRunning then
  1541.   begin
  1542.     // warning: we're reentering this method if FRunning is true
  1543.     assert(FTestResult <> nil);
  1544.     FTestResult.Stop;
  1545.     EXIT;
  1546.   end;
  1548.   FRunning := true;
  1549.   try
  1550.     RunAction.Enabled  := False;
  1551.     StopAction.Enabled := True;
  1553.     CopyMessageToClipboardAction.Enabled := false;
  1555.     EnableUI(false);
  1556.     AutoSaveConfiguration;
  1557.     ClearResult;
  1558.     TestResult := TTestResult.create;
  1559.     try
  1560.       TestResult.addListener(self);
  1561.       TestResult.BreakOnFailures := BreakOnFailuresAction.Checked;
  1562.       TestResult.FailsIfNoChecksExecuted := FailIfNoChecksExecutedAction.Checked;
  1563.       TestResult.FailsIfMemoryLeaked := FailTestCaseIfMemoryLeakedAction.Checked;
  1564.       TestResult.IgnoresMemoryLeakInSetUpTearDown :=
  1565.         IgnoreMemoryLeakInSetUpTearDownAction.Checked;
  1566.       aTest.run(TestResult);
  1567.     finally
  1568.       FErrorCount := TestResult.ErrorCount;
  1569.       FFailureCount := TestResult.FailureCount;
  1570.       TestResult.Free;
  1571.       TestResult := nil;
  1572.     end;
  1573.   finally
  1574.       FRunning := false;
  1575.       EnableUI(true);
  1576.   end;
  1577. end;
  1579. procedure TGUITestRunner.RunActionExecute(Sender: TObject);
  1580. begin
  1581.   if Suite = nil then
  1582.     EXIT;
  1584.   Setup;
  1585.   RunTheTest(Suite);
  1586. end;
  1588. procedure TGUITestRunner.ExitActionExecute(Sender: TObject);
  1589. begin
  1590.   if FTestResult <> nil then
  1591.      FTestResult.stop;
  1592.   self.ModalResult := mrCancel;
  1593.   Close;
  1594. end;
  1596. procedure TGUITestRunner.BreakOnFailuresActionExecute(Sender: TObject);
  1597. begin
  1598.   with BreakOnFailuresAction do
  1599.    Checked := not Checked;
  1600. end;
  1602. procedure TGUITestRunner.FailIfNoChecksExecutedActionExecute(Sender: TObject);
  1603. begin
  1604.   with FailIfNoChecksExecutedAction do
  1605.     Checked := not Checked;
  1606. end;
  1608. procedure TGUITestRunner.FailTestCaseIfMemoryLeakedActionExecute(Sender: TObject);
  1609. begin
  1610.   with FailTestCaseIfMemoryLeakedAction do
  1611.   begin
  1612.     Checked := not Checked;
  1613.     IgnoreMemoryLeakInSetUpTearDownAction.Enabled := Checked;
  1614.     if not Checked then
  1615.       IgnoreMemoryLeakInSetUpTearDownAction.Checked := False;
  1616.   end;
  1617. end;
  1619. procedure TGUITestRunner.ShowTestCasesWithRunTimePropertiesActionExecute(
  1620.   Sender: TObject);
  1621. begin
  1622.   with ShowTestCasesWithRunTimePropertiesAction do
  1623.   begin
  1624.     Checked := not Checked;
  1625.     if Checked then
  1626.       WarnOnFailTestOverrideAction.Checked := False;
  1627.   end;
  1628. end;
  1630. procedure TGUITestRunner.WarnOnFailTestOverrideActionExecute(
  1631.   Sender: TObject);
  1632. begin
  1633.   with WarnOnFailTestOverrideAction do
  1634.   begin
  1635.     Checked := not Checked;
  1636.     if Checked then
  1637.       ShowTestCasesWithRunTimePropertiesAction.Checked := False;
  1638.   end;
  1639. end;
  1641. procedure TGUITestRunner.ShowTestedNodeActionExecute(Sender: TObject);
  1642. begin
  1643.   with ShowTestedNodeAction do
  1644.     Checked := not Checked;
  1645. end;
  1647. procedure TGUITestRunner.SetUpStateImages;
  1648. begin
  1649.     TestTree.Images             := RunImages;
  1650.     TestTree.StateImages        := StateImages;
  1651.     FailureListView.SmallImages := RunImages;
  1652. end;
  1654. procedure TGUITestRunner.LoadSuiteConfiguration;
  1655. begin
  1656.   if Suite <> nil then
  1657.     Suite.LoadConfiguration(IniFileName, UseRegistryAction.Checked, True);
  1658. end;
  1660. procedure TGUITestRunner.MakeNodeVisible(node: TTreeNode);
  1661. begin
  1662.   node.MakeVisible
  1663. end;
  1665. procedure TGUITestRunner.ProcessClickOnStateIcon;
  1666. var
  1667.   HitInfo: THitTests;
  1668.   node: TTreeNode;
  1669.   PointPos: TPoint;
  1670. begin
  1671.   GetCursorPos(PointPos);
  1672.   PointPos := TestTree.ScreenToClient(PointPos);
  1673.   with PointPos do
  1674.   begin
  1675.     HitInfo := TestTree.GetHitTestInfoAt(X, Y);
  1676.     node := TestTree.GetNodeAt(X, Y);
  1677.   end;
  1678.   if (node <> nil) and (HtOnStateIcon in HitInfo) then
  1679.   begin
  1680.     SwitchNodeState(node);
  1681.   end;
  1682. end;
  1684. procedure TGUITestRunner.UpdateNodeImage(node: TTreeNode);
  1685. var
  1686.   test :ITest;
  1687. begin
  1688.   test := NodeToTest(node);
  1689.   if not test.enabled then
  1690.   begin
  1691.     node.StateIndex := imgDISABLED;
  1692.   end
  1693.   else if (node.Parent <> nil)
  1694.   and (node.Parent.StateIndex <= imgPARENT_DISABLED) then
  1695.   begin
  1696.     node.StateIndex := imgPARENT_DISABLED;
  1697.   end
  1698.   else
  1699.   begin
  1700.     node.StateIndex := imgENABLED;
  1701.   end;
  1702. end;
  1704. procedure TGUITestRunner.CopyMessageToClipboardActionExecute(Sender: TObject);
  1705. begin
  1706.   ErrorMessageRTF.SelectAll;
  1707.   ErrorMessageRTF.CopyToClipboard;
  1708. end;
  1710. procedure TGUITestRunner.UseRegistryActionExecute(Sender: TObject);
  1711. begin
  1712.   with UseRegistryAction do
  1713.     Checked := not Checked;
  1714. end;
  1716. function TGUITestRunner.GetIniFile(const FileName: string) : tCustomIniFile;
  1717. begin
  1718.   if UseRegistryAction.Checked then
  1719.     Result := tRegistryIniFile.Create( GetDUnitRegistryKey + FileName )
  1720.   else
  1721.     Result := tIniFile.Create( FileName );
  1722. end;
  1724. procedure TGUITestRunner.LoadRegistryAction;
  1725. begin
  1726.   with TIniFile.Create(IniFileName) do
  1727.   try
  1728.     UseRegistryAction.Checked := ReadBool(cnConfigIniSection,
  1729.       'UseRegistry', UseRegistryAction.Checked);
  1730.   finally
  1731.     Free;
  1732.   end;
  1733. end;
  1735. procedure TGUITestRunner.SaveRegistryAction;
  1736. begin
  1737.   if UseRegistryAction.Checked then
  1738.     DeleteFile( IniFileName );
  1740.   with TIniFile.Create(IniFileName) do
  1741.   try
  1742.     WriteBool(cnConfigIniSection, 'UseRegistry', UseRegistryAction.Checked);
  1743.   finally
  1744.     Free;
  1745.   end;
  1746. end;
  1748. procedure TGUITestRunner.RunActionUpdate(Sender: TObject);
  1749. begin
  1750.   RunAction.Enabled := not FRunning and assigned( Suite ) and (Suite.countEnabledTestCases > 0);
  1751. end;
  1753. procedure TGUITestRunner.CopyMessageToClipboardActionUpdate(Sender: TObject);
  1754. begin
  1755.   CopyMessageToClipboardAction.Enabled := FailureListView.Selected <> nil;
  1756. end;
  1758. procedure TGUITestRunner.SelectCurrentActionExecute(Sender: TObject);
  1759. begin
  1760.   ApplyToTests(TestTree.Selected, EnableTest);
  1761.   SetNodeState(TestTree.Selected, true);
  1762.   UpdateStatus(True);
  1763. end;
  1765. procedure TGUITestRunner.DeselectCurrentActionExecute(Sender: TObject);
  1766. begin
  1767.   ApplyToTests(TestTree.Selected, DisableTest);
  1768.   UpdateStatus(True);
  1769. end;
  1771. procedure TGUITestRunner.StopActionExecute(Sender: TObject);
  1772. begin
  1773.   if FTestResult <> nil then
  1774.      FTestResult.stop;
  1775. end;
  1777. procedure TGUITestRunner.StopActionUpdate(Sender: TObject);
  1778. begin
  1779.   StopAction.Enabled := FRunning and (FTestResult <> nil);
  1780. end;
  1782. procedure TGUITestRunner.Status(test: ITest; const Msg: string);
  1783. begin
  1784.   if ErrorMessageRTF.Lines.Count = 0 then
  1785.     ErrorMessageRTF.Lines.Add(test.Name + ':');
  1787.   ErrorMessageRTF.Lines.Add(Msg);
  1789.   ErrorMessageRTF.Update;
  1790. end;
  1792. procedure TGUITestRunner.Warning(test: ITest; const Msg: string);
  1793. begin
  1794.   if ErrorMessageRTF.Lines.Count = 0 then
  1795.     ErrorMessageRTF.Lines.Add(test.Name + ':');
  1797.   ErrorMessageRTF.Lines.Add(Msg);
  1799.   ErrorMessageRTF.Update;
  1800. end;
  1802. procedure TGUITestRunner.ClearStatusMessage;
  1803. begin
  1804.   ErrorMessageRTF.Lines.Clear;
  1805. end;
  1807. procedure TGUITestRunner.CopyProcnameToClipboardActionExecute(
  1808.   Sender: TObject);
  1809. begin
  1810.   CopyTestNametoClipboard(TestTree.Selected);
  1811. end;
  1813. procedure TGUITestRunner.CopyTestNametoClipboard(ANode: TTreeNode);
  1814. begin
  1815.   if Assigned(ANode) then
  1816.   begin
  1817.     Clipboard.AsText := ANode.Text;
  1818.   end;
  1819. end;
  1821. procedure TGUITestRunner.CopyProcnameToClipboardActionUpdate(
  1822.   Sender: TObject);
  1823. begin
  1824.   (Sender as TAction).Enabled := Assigned(TestTree.Selected)
  1825.                                  and isTestMethod(NodeToTest(TestTree.Selected));
  1826. end;
  1828. function TGUITestRunner.SelectedTest: ITest;
  1829. begin
  1830.   if TestTree.Selected = nil then
  1831.     Result := nil
  1832.   else
  1833.     Result := NodeToTest(TestTree.Selected);
  1834. end;
  1836. procedure TGUITestRunner.ListSelectedTests;
  1837. var
  1838.   aTest: ITest;
  1839.   aNode: TTreeNode;
  1840. begin
  1841.   FSelectedTests.Free;
  1842.   FSelectedTests := nil;
  1843.   FSelectedTests := TInterfaceList.Create;
  1845.   aNode := TestTree.Selected;
  1847.   while Assigned(aNode) do
  1848.   begin
  1849.     aTest := NodeToTest(aNode);
  1850.     FSelectedTests.Add(aTest as ITest);
  1851.     aNode := aNode.Parent;
  1852.   end;
  1853. end;
  1855. procedure TGUITestRunner.RunSelectedTestActionExecute(Sender: TObject);
  1856. begin
  1857.   Setup;
  1858.   ListSelectedTests;
  1859.   ProgressBar.Max := 1;
  1860.   ScoreBar.Max    := 1;
  1861.   RunTheTest(Suite);
  1862.   {$IFDEF VER130}
  1863.     FreeAndNil(FSelectedTests);
  1864.   {$ELSE}
  1865.     FSelectedTests.Free;
  1866.     FSelectedTests := nil;
  1867.   {$ENDIF}
  1868. end;
  1870. procedure TGUITestRunner.RunSelectedTestActionUpdate(Sender: TObject);
  1871. var
  1872.   aTest :ITest;
  1873. begin
  1874.   ATest := SelectedTest;
  1875.   RunSelectedTestAction.Enabled := (aTest <> nil) and (aTest.CountTestCases = 1);
  1876. end;
  1878. class procedure TGUITestRunner.RunTest(test: ITest);
  1879. var
  1880.   myform: TGUITestRunner;
  1881. begin
  1882.   Application.CreateForm(TGUITestRunner, MyForm);
  1883.   with MyForm do
  1884.   begin
  1885.     try
  1886.       suite := test;
  1887.       ShowModal;
  1888.     finally
  1889.       MyForm.Free;
  1890.     end;
  1891.   end;
  1892. end;
  1894. class procedure TGUITestRunner.RunRegisteredTests;
  1895. begin
  1896.   RunTest(RegisteredTests);
  1897. end;
  1899. procedure TGUITestRunner.EndSuite(suite: ITest);
  1900. begin
  1901.   UpdateStatus(True);
  1902. end;
  1904. procedure TGUITestRunner.StartSuite(suite: ITest);
  1905. begin
  1906. end;
  1908. procedure TGUITestRunner.TestTreeMouseDown(Sender: TObject;
  1909.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  1910. var
  1911.   NewNode: TTreeNode;
  1912. begin
  1913.   { a version of this code was in the pmTestTreePopup event, but it created
  1914.     an intermittent bug. OnPopup is executed if any of the ShortCut keys
  1915.     belonging to items on the popup menu are used. This caused weird behavior,
  1916.     with the selected node suddenly changing to whatever was under the mouse
  1917.     cursor (or AV-ing if the mouse cursor wasn't over the DUnit form) when
  1918.     the user executed one of the keyboard shortcuts.
  1920.     It was intermittent most likely because the ShortCuts belonged to
  1921.     Main Menu items as well (shared from the Action.ShortCut), and the bug
  1922.     dependended on the Popup menu items receiving the ShortCut Windows message
  1923.     first.
  1925.     This code ensures that node selection occurs prior to the popup menu
  1926.     appearing when the user right-clicks on a non-selected tree node. }
  1928.   if (Button = mbRight) and (htOnItem in TestTree.GetHitTestInfoAt(X, Y)) then
  1929.   begin
  1930.     NewNode := TestTree.GetNodeAt(X, Y);
  1931.     if TestTree.Selected <> NewNode then
  1932.       TestTree.Selected := NewNode;
  1933.   end;
  1934. end;
  1936. procedure TGUITestRunner.GoToNextSelectedTestActionExecute(
  1937.   Sender: TObject);
  1938. var
  1939.   aNode: TTreeNode;
  1940. begin
  1941.   if TestTree.Selected <> nil then
  1942.   begin
  1943.     aNode := TestTree.Selected.GetNext;
  1944.     while aNode <> nil do
  1945.     begin
  1946.       if SelectNodeIfTestEnabled(aNode) then
  1947.         break
  1948.       else
  1949.         aNode := aNode.GetNext;
  1950.     end;
  1951.   end;
  1952. end;
  1954. function TGUITestRunner.SelectNodeIfTestEnabled(ANode: TTreeNode): boolean;
  1955. var
  1956.   ATest: ITest;
  1957. begin
  1958.   ATest := NodeToTest(ANode);
  1959.   if (ATest.Enabled) and (IsTestMethod(ATest)) then
  1960.   begin
  1961.     Result := true;
  1962.     SelectNode(ANode);
  1963.   end
  1964.   else
  1965.     Result := false;
  1966. end;
  1968. procedure TGUITestRunner.GoToPrevSelectedTestActionExecute(
  1969.   Sender: TObject);
  1970. var
  1971.   aNode: TTreeNode;
  1972. begin
  1973.   if TestTree.Selected <> nil then
  1974.   begin
  1975.     aNode := TestTree.Selected.GetPrev;
  1976.     while aNode <> nil do
  1977.     begin
  1978.       if SelectNodeIfTestEnabled(aNode) then
  1979.         break
  1980.       else
  1981.         aNode := aNode.GetPrev;
  1982.     end;
  1983.   end;
  1984. end;
  1986. procedure TGUITestRunner.SelectNode(node: TTreeNode);
  1987. begin
  1988.   node.Selected := true;
  1989.   MakeNodeVisible(node);
  1990. end;
  1992. procedure TGUITestRunner.SetupCustomShortcuts;
  1993. begin
  1994.   { the following shortcuts are not offered as an option in the
  1995.     form designer, but can be set up here }
  1996.   GoToNextSelectedTestAction.ShortCut := ShortCut(VK_RIGHT, [ssCtrl]);
  1997.   GoToPrevSelectedTestAction.ShortCut := ShortCut(VK_LEFT, [ssCtrl]);
  1998. end;
  2000. procedure TGUITestRunner.SetupGUINodes;
  2001. var
  2002.   node: TTreeNode;
  2003.   test: ITest;
  2004. begin
  2005.   { Set up the GUI nodes in the test nodes. We do it here because the form,
  2006.     the tree and all its tree nodes get recreated in TCustomForm.ShowModal
  2007.     in D8+ so we cannot do it sooner.
  2008.     This method is also called after loading test libraries }
  2010.   node := TestTree.Items.GetFirstNode;
  2011.   while assigned(node) do
  2012.   begin
  2013.     // Get and check the test for the tree node
  2015.     test := NodeToTest(node);
  2016.     assert(Assigned(test));
  2018.     // Save the tree node in the test and get the next tree node
  2020.     test.GUIObject := node;
  2022.     node := node.GetNext;
  2023.   end;
  2024. end;
  2026. const
  2027.   PopupTitle   = 'TestCase Run-Time Applied Properties';
  2028.   PopupPrevious= ' Previous';
  2029.   PopupRun     = ' Run Selected Test';
  2030.   PopupNext    = ' Next';
  2031.   NoChecksStrT = ' FailsOnNoChecksExecuted  := True ';
  2032.   NoChecksStrF = ' FailsOnNoChecksExecuted  := False';
  2033.   MemLeakStrT  = ' FailsOnMemoryLeak        := True ';
  2034.   MemLeakStrF  = ' FailsOnMemoryLeak        := False';
  2035.   MemGainStrT  = ' FailsOnMemoryRecovery    := True ';
  2036.   MemGainStrF  = ' FailsOnMemoryRecovery    := False';
  2037.   MemBytesStr0 = ' AllowedMemoryLeakSize '           ;
  2038.   IgnoreStrT   = ' IgnoreSetUpTearDownLeaks := True ';
  2039.   IgnoreStrF   = ' IgnoreSetUpTearDownLeaks := False';
  2041. procedure TGUITestRunner.TestCasePropertiesActionExecute(Sender: TObject);
  2042. var
  2043.   aNode: TTreeNode;
  2044.   ATest: ITest;
  2046. begin
  2047.   if TestTree.Selected <> nil then
  2048.   begin
  2049.     aNode := TestTree.Selected;
  2050.     if (aNode <> nil) then
  2051.     begin
  2052.       ATest := NodeToTest(ANode);
  2053.       if IsTestMethod(ATest) then
  2054.       begin
  2055.         if ATest.FailsOnNoChecksExecuted then
  2056.           FNoChecksStr := NoChecksStrT
  2057.         else
  2058.           FNoChecksStr := NoChecksStrF;
  2059.         fNoCheckExecutedPtyOverridden := FailIfNoChecksExecutedAction.Checked and
  2060.           (not ATest.FailsOnNoChecksExecuted);
  2062.         if ATest.FailsOnMemoryLeak then
  2063.           FMemLeakStr := MemLeakStrT
  2064.         else
  2065.           FMemLeakStr := MemLeakStrF;
  2066.         fMemLeakDetectedPtyOverridden := FailTestCaseIfMemoryLeakedAction.Checked and
  2067.           (not ATest.FailsOnMemoryLeak);
  2068.         if (ATest.FailsOnMemoryLeak and ATest.FailsOnMemoryRecovery) then
  2069.           FMemGainStr := MemGainStrT
  2070.         else
  2071.           FMemGainStr := MemGainStrF;
  2073.         if (ATest.IgnoreSetUpTearDownLeaks) and ATest.FailsOnMemoryLeak then
  2074.           FIgnoreLeakStr := IgnoreStrT
  2075.         else
  2076.           FIgnoreLeakStr := IgnoreStrF;
  2077.         FIgnoreSetUpTearDownLeakPtyOverridden := ATest.IgnoreSetUpTearDownLeaks and
  2078.           ATest.FailsOnMemoryLeak and (not IgnoreMemoryLeakInSetUpTearDownAction.Checked);
  2080.         FBytes := ':= ' + IntToStr(Atest.AllowedMemoryLeakSize) + ' Bytes';
  2081.         FMemBytesStr := MemBytesStr0 + FBytes;
  2082.         TestCaseProperty.Popup(Self.Left + FPopupX,Self.Top + FPopupY);
  2083.       end;
  2084.     end;
  2085.     ATest := nil;
  2086.   end;
  2087. end;
  2089. procedure TGUITestRunner.Previous1Click(Sender: TObject);
  2090. begin
  2091.   GoToPrevSelectedTestActionExecute(Self);
  2092.   TestCasePropertiesActionExecute(self);
  2093. end;
  2095. procedure TGUITestRunner.Next1Click(Sender: TObject);
  2096. begin
  2097.   GoToNextSelectedTestActionExecute(Self);
  2098.   TestCasePropertiesActionExecute(self);
  2099. end;
  2101. procedure TGUITestRunner.TestCasePropertiesMeasureItem(Sender: TObject;
  2102.   ACanvas: TCanvas; var Width, Height: Integer);
  2103. var
  2104.   ImageSize: TSize;
  2105. begin
  2106.   if GetTextExtentPoint32(ACanvas.Handle,
  2107.                           PChar(PopupTitle),
  2108.                           Length(PopupTitle),
  2109.                           ImageSize) then
  2110.   begin
  2111.     Width  := ImageSize.cx + 60;
  2112.     Height := ImageSize.cy + 4;
  2113.   end;
  2114. end;
  2116. procedure TGUITestRunner.MenuLooksInactive(ACanvas: TCanvas;
  2117.                                            ARect: TRect;
  2118.                                            Selected: Boolean;
  2119.                                            ATitle: string;
  2120.                                            TitlePosn: UINT;
  2121.                                            PtyOveridesGUI: boolean);
  2122. var
  2123.   Count: integer;
  2124.   SecondPart: string;
  2125.   SecondRect: TRect;
  2126. begin
  2127.   if TitlePosn = DT_CENTER then
  2128.     ACanvas.Font.Style := [fsBold];
  2129.   if Selected then
  2130.     ACanvas.Font.Color := clBlack;
  2131.   if PtyOveridesGUI then
  2132.     ACanvas.Brush.Color := clYellow
  2133.   else
  2134.     ACanvas.Brush.Color := TColor($C0FCC0);  //Sort of Moneygreen
  2135.   ACanvas.FillRect(ARect);
  2136.   Count := Pos(':=', ATitle);
  2137.   if Count = 0 then
  2138.     DrawText(ACanvas.Handle,
  2139.              PChar(ATitle),
  2140.              Length(ATitle),
  2141.              ARect,
  2142.              DT_VCENTER or DT_SINGLELINE or DT_NOCLIP or DT_NOPREFIX or TitlePosn)
  2143.   else
  2144.   begin
  2145.     DrawText(ACanvas.Handle,
  2146.              PChar(ATitle),
  2147.              Count-1,
  2148.              ARect,
  2149.              DT_VCENTER or DT_SINGLELINE or DT_NOCLIP or DT_NOPREFIX or TitlePosn);
  2151.     SecondPart := Copy(ATitle, Count, Length(ATitle));
  2152.     SecondRect := ARect;
  2153.     SecondRect.Left := 5 * ((ARect.Right - ARect.Left) div 8);
  2154.     DrawText(ACanvas.Handle,
  2155.              PChar(SecondPart),
  2156.              Length(SecondPart),
  2157.              SecondRect,
  2158.              DT_VCENTER or DT_SINGLELINE or DT_NOCLIP or DT_NOPREFIX or TitlePosn)
  2159.   end;
  2160. end;
  2162. procedure TGUITestRunner.MenuLooksActive(ACanvas: TCanvas;
  2163.                                          ARect: TRect;
  2164.                                          Selected: Boolean;
  2165.                                          ATitle: string;
  2166.                                          TitlePosn: UINT);
  2167. begin
  2168.   ACanvas.FillRect(ARect);
  2169.   DrawText(ACanvas.Handle,
  2170.            PChar(ATitle),
  2171.            Length(ATitle),
  2172.            ARect,
  2173.            DT_VCENTER or DT_SINGLELINE or DT_NOCLIP or DT_NOPREFIX or TitlePosn);
  2174. end;
  2176. procedure TGUITestRunner.TestCasePropertiesDrawItem(Sender: TObject;
  2177.   ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  2178. begin
  2179.   MenuLooksInactive(ACanvas, ARect, Selected, PopupTitle, DT_CENTER, False);
  2180. end;
  2182. procedure TGUITestRunner.Previous1DrawItem(Sender: TObject;
  2183.   ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  2184. begin
  2185.   MenuLooksActive(ACanvas, ARect, Selected, PopupPrevious, DT_LEFT);
  2186. end;
  2188. procedure TGUITestRunner.RunSelectedTest1DrawItem(Sender: TObject;
  2189.   ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  2190. begin
  2191.   MenuLooksActive(ACanvas, ARect, Selected, PopupRun, DT_LEFT);
  2192. end;
  2194. procedure TGUITestRunner.Next1DrawItem(Sender: TObject; ACanvas: TCanvas;
  2195.   ARect: TRect; Selected: Boolean);
  2196. begin
  2197.   MenuLooksActive(ACanvas, ARect, Selected, PopupNext, DT_LEFT);
  2198. end;
  2200. procedure TGUITestRunner.FailNoCheckExecutedMenuItemDrawItem(
  2201.   Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  2202. begin
  2203.   MenuLooksInactive(ACanvas, ARect, Selected, FNoChecksStr,
  2204.     DT_LEFT, fNoCheckExecutedPtyOverridden);
  2205. end;
  2207. procedure TGUITestRunner.FailsOnMemoryLeakMenuItemDrawItem(Sender: TObject;
  2208.   ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  2209. begin
  2210.   MenuLooksInactive(ACanvas, ARect, Selected, FMemLeakStr,
  2211.     DT_LEFT, fMemLeakDetectedPtyOverridden);
  2212. end;
  2214. procedure TGUITestRunner.FailsOnMemoryRecoveryMenuItemDrawItem(
  2215.   Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  2216. begin
  2217.   MenuLooksInactive(ACanvas, ARect, Selected, FMemGainStr,
  2218.     DT_LEFT, False);
  2219. end;
  2221. procedure TGUITestRunner.AllowedLeakSizeMemuItemDrawItem(Sender: TObject;
  2222.   ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  2223. begin
  2224.   MenuLooksInactive(ACanvas, ARect, Selected, FMemBytesStr, DT_LEFT, False);
  2225. end;
  2227. procedure TGUITestRunner.TestCaseIgnoreSetUpTearDownLeaksMenuItemDrawItem(
  2228.   Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  2229. begin
  2230.   MenuLooksInactive(ACanvas, ARect, Selected, FIgnoreLeakStr,
  2231.     DT_LEFT, FIgnoreSetUpTearDownLeakPtyOverridden);
  2232. end;
  2234. procedure TGUITestRunner.pmTestTreePopup(Sender: TObject);
  2235. var
  2236.   aNode: TTreeNode;
  2237.   ATest: ITest;
  2239. begin
  2240.   if TestTree.Selected <> nil then
  2241.   begin
  2242.     aNode := TestTree.Selected;
  2243.     if (aNode <> nil) then
  2244.     begin
  2245.       ATest := NodeToTest(ANode);
  2246.       TestCasePopup.Enabled := IsTestMethod(ATest);
  2247.     end;
  2248.     ATest := nil;
  2249.   end;
  2250. end;
  2252. function TGUITestRunner.GetPropertyName(const Caption: string): string;
  2253. var
  2254.   TempStr: string;
  2255.   PosSpace: integer;
  2256. begin
  2257.   TempStr := Trim(Caption);
  2258.   PosSpace := Pos(' ',TempStr);
  2259.   if (PosSpace > 1)  then
  2260.     result := Copy(TempStr, 1, PosSpace-1);
  2261. end;
  2263. procedure TGUITestRunner.FailNoCheckExecutedMenuItemClick(Sender: TObject);
  2264. begin
  2265.   Clipboard.AsText := GetPropertyName(NoChecksStrT);
  2266. end;
  2268. procedure TGUITestRunner.FailsOnMemoryLeakMenuItemClick(Sender: TObject);
  2269. begin
  2270.   Clipboard.AsText := GetPropertyName(MemLeakStrT);
  2271. end;
  2273. procedure TGUITestRunner.AllowedLeakSizeMemuItemClick(Sender: TObject);
  2274. begin
  2275.   Clipboard.AsText := GetPropertyName(MemBytesStr0);
  2276. end;
  2278. procedure TGUITestRunner.FailsOnMemoryRecoveryMenuItemClick(
  2279.   Sender: TObject);
  2280. begin
  2281.   Clipboard.AsText := GetPropertyName(MemGainStrT);
  2282. end;
  2284. procedure TGUITestRunner.TestCaseIgnoreSetUpTearDownLeaksMenuItemClick(
  2285.   Sender: TObject);
  2286. begin
  2287.   Clipboard.AsText := GetPropertyName(IgnoreStrT);
  2288. end;
  2290. procedure TGUITestRunner.RunSelectedTestAltActionExecute(Sender: TObject);
  2291. begin
  2292.   RunSelectedTestActionExecute(Self);
  2293.   TestCasePropertiesActionExecute(Self);
  2294. end;
  2296. procedure TGUITestRunner.IgnoreMemoryLeakInSetUpTearDownActionExecute(
  2297.   Sender: TObject);
  2298. begin
  2299.   with IgnoreMemoryLeakInSetUpTearDownAction do
  2300.     Checked := not Checked;
  2301. end;
  2303. procedure TGUITestRunner.ReportMemoryLeakTypeOnShutdownActionExecute(
  2304.   Sender: TObject);
  2305. begin
  2306.   with ReportMemoryLeakTypeOnShutdownAction do
  2307.   begin
  2308.     Checked := not Checked;
  2309.   {$IFDEF VER180}
  2310.     ReportMemoryLeaksOnShutdown := Checked;
  2311.   {$ELSE}
  2312.     {$IFDEF FASTMM}
  2313.      {$IFDEF ManualLeakReportingControl}
  2314.        ReportMemoryLeaksOnShutdown := Checked;
  2315.      {$ENDIF}
  2316.     {$ENDIF}
  2317.   {$ENDIF}
  2318.   end;    // with
  2319. end;
  2321. end.