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

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

Email服务器

开发平台：

Delphi

NGUITestRunner.pas：源码内容
  1. { $Id: NGUITestRunner.pas,v 1.4 2006/07/19 02:45:55 judc Exp $ }
  2. {: DUnit: An XTreme testing framework for Delphi programs.
  3.    @author  The DUnit Group.
  4.    @version $Revision: 1.4 $ 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.  *)
  39. unit NGUITestRunner;
  41. interface
  43. uses
  44.   TestFramework,
  46.   Windows,
  47.   Math,
  48.   Graphics, Controls, Forms, Dialogs,
  49.   ComCtrls, ExtCtrls, StdCtrls, ImgList, Buttons, Menus, ActnList,
  50.   SysUtils, Classes, IniFiles, ToolWin, System.ComponentModel;
  52. const
  53.   {: Section of the dunit.ini file where GUI information will be stored }
  54.   cnConfigIniSection = 'GUITestRunner Config';
  56.   {: Color constants for the progress bar and failure details panel }
  57.   clOK      = clGreen;
  58.   clFAILURE = clFuchsia;
  59.   clERROR   = clRed;
  61.   {: Indexes of the color images used in the test tree and failure list }
  62.   imgNONE     = 0;
  63.   imgRUNNING  = 1;
  64.   imgRUN      = 2;
  65.   imgHASPROPS = 3;
  66.   imgFAILED   = 4;
  67.   imgERROR    = 5;
  69.   {: Indexes of the images used for test tree checkboxes }
  70.   imgDISABLED        = 1;
  71.   imgPARENT_DISABLED = 2;
  72.   imgENABLED         = 3;
  74. type
  75.   {: Function type used by the TDUnitDialog.ApplyToTests method
  76.      @param item  The ITest instance on which to act
  77.      @return true if processing should continue, false otherwise
  78.   }
  79.   TTestFunc = function (item :ITest):Boolean of object;
  81.   TGUITestRunner = class(TForm, ITestListener, ITestListenerX)
  82.     StateImages: TImageList;
  83.     RunImages: TImageList;
  84.     DialogActions: TActionList;
  85.     SelectAllAction: TAction;
  86.     DeselectAllAction: TAction;
  87.     SelectFailedAction: TAction;
  88.     MainMenu: TMainMenu;
  89.     TestTreeMenu: TMenuItem;
  90.     SelectAllItem: TMenuItem;
  91.     DeselectAllItem: TMenuItem;
  92.     SelectFailedItem: TMenuItem;
  93.     FileMenu: TMenuItem;
  94.     SaveConfigurationAction: TAction;
  95.     AutoSaveAction: TAction;
  96.     SaveConfigurationItem: TMenuItem;
  97.     AutoSaveItem: TMenuItem;
  98.     RestoreSavedAction: TAction;
  99.     RestoreSavedConfigurationItem: TMenuItem;
  100.     ViewMenu: TMenuItem;
  101.     HideErrorBoxItem: TMenuItem;
  102.     BodyPanel: TPanel;
  103.     ErrorBoxVisibleAction: TAction;
  104.     TopPanel: TPanel;
  105.     TreePanel: TPanel;
  106.     TestTree: TTreeView;
  107.     ResultsPanel: TPanel;
  108.     ProgressPanel: TPanel;
  109.     ResultsView: TListView;
  110.     FailureListView: TListView;
  111.     ErrorBoxPanel: TPanel;
  112.     ErrorBoxSplitter: TSplitter;
  113.     ResultsSplitter: TSplitter;
  114.     AutoChangeFocusItem: TMenuItem;
  115.     TopProgressPanel: TPanel;
  116.     ProgressBar: TProgressBar;
  117.     pnlProgresslabel: TPanel;
  118.     ScorePanel: TPanel;
  119.     ScoreLabel: TPanel;
  120.     ScoreBar: TProgressBar;
  121.     pmTestTree: TPopupMenu;
  122.     pmiSelectAll: TMenuItem;
  123.     pmiDeselectAll: TMenuItem;
  124.     pmiSelectFailed: TMenuItem;
  125.     HideTestNodesAction: TAction;
  126.     CollapseLowestSuiteNodesItem: TMenuItem;
  127.     CollapseLowestSuiteNodes1: TMenuItem;
  128.     HideTestNodesOnOpenAction: TAction;
  129.     HideTestNodesItem: TMenuItem;
  130.     ExpandAllNodesAction: TAction;
  131.     TestTreeMenuSeparator: TMenuItem;
  132.     ExpandAllItem: TMenuItem;
  133.     TestTreeLocalMenuSeparator: TMenuItem;
  134.     ExpandAll2: TMenuItem;
  135.     lblTestTree: TLabel;
  136.     RunAction: TAction;
  137.     ExitAction: TAction;
  138.     BreakOnFailuresAction: TAction;
  139.     BreakonFailuresItem: TMenuItem;
  140.     ShowTestedNodeAction: TAction;
  141.     SelectTestedNodeItem: TMenuItem;
  142.     ErrorMessagePopup: TPopupMenu;
  143.     CopyFailureMessage: TMenuItem;
  144.     CopyMessageToClipboardAction: TAction;
  145.     ActionsMenu: TMenuItem;
  146.     CopyMessagetoCllipboardItem: TMenuItem;
  147.     LbProgress: TLabel;
  148.     UseRegistryAction: TAction;
  149.     UseRegistryItem: TMenuItem;
  150.     ErrorMessageRTF: TRichEdit;
  151.     SelectCurrentAction: TAction;
  152.     DeselectCurrentAction: TAction;
  153.     SelectCurrent1: TMenuItem;
  154.     DeselectCurrent1: TMenuItem;
  155.     ActionsImages: TImageList;
  156.     CloseItem: TMenuItem;
  157.     RunItem: TMenuItem;
  158.     StopAction: TAction;
  159.     StopActionItem: TMenuItem;
  160.     ToolBar1: TToolBar;
  161.     SelectAllButton: TToolButton;
  162.     DeselectAllButton: TToolButton;
  163.     ToolButton1: TToolButton;
  164.     SelectFailedButton: TToolButton;
  165.     ToolButton2: TToolButton;
  166.     SelectCurrentButton: TToolButton;
  167.     DeselectCurrentButton: TToolButton;
  168.     ToolButton3: TToolButton;
  169.     ToolButton4: TToolButton;
  170.     ToolButton5: TToolButton;
  171.     Alt_R_RunAction: TAction;
  172.     Alt_S_StopAction: TAction;
  173.     N1: TMenuItem;
  174.     DeselectCurrent2: TMenuItem;
  175.     SelectCurrent2: TMenuItem;
  176.     N2: TMenuItem;
  177.     CopyProcnameToClipboardAction: TAction;
  178.     N3: TMenuItem;
  179.     Copytestnametoclipboard1: TMenuItem;
  180.     N4: TMenuItem;
  181.     Copytestnametoclipboard2: TMenuItem;
  182.     RunSelectedTestAction: TAction;
  183.     N5: TMenuItem;
  184.     Runcurrenttest1: TMenuItem;
  185.     N6: TMenuItem;
  186.     Runcurrenttest2: TMenuItem;
  187.     RunSelectedTestItem: TMenuItem;
  188.     RunSelectedTestButton: TToolButton;
  189.     GoToNextSelectedTestAction: TAction;
  190.     GoToPrevSelectedTestAction: TAction;
  191.     N7: TMenuItem;
  192.     GoToNextSelectedNode1: TMenuItem;
  193.     GoToPreviousSelectedNode1: TMenuItem;
  194.     N8: TMenuItem;
  195.     GoToNextSelectedNode2: TMenuItem;
  196.     GoToPreviousSelectedNode2: TMenuItem;
  197.     FailIfNoChecksExecuted: TMenuItem;
  198.     FailIfNoChecksExecutedAction: TAction;
  199.     TestCaseProperty: TPopupMenu;
  200.     TestCaseProperties: TMenuItem;
  201.     N10: TMenuItem;
  202.     FailNoCheckExecutedMenuItem: TMenuItem;
  203.     N11: TMenuItem;
  204.     TestCasePopup: TMenuItem;
  205.     ShowTestCaseswithRunTimeProperties: TMenuItem;
  206.     ShowTestCasesWithRunTimePropertiesAction: TAction;
  207.     N9: TMenuItem;
  208.     N12: TMenuItem;
  209.     TestCasePropertiesAction: TAction;
  210.     PropertyPopUpAction: TAction;
  211.     Previous1: TMenuItem;
  212.     Next1: TMenuItem;
  213.     RunSelectedTest1: TMenuItem;
  214.     RunSelectedTestAltAction: TAction;
  215.     N13: TMenuItem;
  216.     WarnOnFailTestOverrideAction: TAction;
  217.     WarnOnFailTestOverride: TMenuItem;
  218.     procedure WarnOnFailTestOverrideActionExecute(Sender: TObject);
  219.     procedure FormCreate(Sender: TObject);
  220.     procedure TestTreeClick(Sender: TObject);
  221.     procedure FailureListViewSelectItem(Sender: TObject; Item: TListItem;
  222.       Selected: Boolean);
  223.     procedure FailureListViewClick(Sender: TObject);
  224.     procedure TestTreeKeyPress(Sender: TObject; var Key: Char);
  225.     procedure SelectAllActionExecute(Sender: TObject);
  226.     procedure DeselectAllActionExecute(Sender: TObject);
  227.     procedure SelectFailedActionExecute(Sender: TObject);
  228.     procedure SaveConfigurationActionExecute(Sender: TObject);
  229.     procedure RestoreSavedActionExecute(Sender: TObject);
  230.     procedure AutoSaveActionExecute(Sender: TObject);
  231.     procedure ErrorBoxVisibleActionExecute(Sender: TObject);
  232.     procedure ErrorBoxSplitterMoved(Sender: TObject);
  233.     procedure ErrorBoxPanelResize(Sender: TObject);
  234.     procedure HideTestNodesActionExecute(Sender: TObject);
  235.     procedure HideTestNodesOnOpenActionExecute(Sender: TObject);
  236.     procedure ExpandAllNodesActionExecute(Sender: TObject);
  237.     procedure RunActionExecute(Sender: TObject);
  238.     procedure ExitActionExecute(Sender: TObject);
  239.     procedure BreakOnFailuresActionExecute(Sender: TObject);
  240.     procedure FormDestroy(Sender: TObject);
  241.     procedure ShowTestedNodeActionExecute(Sender: TObject);
  242.     procedure CopyMessageToClipboardActionExecute(Sender: TObject);
  243.     procedure UseRegistryActionExecute(Sender: TObject);
  244.     procedure RunActionUpdate(Sender: TObject);
  245.     procedure CopyMessageToClipboardActionUpdate(Sender: TObject);
  246.     procedure SelectCurrentActionExecute(Sender: TObject);
  247.     procedure DeselectCurrentActionExecute(Sender: TObject);
  248.     procedure StopActionExecute(Sender: TObject);
  249.     procedure StopActionUpdate(Sender: TObject);
  250.     procedure TestTreeChange(Sender: TObject; Node: TTreeNode);
  251.     procedure CopyProcnameToClipboardActionExecute(Sender: TObject);
  252.     procedure CopyProcnameToClipboardActionUpdate(Sender: TObject);
  253.     procedure RunSelectedTestActionExecute(Sender: TObject);
  254.     procedure RunSelectedTestActionUpdate(Sender: TObject);
  255.     procedure TestTreeMouseDown(Sender: TObject; Button: TMouseButton;
  256.       Shift: TShiftState; X, Y: Integer);
  257.     procedure GoToNextSelectedTestActionExecute(Sender: TObject);
  258.     procedure GoToPrevSelectedTestActionExecute(Sender: TObject);
  259.     procedure FormShow(Sender: TObject);
  260.     procedure FailIfNoChecksExecutedActionExecute(Sender: TObject);
  261.     procedure ShowTestCasesWithRunTimePropertiesActionExecute(
  262.       Sender: TObject);
  263.     procedure TestCasePropertiesActionExecute(Sender: TObject);
  264.     procedure Previous1Click(Sender: TObject);
  265.     procedure Next1Click(Sender: TObject);
  266.     procedure TestCasePropertiesMeasureItem(Sender: TObject;
  267.       ACanvas: TCanvas; var Width, Height: Integer);
  268.     procedure TestCasePropertiesDrawItem(Sender: TObject; ACanvas: TCanvas;
  269.       ARect: TRect; Selected: Boolean);
  270.     procedure FailNoCheckExecutedMenuItemDrawItem(Sender: TObject;
  271.       ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  272.     procedure pmTestTreePopup(Sender: TObject);
  273.     procedure FailNoCheckExecutedMenuItemClick(Sender: TObject);
  274.     procedure RunSelectedTestAltActionExecute(Sender: TObject);
  275.     procedure Previous1DrawItem(Sender: TObject; ACanvas: TCanvas;
  276.       ARect: TRect; Selected: Boolean);
  277.     procedure RunSelectedTest1DrawItem(Sender: TObject; ACanvas: TCanvas;
  278.       ARect: TRect; Selected: Boolean);
  279.     procedure Next1DrawItem(Sender: TObject; ACanvas: TCanvas;
  280.       ARect: TRect; Selected: Boolean);
  281.   private
  282.     FNoCheckExecutedPtyOverridden: Boolean;
  283.     FPopupY: Integer;
  284.     FPopupX: Integer;
  285.     procedure ResetProgress;
  286.     procedure MenuLooksInactive(ACanvas: TCanvas; ARect: TRect; Selected: Boolean;
  287.       Title: string; TitlePosn: UINT; PtyOveridesGUI: boolean);
  288.     procedure MenuLooksActive(ACanvas: TCanvas; ARect: TRect; Selected: Boolean;
  289.       Title: string; TitlePosn: UINT);
  290.     function  GetPropertyName(const Caption: string): string;
  291.   protected
  292.     FSuite:         ITest;
  293.     FTestResult:    TTestResult;
  294.     FRunning:       Boolean;
  295.     FTests:         TInterfaceList;
  296.     FSelectedTests: TInterfaceList;
  297.     FTotalTime:     Int64;
  298.     FRunTimeStr:    string;
  299.     FNoChecksStr:   string;
  301.     procedure Setup;
  302.     procedure SetUpStateImages;
  303.     procedure SetSuite(value: ITest);
  304.     procedure ClearResult;
  305.     procedure DisplayFailureMessage(Item :TListItem);
  306.     procedure ClearFailureMessage;
  308.     function  AddFailureItem(failure: TTestFailure): TListItem;
  309.     procedure UpdateStatus(const fullUpdate:Boolean);
  311.     procedure FillTestTree(RootNode: TTreeNode; ATest: ITest); overload;
  312.     procedure FillTestTree(ATest: ITest);                      overload;
  314.     procedure UpdateNodeImage(node: TTreeNode);
  315.     procedure UpdateNodeState(node: TTreeNode);
  316.     procedure SetNodeState(node: TTreeNode; enabled :boolean);
  317.     procedure SwitchNodeState(node: TTreeNode);
  318.     procedure UpdateTestTreeState;
  320.     procedure MakeNodeVisible(node :TTreeNode);
  321.     procedure SetTreeNodeImage(Node :TTReeNode; imgIndex :Integer);
  322.     procedure SelectNode(node: TTreeNode);
  324.     function  NodeToTest(node :TTreeNode) :ITest;
  325.     function  TestToNode(test :ITest) :TTreeNode;
  326.     function  SelectedTest :ITest;
  327.     procedure ListSelectedTests;
  329.     function  EnableTest(test :ITest) : boolean;
  330.     function  DisableTest(test :ITest) : boolean;
  331.     procedure ApplyToTests(root :TTreeNode; const func :TTestFunc);
  333.     procedure EnableUI(enable :Boolean);
  334.     procedure RunTheTest(aTest: ITest);
  336.     procedure InitTree; virtual;
  338.     function  IniFileName :string;
  339.     function  GetIniFile( const FileName : string ) : tCustomIniFile;
  341.     procedure LoadRegistryAction;
  342.     procedure SaveRegistryAction;
  344.     procedure LoadFormPlacement;
  345.     procedure SaveFormPlacement;
  347.     procedure SaveConfiguration;
  348.     procedure LoadConfiguration;
  350.     procedure LoadSuiteConfiguration;
  351.     procedure AutoSaveConfiguration;
  353.     function NodeIsGrandparent(ANode: TTreeNode): boolean;
  354.     procedure CollapseNonGrandparentNodes(RootNode: TTreeNode);
  356.     procedure ProcessClickOnStateIcon;
  357.     procedure ClearStatusMessage;
  359.     procedure CopyTestNametoClipboard(ANode: TTreeNode);
  361.     procedure SetupCustomShortcuts;
  363.     function SelectNodeIfTestEnabled(ANode: TTreeNode): boolean;
  364.   public
  365.     {: implement the ITestListener interface }
  366.     procedure AddSuccess(test: ITest);
  367.     procedure AddError(failure: TTestFailure);
  368.     procedure AddFailure(failure: TTestFailure);
  369.     function  ShouldRunTest(test :ITest):boolean;
  370.     procedure StartSuite(suite: ITest); virtual;
  371.     procedure EndSuite(suite: ITest); virtual;
  372.     procedure StartTest(test: ITest); virtual;
  373.     procedure EndTest(test: ITest); virtual;
  374.     procedure TestingStarts;
  375.     procedure TestingEnds(TestResult :TTestResult);
  376.     procedure Status(test :ITest; const Msg :string);
  377.     procedure Warning(test :ITest; const Msg :string);
  379.     {: The test suite to be run in this runner }
  380.     property Suite: ITest read FSuite write SetSuite;
  381.     {: The result of the last test run }
  382.     property TestResult : TTestResult read FTestResult write FTestResult;
  384.     class procedure RunTest(test: ITest);
  385.     class procedure RunRegisteredTests;
  386.   end;
  388. procedure RunTest(test: ITest);
  389. procedure RunRegisteredTests;
  391. procedure RunTestModeless(test: ITest);
  392. procedure RunRegisteredTestsModeless;
  394. implementation
  395. uses
  396.   Registry, Clipbrd;
  398. {$BOOLEVAL OFF}  // Required or you'll get an AV
  399. {$R *.nfm}
  401. type
  402.   TProgressBarCrack = class(TProgressBar);
  404. procedure RunTest(test: ITest);
  405. begin
  406.   with TGUITestRunner.Create(nil) do
  407.   begin
  408.     try
  409.       Suite := test;
  410.       ShowModal;
  411.     finally
  412.       Free;
  413.     end;
  414.   end;
  415. end;
  417. procedure RunTestModeless(test: ITest);
  418. var
  419.   GUI :TGUITestRunner;
  420. begin
  421.   Application.CreateForm(TGUITestRunner, GUI);
  422.   GUI.Suite := test;
  423.   GUI.Show;
  424. end;
  426. procedure RunRegisteredTests;
  427. begin
  428.    RunTest(registeredTests)
  429. end;
  431. procedure RunRegisteredTestsModeless;
  432. begin
  433.    RunTestModeless(registeredTests)
  434. end;
  436. { TGUITestRunner }
  438. procedure TGUITestRunner.InitTree;
  439. begin
  440.   FTests.Clear;
  441.   FillTestTree(Suite);
  442.   Setup;
  443.   if HideTestNodesOnOpenAction.Checked then
  444.     HideTestNodesAction.Execute
  445.   else
  446.     ExpandAllNodesAction.Execute;
  447.   TestTree.Selected := TestTree.Items.GetFirstNode;
  448. end;
  450. function TGUITestRunner.NodeToTest(Node: TTreeNode): ITest;
  451. var
  452.   idx: Integer;
  453. begin
  454.   assert(assigned(Node));
  456.   idx  := Integer(Node.data);
  457.   assert((idx >= 0) and (idx < FTests.Count));
  458.   result := FTests[idx] as ITest;
  459. end;
  461. function TGUITestRunner.TestToNode(test: ITest): TTreeNode;
  462. begin
  463.   assert(assigned(test));
  465.   Result := test.GUIObject as TTreeNode;
  467.   assert(assigned(Result));
  468. end;
  470. function TGUITestRunner.ShouldRunTest(test: ITest): boolean;
  471. begin
  472.   if FSelectedTests = nil then
  473.     Result := test.Enabled
  474.   else
  475.     Result := FSelectedTests.IndexOf(test as ITest) >= 0;
  476. end;
  478. procedure TGUITestRunner.StartTest(test: ITest);
  479. var
  480.   node :TTreeNode;
  481. begin
  482.   assert(assigned(TestResult));
  483.   assert(assigned(test));
  484.   node := TestToNode(test);
  485.   assert(assigned(node));
  486.   SetTreeNodeImage(node, imgRunning);
  487.   if ShowTestedNodeAction.Checked then
  488.   begin
  489.     MakeNodeVisible(node);
  490.     TestTree.Update;
  491.   end;
  492.   ClearStatusMessage;
  493.   UpdateStatus(False);
  494. end;
  496. procedure TGUITestRunner.EndTest(test: ITest);
  497. begin
  498.   UpdateStatus(False);
  499. end;
  501. procedure TGUITestRunner.TestingStarts;
  502. begin
  503.   FTotalTime := 0;
  504.   UpdateStatus(True);
  505. //  TProgressBarCrack(ScoreBar).Color := clOK;
  506. //  TProgressBarCrack(ScoreBar).RecreateWnd;
  507. //  (ScoreBar as TProgressBarCrack).Color := clOK;
  508. //  (ScoreBar as TProgressBarCrack).RecreateWnd;
  509.   ScoreBar.color := clOk;
  510. end;
  512. procedure TGUITestRunner.AddSuccess(test: ITest);
  513. var
  514.   OverridesGUI: Boolean;
  515.   HasRunTimePropsSet: Boolean;
  516. begin
  517.   assert(assigned(test));
  518.   if not IsTestMethod(test) then
  519.     SetTreeNodeImage(TestToNode(Test), imgRun)
  520.   else
  521.   begin
  522.     OverridesGUI :=
  523.       ((FailIfNoChecksExecuted.Checked and not Test.FailsOnNoChecksExecuted));
  524.     HasRunTimePropsSet :=
  525.       ((Test.FailsOnNoChecksExecuted and not FailIfNoChecksExecuted.Checked));
  527.     if OverridesGUI then
  528.       FTestResult.Overrides := FTestResult.Overrides + 1;
  530.     if (WarnOnFailTestOverride.Checked and OverridesGUI) or
  531.        (ShowTestCaseswithRunTimeProperties.Checked and HasRunTimePropsSet) then
  532.       SetTreeNodeImage(TestToNode(Test), imgHASPROPS)
  533.     else
  534.       SetTreeNodeImage(TestToNode(Test), imgRun);
  535.   end;
  536. end;
  538. procedure TGUITestRunner.AddError(failure: TTestFailure);
  539. var
  540.   ListItem: TListItem;
  541. begin
  542.   ListItem := AddFailureItem(failure);
  543.   ListItem.ImageIndex := imgERROR;
  544. //  TProgressBarCrack(ScoreBar).Color := clERROR;
  545. //  TProgressBarCrack(ScoreBar).RecreateWnd;
  546.   ScoreBar.Color := clERROR;
  548.   SetTreeNodeImage(TestToNode(failure.failedTest), imgERROR);
  549.   UpdateStatus(False);
  550. end;
  552. procedure TGUITestRunner.AddFailure(failure: TTestFailure);
  553. var
  554.   ListItem: TListItem;
  555. begin
  556.   ListItem := AddFailureItem(failure);
  557.   ListItem.ImageIndex := imgFAILED;
  558.   if TestResult.errorCount = 0 then
  559.   begin
  560. //    TProgressBarCrack(ScoreBar).Color := clFAILURE;
  561. //    TProgressBarCrack(ScoreBar).RecreateWnd;
  562.     ScoreBar.Color := clFAILURE;
  563.   end;
  564.   SetTreeNodeImage(TestToNode(failure.failedTest), imgFAILED);
  565.   UpdateStatus(False);
  566. end;
  568. function TGUITestRunner.IniFileName: string;
  569. const
  570.   TEST_INI_FILE = 'dunit.ini';
  571. begin
  572.     result := ExtractFilePath(Application.ExeName) + TEST_INI_FILE
  573. end;
  575. procedure TGUITestRunner.LoadFormPlacement;
  576. begin
  577.   with GetIniFile( IniFileName ) do
  578.   try
  579.     Self.SetBounds(
  580.                    ReadInteger(cnConfigIniSection, 'Left',   Left),
  581.                    ReadInteger(cnConfigIniSection, 'Top',    Top),
  582.                    ReadInteger(cnConfigIniSection, 'Width',  Width),
  583.                    ReadInteger(cnConfigIniSection, 'Height', Height)
  584.                    );
  585.     if ReadBool(cnConfigIniSection, 'Maximized', False ) then
  586.       WindowState := wsMaximized;
  587.   finally
  588.     Free;
  589.   end;
  590. end;
  592. procedure TGUITestRunner.SaveFormPlacement;
  593. begin
  594.   with GetIniFile(IniFileName) do
  595.     try
  596.       WriteBool(cnConfigIniSection, 'AutoSave', AutoSaveAction.Checked);
  598.       if WindowState <> wsMaximized then
  599.       begin
  600.         WriteInteger(cnConfigIniSection, 'Left',   Left);
  601.         WriteInteger(cnConfigIniSection, 'Top',    Top);
  602.         WriteInteger(cnConfigIniSection, 'Width',  Width);
  603.         WriteInteger(cnConfigIniSection, 'Height', Height );
  604.       end;
  606.       WriteBool(cnConfigIniSection, 'Maximized', WindowState = wsMaximized );
  607.     finally
  608.       Free
  609.     end;
  610. end;
  612. procedure TGUITestRunner.LoadConfiguration;
  613. var
  614.   i :Integer;
  615. begin
  616.   LoadRegistryAction;
  617.   LoadFormPlacement;
  618.   LoadSuiteConfiguration;
  619.   with GetIniFile(IniFileName) do
  620.   try
  621.     with AutoSaveAction do
  622.       Checked := ReadBool(cnConfigIniSection, 'AutoSave', Checked);
  624.     { center splitter location }
  625.     with ResultsPanel do
  626.       Height := ReadInteger(cnConfigIniSection, 'ResultsPanel.Height', Height);
  628.     { error splitter location }
  629.     with ErrorBoxPanel do
  630.       Height := ReadInteger(cnConfigIniSection, 'ErrorMessage.Height', Height);
  631.     with ErrorBoxVisibleAction do
  632.       Checked := ReadBool(cnConfigIniSection, 'ErrorMessage.Visible', Checked);
  634.     ErrorBoxSplitter.Visible := ErrorBoxVisibleAction.Checked;
  635.     ErrorBoxPanel.Visible    := ErrorBoxVisibleAction.Checked;
  637.     { failure list configuration }
  638.     with FailureListView do begin
  639.       for i := 0 to Columns.Count-1 do
  640.       begin
  641.         Columns[i].Width := Max(4, ReadInteger(cnConfigIniSection,
  642.                                         Format('FailureList.ColumnWidth[%d]', [i]),
  643.                                         Columns[i].Width)
  644.                                         );
  645.       end;
  646.     end;
  648.     { other options }
  649.     HideTestNodesOnOpenAction.Checked := ReadBool(cnConfigIniSection,
  650.       'HideTestNodesOnOpen', HideTestNodesOnOpenAction.Checked);
  651.     BreakOnFailuresAction.Checked := ReadBool(cnConfigIniSection,
  652.       'BreakOnFailures', BreakOnFailuresAction.Checked);
  653.     FailIfNoChecksExecutedAction.Checked := ReadBool(cnConfigIniSection,
  654.       'FailOnNoChecksExecuted', FailIfNoChecksExecutedAction.Checked);
  655.     WarnOnFailTestOverrideAction.Checked := ReadBool(cnConfigIniSection,
  656.       'WarnOnFailTestOverride', WarnOnFailTestOverrideAction.Checked);
  657.     ShowTestedNodeAction.Checked := ReadBool(cnConfigIniSection,
  658.       'SelectTestedNode', ShowTestedNodeAction.Checked);
  659.     FPopupX := ReadInteger(cnConfigIniSection,'PopupX', 350);
  660.     FPopupY := ReadInteger(cnConfigIniSection,'PopupY', 30);
  661.   finally
  662.     Free;
  663.   end;
  665.   if Suite <> nil then
  666.     UpdateTestTreeState;
  667. end;
  669. procedure TGUITestRunner.AutoSaveConfiguration;
  670. begin
  671.   if AutoSaveAction.Checked then
  672.     SaveConfiguration;
  673. end;
  675. procedure TGUITestRunner.SaveConfiguration;
  676. var
  677.   i :Integer;
  678. begin
  679.   if Suite <> nil then
  680.     Suite.SaveConfiguration(IniFileName, UseRegistryAction.Checked, True);
  682.   SaveFormPlacement;
  683.   SaveRegistryAction;
  685.   with GetIniFile(IniFileName) do
  686.   try
  687.     { center splitter location }
  688.     WriteInteger(cnConfigIniSection, 'ResultsPanel.Height',
  689.       ResultsPanel.Height);
  691.     { error box }
  692.     WriteInteger(cnConfigIniSection, 'ErrorMessage.Height',
  693.       ErrorBoxPanel.Height);
  694.     WriteBool(cnConfigIniSection, 'ErrorMessage.Visible',
  695.       ErrorBoxVisibleAction.Checked);
  697.     { failure list configuration }
  698.     with FailureListView do begin
  699.       for i := 0 to Columns.Count-1 do
  700.       begin
  701.        WriteInteger( cnConfigIniSection,
  702.                      Format('FailureList.ColumnWidth[%d]', [i]),
  703.                      Columns[i].Width);
  704.       end;
  705.     end;
  707.     { other options }
  708.     WriteBool(cnConfigIniSection, 'HideTestNodesOnOpen',      HideTestNodesOnOpenAction.Checked);
  709.     WriteBool(cnConfigIniSection, 'BreakOnFailures',          BreakOnFailuresAction.Checked);
  710.     WriteBool(cnConfigIniSection, 'FailOnNoChecksExecuted',   FailIfNoChecksExecutedAction.Checked);
  711.     WriteBool(cnConfigIniSection, 'SelectTestedNode',         ShowTestedNodeAction.Checked);
  712.     WriteBool(cnConfigIniSection, 'WarnOnFailTestOverride',   WarnOnFailTestOverrideAction.Checked);
  713.     WriteInteger(cnConfigIniSection, 'PopupX',                FPopupX);
  714.     WriteInteger(cnConfigIniSection, 'PopupY',                FPopupY);
  716.   finally
  717.     Free;
  718.   end;
  719. end;
  721. procedure TGUITestRunner.TestingEnds(TestResult :TTestResult);
  722. begin
  723.   FTotalTime := TestResult.TotalTime;
  724. end;
  726. procedure TGUITestRunner.UpdateNodeState(node: TTreeNode);
  727. var
  728.   test: ITest;
  729. begin
  730.   assert(assigned(node));
  731.   test := NodeToTest(node);
  732.   assert(assigned(test));
  734.   UpdateNodeImage(node);
  736.   if node.HasChildren then
  737.   begin
  738.     node := node.getFirstChild;
  739.     while node <> nil do
  740.     begin
  741.       UpdateNodeState(node);
  742.       node := node.getNextSibling;
  743.     end;
  744.   end;
  745. end;
  747. procedure TGUITestRunner.SetNodeState(node: TTreeNode; enabled :boolean);
  748. var
  749.   MostSeniorChanged :TTReeNode;
  750. begin
  751.    assert(node <> nil);
  753.    // update ancestors if enabling
  754.    NodeToTest(Node).Enabled := enabled;
  756.    MostSeniorChanged := Node;
  757.    if enabled then
  758.    begin
  759.      while Node.Parent <> nil do
  760.      begin
  761.        Node := Node.Parent;
  762.        if not NodeToTest(Node).Enabled then
  763.        begin // changed
  764.           NodeToTest(Node).Enabled := true;
  765.           MostSeniorChanged := Node;
  766.           UpdateNodeImage(Node);
  767.        end
  768.      end;
  769.    end;
  770.    TestTree.Items.BeginUpdate;
  771.    try
  772.      UpdateNodeState(MostSeniorChanged);
  773.    finally
  774.      TestTree.Items.EndUpdate;
  775.    end
  776. end;
  778. procedure TGUITestRunner.SwitchNodeState(node: TTreeNode);
  779. begin
  780.    assert(node <> nil);
  782.    SetNodeState(node, not NodeToTest(node).enabled);
  783. end;
  785. procedure TGUITestRunner.UpdateTestTreeState;
  786. var
  787.   node :TTreeNode;
  788. begin
  789.   if TestTree.Items.Count > 0 then
  790.   begin
  791.     TestTree.Items.BeginUpdate;
  792.     try
  793.       node := TestTree.Items.GetFirstNode;
  794.       while node <> nil do
  795.       begin
  796.         UpdateNodeState(node);
  797.         node := node.getNextSibling;
  798.       end
  799.     finally
  800.       TestTree.Items.EndUpdate;
  801.     end;
  802.   end;
  803. end;
  805. procedure TGUITestRunner.UpdateStatus(const fullUpdate:Boolean);
  806. var
  807.   i :Integer;
  808.   TestNumber: Integer;
  810.    function FormatElapsedTime(milli: Int64):string;
  811.    var
  812.      h,nn,ss,zzz: Cardinal;
  813.    begin
  814.      h := milli div 3600000;
  815.      milli := milli mod 3600000;
  816.      nn := milli div 60000;
  817.      milli := milli mod 60000;
  818.      ss := milli div 1000;
  819.      milli := milli mod 1000;
  820.      zzz := milli;
  821.      Result := Format('%d:%2.2d:%2.2d.%3.3d', [h, nn, ss, zzz]);
  822.    end;
  823. begin
  824. // ATTENTION
  825. // when called first time after ShowModal the ResultView doesn't contain any items
  826.   if ResultsView.Items.Count = 0 then
  827.     Exit;
  829.   if fullUpdate then
  830.     if Assigned(Suite) then
  831.       ResultsView.Items[0].SubItems[0] := IntToStr(Suite.countEnabledTestCases)
  832.     else
  833.       ResultsView.Items[0].SubItems[0] := '';
  835.   if TestResult <> nil then
  836.   begin
  837.     // Save the test number as we use it a lot
  838.     TestNumber := TestResult.runCount;
  840.     // Only update every 8 tests to speed things up considerably
  841.     if fullUpdate or ((TestNumber and 7) = 0) then
  842.     begin
  843.       with ResultsView.Items[0] do
  844.       begin
  845.         SubItems[1] := IntToStr(TestNumber);
  846.         SubItems[2] := IntToStr(TestResult.failureCount);
  847.         SubItems[3] := IntToStr(TestResult.errorCount);
  848.         SubItems[4] := IntToStr(TestResult.Overrides);
  849.         SubItems[5] := FormatElapsedTime(TestResult.TotalTime);
  850.         SubItems[6] := FormatElapsedTime(max(TestResult.TotalTime, FTotalTime));
  851.       end;
  852.       with TestResult do
  853.       begin
  854.         ScoreBar.Position  := TestNumber - (failureCount + errorCount);
  855.         ProgressBar.Position := TestNumber;
  857.         // There is a possibility for zero tests
  858.         if (TestNumber = 0) and (Suite.CountEnabledTestCases = 0) then
  859.           LbProgress.Caption := '100%'
  860.         else
  861.           LbProgress.Caption := IntToStr((100 * ScoreBar.Position) div ScoreBar.Max) + '%';
  862.       end;
  863.     end;
  864.     // Allow the display to catch up and check for key strokes
  865.     Application.ProcessMessages;
  866.   end
  867.   else
  868.   begin
  869.     with ResultsView.Items[0] do
  870.     begin
  871.       if (SubItems[0] = '0') or (subItems[0] = '') then
  872.       begin
  873.         for i := 1 to 6 do
  874.           SubItems[i] := ''
  875.       end
  876.       else
  877.       begin
  878.         if SubItems[0] <> subItems[1] then
  879.           for i := 1 to 6 do
  880.             SubItems[i] := ''
  881.         else
  882.         begin
  883.           SubItems[5] := FormatElapsedTime(SelectedTest.ElapsedTestTime);
  884.           SubItems[6] := FormatElapsedTime(Max(SelectedTest.ElapsedTestTime, FTotalTime));
  885.         end;
  886.       end;
  887.     end;
  889.     ResetProgress;
  890.   end;
  892.   if fullUpdate then
  893.     Update;
  894. end;
  896. procedure TGUITestRunner.ResetProgress;
  897. begin
  898. //  TProgressBarCrack(ScoreBar).ParentColor := True;
  899. //  TProgressBarCrack(ScoreBar).RecreateWnd;
  900.   ScoreBar.Position := 0;
  901.   ProgressBar.Position := 0;
  902.   LbProgress.Caption := '';
  903. end;
  905. function TGUITestRunner.AddFailureItem(failure: TTestFailure): TListItem;
  906. var
  907.   item : TListItem;
  908.   node : TTreeNode;
  909. begin
  910.   assert(assigned(failure));
  911.   item := FailureListView.Items.Add;
  912.   item.data := (TestToNode(failure.failedTest));
  913.   item.Caption := failure.failedTest.Name;
  914.   item.SubItems.Add(failure.thrownExceptionName);
  915.   item.SubItems.Add(failure.thrownExceptionMessage);
  916.   item.SubItems.Add( failure.LocationInfo
  917.                      + ' ' +
  918.                      failure.AddressInfo
  919.                      );
  920.   item.SubItems.Add(failure.StackTrace);
  922.   node := testToNode(failure.failedTest);
  923.   while node <> nil do
  924.   begin
  925.     node.Expand(false);
  926.     node := node.Parent;
  927.   end;
  929.   Result := item;
  930. end;
  932. procedure TGUITestRunner.FillTestTree(RootNode: TTreeNode; ATest: ITest);
  933. var
  934.   TestTests: IInterfaceList;
  935.   i: Integer;
  936. begin
  937.   if ATest = nil then
  938.     EXIT;
  940.   RootNode := TestTree.Items.AddChild(RootNode, ATest.Name);
  941.   RootNode.data := TObject(FTests.Add(ATest));
  943.   TestTests := ATest.Tests;
  944.   for i := 0 to TestTests.count - 1 do
  945.   begin
  946.     FillTestTree(RootNode, TestTests[i] as ITest);
  947.   end;
  948. end;
  950. procedure TGUITestRunner.FillTestTree(ATest: ITest);
  951. begin
  952.   TestTree.Items.Clear;
  953.   FTests.Clear;
  954.   fillTestTree(nil, Suite);
  955. end;
  957. procedure TGUITestRunner.SetTreeNodeImage(Node :TTReeNode; imgIndex :Integer);
  958. begin
  959.   while Node <> nil do
  960.   begin
  961.     if imgIndex > Node.ImageIndex then
  962.     begin
  963.        Node.ImageIndex    := imgIndex;
  964.        Node.SelectedIndex := imgIndex;
  965.     end;
  966.     if imgIndex = imgRunning then
  967.       Node := nil
  968.     else
  969.       Node := Node.Parent;
  970.   end;
  971. end;
  973. procedure TGUITestRunner.SetSuite(value: ITest);
  974. begin
  975.   FSuite := value;
  976.   if FSuite <> nil then
  977.   begin
  978.     LoadSuiteConfiguration;
  979.     EnableUI(True);
  980.     InitTree;
  981.   end
  982.   else
  983.     EnableUI(False)
  984. end;
  986. procedure TGUITestRunner.DisplayFailureMessage(Item: TListItem);
  987. var
  988.   hlColor :TColor;
  989.   Test    :ITest;
  990.   Status  :string;
  991. begin
  992.   TestTree.Selected := TTreeNode(Item.data);
  993.   Test := NodeToTest(TestTree.Selected);
  994.   hlColor := clFAILURE;
  995.   if Item.ImageIndex >= imgERROR then
  996.      hlColor := clERROR;
  997.   with ErrorMessageRTF do
  998.     begin
  999.       Clear;
  1000.       SelAttributes.Size  := self.Font.Size;
  1001.       SelAttributes.Style := [fsBold];
  1002.       SelText := Item.Caption + ': ';
  1004.       SelAttributes.Color := hlColor;
  1005.       SelAttributes.Style := [fsBold];
  1006.       SelText := Item.SubItems[0];
  1008.       Lines.Add('');
  1009.       SelAttributes.Color := clWindowText;
  1010.       SelAttributes.Style := [];
  1011.       SelText := 'at ' + Item.SubItems[2];
  1013.       if Item.SubItems[1] <> '' then
  1014.       begin
  1015.         SelAttributes.Color := clWindowText;
  1016.         Lines.Add('');
  1017.         SelAttributes.Size  := 12;
  1018.         SelAttributes.Style := [];
  1019.         SelText := Item.SubItems[1];
  1020.         SelAttributes.Size  := self.Font.Size;
  1021.       end;
  1023.       Status := Test.Status;
  1024.       if Status <> '' then
  1025.       begin
  1026.         Lines.Add('');
  1027.         Lines.Add('');
  1028.         SelAttributes.Style := [fsBold];
  1029.         Lines.Add('Status Messages');
  1030.         SelAttributes.Style := [];
  1031.         Lines.Add(Status);
  1032.       end;
  1034.       if Item.SubItems[3] <> '' then
  1035.       begin
  1036.         Lines.Add('');
  1037.         SelAttributes.Style := [fsBold];
  1038.         Lines.Add('StackTrace');
  1039.         SelAttributes.Style := [];
  1040.         SelText := Item.SubItems[3];
  1041.       end;
  1042.     end
  1043. end;
  1045. procedure TGUITestRunner.ClearFailureMessage;
  1046. begin
  1047.   ErrorMessageRTF.Clear;
  1048. end;
  1050. procedure TGUITestRunner.ClearResult;
  1051. begin
  1052.   if FTestResult <> nil then
  1053.   begin
  1054.     FTestResult.Free;
  1055.     FTestResult := nil;
  1056.     ClearFailureMessage;
  1057.   end;
  1058. end;
  1060. procedure TGUITestRunner.SetUp;
  1061. var
  1062.   i: Integer;
  1063.   node: TTreeNode;
  1064. begin
  1065.   FailureListView.Items.Clear;
  1066.   ResetProgress;
  1067.   Update;
  1069.   with ResultsView.Items[0] do
  1070.   begin
  1071.     if Suite <> nil then
  1072.     begin
  1073.       SubItems[0] := IntToStr(Suite.countEnabledTestCases);
  1074.     end
  1075.     else
  1076.     begin
  1077.       SubItems[0] := '';
  1078.     end;
  1079.     SubItems[1] := '';
  1080.     SubItems[2] := '';
  1081.     SubItems[3] := '';
  1082.     SubItems[4] := '';
  1083.     SubItems[5] := '';
  1084.     SubItems[6] := '';
  1085.   end;
  1087.   if Suite <> nil then
  1088.   begin
  1089.     ProgressBar.Max := Suite.countEnabledTestCases;
  1090.   end
  1091.   else
  1092.   begin
  1093.     ProgressBar.Max:= 10000;
  1094.   end;
  1095.   ScoreBar.Max := ProgressBar.Max;
  1097.   for i := 0 to TestTree.Items.Count - 1 do
  1098.   begin
  1099.     node := TestTree.Items[i];
  1100.     node.ImageIndex    := imgNONE;
  1101.     node.SelectedIndex := imgNONE;
  1102.   end;
  1103.   UpdateTestTreeState;
  1104. end;
  1106. procedure TGUITestRunner.EnableUI(enable: Boolean);
  1107. begin
  1108.   SelectAllAction.Enabled    := enable;
  1109.   DeselectAllAction.Enabled  := enable;
  1110.   SelectFailedAction.Enabled := enable;
  1111.   SelectCurrentAction.Enabled := enable;
  1112.   DeselectCurrentAction.Enabled := enable;
  1113.   HideTestNodesAction.Enabled   := enable;
  1114.   ExpandAllNodesAction.Enabled  := enable;
  1115. end;
  1117. procedure TGUITestRunner.FormCreate(Sender: TObject);
  1118. begin
  1119.   inherited;
  1120.   FTests := TInterfaceList.Create;
  1121.   LoadConfiguration;
  1123.   TimeSeparator := ':';
  1124.   SetUpStateImages;
  1125.   SetupCustomShortcuts;
  1126.   TestTree.Items.Clear;
  1127.   EnableUI(false);
  1128.   ClearFailureMessage;
  1129.   Setup;
  1130. end;
  1132. procedure TGUITestRunner.FormDestroy(Sender: TObject);
  1133. begin
  1134.   ClearResult;
  1135.   AutoSaveConfiguration;
  1136.   Suite := nil;
  1137.   FTests.Free;
  1138.   FTests := nil;
  1139.   inherited;
  1140. end;
  1142. procedure TGUITestRunner.FormShow(Sender: TObject);
  1143. var
  1144.   node: TTreeNode;
  1145.   test: ITest;
  1146. begin
  1147.   // Set up the GUI nodes here because the tree and all its tree nodes get
  1148.   // recreated in TCustomForm.ShowModal in D8+ so we cannot do it sooner
  1150.   node := TestTree.Items.GetFirstNode;
  1151.   while assigned(node) do
  1152.   begin
  1153.     // Get and check the test for the tree node
  1155.     test := NodeToTest(node);
  1156.     assert(Assigned(test));
  1158.     // Save the tree node in the test and get the next tree node
  1160.     test.GUIObject := node;
  1162.     node := node.GetNext;
  1163.   end;
  1164. end;
  1166. procedure TGUITestRunner.TestTreeClick(Sender: TObject);
  1167. begin
  1168.   if FRunning then
  1169.     EXIT;
  1171.   ProcessClickOnStateIcon;
  1172.   TestTreeChange(Sender, TestTree.Selected);
  1173. end;
  1175. procedure TGUITestRunner.TestTreeChange(Sender: TObject; Node: TTreeNode);
  1176. var
  1177.   i : Integer;
  1178. begin
  1179.   if (Node <> nil) and (Node = TestTree.Selected) then
  1180.   begin
  1181.     FailureListView.Selected := nil;
  1182.     for i := 0 to FailureListView.Items.count - 1 do
  1183.     begin
  1184.       if TTreeNode(FailureListView.Items[i].Data) = Node then
  1185.       begin
  1186.         FailureListView.Selected := FailureListView.Items[i];
  1187.         break;
  1188.       end;
  1189.     end;
  1190.     UpdateStatus(True);
  1191.   end;
  1192. end;
  1194. procedure TGUITestRunner.FailureListViewClick(Sender: TObject);
  1195. begin
  1196.   if FailureListView.Selected <> nil then
  1197.   begin
  1198.     TestTree.Selected := TTreeNode(FailureListView.Selected.data);
  1199.   end;
  1200. end;
  1202. procedure TGUITestRunner.FailureListViewSelectItem(Sender: TObject; Item: TListItem; Selected: Boolean);
  1203. begin
  1204.   if not Selected then
  1205.     ClearFailureMessage
  1206.   else
  1207.     DisplayFailureMessage(Item);
  1208. end;
  1210. function TGUITestRunner.DisableTest(test: ITest): boolean;
  1211. begin
  1212.   test.enabled := false;
  1213.   result := true;
  1214. end;
  1216. function TGUITestRunner.EnableTest(test: ITest): boolean;
  1217. begin
  1218.   test.enabled := true;
  1219.   result := true;
  1220. end;
  1222. procedure TGUITestRunner.ApplyToTests(root :TTreeNode; const func :TTestFunc);
  1224.   procedure DoApply(rootnode :TTreeNode);
  1225.   var
  1226.     test: ITest;
  1227.     node: TTreeNode;
  1228.   begin
  1229.     if rootnode <> nil then
  1230.     begin
  1231.       test := NodeToTest(rootnode);
  1232.       if func(test) then
  1233.       begin
  1234.         node := rootnode.getFirstChild;
  1235.         while node <> nil do
  1236.         begin
  1237.           DoApply(node);
  1238.           node := node.getNextSibling;
  1239.         end;
  1240.       end;
  1241.     end;
  1242.   end;
  1243. begin
  1244.   TestTree.Items.BeginUpdate;
  1245.   try
  1246.     DoApply(root)
  1247.   finally
  1248.     TestTree.Items.EndUpdate
  1249.   end;
  1250.   UpdateTestTreeState;
  1251. end;
  1253. procedure TGUITestRunner.TestTreeKeyPress(Sender: TObject; var Key: Char);
  1254. begin
  1255.   if (Key = ' ') and (TestTree.Selected <> nil) then
  1256.   begin
  1257.     SwitchNodeState(TestTree.Selected);
  1258.     UpdateStatus(True);
  1259.     Key := #0
  1260.   end;
  1261. end;
  1263. procedure TGUITestRunner.SelectAllActionExecute(Sender: TObject);
  1264. begin
  1265.   ApplyToTests(TestTree.Items.GetFirstNode, EnableTest);
  1266.   UpdateStatus(True);
  1267. end;
  1269. procedure TGUITestRunner.DeselectAllActionExecute(Sender: TObject);
  1270. begin
  1271.   ApplyToTests(TestTree.Items.GetFirstNode, DisableTest);
  1272.   UpdateStatus(True);
  1273. end;
  1275. procedure TGUITestRunner.SelectFailedActionExecute(Sender: TObject);
  1276. var
  1277.   i: integer;
  1278.   ANode: TTreeNode;
  1279. begin
  1280.   { deselect all }
  1281.   ApplyToTests(TestTree.Items[0], DisableTest);
  1283.   { select failed }
  1284.   for i := 0 to FailureListView.Items.Count - 1 do
  1285.   begin
  1286.     ANode := TTreeNode(FailureListView.Items[i].Data);
  1287.     SetNodeState(ANode, true);
  1288.   end;
  1289.   UpdateStatus(True);
  1290. end;
  1292. procedure TGUITestRunner.SaveConfigurationActionExecute(Sender: TObject);
  1293. begin
  1294.   SaveConfiguration
  1295. end;
  1297. procedure TGUITestRunner.RestoreSavedActionExecute(Sender: TObject);
  1298. begin
  1299.   LoadConfiguration
  1300. end;
  1302. procedure TGUITestRunner.AutoSaveActionExecute(Sender: TObject);
  1303. begin
  1304.   with AutoSaveAction do
  1305.   begin
  1306.     Checked := not Checked
  1307.   end;
  1308.   AutoSaveConfiguration;
  1309. end;
  1311. procedure TGUITestRunner.ErrorBoxVisibleActionExecute(Sender: TObject);
  1312. begin
  1313.    with ErrorBoxVisibleAction do
  1314.    begin
  1315.      Checked := not Checked;
  1316.      ErrorBoxSplitter.Visible := Checked;
  1317.      ErrorBoxPanel.Visible    := Checked;
  1318.      if Checked then
  1319.      begin
  1320.       // Solve bugs with Delphi4 resizing with constraints
  1321.        ErrorBoxSplitter.Top := ErrorBoxPanel.Top-8;
  1322.      end
  1323.    end;
  1324. end;
  1326. procedure TGUITestRunner.ErrorBoxSplitterMoved(Sender: TObject);
  1327. begin
  1328.   // Solve bugs with Delphi4 resizing with constraints
  1329.   ErrorBoxSplitter.Top := ErrorBoxPanel.Top-8;
  1330.   self.Update;
  1331. end;
  1333. procedure TGUITestRunner.ErrorBoxPanelResize(Sender: TObject);
  1334. begin
  1335.   // Solve bugs with Delphi4 resizing with constraints
  1336.   ErrorBoxSplitter.Top := ErrorBoxPanel.Top-8;
  1337. end;
  1339. function TGUITestRunner.NodeIsGrandparent(ANode: TTreeNode): boolean;
  1340. var
  1341.   AChildNode: TTreeNode;
  1342. begin
  1343.   Result := false;
  1344.   if ANode.HasChildren then
  1345.   begin
  1346.     AChildNode := ANode.GetFirstChild;
  1347.     while AChildNode <> nil do
  1348.     begin
  1349.       Result := AChildNode.HasChildren or Result;
  1350.       AChildNode := ANode.GetNextChild(AChildNode);
  1351.     end;
  1352.   end;
  1353. end;
  1355. procedure TGUITestRunner.CollapseNonGrandparentNodes(RootNode: TTreeNode);
  1356. var
  1357.   AChildNode: TTreeNode;
  1358. begin
  1359.   if not NodeIsGrandparent(RootNode) then
  1360.     RootNode.Collapse(false);
  1362.   AChildNode := RootNode.GetFirstChild;
  1363.   while AChildNode <> nil do
  1364.   begin
  1365.     CollapseNonGrandparentNodes(AChildNode);
  1366.     AChildNode := RootNode.GetNextChild(AChildNode);
  1367.   end;
  1368. end;
  1370. procedure TGUITestRunner.HideTestNodesActionExecute(Sender: TObject);
  1371. var
  1372.   ANode: TTreeNode;
  1373. begin
  1374.   inherited;
  1375.   if TestTree.Items.Count = 0 then
  1376.     EXIT;
  1378.   TestTree.Items.BeginUpdate;
  1379.   try
  1380.     ANode := TestTree.Items[0];
  1381.     if ANode <> nil then
  1382.     begin
  1383.       ANode.Expand(true);
  1384.       CollapseNonGrandparentNodes(ANode);
  1385.       SelectNode(ANode);
  1386.     end;
  1387.   finally
  1388.     TestTree.Items.EndUpdate;
  1389.   end;
  1390. end;
  1392. procedure TGUITestRunner.HideTestNodesOnOpenActionExecute(Sender: TObject);
  1393. begin
  1394.   HideTestNodesOnOpenAction.Checked := not HideTestNodesOnOpenAction.Checked;
  1395. end;
  1397. procedure TGUITestRunner.ExpandAllNodesActionExecute(Sender: TObject);
  1398. begin
  1399.   TestTree.FullExpand;
  1400.   if (TestTree.Selected <> nil) then
  1401.     MakeNodeVisible(TestTree.Selected)
  1402.   else if(TestTree.Items.Count > 0) then
  1403.     TestTree.Selected := TestTree.Items[0];
  1404. end;
  1406. procedure TGUITestRunner.RunTheTest(aTest : ITest);
  1407. begin
  1408.   if aTest = nil then
  1409.     EXIT;
  1410.   if FRunning then
  1411.   begin
  1412.     // warning: we're reentering this method if FRunning is true
  1413.     assert(FTestResult <> nil);
  1414.     FTestResult.Stop;
  1415.     EXIT;
  1416.   end;
  1418.   FRunning := true;
  1419.   try
  1420.     RunAction.Enabled  := False;
  1421.     StopAction.Enabled := True;
  1423.     CopyMessageToClipboardAction.Enabled := false;
  1425.     EnableUI(false);
  1426.     AutoSaveConfiguration;
  1427.     ClearResult;
  1428.     TestResult := TTestResult.create;
  1429.     try
  1430.       TestResult.addListener(self);
  1431.       TestResult.BreakOnFailures := BreakOnFailuresAction.Checked;
  1432.       TestResult.FailsIfNoChecksExecuted := FailIfNoChecksExecutedAction.Checked;
  1433.       aTest.run(TestResult);
  1434.     finally
  1435.       TestResult.Free;
  1436.       TestResult := nil;
  1437.     end;
  1438.   finally
  1439.       FRunning := false;
  1440.       EnableUI(true);
  1441.   end;
  1442. end;
  1444. procedure TGUITestRunner.RunActionExecute(Sender: TObject);
  1445. begin
  1446.   if Suite = nil then
  1447.     EXIT;
  1449.   Setup;
  1450.   RunTheTest(Suite);
  1451. end;
  1453. procedure TGUITestRunner.ExitActionExecute(Sender: TObject);
  1454. begin
  1455.   if FTestResult <> nil then
  1456.      FTestResult.stop;
  1457.   self.ModalResult := mrCancel;
  1458.   Close;
  1459. end;
  1461. procedure TGUITestRunner.BreakOnFailuresActionExecute(Sender: TObject);
  1462. begin
  1463.   with BreakOnFailuresAction do
  1464.    Checked := not Checked;
  1465. end;
  1467. procedure TGUITestRunner.FailIfNoChecksExecutedActionExecute(Sender: TObject);
  1468. begin
  1469.   with FailIfNoChecksExecutedAction do
  1470.     Checked := not Checked;
  1471. end;
  1473. procedure TGUITestRunner.ShowTestCasesWithRunTimePropertiesActionExecute(
  1474.   Sender: TObject);
  1475. begin
  1476.   with ShowTestCasesWithRunTimePropertiesAction do
  1477.     Checked := not Checked;
  1478. end;
  1480. procedure TGUITestRunner.ShowTestedNodeActionExecute(Sender: TObject);
  1481. begin
  1482.   with ShowTestedNodeAction do
  1483.     Checked := not Checked;
  1484. end;
  1486. procedure TGUITestRunner.SetUpStateImages;
  1487. begin
  1488.     TestTree.Images             := RunImages;
  1489.     TestTree.StateImages        := StateImages;
  1490.     FailureListView.SmallImages := RunImages;
  1491. end;
  1493. procedure TGUITestRunner.LoadSuiteConfiguration;
  1494. begin
  1495.   if Suite <> nil then
  1496.     Suite.LoadConfiguration(IniFileName, UseRegistryAction.Checked, True);
  1497. end;
  1499. procedure TGUITestRunner.MakeNodeVisible(node: TTreeNode);
  1500. begin
  1501.   node.MakeVisible
  1502. end;
  1504. procedure TGUITestRunner.ProcessClickOnStateIcon;
  1505. var
  1506.   HitInfo: THitTests;
  1507.   node: TTreeNode;
  1508.   PointPos: TPoint;
  1509. begin
  1510.   GetCursorPos(PointPos);
  1511.   PointPos := TestTree.ScreenToClient(PointPos);
  1512.   with PointPos do
  1513.   begin
  1514.     HitInfo := TestTree.GetHitTestInfoAt(X, Y);
  1515.     node := TestTree.GetNodeAt(X, Y);
  1516.   end;
  1517.   if (node <> nil) and (HtOnStateIcon in HitInfo) then
  1518.   begin
  1519.     SwitchNodeState(node);
  1520.   end;
  1521. end;
  1523. procedure TGUITestRunner.UpdateNodeImage(node: TTreeNode);
  1524. var
  1525.   test :ITest;
  1526. begin
  1527.   test := NodeToTest(node);
  1528.   if not test.enabled then
  1529.   begin
  1530.     node.StateIndex := imgDISABLED;
  1531.   end
  1532.   else if (node.Parent <> nil)
  1533.   and (node.Parent.StateIndex <= imgPARENT_DISABLED) then
  1534.   begin
  1535.     node.StateIndex := imgPARENT_DISABLED;
  1536.   end
  1537.   else
  1538.   begin
  1539.     node.StateIndex := imgENABLED;
  1540.   end;
  1541. end;
  1543. procedure TGUITestRunner.CopyMessageToClipboardActionExecute(Sender: TObject);
  1544. begin
  1545.   ErrorMessageRTF.SelectAll;
  1546.   ErrorMessageRTF.CopyToClipboard;
  1547. end;
  1549. procedure TGUITestRunner.UseRegistryActionExecute(Sender: TObject);
  1550. begin
  1551.   with UseRegistryAction do
  1552.     Checked := not Checked;
  1553. end;
  1555. function TGUITestRunner.GetIniFile(const FileName: string) : tCustomIniFile;
  1556. begin
  1557.   if UseRegistryAction.Checked then
  1558.     Result := tRegistryIniFile.Create( GetDUnitRegistryKey + FileName )
  1559.   else
  1560.     Result := tIniFile.Create( FileName );
  1561. end;
  1563. procedure TGUITestRunner.LoadRegistryAction;
  1564. begin
  1565.   with TIniFile.Create(IniFileName) do
  1566.   try
  1567.     UseRegistryAction.Checked := ReadBool(cnConfigIniSection,
  1568.       'UseRegistry', UseRegistryAction.Checked);
  1569.   finally
  1570.     Free;
  1571.   end;
  1572. end;
  1574. procedure TGUITestRunner.SaveRegistryAction;
  1575. begin
  1576.   if UseRegistryAction.Checked then
  1577.     DeleteFile( IniFileName );
  1579.   with TIniFile.Create(IniFileName) do
  1580.   try
  1581.     WriteBool(cnConfigIniSection, 'UseRegistry', UseRegistryAction.Checked);
  1582.   finally
  1583.     Free;
  1584.   end;
  1585. end;
  1587. procedure TGUITestRunner.RunActionUpdate(Sender: TObject);
  1588. begin
  1589.   RunAction.Enabled := not FRunning and assigned( Suite ) and (Suite.countEnabledTestCases > 0);
  1590. end;
  1592. procedure TGUITestRunner.CopyMessageToClipboardActionUpdate(Sender: TObject);
  1593. begin
  1594.   CopyMessageToClipboardAction.Enabled := FailureListView.Selected <> nil;
  1595. end;
  1597. procedure TGUITestRunner.SelectCurrentActionExecute(Sender: TObject);
  1598. begin
  1599.   ApplyToTests(TestTree.Selected, EnableTest);
  1600.   SetNodeState(TestTree.Selected, true);
  1601.   UpdateStatus(True);
  1602. end;
  1604. procedure TGUITestRunner.DeselectCurrentActionExecute(Sender: TObject);
  1605. begin
  1606.   ApplyToTests(TestTree.Selected, DisableTest);
  1607.   UpdateStatus(True);
  1608. end;
  1610. procedure TGUITestRunner.StopActionExecute(Sender: TObject);
  1611. begin
  1612.   if FTestResult <> nil then
  1613.      FTestResult.stop;
  1614. end;
  1616. procedure TGUITestRunner.StopActionUpdate(Sender: TObject);
  1617. begin
  1618.   StopAction.Enabled := FRunning and (FTestResult <> nil);
  1619. end;
  1621. procedure TGUITestRunner.Status(test: ITest; const Msg: string);
  1622. begin
  1623.   if ErrorMessageRTF.Lines.Count = 0 then
  1624.     ErrorMessageRTF.Lines.Add(test.Name + ':');
  1626.   ErrorMessageRTF.Lines.Add(Msg);
  1628.   ErrorMessageRTF.Update;
  1629. end;
  1631. procedure TGUITestRunner.Warning(test: ITest; const Msg: string);
  1632. begin
  1633.   if ErrorMessageRTF.Lines.Count = 0 then
  1634.     ErrorMessageRTF.Lines.Add(test.Name + ':');
  1636.   ErrorMessageRTF.Lines.Add(Msg);
  1638.   ErrorMessageRTF.Update;
  1639. end;
  1641. procedure TGUITestRunner.WarnOnFailTestOverrideActionExecute(Sender: TObject);
  1642. begin
  1643.   with WarnOnFailTestOverrideAction do
  1644.     Checked := not Checked;
  1645. end;
  1647. procedure TGUITestRunner.ClearStatusMessage;
  1648. begin
  1649.   ErrorMessageRTF.Lines.Clear;
  1650. end;
  1652. procedure TGUITestRunner.CopyProcnameToClipboardActionExecute(
  1653.   Sender: TObject);
  1654. begin
  1655.   CopyTestNametoClipboard(TestTree.Selected);
  1656. end;
  1658. procedure TGUITestRunner.CopyTestNametoClipboard(ANode: TTreeNode);
  1659. begin
  1660.   if Assigned(ANode) then
  1661.   begin
  1662.     Clipboard.AsText := ANode.Text;
  1663.   end;
  1664. end;
  1666. procedure TGUITestRunner.CopyProcnameToClipboardActionUpdate(
  1667.   Sender: TObject);
  1668. begin
  1669.   (Sender as TAction).Enabled := Assigned(TestTree.Selected)
  1670.                                  and isTestMethod(NodeToTest(TestTree.Selected));
  1671. end;
  1673. function TGUITestRunner.SelectedTest: ITest;
  1674. begin
  1675.   if TestTree.Selected = nil then
  1676.     Result := nil
  1677.   else
  1678.     Result := NodeToTest(TestTree.Selected);
  1679. end;
  1681. procedure TGUITestRunner.ListSelectedTests;
  1682. var
  1683.   aTest: ITest;
  1684.   aNode: TTreeNode;
  1685. begin
  1686.   FSelectedTests.Free;
  1687.   FSelectedTests := nil;
  1688.   FSelectedTests := TInterfaceList.Create;
  1690.   aNode := TestTree.Selected;
  1692.   while Assigned(aNode) do
  1693.   begin
  1694.     aTest := NodeToTest(aNode);
  1695.     FSelectedTests.Add(aTest as ITest);
  1696.     aNode := aNode.Parent;
  1697.   end;
  1698. end;
  1700. procedure TGUITestRunner.RunSelectedTestActionExecute(Sender: TObject);
  1701. begin
  1702.   Setup;
  1703.   ListSelectedTests;
  1704.   ProgressBar.Max := 1;
  1705.   ScoreBar.Max    := 1;
  1706.   RunTheTest(Suite);
  1707.   {$IFDEF VER130}
  1708.     FreeAndNil(FSelectedTests);
  1709.   {$ELSE}
  1710.     FSelectedTests.Free;
  1711.     FSelectedTests := nil;
  1712.   {$ENDIF}
  1713. end;
  1715. procedure TGUITestRunner.RunSelectedTestActionUpdate(Sender: TObject);
  1716. var
  1717.   aTest :ITest;
  1718. begin
  1719.   ATest := SelectedTest;
  1720.   RunSelectedTestAction.Enabled := (aTest <> nil) and (aTest.CountTestCases = 1);
  1721. end;
  1723. class procedure TGUITestRunner.RunTest(test: ITest);
  1724. var
  1725.   myform: TGUITestRunner;
  1726. begin
  1727.   Application.CreateForm(TGUITestRunner, MyForm);
  1728.   with MyForm do
  1729.   begin
  1730.     try
  1731.   suite := test;
  1732.       ShowModal;
  1733.     finally
  1734.       Free;
  1735.     end;
  1736.   end;
  1737. end;
  1739. class procedure TGUITestRunner.RunRegisteredTests;
  1740. begin
  1741.   RunTest(RegisteredTests);
  1742. end;
  1744. procedure TGUITestRunner.EndSuite(suite: ITest);
  1745. begin
  1746.   UpdateStatus(True);
  1747. end;
  1749. procedure TGUITestRunner.StartSuite(suite: ITest);
  1750. begin
  1751. end;
  1753. procedure TGUITestRunner.TestTreeMouseDown(Sender: TObject;
  1754.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  1755. var
  1756.   NewNode: TTreeNode;
  1757. begin
  1758.   { a version of this code was in the pmTestTreePopup event, but it created
  1759.     an intermittent bug. OnPopup is executed if any of the ShortCut keys
  1760.     belonging to items on the popup menu are used. This caused weird behavior,
  1761.     with the selected node suddenly changing to whatever was under the mouse
  1762.     cursor (or AV-ing if the mouse cursor wasn't over the DUnit form) when
  1763.     the user executed one of the keyboard shortcuts.
  1765.     It was intermittent most likely because the ShortCuts belonged to
  1766.     Main Menu items as well (shared from the Action.ShortCut), and the bug
  1767.     dependended on the Popup menu items receiving the ShortCut Windows message
  1768.     first.
  1770.     This code ensures that node selection occurs prior to the popup menu
  1771.     appearing when the user right-clicks on a non-selected tree node. }
  1773.   if (Button = mbRight) and (htOnItem in TestTree.GetHitTestInfoAt(X, Y)) then
  1774.   begin
  1775.     NewNode := TestTree.GetNodeAt(X, Y);
  1776.     if TestTree.Selected <> NewNode then
  1777.       TestTree.Selected := NewNode;
  1778.   end;
  1779. end;
  1781. procedure TGUITestRunner.GoToNextSelectedTestActionExecute(
  1782.   Sender: TObject);
  1783. var
  1784.   aNode: TTreeNode;
  1785. begin
  1786.   if TestTree.Selected <> nil then
  1787.   begin
  1788.     aNode := TestTree.Selected.GetNext;
  1789.     while aNode <> nil do
  1790.     begin
  1791.       if SelectNodeIfTestEnabled(aNode) then
  1792.         break
  1793.       else
  1794.         aNode := aNode.GetNext;
  1795.     end;
  1796.   end;
  1797. end;
  1799. function TGUITestRunner.SelectNodeIfTestEnabled(ANode: TTreeNode): boolean;
  1800. var
  1801.   ATest: ITest;
  1802. begin
  1803.   ATest := NodeToTest(ANode);
  1804.   if (ATest.Enabled) and (IsTestMethod(ATest)) then
  1805.   begin
  1806.     Result := true;
  1807.     SelectNode(ANode);
  1808.   end
  1809.   else
  1810.     Result := false;
  1811. end;
  1813. procedure TGUITestRunner.GoToPrevSelectedTestActionExecute(
  1814.   Sender: TObject);
  1815. var
  1816.   aNode: TTreeNode;
  1817. begin
  1818.   if TestTree.Selected <> nil then
  1819.   begin
  1820.     aNode := TestTree.Selected.GetPrev;
  1821.     while aNode <> nil do
  1822.     begin
  1823.       if SelectNodeIfTestEnabled(aNode) then
  1824.         break
  1825.       else
  1826.         aNode := aNode.GetPrev;
  1827.     end;
  1828.   end;
  1829. end;
  1831. procedure TGUITestRunner.SelectNode(node: TTreeNode);
  1832. begin
  1833.   node.Selected := true;
  1834.   MakeNodeVisible(node);
  1835. end;
  1837. procedure TGUITestRunner.SetupCustomShortcuts;
  1838. begin
  1839.   { the following shortcuts are not offered as an option in the
  1840.     form designer, but can be set up here }
  1841.   GoToNextSelectedTestAction.ShortCut := ShortCut(VK_RIGHT, [ssCtrl]);
  1842.   GoToPrevSelectedTestAction.ShortCut := ShortCut(VK_LEFT, [ssCtrl]);
  1843. end;
  1845. const
  1846.   PopupTitle   = 'TestCase Run-Time Applied Properties';
  1847.   PopupPrevious= ' Previous';
  1848.   PopupRun     = ' Run Selected Test';
  1849.   PopupNext    = ' Next';
  1850.   NoChecksStrT = ' FailsOnNoChecksExecuted    := True ';
  1851.   NoChecksStrF = ' FailsOnNoChecksExecuted    := False';
  1852.   ByteStrEnd = 31;
  1854. procedure TGUITestRunner.TestCasePropertiesActionExecute(Sender: TObject);
  1855. var
  1856.   aNode: TTreeNode;
  1857.   ATest: ITest;
  1859. begin
  1860.   if TestTree.Selected <> nil then
  1861.   begin
  1862.     aNode := TestTree.Selected;
  1863.     if (aNode <> nil) then
  1864.     begin
  1865.       ATest := NodeToTest(ANode);
  1866.       if IsTestMethod(ATest) then
  1867.       begin
  1868.         if ATest.FailsOnNoChecksExecuted then
  1869.           FNoChecksStr := NoChecksStrT
  1870.         else
  1871.           FNoChecksStr := NoChecksStrF;
  1872.         fNoCheckExecutedPtyOverridden := FailIfNoChecksExecutedAction.Checked and
  1873.           (not ATest.FailsOnNoChecksExecuted);
  1875.         TestCaseProperty.Popup(Self.Left + FPopupX,Self.Top + FPopupY);
  1876.       end;
  1877.     end;
  1878.     ATest := nil;
  1879.   end;
  1880. end;
  1882. procedure TGUITestRunner.Previous1Click(Sender: TObject);
  1883. begin
  1884.   GoToPrevSelectedTestActionExecute(Self);
  1885.   TestCasePropertiesActionExecute(self);
  1886. end;
  1888. procedure TGUITestRunner.Next1Click(Sender: TObject);
  1889. begin
  1890.   GoToNextSelectedTestActionExecute(Self);
  1891.   TestCasePropertiesActionExecute(self);
  1892. end;
  1894. procedure TGUITestRunner.TestCasePropertiesMeasureItem(Sender: TObject;
  1895.   ACanvas: TCanvas; var Width, Height: Integer);
  1896. var
  1897.   ImageSize: TSize;
  1898. begin
  1899.   ACanvas.Font.Name := 'Courier New';
  1900.   ACanvas.Font.Size := 8;
  1901.   if GetTextExtentPoint32(ACanvas.Handle,
  1902.                           {PChar}(FNoChecksStr),
  1903.                           Length(FNoChecksStr),
  1904.                           ImageSize) then
  1905.   Width  := ImageSize.cx + 20;
  1906.   Height := ImageSize.cy + 4;
  1907. end;
  1909. procedure TGUITestRunner.MenuLooksInactive(ACanvas: TCanvas;
  1910.                                            ARect: TRect;
  1911.                                            Selected: Boolean;
  1912.                                            Title: string;
  1913.                                            TitlePosn: UINT;
  1914.                                            PtyOveridesGUI: boolean);
  1915. begin
  1916.   ACanvas.Font.Name := 'Courier New';
  1917.   ACanvas.Font.Size := 8;
  1918.   if Selected then
  1919.     ACanvas.Font.Color := clBlack;
  1920.   if PtyOveridesGUI then
  1921.     ACanvas.Brush.Color := clYellow
  1922.   else
  1923.     ACanvas.Brush.Color := TColor($C0FCC0);  //Sort of Moneygreen
  1924.   ACanvas.FillRect(ARect);
  1925.   DrawText(ACanvas.Handle,
  1926.            {PChar}(Title),
  1927.            Length(Title),
  1928.            ARect,
  1929.            DT_VCENTER or DT_SINGLELINE or DT_NOCLIP or DT_NOPREFIX or TitlePosn);
  1930. end;
  1932. procedure TGUITestRunner.MenuLooksActive(ACanvas: TCanvas;
  1933.                                          ARect: TRect;
  1934.                                          Selected: Boolean;
  1935.                                          Title: string;
  1936.                                          TitlePosn: UINT);
  1937. begin
  1938.   ACanvas.Font.Name := 'Courier New';
  1939.   ACanvas.Font.Size := 8;
  1940.   ACanvas.FillRect(ARect);
  1941.   DrawText(ACanvas.Handle,
  1942.            {PChar}(Title),
  1943.            Length(Title),
  1944.            ARect,
  1945.            DT_VCENTER or DT_SINGLELINE or DT_NOCLIP or DT_NOPREFIX or TitlePosn);
  1946. end;
  1948. procedure TGUITestRunner.TestCasePropertiesDrawItem(Sender: TObject;
  1949.   ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  1950. begin
  1951.   MenuLooksInactive(ACanvas, ARect, Selected, PopupTitle, DT_CENTER, False);
  1952. end;
  1954. procedure TGUITestRunner.Previous1DrawItem(Sender: TObject;
  1955.   ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  1956. begin
  1957.   MenuLooksActive(ACanvas, ARect, Selected, PopupPrevious, DT_LEFT);
  1958. end;
  1960. procedure TGUITestRunner.RunSelectedTest1DrawItem(Sender: TObject;
  1961.   ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  1962. begin
  1963.   MenuLooksActive(ACanvas, ARect, Selected, PopupRun, DT_LEFT);
  1964. end;
  1966. procedure TGUITestRunner.Next1DrawItem(Sender: TObject; ACanvas: TCanvas;
  1967.   ARect: TRect; Selected: Boolean);
  1968. begin
  1969.   MenuLooksActive(ACanvas, ARect, Selected, PopupNext, DT_LEFT);
  1970. end;
  1972. procedure TGUITestRunner.FailNoCheckExecutedMenuItemDrawItem(
  1973.   Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean);
  1974. begin
  1975.   MenuLooksInactive(ACanvas, ARect, Selected, FNoChecksStr,
  1976.     DT_LEFT, fNoCheckExecutedPtyOverridden);
  1977. end;
  1979. procedure TGUITestRunner.pmTestTreePopup(Sender: TObject);
  1980. var
  1981.   aNode: TTreeNode;
  1982.   ATest: ITest;
  1984. begin
  1985.   if TestTree.Selected <> nil then
  1986.   begin
  1987.     aNode := TestTree.Selected;
  1988.     if (aNode <> nil) then
  1989.     begin
  1990.       ATest := NodeToTest(ANode);
  1991.       TestCasePopup.Enabled := IsTestMethod(ATest);
  1992.     end;
  1993.     ATest := nil;
  1994.   end;
  1995. end;
  1997. function TGUITestRunner.GetPropertyName(const Caption: string): string;
  1998. var
  1999.   TempStr: string;
  2000.   PosSpace: integer;
  2001. begin
  2002.   TempStr := Trim(Caption);
  2003.   PosSpace := Pos(' ',TempStr);
  2004.   if (PosSpace > 1)  then
  2005.     result := Copy(TempStr, 1, PosSpace-1);
  2006. end;
  2008. procedure TGUITestRunner.FailNoCheckExecutedMenuItemClick(Sender: TObject);
  2009. begin
  2010.   Clipboard.AsText := GetPropertyName(NoChecksStrT);
  2011. end;
  2013. procedure TGUITestRunner.RunSelectedTestAltActionExecute(Sender: TObject);
  2014. begin
  2015.   RunSelectedTestActionExecute(Self);
  2016.   TestCasePropertiesActionExecute(Self);
  2017. end;
  2019. end.