├── .gitignore ├── CodeCoverage ├── CodeCoverage.zip └── Readme.txt ├── README.md ├── Sample ├── ProjectGroup.groupproj ├── TestProject │ ├── Bin │ │ ├── dcov_execute.bat │ │ ├── dcov_paths.lst │ │ └── dcov_units.lst │ ├── Source │ │ └── Model │ │ │ └── Model.Calculator.Test.pas │ ├── TestProject.dpr │ └── TestProject.dproj └── VCLProject │ ├── FMain.dfm │ ├── FMain.pas │ ├── Source │ └── Model │ │ ├── Model.Calculator.pas │ │ └── Model.Formatter.pas │ ├── VCLProject.dpr │ └── VCLProject.dproj └── Source ├── Library ├── CCE.DLL.Registry.pas ├── CodeCoverageExperts.dpr └── CodeCoverageExperts.dproj ├── Package ├── CCE.Pkg.Registry.pas ├── CodeCoverageExperts.dpk └── CodeCoverageExperts.dproj └── Src ├── Core ├── CCE.Constants.pas ├── CCE.Core.CodeCoverage.pas ├── CCE.Core.Interfaces.pas ├── CCE.Core.Project.pas ├── CCE.Core.Utils.pas └── CCE.Helpers.TreeView.pas ├── IDE ├── CCE.ContextMenu.pas ├── CCE.Wizard.Forms.dfm └── CCE.Wizard.Forms.pas └── Third ├── CCE.dpipes.pas ├── CCE.dprocess.pas ├── CCE.pipes_win.inc └── CCE.process_win.inc /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | 48 | # Delphi autogenerated files (duplicated info) 49 | *.cfg 50 | *.hpp 51 | *Resource.rc 52 | 53 | # Delphi local files (user-specific info) 54 | *.local 55 | *.identcache 56 | *.projdata 57 | *.tvsconfig 58 | *.dsk 59 | 60 | # Delphi history and backups 61 | __history/ 62 | __recovery/ 63 | *.~* 64 | 65 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 66 | *.stat 67 | 68 | # Boss dependency manager vendor folder https://github.com/HashLoad/boss 69 | modules/ 70 | *.res 71 | *.log 72 | Sample/TestProject/Bin/report/ 73 | Sample/TestProject/Bin/dunitx-results.xml 74 | -------------------------------------------------------------------------------- /CodeCoverage/CodeCoverage.zip: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gabrielbaltazar/code-coverage-experts/977324a2bbe60b0cd32d27da6bb80576d45d01a0/CodeCoverage/CodeCoverage.zip -------------------------------------------------------------------------------- /CodeCoverage/Readme.txt: -------------------------------------------------------------------------------- 1 | https://github.com/DelphiCodeCoverage/DelphiCodeCoverage/releases/download/1.0.15/DelphiCodeCoverage_1_0_15.zip -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Code Coverage Experts 2 | ### Wizard to configure CodeCoverage in Delphi Test Projects 3 | 4 | ## ⚙️ Settings 5 | 6 | - Set the exe and map test project filename and the report output directory. 7 | 8 | ![image](https://github.com/gabrielbaltazar/code-coverage-experts/assets/9014016/5a652c28-b5d8-4199-b6d6-568990190232) 9 | 10 | - Inform the units that the code coverage project will cover 11 | 12 | ![image](https://github.com/gabrielbaltazar/code-coverage-experts/assets/9014016/20a65b84-eb49-4f4b-a29c-119c396223f7) 13 | -------------------------------------------------------------------------------- /Sample/ProjectGroup.groupproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {60878318-6802-4DD9-B2BC-83C66C91BFB1} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | Default.Personality.12 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | -------------------------------------------------------------------------------- /Sample/TestProject/Bin/dcov_execute.bat: -------------------------------------------------------------------------------- 1 | "CodeCoverage.exe" -e ".\TestProject.exe" -m ".\TestProject.map" -uf ".\dcov_units.lst" -spf ".\dcov_paths.lst" -od ".\report" -lt -html -xml 2 | -------------------------------------------------------------------------------- /Sample/TestProject/Bin/dcov_paths.lst: -------------------------------------------------------------------------------- 1 | ..\..\VCLProject\Source\Model\ 2 | -------------------------------------------------------------------------------- /Sample/TestProject/Bin/dcov_units.lst: -------------------------------------------------------------------------------- 1 | Model.Calculator.pas 2 | Model.Formatter.pas 3 | -------------------------------------------------------------------------------- /Sample/TestProject/Source/Model/Model.Calculator.Test.pas: -------------------------------------------------------------------------------- 1 | unit Model.Calculator.Test; 2 | 3 | interface 4 | 5 | uses 6 | DUnitX.TestFramework, 7 | Model.Calculator, 8 | System.SysUtils; 9 | 10 | type 11 | [TestFixture] 12 | TCalculatorTest = class 13 | private 14 | FCalculator: TCalculator; 15 | FResult: Double; 16 | public 17 | [Setup] 18 | procedure Setup; 19 | 20 | [TearDown] 21 | procedure TearDown; 22 | 23 | [Test] 24 | procedure Sum; 25 | 26 | [Test] 27 | procedure Subtract; 28 | end; 29 | 30 | implementation 31 | 32 | procedure TCalculatorTest.Setup; 33 | begin 34 | FCalculator := TCalculator.Create; 35 | FResult := 0; 36 | end; 37 | 38 | procedure TCalculatorTest.Subtract; 39 | begin 40 | FResult := FCalculator.Subtract(10, 5); 41 | Assert.AreEqual(5, FResult); 42 | end; 43 | 44 | procedure TCalculatorTest.Sum; 45 | begin 46 | FResult := FCalculator.Sum(10, 5); 47 | Assert.AreEqual(15, FResult); 48 | end; 49 | 50 | procedure TCalculatorTest.TearDown; 51 | begin 52 | FCalculator.Free; 53 | end; 54 | 55 | end. 56 | -------------------------------------------------------------------------------- /Sample/TestProject/TestProject.dpr: -------------------------------------------------------------------------------- 1 | program TestProject; 2 | 3 | {$IFNDEF TESTINSIGHT} 4 | {$APPTYPE CONSOLE} 5 | {$ENDIF} 6 | {$STRONGLINKTYPES ON} 7 | uses 8 | System.SysUtils, 9 | {$IFDEF TESTINSIGHT} 10 | TestInsight.DUnitX, 11 | {$ELSE} 12 | DUnitX.Loggers.Console, 13 | DUnitX.Loggers.Xml.NUnit, 14 | {$ENDIF } 15 | DUnitX.TestFramework, 16 | Model.Calculator, 17 | Model.Formatter, 18 | Model.Calculator.Test in 'Source\Model\Model.Calculator.Test.pas'; 19 | 20 | { keep comment here to protect the following conditional from being removed by the IDE when adding a unit } 21 | {$IFNDEF TESTINSIGHT} 22 | var 23 | runner: ITestRunner; 24 | results: IRunResults; 25 | logger: ITestLogger; 26 | nunitLogger : ITestLogger; 27 | {$ENDIF} 28 | begin 29 | {$IFDEF TESTINSIGHT} 30 | TestInsight.DUnitX.RunRegisteredTests; 31 | {$ELSE} 32 | try 33 | //Check command line options, will exit if invalid 34 | TDUnitX.CheckCommandLine; 35 | //Create the test runner 36 | runner := TDUnitX.CreateRunner; 37 | //Tell the runner to use RTTI to find Fixtures 38 | runner.UseRTTI := True; 39 | //When true, Assertions must be made during tests; 40 | runner.FailsOnNoAsserts := False; 41 | 42 | //tell the runner how we will log things 43 | //Log to the console window if desired 44 | if TDUnitX.Options.ConsoleMode <> TDunitXConsoleMode.Off then 45 | begin 46 | logger := TDUnitXConsoleLogger.Create(TDUnitX.Options.ConsoleMode = TDunitXConsoleMode.Quiet); 47 | runner.AddLogger(logger); 48 | end; 49 | //Generate an NUnit compatible XML File 50 | nunitLogger := TDUnitXXMLNUnitFileLogger.Create(TDUnitX.Options.XMLOutputFile); 51 | runner.AddLogger(nunitLogger); 52 | 53 | //Run tests 54 | results := runner.Execute; 55 | if not results.AllPassed then 56 | System.ExitCode := EXIT_ERRORS; 57 | 58 | System.Write('Done.. press key to quit.'); 59 | System.Readln; 60 | except 61 | on E: Exception do 62 | System.Writeln(E.ClassName, ': ', E.Message); 63 | end; 64 | {$ENDIF} 65 | end. 66 | -------------------------------------------------------------------------------- /Sample/VCLProject/FMain.dfm: -------------------------------------------------------------------------------- 1 | object FrmMain: TFrmMain 2 | Left = 0 3 | Top = 0 4 | BorderStyle = bsDialog 5 | Caption = 'VCL Project' 6 | ClientHeight = 409 7 | ClientWidth = 715 8 | Color = clBtnFace 9 | Font.Charset = DEFAULT_CHARSET 10 | Font.Color = clWindowText 11 | Font.Height = -16 12 | Font.Name = 'Segoe UI' 13 | Font.Style = [] 14 | Position = poScreenCenter 15 | TextHeight = 21 16 | object Label1: TLabel 17 | Left = 48 18 | Top = 72 19 | Width = 71 20 | Height = 21 21 | Caption = 'Number 1' 22 | end 23 | object Label2: TLabel 24 | Left = 216 25 | Top = 72 26 | Width = 71 27 | Height = 21 28 | Caption = 'Number 2' 29 | end 30 | object Label3: TLabel 31 | Left = 48 32 | Top = 200 33 | Width = 43 34 | Height = 21 35 | Caption = 'Result' 36 | end 37 | object Label4: TLabel 38 | Left = 48 39 | Top = 328 40 | Width = 26 41 | Height = 21 42 | Caption = 'Text' 43 | end 44 | object Label5: TLabel 45 | Left = 424 46 | Top = 328 47 | Width = 43 48 | Height = 21 49 | Caption = 'Result' 50 | end 51 | object EdtNumber1: TEdit 52 | Left = 48 53 | Top = 95 54 | Width = 145 55 | Height = 29 56 | NumbersOnly = True 57 | TabOrder = 0 58 | end 59 | object EdtNumber2: TEdit 60 | Left = 216 61 | Top = 95 62 | Width = 145 63 | Height = 29 64 | NumbersOnly = True 65 | TabOrder = 1 66 | end 67 | object EdtResult: TEdit 68 | Left = 48 69 | Top = 223 70 | Width = 145 71 | Height = 29 72 | NumbersOnly = True 73 | ReadOnly = True 74 | TabOrder = 2 75 | end 76 | object BtnSum: TButton 77 | Left = 48 78 | Top = 152 79 | Width = 105 80 | Height = 25 81 | Caption = 'Sum' 82 | TabOrder = 3 83 | OnClick = BtnSumClick 84 | end 85 | object BtnSubtract: TButton 86 | Left = 176 87 | Top = 152 88 | Width = 105 89 | Height = 25 90 | Caption = 'Subtract' 91 | TabOrder = 4 92 | OnClick = BtnSubtractClick 93 | end 94 | object EdtText: TEdit 95 | Left = 48 96 | Top = 351 97 | Width = 233 98 | Height = 29 99 | TabOrder = 5 100 | end 101 | object BtnOnlyNumber: TButton 102 | Left = 287 103 | Top = 353 104 | Width = 105 105 | Height = 25 106 | Caption = 'Only Number' 107 | TabOrder = 6 108 | OnClick = BtnOnlyNumberClick 109 | end 110 | object EdtResultOnlyNumber: TEdit 111 | Left = 424 112 | Top = 351 113 | Width = 145 114 | Height = 29 115 | ReadOnly = True 116 | TabOrder = 7 117 | end 118 | end 119 | -------------------------------------------------------------------------------- /Sample/VCLProject/FMain.pas: -------------------------------------------------------------------------------- 1 | unit FMain; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, 8 | Model.Calculator, 9 | Model.Formatter; 10 | 11 | type 12 | TFrmMain = class(TForm) 13 | Label1: TLabel; 14 | EdtNumber1: TEdit; 15 | EdtNumber2: TEdit; 16 | Label2: TLabel; 17 | EdtResult: TEdit; 18 | Label3: TLabel; 19 | BtnSum: TButton; 20 | BtnSubtract: TButton; 21 | Label4: TLabel; 22 | EdtText: TEdit; 23 | BtnOnlyNumber: TButton; 24 | Label5: TLabel; 25 | EdtResultOnlyNumber: TEdit; 26 | procedure BtnSumClick(Sender: TObject); 27 | procedure BtnSubtractClick(Sender: TObject); 28 | procedure BtnOnlyNumberClick(Sender: TObject); 29 | private 30 | FCalculator: TCalculator; 31 | FFormatter: TFormatter; 32 | { Private declarations } 33 | public 34 | constructor Create(AOwner: TComponent); override; 35 | destructor Destroy; override; 36 | { Public declarations } 37 | end; 38 | 39 | var 40 | FrmMain: TFrmMain; 41 | 42 | implementation 43 | 44 | {$R *.dfm} 45 | 46 | procedure TFrmMain.BtnOnlyNumberClick(Sender: TObject); 47 | var 48 | LResult: string; 49 | begin 50 | LResult := FFormatter.OnlyNumbers(EdtText.Text); 51 | EdtResultOnlyNumber.Text := LResult; 52 | end; 53 | 54 | procedure TFrmMain.BtnSubtractClick(Sender: TObject); 55 | var 56 | LNum1: Double; 57 | LNum2: Double; 58 | LResult: Double; 59 | begin 60 | LNum1 := StrToFloatDef(EdtNumber1.Text, 0); 61 | LNum2 := StrToFloatDef(EdtNumber2.Text, 0); 62 | LResult := FCalculator.Subtract(LNum1, LNum2); 63 | EdtResult.Text := LResult.ToString; 64 | end; 65 | 66 | procedure TFrmMain.BtnSumClick(Sender: TObject); 67 | var 68 | LNum1: Double; 69 | LNum2: Double; 70 | LResult: Double; 71 | begin 72 | LNum1 := StrToFloatDef(EdtNumber1.Text, 0); 73 | LNum2 := StrToFloatDef(EdtNumber2.Text, 0); 74 | LResult := FCalculator.Sum(LNum1, LNum2); 75 | EdtResult.Text := LResult.ToString; 76 | end; 77 | 78 | constructor TFrmMain.Create(AOwner: TComponent); 79 | begin 80 | inherited; 81 | FCalculator := TCalculator.Create; 82 | FFormatter := TFormatter.Create; 83 | end; 84 | 85 | destructor TFrmMain.Destroy; 86 | begin 87 | FCalculator.Free; 88 | FFormatter.Free; 89 | inherited; 90 | end; 91 | 92 | end. 93 | -------------------------------------------------------------------------------- /Sample/VCLProject/Source/Model/Model.Calculator.pas: -------------------------------------------------------------------------------- 1 | unit Model.Calculator; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | System.StrUtils; 8 | 9 | type 10 | TCalculator = class 11 | public 12 | function Sum(ANum1, ANum2: Double): Double; 13 | function Subtract(ANum1, ANum2: Double): Double; 14 | function Multiply(ANum1, ANum2: Double): Double; 15 | end; 16 | 17 | implementation 18 | 19 | { TCalculator } 20 | 21 | function TCalculator.Multiply(ANum1, ANum2: Double): Double; 22 | begin 23 | Result := ANum1 * ANum2; 24 | end; 25 | 26 | function TCalculator.Subtract(ANum1, ANum2: Double): Double; 27 | begin 28 | Result := ANum1 - ANum2; 29 | end; 30 | 31 | function TCalculator.Sum(ANum1, ANum2: Double): Double; 32 | begin 33 | Result := ANum1 + ANum2; 34 | end; 35 | 36 | end. 37 | -------------------------------------------------------------------------------- /Sample/VCLProject/Source/Model/Model.Formatter.pas: -------------------------------------------------------------------------------- 1 | unit Model.Formatter; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | System.StrUtils; 8 | 9 | type 10 | TFormatter = class 11 | public 12 | function OnlyNumbers(const AText: string): string; 13 | end; 14 | 15 | implementation 16 | 17 | { TFormatter } 18 | 19 | function TFormatter.OnlyNumbers(const AText: string): string; 20 | var 21 | I: Integer; 22 | begin 23 | Result := EmptyStr; 24 | for I := 1 to AText.Length do 25 | begin 26 | if AText[I] in ['0'..'9'] then 27 | Result := Result + AText[I]; 28 | end; 29 | end; 30 | 31 | end. 32 | -------------------------------------------------------------------------------- /Sample/VCLProject/VCLProject.dpr: -------------------------------------------------------------------------------- 1 | program VCLProject; 2 | 3 | uses 4 | Vcl.Forms, 5 | FMain in 'FMain.pas' {FrmMain}, 6 | Model.Calculator in 'Source\Model\Model.Calculator.pas', 7 | Model.Formatter in 'Source\Model\Model.Formatter.pas'; 8 | 9 | {$R *.res} 10 | 11 | begin 12 | Application.Initialize; 13 | Application.MainFormOnTaskbar := True; 14 | Application.CreateForm(TFrmMain, FrmMain); 15 | Application.Run; 16 | end. 17 | -------------------------------------------------------------------------------- /Sample/VCLProject/VCLProject.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {90EA3A85-0639-43EC-832E-4818F685512F} 4 | 19.5 5 | VCL 6 | True 7 | Debug 8 | Win32 9 | 1 10 | Application 11 | VCLProject.dpr 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | Base 29 | true 30 | 31 | 32 | true 33 | Cfg_1 34 | true 35 | true 36 | 37 | 38 | true 39 | Base 40 | true 41 | 42 | 43 | true 44 | Cfg_2 45 | true 46 | true 47 | 48 | 49 | .\$(Platform)\$(Config) 50 | .\$(Platform)\$(Config) 51 | false 52 | false 53 | false 54 | false 55 | false 56 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) 57 | $(BDS)\bin\delphi_PROJECTICON.ico 58 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png 59 | $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png 60 | VCLProject 61 | 62 | 63 | dxPSdxSpreadSheetLnkRS28;vclwinx;DataSnapServer;dacvcl280;fmx;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;DBXMSSQLDriver;FireDACCommonODBC;emsclient;cxExportRS28;dxHttpIndyRequestRS28;appanalytics;IndyProtocols;vclx;dxPSPrVwRibbonRS28;dxTileControlRS28;dbxcds;vcledge;dxPSdxDBOCLnkRS28;Skia.Package.RTL;cxPivotGridOLAPRS28;CodeCoverageExperts;dxGDIPlusRS28;DBXFirebirdDriver;dxCoreRS28;cxPivotGridRS28;StyleControls_d11Alexandria;dxPSCoreRS28;FireDACSqliteDriver;DbxClientDriver;dxSpreadSheetRS28;dxSkinsCoreRS28;soapmidas;dxBarRS28;dxADOServerModeRS28;dxWizardControlRS28;dbexpress;dacfmx280;inet;dxServerModeRS28;pgdacfmx280;vcltouch;cxTreeListRS28;dxBarDBNavRS28;FireDACDBXDriver;fmxdae;dxPScxCommonRS28;dxNavBarRS28;CustomIPTransport;FireDACMSSQLDriver;dxSpreadSheetReportDesignerRS28;dxFireDACEMFRS28;dxComnRS28;dxFlowChartDesignerRS28;IndySystem;cxVerticalGridRS28;dxmdsRS28;dxRichEditControlRS28;cxSchedulerGridRS28;dxPsPrVwAdvRS28;dxPScxSchedulerLnkRS28;dxPSdxOCLnkRS28;vclFireDAC;office2K;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;dxADOEMFRS28;dxRibbonCustomizationFormRS28;dxPSdxDBTVLnkRS28;bindcompdbx;dxGaugeControlRS28;rtl;FireDACMySQLDriver;dxDockingRS28;dxPDFViewerRS28;DBXSqliteDriver;dxBarExtItemsRS28;dxPSdxFCLnkRS28;dxorgcRS28;DBXSybaseASEDriver;dxSpreadSheetCoreConditionalFormattingDialogsRS28;Intraweb_15_D11;dxPSRichEditControlLnkRS28;vclimg;DataSnapFireDAC;inetdbxpress;FireDAC;xmlrtl;dsnap;pkgADRIFood;FireDACDb2Driver;cxSchedulerRibbonStyleEventEditorRS28;DBXOracleDriver;dxPScxTLLnkRS28;DBXInformixDriver;fmxobj;bindcompvclsmp;DataSnapNativeClient;dxFlowChartRS28;YxdUI;dxPScxPCProdRS28;DatasnapConnectorsFreePascal;pgdac280;emshosting;dxRichEditDocumentModelRS28;dxPSdxMapControlLnkRS28;cxGridEMFRS28;dxGanttControlRS28;dxPScxVGridLnkRS28;dxPScxPivotGridLnkRS28;FireDACCommonDriver;IndyIPClient;dac280;cxLibraryRS28;dxCloudServiceLibraryRS28;bindcompvclwinx;emsedge;bindcompfmx;dxPSdxPDFViewerLnkRS28;inetdb;dxSpreadSheetCoreRS28;cxSchedulerTreeBrowserRS28;FireDACASADriver;dxTabbedMDIRS28;vclactnband;fmxFireDAC;dxFireDACServerModeRS28;FireDACInfxDriver;DBXMySQLDriver;VclSmp;dxPSdxLCLnkRS28;DataSnapCommon;fmxase;dxdbtrRS28;DBXOdbcDriver;pgdacvcl280;dbrtl;FireDACOracleDriver;dxPSLnksRS28;Skia.Package.FMX;FireDACMSAccDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;dxChartControlRS28;vcldsnap;DBXInterBaseDriver;FireDACMongoDBDriver;dxSpreadSheetConditionalFormattingDialogsRS28;FireDACTDataDriver;Skia.Package.VCL;OTAHistoryProjectsPkg;dxOrgChartAdvancedCustomizeFormRS28;vcldb;dxDBXServerModeRS28;cxSchedulerRS28;dxRibbonRS28;dxFlowChartLayoutsRS28;dxPScxExtCommonRS28;dxdborRS28;dxRichEditControlCoreRS28;IWBootstrap4D11;bindcomp;dxPScxGridLnkRS28;IndyCore;RESTBackendComponents;cxPivotGridChartRS28;dxBarExtDBItemsRS28;dxRichEditCoreRS28;cxTreeListdxBarPopupMenuRS28;dxFlowChartAdvancedCustomizeFormRS28;FireDACADSDriver;RESTComponents;IndyIPServer;vcl;dsnapxml;adortl;dsnapcon;DataSnapClient;DataSnapProviderClient;cxSchedulerWebServiceStorageRS28;dxtrmdRS28;DBXDb2Driver;dxPSdxGaugeControlLnkRS28;cxGridRS28;dxSpellCheckerRS28;emsclientfiredac;FireDACPgDriver;FireDACDSDriver;tethering;dxMapControlRS28;crcontrols280;bindcompvcl;dxEMFRS28;CloudService;DBXSybaseASADriver;IWBootstrapD11;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) 64 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 65 | Debug 66 | true 67 | CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= 68 | 1033 69 | $(BDS)\bin\default_app.manifest 70 | 71 | 72 | dxPSdxSpreadSheetLnkRS28;vclwinx;DataSnapServer;fmx;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;DBXMSSQLDriver;FireDACCommonODBC;emsclient;cxExportRS28;dxHttpIndyRequestRS28;appanalytics;IndyProtocols;vclx;dxPSPrVwRibbonRS28;dxTileControlRS28;dbxcds;vcledge;dxPSdxDBOCLnkRS28;Skia.Package.RTL;cxPivotGridOLAPRS28;dxGDIPlusRS28;DBXFirebirdDriver;dxCoreRS28;cxPivotGridRS28;StyleControls_d11Alexandria;dxPSCoreRS28;FireDACSqliteDriver;DbxClientDriver;dxSpreadSheetRS28;dxSkinsCoreRS28;soapmidas;dxBarRS28;dxADOServerModeRS28;dxWizardControlRS28;dbexpress;inet;dxServerModeRS28;vcltouch;cxTreeListRS28;dxBarDBNavRS28;FireDACDBXDriver;fmxdae;dxPScxCommonRS28;dxNavBarRS28;CustomIPTransport;FireDACMSSQLDriver;dxSpreadSheetReportDesignerRS28;dxFireDACEMFRS28;dxComnRS28;dxFlowChartDesignerRS28;IndySystem;cxVerticalGridRS28;dxmdsRS28;dxRichEditControlRS28;cxSchedulerGridRS28;dxPsPrVwAdvRS28;dxPScxSchedulerLnkRS28;dxPSdxOCLnkRS28;vclFireDAC;office2K;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;dxADOEMFRS28;dxRibbonCustomizationFormRS28;dxPSdxDBTVLnkRS28;bindcompdbx;dxGaugeControlRS28;rtl;FireDACMySQLDriver;dxDockingRS28;dxPDFViewerRS28;DBXSqliteDriver;dxBarExtItemsRS28;dxPSdxFCLnkRS28;dxorgcRS28;DBXSybaseASEDriver;dxSpreadSheetCoreConditionalFormattingDialogsRS28;dxPSRichEditControlLnkRS28;vclimg;DataSnapFireDAC;inetdbxpress;FireDAC;xmlrtl;dsnap;pkgADRIFood;FireDACDb2Driver;cxSchedulerRibbonStyleEventEditorRS28;DBXOracleDriver;dxPScxTLLnkRS28;DBXInformixDriver;fmxobj;bindcompvclsmp;DataSnapNativeClient;dxFlowChartRS28;dxPScxPCProdRS28;DatasnapConnectorsFreePascal;emshosting;dxRichEditDocumentModelRS28;dxPSdxMapControlLnkRS28;cxGridEMFRS28;dxGanttControlRS28;dxPScxVGridLnkRS28;dxPScxPivotGridLnkRS28;FireDACCommonDriver;IndyIPClient;cxLibraryRS28;dxCloudServiceLibraryRS28;bindcompvclwinx;emsedge;bindcompfmx;dxPSdxPDFViewerLnkRS28;inetdb;dxSpreadSheetCoreRS28;cxSchedulerTreeBrowserRS28;FireDACASADriver;dxTabbedMDIRS28;vclactnband;fmxFireDAC;dxFireDACServerModeRS28;FireDACInfxDriver;DBXMySQLDriver;VclSmp;dxPSdxLCLnkRS28;DataSnapCommon;fmxase;dxdbtrRS28;DBXOdbcDriver;dbrtl;FireDACOracleDriver;dxPSLnksRS28;Skia.Package.FMX;FireDACMSAccDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;dxChartControlRS28;vcldsnap;DBXInterBaseDriver;FireDACMongoDBDriver;dxSpreadSheetConditionalFormattingDialogsRS28;FireDACTDataDriver;Skia.Package.VCL;dxOrgChartAdvancedCustomizeFormRS28;vcldb;dxDBXServerModeRS28;cxSchedulerRS28;dxRibbonRS28;dxFlowChartLayoutsRS28;dxPScxExtCommonRS28;dxdborRS28;dxRichEditControlCoreRS28;bindcomp;dxPScxGridLnkRS28;IndyCore;RESTBackendComponents;cxPivotGridChartRS28;dxBarExtDBItemsRS28;dxRichEditCoreRS28;cxTreeListdxBarPopupMenuRS28;dxFlowChartAdvancedCustomizeFormRS28;FireDACADSDriver;RESTComponents;IndyIPServer;vcl;dsnapxml;adortl;dsnapcon;DataSnapClient;DataSnapProviderClient;cxSchedulerWebServiceStorageRS28;dxtrmdRS28;DBXDb2Driver;dxPSdxGaugeControlLnkRS28;cxGridRS28;dxSpellCheckerRS28;emsclientfiredac;FireDACPgDriver;FireDACDSDriver;tethering;dxMapControlRS28;bindcompvcl;dxEMFRS28;CloudService;DBXSybaseASADriver;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage) 73 | 74 | 75 | DEBUG;$(DCC_Define) 76 | true 77 | false 78 | true 79 | true 80 | true 81 | true 82 | true 83 | 84 | 85 | false 86 | PerMonitorV2 87 | 88 | 89 | false 90 | RELEASE;$(DCC_Define) 91 | 0 92 | 0 93 | 94 | 95 | PerMonitorV2 96 | 97 | 98 | 99 | MainSource 100 | 101 | 102 |
FrmMain
103 | dfm 104 | 105 | 106 | 107 | 108 | Base 109 | 110 | 111 | Cfg_1 112 | Base 113 | 114 | 115 | Cfg_2 116 | Base 117 | 118 | 119 | 120 | Delphi.Personality.12 121 | Application 122 | 123 | 124 | 125 | VCLProject.dpr 126 | 127 | 128 | 129 | 130 | 131 | VCLProject.exe 132 | true 133 | 134 | 135 | 136 | 137 | 1 138 | 139 | 140 | Contents\MacOS 141 | 1 142 | 143 | 144 | 0 145 | 146 | 147 | 148 | 149 | classes 150 | 64 151 | 152 | 153 | classes 154 | 64 155 | 156 | 157 | 158 | 159 | res\xml 160 | 1 161 | 162 | 163 | res\xml 164 | 1 165 | 166 | 167 | 168 | 169 | library\lib\armeabi-v7a 170 | 1 171 | 172 | 173 | 174 | 175 | library\lib\armeabi 176 | 1 177 | 178 | 179 | library\lib\armeabi 180 | 1 181 | 182 | 183 | 184 | 185 | library\lib\armeabi-v7a 186 | 1 187 | 188 | 189 | 190 | 191 | library\lib\mips 192 | 1 193 | 194 | 195 | library\lib\mips 196 | 1 197 | 198 | 199 | 200 | 201 | library\lib\armeabi-v7a 202 | 1 203 | 204 | 205 | library\lib\arm64-v8a 206 | 1 207 | 208 | 209 | 210 | 211 | library\lib\armeabi-v7a 212 | 1 213 | 214 | 215 | 216 | 217 | res\drawable 218 | 1 219 | 220 | 221 | res\drawable 222 | 1 223 | 224 | 225 | 226 | 227 | res\values 228 | 1 229 | 230 | 231 | res\values 232 | 1 233 | 234 | 235 | 236 | 237 | res\values-v21 238 | 1 239 | 240 | 241 | res\values-v21 242 | 1 243 | 244 | 245 | 246 | 247 | res\values 248 | 1 249 | 250 | 251 | res\values 252 | 1 253 | 254 | 255 | 256 | 257 | res\drawable 258 | 1 259 | 260 | 261 | res\drawable 262 | 1 263 | 264 | 265 | 266 | 267 | res\drawable-xxhdpi 268 | 1 269 | 270 | 271 | res\drawable-xxhdpi 272 | 1 273 | 274 | 275 | 276 | 277 | res\drawable-xxxhdpi 278 | 1 279 | 280 | 281 | res\drawable-xxxhdpi 282 | 1 283 | 284 | 285 | 286 | 287 | res\drawable-ldpi 288 | 1 289 | 290 | 291 | res\drawable-ldpi 292 | 1 293 | 294 | 295 | 296 | 297 | res\drawable-mdpi 298 | 1 299 | 300 | 301 | res\drawable-mdpi 302 | 1 303 | 304 | 305 | 306 | 307 | res\drawable-hdpi 308 | 1 309 | 310 | 311 | res\drawable-hdpi 312 | 1 313 | 314 | 315 | 316 | 317 | res\drawable-xhdpi 318 | 1 319 | 320 | 321 | res\drawable-xhdpi 322 | 1 323 | 324 | 325 | 326 | 327 | res\drawable-mdpi 328 | 1 329 | 330 | 331 | res\drawable-mdpi 332 | 1 333 | 334 | 335 | 336 | 337 | res\drawable-hdpi 338 | 1 339 | 340 | 341 | res\drawable-hdpi 342 | 1 343 | 344 | 345 | 346 | 347 | res\drawable-xhdpi 348 | 1 349 | 350 | 351 | res\drawable-xhdpi 352 | 1 353 | 354 | 355 | 356 | 357 | res\drawable-xxhdpi 358 | 1 359 | 360 | 361 | res\drawable-xxhdpi 362 | 1 363 | 364 | 365 | 366 | 367 | res\drawable-xxxhdpi 368 | 1 369 | 370 | 371 | res\drawable-xxxhdpi 372 | 1 373 | 374 | 375 | 376 | 377 | res\drawable-small 378 | 1 379 | 380 | 381 | res\drawable-small 382 | 1 383 | 384 | 385 | 386 | 387 | res\drawable-normal 388 | 1 389 | 390 | 391 | res\drawable-normal 392 | 1 393 | 394 | 395 | 396 | 397 | res\drawable-large 398 | 1 399 | 400 | 401 | res\drawable-large 402 | 1 403 | 404 | 405 | 406 | 407 | res\drawable-xlarge 408 | 1 409 | 410 | 411 | res\drawable-xlarge 412 | 1 413 | 414 | 415 | 416 | 417 | res\values 418 | 1 419 | 420 | 421 | res\values 422 | 1 423 | 424 | 425 | 426 | 427 | 1 428 | 429 | 430 | Contents\MacOS 431 | 1 432 | 433 | 434 | 0 435 | 436 | 437 | 438 | 439 | Contents\MacOS 440 | 1 441 | .framework 442 | 443 | 444 | Contents\MacOS 445 | 1 446 | .framework 447 | 448 | 449 | Contents\MacOS 450 | 1 451 | .framework 452 | 453 | 454 | 0 455 | 456 | 457 | 458 | 459 | 1 460 | .dylib 461 | 462 | 463 | 1 464 | .dylib 465 | 466 | 467 | 1 468 | .dylib 469 | 470 | 471 | Contents\MacOS 472 | 1 473 | .dylib 474 | 475 | 476 | Contents\MacOS 477 | 1 478 | .dylib 479 | 480 | 481 | Contents\MacOS 482 | 1 483 | .dylib 484 | 485 | 486 | 0 487 | .dll;.bpl 488 | 489 | 490 | 491 | 492 | 1 493 | .dylib 494 | 495 | 496 | 1 497 | .dylib 498 | 499 | 500 | 1 501 | .dylib 502 | 503 | 504 | Contents\MacOS 505 | 1 506 | .dylib 507 | 508 | 509 | Contents\MacOS 510 | 1 511 | .dylib 512 | 513 | 514 | Contents\MacOS 515 | 1 516 | .dylib 517 | 518 | 519 | 0 520 | .bpl 521 | 522 | 523 | 524 | 525 | 0 526 | 527 | 528 | 0 529 | 530 | 531 | 0 532 | 533 | 534 | 0 535 | 536 | 537 | 0 538 | 539 | 540 | Contents\Resources\StartUp\ 541 | 0 542 | 543 | 544 | Contents\Resources\StartUp\ 545 | 0 546 | 547 | 548 | Contents\Resources\StartUp\ 549 | 0 550 | 551 | 552 | 0 553 | 554 | 555 | 556 | 557 | 1 558 | 559 | 560 | 1 561 | 562 | 563 | 564 | 565 | ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 566 | 1 567 | 568 | 569 | ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 570 | 1 571 | 572 | 573 | 574 | 575 | ..\ 576 | 1 577 | 578 | 579 | ..\ 580 | 1 581 | 582 | 583 | ..\ 584 | 1 585 | 586 | 587 | 588 | 589 | Contents 590 | 1 591 | 592 | 593 | Contents 594 | 1 595 | 596 | 597 | Contents 598 | 1 599 | 600 | 601 | 602 | 603 | Contents\Resources 604 | 1 605 | 606 | 607 | Contents\Resources 608 | 1 609 | 610 | 611 | Contents\Resources 612 | 1 613 | 614 | 615 | 616 | 617 | library\lib\armeabi-v7a 618 | 1 619 | 620 | 621 | library\lib\arm64-v8a 622 | 1 623 | 624 | 625 | 1 626 | 627 | 628 | 1 629 | 630 | 631 | 1 632 | 633 | 634 | 1 635 | 636 | 637 | Contents\MacOS 638 | 1 639 | 640 | 641 | Contents\MacOS 642 | 1 643 | 644 | 645 | Contents\MacOS 646 | 1 647 | 648 | 649 | 0 650 | 651 | 652 | 653 | 654 | library\lib\armeabi-v7a 655 | 1 656 | 657 | 658 | 659 | 660 | 1 661 | 662 | 663 | 1 664 | 665 | 666 | 667 | 668 | ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 669 | 1 670 | 671 | 672 | ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 673 | 1 674 | 675 | 676 | ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 677 | 1 678 | 679 | 680 | 681 | 682 | ..\ 683 | 1 684 | 685 | 686 | ..\ 687 | 1 688 | 689 | 690 | ..\ 691 | 1 692 | 693 | 694 | 695 | 696 | 1 697 | 698 | 699 | 1 700 | 701 | 702 | 1 703 | 704 | 705 | 706 | 707 | ..\$(PROJECTNAME).launchscreen 708 | 64 709 | 710 | 711 | ..\$(PROJECTNAME).launchscreen 712 | 64 713 | 714 | 715 | 716 | 717 | 1 718 | 719 | 720 | 1 721 | 722 | 723 | 1 724 | 725 | 726 | 727 | 728 | Assets 729 | 1 730 | 731 | 732 | Assets 733 | 1 734 | 735 | 736 | 737 | 738 | Assets 739 | 1 740 | 741 | 742 | Assets 743 | 1 744 | 745 | 746 | 747 | 748 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 749 | 1 750 | 751 | 752 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 753 | 1 754 | 755 | 756 | 757 | 758 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 759 | 1 760 | 761 | 762 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 763 | 1 764 | 765 | 766 | 767 | 768 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 769 | 1 770 | 771 | 772 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 773 | 1 774 | 775 | 776 | 777 | 778 | ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 779 | 1 780 | 781 | 782 | ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 783 | 1 784 | 785 | 786 | 787 | 788 | ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 789 | 1 790 | 791 | 792 | ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 793 | 1 794 | 795 | 796 | 797 | 798 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 799 | 1 800 | 801 | 802 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 803 | 1 804 | 805 | 806 | 807 | 808 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 809 | 1 810 | 811 | 812 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 813 | 1 814 | 815 | 816 | 817 | 818 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 819 | 1 820 | 821 | 822 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 823 | 1 824 | 825 | 826 | 827 | 828 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 829 | 1 830 | 831 | 832 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 833 | 1 834 | 835 | 836 | 837 | 838 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 839 | 1 840 | 841 | 842 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 843 | 1 844 | 845 | 846 | 847 | 848 | ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 849 | 1 850 | 851 | 852 | ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 853 | 1 854 | 855 | 856 | 857 | 858 | ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 859 | 1 860 | 861 | 862 | ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 863 | 1 864 | 865 | 866 | 867 | 868 | ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 869 | 1 870 | 871 | 872 | ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 873 | 1 874 | 875 | 876 | 877 | 878 | ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 879 | 1 880 | 881 | 882 | ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 883 | 1 884 | 885 | 886 | 887 | 888 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 889 | 1 890 | 891 | 892 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 893 | 1 894 | 895 | 896 | 897 | 898 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 899 | 1 900 | 901 | 902 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 903 | 1 904 | 905 | 906 | 907 | 908 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 909 | 1 910 | 911 | 912 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 913 | 1 914 | 915 | 916 | 917 | 918 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 919 | 1 920 | 921 | 922 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 923 | 1 924 | 925 | 926 | 927 | 928 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 929 | 1 930 | 931 | 932 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 933 | 1 934 | 935 | 936 | 937 | 938 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 939 | 1 940 | 941 | 942 | ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 943 | 1 944 | 945 | 946 | 947 | 948 | 949 | 950 | 951 | 952 | 953 | 954 | 955 | 956 | 957 | 958 | 959 | True 960 | False 961 | 962 | 963 | 12 964 | 965 | 966 | 967 | 968 | 969 | -------------------------------------------------------------------------------- /Source/Library/CCE.DLL.Registry.pas: -------------------------------------------------------------------------------- 1 | unit CCE.DLL.Registry; 2 | 3 | interface 4 | 5 | uses 6 | ToolsAPI, 7 | CCE.ContextMenu; 8 | 9 | function RegisterCodeCoverageExperts(ABorlandIDEServices: IBorlandIDEServices; 10 | ARegisterProc: TWizardRegisterProc; 11 | var ATerminate: TWizardTerminateProc): Boolean; stdcall; 12 | 13 | implementation 14 | 15 | function RegisterCodeCoverageExperts(ABorlandIDEServices: IBorlandIDEServices; 16 | ARegisterProc: TWizardRegisterProc; 17 | var ATerminate: TWizardTerminateProc): Boolean; stdcall; 18 | begin 19 | Result := True; 20 | RegisterContextMenu; 21 | end; 22 | 23 | end. 24 | -------------------------------------------------------------------------------- /Source/Library/CodeCoverageExperts.dpr: -------------------------------------------------------------------------------- 1 | library CodeCoverageExperts; 2 | 3 | { Important note about DLL memory management: ShareMem must be the 4 | first unit in your library's USES clause AND your project's (select 5 | Project-View Source) USES clause if your DLL exports any procedures or 6 | functions that pass strings as parameters or function results. This 7 | applies to all strings passed to and from your DLL--even those that 8 | are nested in records and classes. ShareMem is the interface unit to 9 | the BORLNDMM.DLL shared memory manager, which must be deployed along 10 | with your DLL. To avoid using BORLNDMM.DLL, pass string information 11 | using PChar or ShortString parameters. } 12 | 13 | uses 14 | System.SysUtils, 15 | System.Classes, 16 | ToolsAPI, 17 | CCE.Constants in '..\Src\Core\CCE.Constants.pas', 18 | CCE.Core.CodeCoverage in '..\Src\Core\CCE.Core.CodeCoverage.pas', 19 | CCE.Core.Interfaces in '..\Src\Core\CCE.Core.Interfaces.pas', 20 | CCE.Core.Project in '..\Src\Core\CCE.Core.Project.pas', 21 | CCE.Core.Utils in '..\Src\Core\CCE.Core.Utils.pas', 22 | CCE.Helpers.TreeView in '..\Src\Core\CCE.Helpers.TreeView.pas', 23 | CCE.ContextMenu in '..\Src\IDE\CCE.ContextMenu.pas', 24 | CCE.Wizard.Forms in '..\Src\IDE\CCE.Wizard.Forms.pas' {CCEWizardForms}, 25 | CCE.dpipes in '..\Src\Third\CCE.dpipes.pas', 26 | CCE.dprocess in '..\Src\Third\CCE.dprocess.pas', 27 | CCE.DLL.Registry in 'CCE.DLL.Registry.pas'; 28 | 29 | exports 30 | RegisterCodeCoverageExperts Name WizardEntryPoint; 31 | 32 | {$R *.res} 33 | 34 | begin 35 | end. 36 | -------------------------------------------------------------------------------- /Source/Library/CodeCoverageExperts.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {FD6CA19B-027A-4D12-A7E4-96173478A19E} 4 | 18.4 5 | VCL 6 | CodeCoverageExperts.dpr 7 | True 8 | Release 9 | Win32 10 | 1 11 | Library 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | Base 29 | true 30 | 31 | 32 | true 33 | Base 34 | true 35 | 36 | 37 | true 38 | Base 39 | true 40 | 41 | 42 | true 43 | Cfg_1 44 | true 45 | true 46 | 47 | 48 | true 49 | Base 50 | true 51 | 52 | 53 | true 54 | Cfg_2 55 | true 56 | true 57 | 58 | 59 | .\$(Platform)\$(Config) 60 | .\$(Platform)\$(Config) 61 | false 62 | false 63 | false 64 | false 65 | false 66 | true 67 | designide;$(DCC_UsePackage) 68 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) 69 | CodeCoverageExperts 70 | true 71 | 1046 72 | CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= 73 | 74 | 75 | FireDACADSDriver;rbRCL1825;FireDACMSSQLDriver;dclRBE1825;rbUSER1825;ACBr_OFX;rbIDE1825;rbRTL1825;rbDIDE1825;ACBr_GTIN;bindengine;FireDACMySQLDriver;rbTCUI1825;DataSnapClient;rbRIDE1825;IndySystem;ACBr_PagFor;FireDACInfxDriver;rbTC1825;rbRAP1825;emshosting;rbBDE1825;rbTDBC1825;FireDACTDataDriver;DbxCommonDriver;xmlrtl;DataSnapNativeClient;rtl;DbxClientDriver;rbDBE1825;FireDACODBCDriver;DataSnapIndy10ServerTransport;ACBr_Boleto;FireDACMongoDBDriver;DataSnapServerMidas;rbADO1825;DatasnapConnectorsFreePascal;inetdb;emsedge;dbexpress;IndyCore;dsnap;DataSnapCommon;ACBr_NFSeX;DataSnapConnectors;rbUSERDesign1825;dclRBADO1825;FireDACOracleDriver;FireDACCommonODBC;FireDACDb2Driver;FireDACPgDriver;FireDACASADriver;rbDB1825;DataSnapServer;rbCIDE1825;CustomIPTransport;bindcomp;ACBr_NFSeXDanfseRL;dbxcds;dsnapxml;dbrtl;IndyProtocols;$(DCC_UsePackage) 76 | 77 | 78 | DBXSqliteDriver;tethering;FireDACMSSQLDriver;FireDACDBXDriver;bindengine;FireDACMySQLDriver;DataSnapClient;bindcompdbx;IndyIPServer;IndySystem;fmxFireDAC;emshosting;FireDACTDataDriver;FMXTee;DbxCommonDriver;xmlrtl;DataSnapNativeClient;fmxobj;rtl;DbxClientDriver;DBXSybaseASADriver;IndyIPClient;FireDACODBCDriver;DataSnapIndy10ServerTransport;DataSnapProviderClient;FireDACMongoDBDriver;DataSnapServerMidas;DBXInterBaseDriver;bindcompfmx;DBXOracleDriver;inetdb;FmxTeeUI;emsedge;fmx;fmxdae;dbexpress;IndyCore;dsnap;DataSnapCommon;FireDACOracleDriver;DBXMySQLDriver;DBXFirebirdDriver;FireDACCommonODBC;IndyIPCommon;FireDACPgDriver;ibmonitor;FireDACASADriver;ibxpress;DataSnapServer;ibxbindings;FireDACDSDriver;CustomIPTransport;bindcomp;DBXInformixDriver;dbxcds;dsnapxml;dbrtl;inetdbxpress;IndyProtocols;fmxase;$(DCC_UsePackage) 79 | 80 | 81 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 82 | Debug 83 | true 84 | (None) 85 | 1033 86 | 87 | 88 | DBXSqliteDriver;dxSpreadSheetCoreDialogsRS25;dxRibbonCustomizationFormRS25;DBXDb2Driver;dxPSPrVwRibbonRS25;BemaSQLXE;vclactnband;vclFireDAC;cxExportRS25;dxHttpIndyRequestRS25;tethering;dxPScxCommonRS25;FireDACADSDriver;cxPivotGridOLAPRS25;FireDACMSSQLDriver;cxSchedulerGridRS25;vcltouch;vcldb;Intraweb;TopGridXE;dxGaugeControlRS25;cxLibraryRS25;vclib;MultilizerDXE;CalWidgets;FireDACDBXDriver;vclx;BemaCompoXE;dxTileControlRS25;dxMapControlRS25;dxDockingRS25;VCLRESTComponents;cxPageControlRS25;dxPSLnksRS25;dxWizardControlRS25;vclie;bindengine;dxFireDACServerModeRS25;FireDACMySQLDriver;DataSnapClient;bindcompdbx;dxPSdxLCLnkRS25;DBXSybaseASEDriver;IndyIPServer;IndySystem;dsnapcon;dxLayoutControlRS25;FireDACMSAccDriver;fmxFireDAC;FireDACInfxDriver;vclimg;dxdbtrRS25;Jcl;dxPScxTLLnkRS25;emshosting;dxSpreadSheetRS25;DBXOdbcDriver;FireDACTDataDriver;FMXTee;ipstudiowinclient;cxGridRS25;DbxCommonDriver;dxPScxSchedulerLnkRS25;dxorgcRS25;BemaAddXE;xmlrtl;DataSnapNativeClient;fmxobj;dxPScxGridLnkRS25;rtl;DbxClientDriver;DBXSybaseASADriver;dxPSCoreRS25;dxmdsRS25;ipstudiowin;appanalytics;BemaPdvComposXE;IndyIPClient;bindcompvcl;dxThemeRS25;TeeUI;VclSmp;FireDACODBCDriver;JclVcl;DataSnapIndy10ServerTransport;DataSnapProviderClient;FireDACMongoDBDriver;cxVerticalGridRS25;dxADOServerModeRS25;DataSnapServerMidas;dxCoreRS25;cxSchedulerTreeBrowserRS25;BemaBaseCompoXE;DBXInterBaseDriver;dxPSTeeChartRS25;DBXMSSQLDriver;dxPSdxFCLnkRS25;DatasnapConnectorsFreePascal;BemaProxiesXE;bindcompfmx;DBXOracleDriver;inetdb;EpsonPF300;dxOfficeCoreRS25;FmxTeeUI;emsedge;fmx;fmxdae;dxPScxPivotGridLnkRS25;dxBarDBNavRS25;dxTabbedMDIRS25;ZipMasterR;dbexpress;IndyCore;dxFlowChartRS25;dsnap;DataSnapCommon;dxBarRS25;dxPSDBTeeChartRS25;dxdborRS25;DataSnapConnectors;dxPScxExtCommonRS25;cxPivotGridRS25;BemaUtilsXE;dxPSdxSpreadSheetLnkRS25;dxNavBarRS25;JclDeveloperTools;QR5RunNBDEDXE;cxSchedulerRibbonStyleEventEditorRS25;FireDACOracleDriver;DBXMySQLDriver;DBXFirebirdDriver;FireDACCommonODBC;cxTreeListRS25;IndyIPCommon;vcl;dxPScxVGridLnkRS25;dxBarExtItemsRS25;FireDACDb2Driver;dxComnRS25;dxPSdxDBTVLnkRS25;BemaToolBarXE;TeeDB;dxSpreadSheetCoreRS25;dxServerModeRS25;dxPScxPCProdRS25;FireDACPgDriver;ibmonitor;FireDACASADriver;cxEditorsRS25;ibxpress;Tee;DataSnapServer;ibxbindings;dxPsPrVwAdvRS25;vclwinx;FireDACDSDriver;fcstudiowin;cxDataRS25;cxTreeListdxBarPopupMenuRS25;CustomIPTransport;vcldsnap;dxPSdxOCLnkRS25;bindcomp;DBXInformixDriver;officeXPrt;cxPivotGridChartRS25;cxSchedulerRS25;dxBarExtDBItemsRS25;dxDBXServerModeRS25;dxGDIPlusRS25;dbxcds;adortl;dxPSdxDBOCLnkRS25;dxRibbonRS25;dsnapxml;dxSpellCheckerRS25;dbrtl;inetdbxpress;IndyProtocols;JclContainers;fmxase;$(DCC_UsePackage) 89 | 90 | 91 | DEBUG;$(DCC_Define) 92 | true 93 | false 94 | true 95 | true 96 | true 97 | 98 | 99 | false 100 | true 101 | 1033 102 | (None) 103 | 104 | 105 | false 106 | RELEASE;$(DCC_Define) 107 | 0 108 | 0 109 | 110 | 111 | true 112 | 1033 113 | 114 | 115 | 116 | MainSource 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 |
CCEWizardForms
127 | dfm 128 | 129 | 130 | 131 | 132 | 133 | Cfg_2 134 | Base 135 | 136 | 137 | Base 138 | 139 | 140 | Cfg_1 141 | Base 142 | 143 | 144 | 145 | Delphi.Personality.12 146 | Application 147 | 148 | 149 | 150 | CodeCoverageExperts.dpr 151 | 152 | 153 | File c:\program files (x86)\embarcadero\studio\19.0\bin\spdNFCe_D10T.bpl not found 154 | File c:\program files (x86)\embarcadero\studio\19.0\bin\spdNFCeGov_D10T.bpl not found 155 | ADRIFood 156 | Microsoft Office 2000 Sample Automation Server Wrapper Components 157 | 158 | 159 | 160 | 161 | 162 | true 163 | 164 | 165 | 166 | 167 | true 168 | 169 | 170 | 171 | 172 | true 173 | 174 | 175 | 176 | 177 | true 178 | 179 | 180 | 181 | 182 | CodeCoverageExperts.dll 183 | true 184 | 185 | 186 | 187 | 188 | 1 189 | 190 | 191 | Contents\MacOS 192 | 1 193 | 194 | 195 | Contents\MacOS 196 | 0 197 | 198 | 199 | 200 | 201 | classes 202 | 1 203 | 204 | 205 | 206 | 207 | library\lib\armeabi-v7a 208 | 1 209 | 210 | 211 | 212 | 213 | library\lib\armeabi 214 | 1 215 | 216 | 217 | 218 | 219 | library\lib\mips 220 | 1 221 | 222 | 223 | 224 | 225 | library\lib\armeabi-v7a 226 | 1 227 | 228 | 229 | 230 | 231 | res\drawable 232 | 1 233 | 234 | 235 | 236 | 237 | res\values 238 | 1 239 | 240 | 241 | 242 | 243 | res\drawable 244 | 1 245 | 246 | 247 | 248 | 249 | res\drawable-xxhdpi 250 | 1 251 | 252 | 253 | 254 | 255 | res\drawable-ldpi 256 | 1 257 | 258 | 259 | 260 | 261 | res\drawable-mdpi 262 | 1 263 | 264 | 265 | 266 | 267 | res\drawable-hdpi 268 | 1 269 | 270 | 271 | 272 | 273 | res\drawable-xhdpi 274 | 1 275 | 276 | 277 | 278 | 279 | res\drawable-small 280 | 1 281 | 282 | 283 | 284 | 285 | res\drawable-normal 286 | 1 287 | 288 | 289 | 290 | 291 | res\drawable-large 292 | 1 293 | 294 | 295 | 296 | 297 | res\drawable-xlarge 298 | 1 299 | 300 | 301 | 302 | 303 | 1 304 | 305 | 306 | Contents\MacOS 307 | 1 308 | 309 | 310 | 0 311 | 312 | 313 | 314 | 315 | Contents\MacOS 316 | 1 317 | .framework 318 | 319 | 320 | 0 321 | 322 | 323 | 324 | 325 | 1 326 | .dylib 327 | 328 | 329 | 1 330 | .dylib 331 | 332 | 333 | 1 334 | .dylib 335 | 336 | 337 | Contents\MacOS 338 | 1 339 | .dylib 340 | 341 | 342 | 0 343 | .dll;.bpl 344 | 345 | 346 | 347 | 348 | 1 349 | .dylib 350 | 351 | 352 | 1 353 | .dylib 354 | 355 | 356 | 1 357 | .dylib 358 | 359 | 360 | Contents\MacOS 361 | 1 362 | .dylib 363 | 364 | 365 | 0 366 | .bpl 367 | 368 | 369 | 370 | 371 | 0 372 | 373 | 374 | 0 375 | 376 | 377 | 0 378 | 379 | 380 | 0 381 | 382 | 383 | Contents\Resources\StartUp\ 384 | 0 385 | 386 | 387 | 0 388 | 389 | 390 | 391 | 392 | 1 393 | 394 | 395 | 1 396 | 397 | 398 | 1 399 | 400 | 401 | 402 | 403 | 1 404 | 405 | 406 | 1 407 | 408 | 409 | 1 410 | 411 | 412 | 413 | 414 | 1 415 | 416 | 417 | 1 418 | 419 | 420 | 1 421 | 422 | 423 | 424 | 425 | 1 426 | 427 | 428 | 1 429 | 430 | 431 | 1 432 | 433 | 434 | 435 | 436 | 1 437 | 438 | 439 | 1 440 | 441 | 442 | 1 443 | 444 | 445 | 446 | 447 | 1 448 | 449 | 450 | 1 451 | 452 | 453 | 1 454 | 455 | 456 | 457 | 458 | 1 459 | 460 | 461 | 1 462 | 463 | 464 | 1 465 | 466 | 467 | 468 | 469 | 1 470 | 471 | 472 | 473 | 474 | ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 475 | 1 476 | 477 | 478 | ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 479 | 1 480 | 481 | 482 | 483 | 484 | 1 485 | 486 | 487 | 1 488 | 489 | 490 | 491 | 492 | ..\ 493 | 1 494 | 495 | 496 | ..\ 497 | 1 498 | 499 | 500 | 501 | 502 | 1 503 | 504 | 505 | 1 506 | 507 | 508 | 1 509 | 510 | 511 | 512 | 513 | 1 514 | 515 | 516 | 1 517 | 518 | 519 | 1 520 | 521 | 522 | 523 | 524 | ..\ 525 | 1 526 | 527 | 528 | 529 | 530 | Contents 531 | 1 532 | 533 | 534 | 535 | 536 | Contents\Resources 537 | 1 538 | 539 | 540 | 541 | 542 | library\lib\armeabi-v7a 543 | 1 544 | 545 | 546 | 1 547 | 548 | 549 | 1 550 | 551 | 552 | 1 553 | 554 | 555 | 1 556 | 557 | 558 | Contents\MacOS 559 | 1 560 | 561 | 562 | 0 563 | 564 | 565 | 566 | 567 | 1 568 | 569 | 570 | 1 571 | 572 | 573 | 574 | 575 | Assets 576 | 1 577 | 578 | 579 | Assets 580 | 1 581 | 582 | 583 | 584 | 585 | Assets 586 | 1 587 | 588 | 589 | Assets 590 | 1 591 | 592 | 593 | 594 | 595 | 596 | 597 | 598 | 599 | 600 | 601 | 602 | 603 | False 604 | False 605 | True 606 | False 607 | 608 | 609 | 12 610 | 611 | 612 | 613 | 614 | 615 | -------------------------------------------------------------------------------- /Source/Package/CCE.Pkg.Registry.pas: -------------------------------------------------------------------------------- 1 | unit CCE.Pkg.Registry; 2 | 3 | interface 4 | 5 | uses 6 | ToolsAPI, 7 | CCE.ContextMenu; 8 | 9 | procedure Register; 10 | 11 | implementation 12 | 13 | procedure Register; 14 | begin 15 | RegisterContextMenu; 16 | end; 17 | 18 | end. 19 | -------------------------------------------------------------------------------- /Source/Package/CodeCoverageExperts.dpk: -------------------------------------------------------------------------------- 1 | package CodeCoverageExperts; 2 | 3 | {$R *.res} 4 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 5 | {$ALIGN 8} 6 | {$ASSERTIONS ON} 7 | {$BOOLEVAL OFF} 8 | {$DEBUGINFO OFF} 9 | {$EXTENDEDSYNTAX ON} 10 | {$IMPORTEDDATA ON} 11 | {$IOCHECKS ON} 12 | {$LOCALSYMBOLS OFF} 13 | {$LONGSTRINGS ON} 14 | {$OPENSTRINGS ON} 15 | {$OPTIMIZATION ON} 16 | {$OVERFLOWCHECKS OFF} 17 | {$RANGECHECKS OFF} 18 | {$REFERENCEINFO OFF} 19 | {$SAFEDIVIDE OFF} 20 | {$STACKFRAMES OFF} 21 | {$TYPEDADDRESS OFF} 22 | {$VARSTRINGCHECKS ON} 23 | {$WRITEABLECONST OFF} 24 | {$MINENUMSIZE 1} 25 | {$IMAGEBASE $400000} 26 | {$DEFINE RELEASE} 27 | {$DEFINE TESTINSIGHT} 28 | {$ENDIF IMPLICITBUILDING} 29 | {$DESCRIPTION 'Code Coverage Experts'} 30 | {$IMPLICITBUILD ON} 31 | 32 | requires 33 | rtl, 34 | designide; 35 | 36 | contains 37 | CCE.Constants in '..\Src\Core\CCE.Constants.pas', 38 | CCE.Core.CodeCoverage in '..\Src\Core\CCE.Core.CodeCoverage.pas', 39 | CCE.Core.Interfaces in '..\Src\Core\CCE.Core.Interfaces.pas', 40 | CCE.Core.Project in '..\Src\Core\CCE.Core.Project.pas', 41 | CCE.Core.Utils in '..\Src\Core\CCE.Core.Utils.pas', 42 | CCE.Helpers.TreeView in '..\Src\Core\CCE.Helpers.TreeView.pas', 43 | CCE.ContextMenu in '..\Src\IDE\CCE.ContextMenu.pas', 44 | CCE.Pkg.Registry in 'CCE.Pkg.Registry.pas', 45 | CCE.Wizard.Forms in '..\Src\IDE\CCE.Wizard.Forms.pas' {CCEWizardForms}, 46 | CCE.dpipes in '..\Src\Third\CCE.dpipes.pas', 47 | CCE.dprocess in '..\Src\Third\CCE.dprocess.pas'; 48 | 49 | end. 50 | -------------------------------------------------------------------------------- /Source/Src/Core/CCE.Constants.pas: -------------------------------------------------------------------------------- 1 | unit CCE.Constants; 2 | 3 | interface 4 | 5 | uses 6 | ToolsAPI; 7 | 8 | const 9 | CCE_COVERAGE_POSITION = pmmpUninstall + 200; 10 | CCE_COVERAGE_WIZARD_POSITION = CCE_COVERAGE_POSITION + 100; 11 | CCE_COVERAGE_EXECUTE_POSITION = CCE_COVERAGE_WIZARD_POSITION + 10; 12 | CCE_COVERAGE_HTML_POSITION = CCE_COVERAGE_EXECUTE_POSITION + 10; 13 | 14 | CCE_COVERAGE_CAPTION = 'Code Coverage'; 15 | CCE_COVERAGE_WIZARD_CAPTION = 'Wizard...'; 16 | CCE_COVERAGE_EXECUTE_CAPTION = 'Execute'; 17 | CCE_COVERAGE_HTML_CAPTION = 'Show HTML Report'; 18 | 19 | implementation 20 | 21 | end. 22 | -------------------------------------------------------------------------------- /Source/Src/Core/CCE.Core.CodeCoverage.pas: -------------------------------------------------------------------------------- 1 | unit CCE.Core.CodeCoverage; 2 | 3 | interface 4 | 5 | uses 6 | CCE.Core.Interfaces, 7 | CCE.Core.Utils, 8 | System.SysUtils, 9 | System.Classes, 10 | System.Generics.Collections, 11 | Winapi.Windows, 12 | Vcl.Dialogs; 13 | 14 | type 15 | TCCECoreCodeCoverage = class(TInterfacedObject, ICCECodeCoverage) 16 | private 17 | FCodeCoverageFileName: string; 18 | FExeFileName: string; 19 | FMapFileName: string; 20 | FOutputReport: string; 21 | FUnitsFiles: TList; 22 | FUnitsIgnore: TList; 23 | FPaths: TList; 24 | FGenerateHtml: Boolean; 25 | FGenerateXml: Boolean; 26 | FGenerateEmma: Boolean; 27 | FGenerateLog: Boolean; 28 | FUseRelativePath: Boolean; 29 | 30 | function FileToList(AFileName: string): TList; 31 | 32 | function FilePathsName: string; 33 | function FileUnitsName: string; 34 | function FileCodeCoverageBat: string; 35 | function CodeCoverageCommand: string; 36 | 37 | procedure GenerateFilePaths; 38 | procedure GenerateFileUnits; 39 | 40 | function GetExeName: string; 41 | function GetMapName: string; 42 | function GetOutputReport: string; 43 | function GetFileUnits: string; 44 | function GetFilePaths: string; 45 | function GetReportHTMLName: string; 46 | function GetReportXMLName: string; 47 | function GetCoverageLogFileName: string; 48 | 49 | function ContainsIn(Value: string; AList: TList): Boolean; 50 | protected 51 | function BasePath: string; 52 | function Clear: ICCECodeCoverage; 53 | 54 | function CodeCoverageFileName(Value: string): ICCECodeCoverage; 55 | function ExeFileName(Value: string): ICCECodeCoverage; 56 | function MapFileName(Value: string): ICCECodeCoverage; 57 | function OutputReport(Value: string): ICCECodeCoverage; 58 | function Paths(Values: TArray): ICCECodeCoverage; 59 | function Units(Values: TArray): ICCECodeCoverage; 60 | function GenerateHtml(Value: Boolean): ICCECodeCoverage; 61 | function GenerateXml(Value: Boolean): ICCECodeCoverage; 62 | function GenerateEmma(Value: Boolean): ICCECodeCoverage; 63 | function GenerateLog(Value: Boolean): ICCECodeCoverage; 64 | function UseRelativePath(Value: Boolean): ICCECodeCoverage; 65 | 66 | function IsInCovUnits(AUnitName: string): Boolean; 67 | function IgnoredUnits: TArray; 68 | 69 | function AddUnit(Value: string): ICCECodeCoverage; 70 | function AddUnitIgnore(Value: string): ICCECodeCoverage; 71 | function AddPath(Value: string): ICCECodeCoverage; 72 | 73 | function Save: ICCECodeCoverage; 74 | function Execute: ICCECodeCoverage; 75 | 76 | function ShowHTMLReport: ICCECodeCoverage; 77 | function ShowXMLReport: ICCECodeCoverage; 78 | function ShowLogCoverage: ICCECodeCoverage; 79 | 80 | public 81 | constructor create; 82 | class function New: ICCECodeCoverage; 83 | destructor Destroy; override; 84 | end; 85 | 86 | implementation 87 | 88 | { TCCECoreCodeCoverage } 89 | 90 | function TCCECoreCodeCoverage.AddPath(Value: string): ICCECodeCoverage; 91 | begin 92 | Result := Self; 93 | if not ContainsIn(Value, FPaths) then 94 | FPaths.Add(Value); 95 | end; 96 | 97 | function TCCECoreCodeCoverage.AddUnit(Value: string): ICCECodeCoverage; 98 | begin 99 | Result := Self; 100 | if not ContainsIn(Value, FUnitsFiles) then 101 | FUnitsFiles.Add(Value); 102 | end; 103 | 104 | function TCCECoreCodeCoverage.AddUnitIgnore(Value: string): ICCECodeCoverage; 105 | var 106 | LValue: string; 107 | begin 108 | Result := Self; 109 | LValue := Value; 110 | if LValue.StartsWith('!') then 111 | LValue := Copy(LValue, 2, LValue.Length); 112 | 113 | if not FUnitsIgnore.Contains(LValue) then 114 | FUnitsIgnore.Add(LValue); 115 | end; 116 | 117 | function TCCECoreCodeCoverage.BasePath: string; 118 | begin 119 | Result := ExtractFilePath(FExeFileName); 120 | end; 121 | 122 | function TCCECoreCodeCoverage.Clear: ICCECodeCoverage; 123 | begin 124 | Result := Self; 125 | FUnitsFiles.Clear; 126 | FUnitsIgnore.Clear; 127 | FPaths.Clear; 128 | end; 129 | 130 | function TCCECoreCodeCoverage.CodeCoverageCommand: string; 131 | begin 132 | Result := '"%s" -e "%s" -m "%s" -uf "%s" -spf "%s" -od "%s" '; 133 | if FGenerateLog then 134 | Result := Result + '-lt '; 135 | 136 | if FGenerateEmma then 137 | Result := Result + '-emma -meta '; 138 | 139 | if FGenerateHtml then 140 | Result := Result + '-html '; 141 | 142 | if FGenerateXml then 143 | Result := Result + '-xml -xmllines'; 144 | 145 | Result := Format(Result, [FCodeCoverageFileName, 146 | GetExeName, 147 | GetMapName, 148 | GetFileUnits, 149 | GetFilePaths, 150 | GetOutputReport]); 151 | end; 152 | 153 | function TCCECoreCodeCoverage.CodeCoverageFileName(Value: string): ICCECodeCoverage; 154 | begin 155 | Result := Self; 156 | FCodeCoverageFileName := Value; 157 | end; 158 | 159 | function TCCECoreCodeCoverage.ContainsIn(Value: string; AList: TList): Boolean; 160 | var 161 | listValue: string; 162 | begin 163 | Result := False; 164 | for listValue in AList do 165 | begin 166 | if listValue.ToLower.Equals(Value.ToLower) then 167 | Exit(True); 168 | end; 169 | end; 170 | 171 | constructor TCCECoreCodeCoverage.create; 172 | begin 173 | FCodeCoverageFileName := 'CodeCoverage.exe'; 174 | FGenerateXml := True; 175 | FGenerateLog := True; 176 | FGenerateHtml := True; 177 | FGenerateEmma := True; 178 | FUseRelativePath := True; 179 | 180 | FUnitsFiles := TList.create; 181 | FUnitsIgnore := TList.create; 182 | FPaths := TList.create; 183 | end; 184 | 185 | destructor TCCECoreCodeCoverage.Destroy; 186 | begin 187 | FUnitsFiles.Free; 188 | FPaths.Free; 189 | FUnitsIgnore.Free; 190 | inherited; 191 | end; 192 | 193 | function TCCECoreCodeCoverage.Execute: ICCECodeCoverage; 194 | begin 195 | Result := Self; 196 | 197 | ExecuteAndWait(BasePath, FileCodeCoverageBat); 198 | end; 199 | 200 | function TCCECoreCodeCoverage.ExeFileName(Value: string): ICCECodeCoverage; 201 | begin 202 | Result := Self; 203 | FExeFileName := Value; 204 | end; 205 | 206 | function TCCECoreCodeCoverage.FileCodeCoverageBat: string; 207 | begin 208 | Result := ExtractFilePath(FExeFileName) + 'dcov_execute.bat'; 209 | end; 210 | 211 | function TCCECoreCodeCoverage.FilePathsName: string; 212 | begin 213 | Result := ExtractFilePath(FExeFileName) + 'dcov_paths.lst'; 214 | end; 215 | 216 | function TCCECoreCodeCoverage.FileToList(AFileName: string): TList; 217 | var 218 | LFile: TStrings; 219 | i: Integer; 220 | begin 221 | Result := TList.create; 222 | try 223 | LFile := TStringList.Create; 224 | try 225 | if FileExists(AFileName) then 226 | begin 227 | LFile.LoadFromFile(AFileName); 228 | for i := 0 to Pred(LFile.Count) do 229 | Result.Add(LFile[i]); 230 | end; 231 | finally 232 | LFile.Free; 233 | end; 234 | except 235 | Result.Free; 236 | raise; 237 | end; 238 | end; 239 | 240 | function TCCECoreCodeCoverage.FileUnitsName: string; 241 | begin 242 | Result := ExtractFilePath(FExeFileName) + 'dcov_units.lst'; 243 | end; 244 | 245 | function TCCECoreCodeCoverage.GenerateEmma(Value: Boolean): ICCECodeCoverage; 246 | begin 247 | Result := Self; 248 | FGenerateEmma := Value; 249 | end; 250 | 251 | procedure TCCECoreCodeCoverage.GenerateFilePaths; 252 | var 253 | path: string; 254 | i : Integer; 255 | begin 256 | with TStringList.Create do 257 | try 258 | for i := 0 to Pred(FPaths.Count) do 259 | begin 260 | path := FPaths[i]; 261 | if FUseRelativePath then 262 | path := AbsolutePathToRelative(path, BasePath); 263 | 264 | if not path.EndsWith('\') then 265 | path := path + '\'; 266 | Add(path); 267 | end; 268 | 269 | SaveToFile(FilePathsName); 270 | finally 271 | Free; 272 | end; 273 | end; 274 | 275 | procedure TCCECoreCodeCoverage.GenerateFileUnits; 276 | var 277 | unitFile: string; 278 | i : Integer; 279 | begin 280 | with TStringList.Create do 281 | try 282 | for i := 0 to Pred(FUnitsIgnore.Count) do 283 | Add('!' + FUnitsIgnore[i]); 284 | 285 | for i := 0 to Pred(FUnitsFiles.Count) do 286 | begin 287 | unitFile := ExtractFileName(FUnitsFiles[i]); 288 | Add(unitFile); 289 | end; 290 | 291 | SaveToFile(FileUnitsName); 292 | finally 293 | Free; 294 | end; 295 | end; 296 | 297 | function TCCECoreCodeCoverage.GenerateHtml(Value: Boolean): ICCECodeCoverage; 298 | begin 299 | Result := Self; 300 | FGenerateHtml := Value; 301 | end; 302 | 303 | function TCCECoreCodeCoverage.GenerateLog(Value: Boolean): ICCECodeCoverage; 304 | begin 305 | Result := Self; 306 | FGenerateLog := Value; 307 | end; 308 | 309 | function TCCECoreCodeCoverage.GenerateXml(Value: Boolean): ICCECodeCoverage; 310 | begin 311 | Result := Self; 312 | FGenerateXml := Value; 313 | end; 314 | 315 | function TCCECoreCodeCoverage.GetCoverageLogFileName: string; 316 | begin 317 | Result := BasePath + '\Delphi-Code-Coverage-Debug.log'; 318 | end; 319 | 320 | function TCCECoreCodeCoverage.GetExeName: string; 321 | begin 322 | Result := FExeFileName; 323 | if FUseRelativePath then 324 | Result := AbsolutePathToRelative(FExeFileName, BasePath); 325 | end; 326 | 327 | function TCCECoreCodeCoverage.GetFilePaths: string; 328 | begin 329 | Result := FilePathsName; 330 | if FUseRelativePath then 331 | Result := AbsolutePathToRelative(FilePathsName, BasePath); 332 | end; 333 | 334 | function TCCECoreCodeCoverage.GetFileUnits: string; 335 | begin 336 | Result := FileUnitsName; 337 | if FUseRelativePath then 338 | Result := AbsolutePathToRelative(FileUnitsName, BasePath); 339 | end; 340 | 341 | function TCCECoreCodeCoverage.GetMapName: string; 342 | begin 343 | Result := FMapFileName; 344 | if FUseRelativePath then 345 | Result := AbsolutePathToRelative(FMapFileName, BasePath); 346 | end; 347 | 348 | function TCCECoreCodeCoverage.GetOutputReport: string; 349 | begin 350 | Result := FOutputReport; 351 | if FUseRelativePath then 352 | Result := AbsolutePathToRelative(FOutputReport, BasePath); 353 | end; 354 | 355 | function TCCECoreCodeCoverage.GetReportHTMLName: string; 356 | begin 357 | Result := FOutputReport + '\CodeCoverage_summary.html'; 358 | end; 359 | 360 | function TCCECoreCodeCoverage.GetReportXMLName: string; 361 | begin 362 | Result := FOutputReport + '\CodeCoverage_Summary.xml'; 363 | end; 364 | 365 | function TCCECoreCodeCoverage.IgnoredUnits: TArray; 366 | var 367 | LUnits: TList; 368 | i: Integer; 369 | begin 370 | LUnits := FileToList(FileUnitsName); 371 | try 372 | for i := 0 to Pred(LUnits.Count) do 373 | begin 374 | if LUnits[i].StartsWith('!') then 375 | begin 376 | SetLength(Result, Length(Result) + 1); 377 | Result[Length(Result) - 1] := Copy(LUnits[i], 2, LUnits[i].Length).Trim; 378 | end; 379 | end; 380 | finally 381 | LUnits.Free; 382 | end; 383 | end; 384 | 385 | function TCCECoreCodeCoverage.IsInCovUnits(AUnitName: string): Boolean; 386 | var 387 | LPaths: TList; 388 | LUnits: TList; 389 | LUnitName: string; 390 | LPath: string; 391 | begin 392 | LPaths := FileToList(FilePathsName); 393 | LUnits := FileToList(FileUnitsName); 394 | try 395 | LPath := ExtractFilePath(AUnitName); 396 | if FUseRelativePath then 397 | LPath := AbsolutePathToRelative(LPath, BasePath); 398 | 399 | LUnitName := ExtractFileName(AUnitName); 400 | 401 | Result := (LPaths.Contains(LPath)) and (LUnits.Contains(LUnitName)); 402 | finally 403 | LPaths.Free; 404 | LUnits.Free; 405 | end; 406 | end; 407 | 408 | function TCCECoreCodeCoverage.MapFileName(Value: string): ICCECodeCoverage; 409 | begin 410 | Result := Self; 411 | FMapFileName := Value; 412 | end; 413 | 414 | class function TCCECoreCodeCoverage.New: ICCECodeCoverage; 415 | begin 416 | Result := Self.Create; 417 | end; 418 | 419 | function TCCECoreCodeCoverage.OutputReport(Value: string): ICCECodeCoverage; 420 | begin 421 | Result := Self; 422 | FOutputReport := Value; 423 | end; 424 | 425 | function TCCECoreCodeCoverage.Paths(Values: TArray): ICCECodeCoverage; 426 | var 427 | i: Integer; 428 | begin 429 | Result := Self; 430 | for i := 0 to Pred(Length(Values)) do 431 | AddPath(Values[i]); 432 | end; 433 | 434 | function TCCECoreCodeCoverage.Save: ICCECodeCoverage; 435 | begin 436 | Result := Self; 437 | GenerateFilePaths; 438 | GenerateFileUnits; 439 | 440 | with TStringList.Create do 441 | try 442 | Text := CodeCoverageCommand; 443 | SaveToFile(FileCodeCoverageBat); 444 | finally 445 | Free; 446 | end; 447 | end; 448 | 449 | function TCCECoreCodeCoverage.ShowHTMLReport: ICCECodeCoverage; 450 | begin 451 | Result := Self; 452 | CCE.Core.Utils.OpenFile(GetReportHTMLName); 453 | end; 454 | 455 | function TCCECoreCodeCoverage.ShowLogCoverage: ICCECodeCoverage; 456 | begin 457 | Result := Self; 458 | CCE.Core.Utils.OpenFile(GetCoverageLogFileName); 459 | end; 460 | 461 | function TCCECoreCodeCoverage.ShowXMLReport: ICCECodeCoverage; 462 | begin 463 | Result := Self; 464 | CCE.Core.Utils.OpenFile(GetReportXMLName); 465 | end; 466 | 467 | function TCCECoreCodeCoverage.Units(Values: TArray): ICCECodeCoverage; 468 | var 469 | i: Integer; 470 | begin 471 | Result := Self; 472 | for i := 0 to Pred(Length(Values)) do 473 | AddUnit(Values[i]); 474 | end; 475 | 476 | function TCCECoreCodeCoverage.UseRelativePath(Value: Boolean): ICCECodeCoverage; 477 | begin 478 | Result := Self; 479 | FUseRelativePath := Value; 480 | end; 481 | 482 | end. 483 | -------------------------------------------------------------------------------- /Source/Src/Core/CCE.Core.Interfaces.pas: -------------------------------------------------------------------------------- 1 | unit CCE.Core.Interfaces; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | System.Classes; 8 | 9 | type 10 | ICCEProject = interface 11 | ['{676756F9-BEBC-4FCB-90AE-0B9843F7D126}'] 12 | function ProjectPath: string; 13 | function OutputPath: string; 14 | function ExeName: string; overload; 15 | function DprFileName: string; 16 | function MapFileName: string; overload; 17 | 18 | function SetDetailedMapFile: ICCEProject; 19 | 20 | function ListAllPaths: TArray; 21 | function ListAllUnits(APath: string): TArray; overload; 22 | function ListAllUnits: TArray; overload; 23 | 24 | function Build: ICCEProject; 25 | end; 26 | 27 | ICCECodeCoverage = interface 28 | ['{DCE40126-F975-4BAA-8CAE-3BD2ED2AF6EF}'] 29 | function Clear: ICCECodeCoverage; 30 | function BasePath: string; 31 | function CodeCoverageFileName(AValue: string): ICCECodeCoverage; 32 | function ExeFileName(AValue: string): ICCECodeCoverage; overload; 33 | function MapFileName(AValue: string): ICCECodeCoverage; 34 | function OutputReport(Value: string): ICCECodeCoverage; 35 | function Paths(AValues: TArray): ICCECodeCoverage; 36 | function Units(AValues: TArray): ICCECodeCoverage; 37 | function GenerateHtml(AValue: Boolean): ICCECodeCoverage; 38 | function GenerateXml(AValue: Boolean): ICCECodeCoverage; 39 | function GenerateEmma(AValue: Boolean): ICCECodeCoverage; 40 | function GenerateLog(AValue: Boolean): ICCECodeCoverage; 41 | function UseRelativePath(AValue: Boolean): ICCECodeCoverage; 42 | 43 | function IsInCovUnits(AUnitName: string): Boolean; 44 | function IgnoredUnits: TArray; 45 | 46 | function AddUnit(AValue: string): ICCECodeCoverage; 47 | function AddUnitIgnore(AValue: string): ICCECodeCoverage; 48 | function AddPath(AValue: string): ICCECodeCoverage; 49 | 50 | function Save: ICCECodeCoverage; 51 | function Execute: ICCECodeCoverage; 52 | 53 | function ShowHTMLReport: ICCECodeCoverage; 54 | function ShowXMLReport: ICCECodeCoverage; 55 | function ShowLogCoverage: ICCECodeCoverage; 56 | end; 57 | 58 | implementation 59 | 60 | end. 61 | -------------------------------------------------------------------------------- /Source/Src/Core/CCE.Core.Project.pas: -------------------------------------------------------------------------------- 1 | unit CCE.Core.Project; 2 | 3 | interface 4 | 5 | uses 6 | Dccstrs, 7 | ToolsAPI, 8 | CCE.Core.Interfaces, 9 | CCE.Core.Utils, 10 | System.Generics.Collections, 11 | System.IOUtils, 12 | System.SysUtils, 13 | System.Types, 14 | System.Classes; 15 | 16 | const 17 | TEST_INSIGHT = 'TESTINSIGHT'; 18 | 19 | type TCCECoreProject = class(TInterfacedObject, ICCEProject) 20 | 21 | private 22 | FProject: IOTAProject; 23 | FActiveConfig: IOTABuildConfiguration; 24 | FPaths: TList; 25 | FUnits: TList; 26 | 27 | function ProjectPath: string; 28 | function GetSearchPaths: TList; 29 | 30 | procedure SetAllPaths; 31 | procedure SetAllUnits(Path: String); 32 | 33 | procedure AddPath(Value: String); 34 | procedure AddUnit(Value: String); 35 | public 36 | function OutputPath: string; 37 | function ExeName: String; 38 | function DprFileName: string; 39 | function MapFileName: string; 40 | 41 | function SetDetailedMapFile: ICCEProject; 42 | 43 | function ListAllPaths: TArray; 44 | function ListAllUnits(Path: String): TArray; overload; 45 | function ListAllUnits: TArray; overload; 46 | 47 | function Build: ICCEProject; 48 | 49 | constructor create(Project: IOTAProject); 50 | class function New(Project: IOTAProject): ICCEProject; 51 | destructor Destroy; override; 52 | end; 53 | 54 | implementation 55 | 56 | { TCCECoreProject } 57 | 58 | procedure TCCECoreProject.AddPath(Value: String); 59 | begin 60 | if (not FPaths.Contains(Value)) and (DirectoryExists(Value)) then 61 | FPaths.Add(Value); 62 | end; 63 | 64 | procedure TCCECoreProject.AddUnit(Value: String); 65 | begin 66 | if not FUnits.Contains(Value) then 67 | FUnits.Add(Value); 68 | end; 69 | 70 | function TCCECoreProject.Build: ICCEProject; 71 | begin 72 | result := Self; 73 | FProject.ProjectBuilder 74 | .BuildProject(TOTACompileMode.cmOTABuild, True, True); 75 | end; 76 | 77 | constructor TCCECoreProject.create(Project: IOTAProject); 78 | begin 79 | FProject := Project; 80 | FActiveConfig := (Project.ProjectOptions as IOTAProjectOptionsConfigurations) 81 | .ActiveConfiguration; 82 | 83 | FPaths := TList.create; 84 | FUnits := TList.create; 85 | 86 | SetAllPaths; 87 | end; 88 | 89 | destructor TCCECoreProject.Destroy; 90 | begin 91 | FPaths.Free; 92 | FUnits.Free; 93 | inherited; 94 | end; 95 | 96 | function TCCECoreProject.DprFileName: string; 97 | begin 98 | result := FProject.FileName; 99 | end; 100 | 101 | function TCCECoreProject.ExeName: String; 102 | begin 103 | Result := OutputPath + 104 | ChangeFileExt(ExtractFileName(FProject.FileName), '.exe'); 105 | end; 106 | 107 | function TCCECoreProject.GetSearchPaths: TList; 108 | var 109 | searchPath: TStrings; 110 | path: string; 111 | i: Integer; 112 | begin 113 | searchPath := TStringList.Create; 114 | try 115 | result := TList.create; 116 | try 117 | FActiveConfig.GetValues(sUnitSearchPath, searchPath, True); 118 | for i := 0 to Pred(searchPath.Count) do 119 | begin 120 | path := RelativeToAbsolutePath(searchPath[i], ProjectPath); 121 | result.Add(path); 122 | end; 123 | 124 | except 125 | result.Free; 126 | end; 127 | finally 128 | searchPath.Free; 129 | end; 130 | end; 131 | 132 | function TCCECoreProject.ListAllPaths: TArray; 133 | begin 134 | result := FPaths.ToArray; 135 | end; 136 | 137 | function TCCECoreProject.ListAllUnits: TArray; 138 | begin 139 | result := FUnits.ToArray; 140 | end; 141 | 142 | function TCCECoreProject.ListAllUnits(Path: String): TArray; 143 | var 144 | i: Integer; 145 | unitPath: string; 146 | begin 147 | if not Path.EndsWith('\') then 148 | Path := Path + '\'; 149 | 150 | for i := 0 to Pred(FUnits.Count) do 151 | begin 152 | unitPath := ExtractFilePath(FUnits[i]).ToLower; 153 | if Path.ToLower = unitPath then 154 | begin 155 | SetLength(result, Length(result) + 1); 156 | result[Length(result) - 1] := FUnits[i]; 157 | end; 158 | end; 159 | end; 160 | 161 | function TCCECoreProject.MapFileName: string; 162 | begin 163 | result := ChangeFileExt(ExeName, '.map'); 164 | end; 165 | 166 | class function TCCECoreProject.New(Project: IOTAProject): ICCEProject; 167 | begin 168 | result := Self.create(Project); 169 | end; 170 | 171 | function TCCECoreProject.OutputPath: string; 172 | begin 173 | result := FActiveConfig.GetValue(sExeOutput); 174 | result := RelativeToAbsolutePath(Result, ProjectPath) 175 | .Replace('$(Platform)', FActiveConfig.Platform) 176 | .Replace('$(Config)', FActiveConfig.Name) + '\'; 177 | 178 | result := Result.Replace('\\', '\'); 179 | end; 180 | 181 | function TCCECoreProject.ProjectPath: string; 182 | begin 183 | result := ExtractFilePath(FProject.FileName); 184 | end; 185 | 186 | procedure TCCECoreProject.SetAllPaths; 187 | var 188 | i: Integer; 189 | searchPath: TList; 190 | path: string; 191 | begin 192 | for i := 0 to Pred(FProject.GetModuleCount) do 193 | begin 194 | if ExtractFileExt(FProject.GetModule(i).FileName) = '.pas' then 195 | begin 196 | path := ExtractFilePath(FProject.GetModule(i).FileName); 197 | AddPath(path); 198 | 199 | SetAllUnits(path); 200 | end; 201 | end; 202 | 203 | searchPath := Self.GetSearchPaths; 204 | try 205 | for i := 0 to Pred(searchPath.Count) do 206 | begin 207 | path := searchPath.Items[i]; 208 | AddPath(path); 209 | 210 | SetAllUnits(path); 211 | end; 212 | finally 213 | searchPath.Free; 214 | end; 215 | end; 216 | 217 | procedure TCCECoreProject.SetAllUnits(Path: String); 218 | var 219 | i: Integer; 220 | files: TStringDynArray; 221 | begin 222 | if not DirectoryExists(Path) then 223 | Exit; 224 | 225 | files := TDirectory.GetFiles(Path); 226 | 227 | for i := 0 to Pred(Length(files)) do 228 | begin 229 | if ExtractFileExt(files[i]) = '.pas' then 230 | AddUnit(files[i]); 231 | end; 232 | end; 233 | 234 | function TCCECoreProject.SetDetailedMapFile: ICCEProject; 235 | begin 236 | result := Self; 237 | FActiveConfig.SetValue('DCC_MapFile', '3'); 238 | FProject.Save(False, True); 239 | FProject.Refresh(True); 240 | end; 241 | 242 | end. 243 | -------------------------------------------------------------------------------- /Source/Src/Core/CCE.Core.Utils.pas: -------------------------------------------------------------------------------- 1 | unit CCE.Core.Utils; 2 | 3 | interface 4 | 5 | uses 6 | CCE.dprocess, 7 | System.IOUtils, 8 | System.SysUtils, 9 | System.Types, 10 | Vcl.Forms, 11 | Winapi.ShellAPI, 12 | Winapi.Windows; 13 | 14 | function RelativeToAbsolutePath(const RelativePath, BasePath: string): string; 15 | function AbsolutePathToRelative(const AbsolutePath, BasePath: string): string; 16 | 17 | procedure ExecuteAndWait(const APath, ACommand: string); 18 | procedure OpenFolder(const AFolderName: String); 19 | procedure OpenFile(const AFileName: String); 20 | procedure OpenUrl(const Url: String); 21 | 22 | function PathCanonicalize(lpszDst: PChar; lpszSrc: PChar): LongBool; stdcall; 23 | external 'shlwapi.dll' name 'PathCanonicalizeW'; 24 | 25 | function PathRelativePathTo(pszPath: PChar; pszFrom: PChar; dwAttrFrom: DWORD; 26 | pszTo: PChar; dwAtrTo: DWORD): LongBool; stdcall; external 'shlwapi.dll' name 'PathRelativePathToW'; 27 | 28 | implementation 29 | 30 | function RelativeToAbsolutePath(const RelativePath, BasePath: string): string; 31 | var 32 | Dst: array[0..259] of char; 33 | begin 34 | result := RelativePath; 35 | if TPath.IsRelativePath(RelativePath) then 36 | begin 37 | PathCanonicalize(@Dst[0], PChar(IncludeTrailingBackslash(BasePath) + RelativePath)); 38 | if Dst <> '' then 39 | result := Dst; 40 | end; 41 | end; 42 | 43 | function AbsolutePathToRelative(const AbsolutePath, BasePath: string): string; 44 | var 45 | Path: array[0..259] of char; 46 | begin 47 | result := AbsolutePath; 48 | if not TPath.IsRelativePath(AbsolutePath) then 49 | begin 50 | PathRelativePathTo(@Path[0], PChar(BasePath), FILE_ATTRIBUTE_DIRECTORY, PChar(AbsolutePath), 0); 51 | if Path <> '' then 52 | result := Path; 53 | end; 54 | end; 55 | 56 | procedure ExecuteAndWait(const APath, ACommand: string); 57 | var 58 | output: AnsiString; 59 | begin 60 | RunCommandIndir(APath, 'cmd', ['/c', ACommand], output, [poNoConsole]); 61 | end; 62 | 63 | procedure OpenFolder(const AFolderName: String); 64 | begin 65 | ShellExecute(HInstance, 'open', PChar(AFolderName), '', '', SW_SHOWNORMAL); 66 | end; 67 | 68 | procedure OpenFile(const AFileName: String); 69 | begin 70 | if FileExists(AFileName) then 71 | ShellExecute(HInstance, 'open', PWideChar(AFileName), '', '', SW_SHOWNORMAL); 72 | end; 73 | 74 | procedure OpenUrl(const Url: String); 75 | begin 76 | ShellExecute(HInstance, 'open', PWideChar( Url ), '', '', SW_SHOWNORMAL); 77 | end; 78 | 79 | end. 80 | -------------------------------------------------------------------------------- /Source/Src/Core/CCE.Helpers.TreeView.pas: -------------------------------------------------------------------------------- 1 | unit CCE.Helpers.TreeView; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | System.Classes, 8 | Vcl.ComCtrls, 9 | Vcl.Controls; 10 | 11 | const 12 | UNCHECKED_INDEX = 1; 13 | CHECKED_INDEX = 2; 14 | GRAYED_INDEX = 3; 15 | FOLDER_INDEX = 4; 16 | UNIT_INDEX = 5; 17 | 18 | type TCCEHelperTreeView = class helper for TTreeView 19 | 20 | public 21 | procedure AddPath(APath: String); 22 | function GetNodeParent(AParentCaption: String; AParentLevel: Integer): TTreeNode; 23 | function FindNode(ACaption: String; ALevel: Integer; ANodeParent: TTreeNode): TTreeNode; 24 | 25 | function SelectedPath: string; 26 | function CheckedNodes: TArray; 27 | 28 | procedure ExpandAll; 29 | end; 30 | 31 | implementation 32 | 33 | { TCCEHelperTreeView } 34 | 35 | 36 | function TCCEHelperTreeView.GetNodeParent(AParentCaption: String; AParentLevel: Integer): TTreeNode; 37 | var 38 | i: Integer; 39 | begin 40 | result := nil; 41 | for i := 0 to Pred(Items.Count) do 42 | begin 43 | if (Items[i].Level = AParentLevel) and 44 | (Items[i].Text.ToLower = AParentCaption.ToLower) 45 | then 46 | Exit( Items[i] ); 47 | end; 48 | end; 49 | 50 | function TCCEHelperTreeView.SelectedPath: string; 51 | var 52 | node: TTreeNode; 53 | parent: TTreeNode; 54 | begin 55 | node := Self.Selected; 56 | result := node.Text; 57 | parent := node.Parent; 58 | 59 | if parent = nil then 60 | begin 61 | Result := result + '\'; 62 | exit; 63 | end; 64 | 65 | repeat 66 | result := parent.Text + '\' + Result; 67 | parent := parent.Parent 68 | until (parent = nil); 69 | end; 70 | 71 | { TCCEHelperTreeView } 72 | 73 | procedure TCCEHelperTreeView.AddPath(APath: String); 74 | var 75 | i: Integer; 76 | list: TStringList; 77 | nodeParent: TTreeNode; 78 | node: TTreeNode; 79 | text: String; 80 | begin 81 | list := TStringList.Create; 82 | try 83 | list.Delimiter := '\'; 84 | list.StrictDelimiter := True; 85 | list.DelimitedText := APath; 86 | 87 | nodeParent := nil; 88 | for i := 0 to Pred(list.Count) do 89 | begin 90 | text := list[i]; 91 | node := FindNode(text, i, nodeParent); 92 | 93 | if Assigned(node) then 94 | Continue; 95 | 96 | if (i > 0) and (nodeParent = nil) then 97 | nodeParent := GetNodeParent(list[i - 1], i - 1); 98 | 99 | node := FindNode(text, i, nodeParent); 100 | if not Assigned(node) then 101 | nodeParent := Items.AddChild(nodeParent, text) 102 | end; 103 | 104 | finally 105 | list.Free; 106 | end; 107 | end; 108 | 109 | function TCCEHelperTreeView.CheckedNodes: TArray; 110 | var 111 | i: Integer; 112 | begin 113 | for i := 0 to Pred(Items.Count) do 114 | begin 115 | if Items[i].StateIndex = CHECKED_INDEX then 116 | begin 117 | SetLength(result, Length(result) + 1); 118 | Result[Length(result) - 1] := Items[i]; 119 | end; 120 | end; 121 | end; 122 | 123 | procedure TCCEHelperTreeView.ExpandAll; 124 | begin 125 | Self.FullExpand; 126 | end; 127 | 128 | function TCCEHelperTreeView.FindNode(ACaption: String; ALevel: Integer; ANodeParent: TTreeNode): TTreeNode; 129 | var 130 | i: Integer; 131 | childNode: TTreeNode; 132 | begin 133 | result := nil; 134 | if Assigned(ANodeParent) then 135 | begin 136 | childNode := ANodeParent.getFirstChild; 137 | 138 | while childNode <> nil do 139 | begin 140 | if childNode.Text.ToLower = ACaption.ToLower then 141 | Exit( childNode ); 142 | 143 | childNode := ANodeParent.GetNextChild(childNode); 144 | end; 145 | 146 | Exit; 147 | end; 148 | 149 | for i := 0 to Pred(Items.Count) do 150 | begin 151 | if (Items[i].Level = ALevel) and 152 | (Items[i].Text.ToLower = ACaption.ToLower) 153 | then 154 | begin 155 | if not Assigned(ANodeParent) then 156 | Exit(Items[i]) 157 | else 158 | if ANodeParent.Text.ToLower = Items[i].Parent.Text.ToLower then 159 | Exit(Items[i]); 160 | 161 | end; 162 | end; 163 | end; 164 | 165 | end. 166 | -------------------------------------------------------------------------------- /Source/Src/IDE/CCE.ContextMenu.pas: -------------------------------------------------------------------------------- 1 | unit CCE.ContextMenu; 2 | 3 | interface 4 | 5 | uses 6 | ToolsAPI, 7 | CCE.Constants, 8 | CCE.Core.Interfaces, 9 | CCE.Core.Project, 10 | CCE.Core.CodeCoverage, 11 | CCE.Wizard.Forms, 12 | System.Classes, 13 | System.SysUtils; 14 | 15 | type 16 | TCCEOnContextMenuClick = procedure (const MenuContextList: IInterfaceList) of object; 17 | 18 | TCCEContextMenuWizard = class(TNotifierObject, IOTAProjectMenuItemCreatorNotifier) 19 | private 20 | FProject: IOTAProject; 21 | 22 | procedure Initialize(Project: IOTAProject); 23 | 24 | procedure OnExecuteCodeCoverageWizard(const MenuContextList: IInterfaceList); 25 | procedure OnExecuteCodeCoverage(const MenuContextList: IInterfaceList); 26 | procedure OnExecuteHTMLReport(const MenuContextList: IInterfaceList); 27 | 28 | function AddMenu(Caption: String; 29 | Position: Integer; 30 | Parent: string = ''; 31 | OnExecute: TCCEOnContextMenuClick = nil; 32 | Checked: Boolean = False): IOTAProjectManagerMenu; overload; 33 | protected 34 | procedure AddMenu(const Project: IOTAProject; 35 | const IdentList: TStrings; 36 | const MenuList: IInterfaceList; 37 | IsMultiSelect: Boolean); overload; 38 | 39 | public 40 | class function New: IOTAProjectMenuItemCreatorNotifier; 41 | end; 42 | 43 | TCCEContextMenu = class(TNotifierObject, IOTALocalMenu, IOTAProjectManagerMenu) 44 | private 45 | FCaption: String; 46 | FIsMultiSelectable: Boolean; 47 | FChecked: Boolean; 48 | FEnabled: Boolean; 49 | FHelpContext: Integer; 50 | FName: string; 51 | FParent: string; 52 | FPosition: Integer; 53 | FVerb: string; 54 | 55 | protected 56 | FProject: IOTAProject; 57 | FOnExecute: TCCEOnContextMenuClick; 58 | 59 | function GetCaption: string; 60 | function GetChecked: Boolean; 61 | function GetEnabled: Boolean; 62 | function GetHelpContext: Integer; 63 | function GetName: string; 64 | function GetParent: string; 65 | function GetPosition: Integer; 66 | function GetVerb: string; 67 | procedure SetCaption(const Value: string); 68 | procedure SetChecked(Value: Boolean); 69 | procedure SetEnabled(Value: Boolean); 70 | procedure SetHelpContext(Value: Integer); 71 | procedure SetName(const Value: string); 72 | procedure SetParent(const Value: string); 73 | procedure SetPosition(Value: Integer); 74 | procedure SetVerb(const Value: string); 75 | function GetIsMultiSelectable: Boolean; 76 | procedure SetIsMultiSelectable(Value: Boolean); 77 | procedure Execute(const MenuContextList: IInterfaceList); virtual; 78 | function PreExecute(const MenuContextList: IInterfaceList): Boolean; 79 | function PostExecute(const MenuContextList: IInterfaceList): Boolean; 80 | 81 | constructor create(OnExecute: TCCEOnContextMenuClick); overload; 82 | class function New(OnExecute: TCCEOnContextMenuClick): IOTAProjectManagerMenu; overload; 83 | end; 84 | 85 | var 86 | IndexContextMenuCoverage: Integer = -1; 87 | 88 | procedure RegisterContextMenu; 89 | 90 | implementation 91 | 92 | procedure RegisterContextMenu; 93 | begin 94 | IndexContextMenuCoverage := (BorlandIDEServices as IOTAProjectManager) 95 | .AddMenuItemCreatorNotifier(TCCEContextMenuWizard.New); 96 | end; 97 | 98 | { TCCEContextMenu } 99 | 100 | constructor TCCEContextMenu.create(OnExecute: TCCEOnContextMenuClick); 101 | begin 102 | FOnExecute := OnExecute; 103 | FEnabled := True; 104 | FChecked := False; 105 | FIsMultiSelectable := False; 106 | end; 107 | 108 | procedure TCCEContextMenu.Execute(const MenuContextList: IInterfaceList); 109 | begin 110 | if Assigned(FOnExecute) then 111 | FOnExecute(MenuContextList); 112 | end; 113 | 114 | function TCCEContextMenu.GetCaption: string; 115 | begin 116 | result := FCaption; 117 | end; 118 | 119 | function TCCEContextMenu.GetChecked: Boolean; 120 | begin 121 | result := FChecked; 122 | end; 123 | 124 | function TCCEContextMenu.GetEnabled: Boolean; 125 | begin 126 | result := FEnabled; 127 | end; 128 | 129 | function TCCEContextMenu.GetHelpContext: Integer; 130 | begin 131 | result := FHelpContext; 132 | end; 133 | 134 | function TCCEContextMenu.GetIsMultiSelectable: Boolean; 135 | begin 136 | Result := FIsMultiSelectable; 137 | end; 138 | 139 | function TCCEContextMenu.GetName: string; 140 | begin 141 | result := FName; 142 | end; 143 | 144 | function TCCEContextMenu.GetParent: string; 145 | begin 146 | result := FParent; 147 | end; 148 | 149 | function TCCEContextMenu.GetPosition: Integer; 150 | begin 151 | result := FPosition; 152 | end; 153 | 154 | function TCCEContextMenu.GetVerb: string; 155 | begin 156 | result := FVerb; 157 | end; 158 | 159 | class function TCCEContextMenu.New(OnExecute: TCCEOnContextMenuClick): IOTAProjectManagerMenu; 160 | begin 161 | result := Self.create(OnExecute); 162 | end; 163 | 164 | function TCCEContextMenu.PostExecute(const MenuContextList: IInterfaceList): Boolean; 165 | begin 166 | result := True; 167 | end; 168 | 169 | function TCCEContextMenu.PreExecute(const MenuContextList: IInterfaceList): Boolean; 170 | begin 171 | result := True; 172 | end; 173 | 174 | procedure TCCEContextMenu.SetCaption(const Value: string); 175 | begin 176 | FCaption := Value; 177 | end; 178 | 179 | procedure TCCEContextMenu.SetChecked(Value: Boolean); 180 | begin 181 | FChecked := Value; 182 | end; 183 | 184 | procedure TCCEContextMenu.SetEnabled(Value: Boolean); 185 | begin 186 | FEnabled := Value; 187 | end; 188 | 189 | procedure TCCEContextMenu.SetHelpContext(Value: Integer); 190 | begin 191 | FHelpContext := Value; 192 | end; 193 | 194 | procedure TCCEContextMenu.SetIsMultiSelectable(Value: Boolean); 195 | begin 196 | FIsMultiSelectable := Value; 197 | end; 198 | 199 | procedure TCCEContextMenu.SetName(const Value: string); 200 | begin 201 | FName := Value; 202 | end; 203 | 204 | procedure TCCEContextMenu.SetParent(const Value: string); 205 | begin 206 | FParent := Value; 207 | end; 208 | 209 | procedure TCCEContextMenu.SetPosition(Value: Integer); 210 | begin 211 | FPosition := Value; 212 | end; 213 | 214 | procedure TCCEContextMenu.SetVerb(const Value: string); 215 | begin 216 | FVerb := Value; 217 | end; 218 | 219 | { TCCEContextMenuWizard } 220 | 221 | procedure TCCEContextMenuWizard.AddMenu(const Project: IOTAProject; 222 | const IdentList: TStrings; const MenuList: IInterfaceList; 223 | IsMultiSelect: Boolean); 224 | begin 225 | if (IdentList.IndexOf(sProjectContainer) < 0) or 226 | (not Assigned(MenuList)) 227 | then 228 | Exit; 229 | 230 | Initialize(Project); 231 | 232 | MenuList.Add(AddMenu(CCE_COVERAGE_CAPTION, CCE_COVERAGE_POSITION)); 233 | MenuList.Add(AddMenu(CCE_COVERAGE_WIZARD_CAPTION, CCE_COVERAGE_WIZARD_POSITION, CCE_COVERAGE_CAPTION, OnExecuteCodeCoverageWizard)); 234 | MenuList.Add(AddMenu(CCE_COVERAGE_EXECUTE_CAPTION, CCE_COVERAGE_EXECUTE_POSITION, CCE_COVERAGE_CAPTION, OnExecuteCodeCoverage)); 235 | MenuList.Add(AddMenu(CCE_COVERAGE_HTML_CAPTION, CCE_COVERAGE_HTML_POSITION, CCE_COVERAGE_CAPTION, OnExecuteHTMLReport)); 236 | end; 237 | 238 | function TCCEContextMenuWizard.AddMenu(Caption: String; Position: Integer; 239 | Parent: string; OnExecute: TCCEOnContextMenuClick; 240 | Checked: Boolean): IOTAProjectManagerMenu; 241 | begin 242 | result := TCCEContextMenu.New(OnExecute); 243 | Result.Caption := Caption; 244 | result.Verb := Caption; 245 | Result.Parent := Parent; 246 | result.Position := Position; 247 | result.Checked := Checked; 248 | result.IsMultiSelectable := False; 249 | end; 250 | 251 | procedure TCCEContextMenuWizard.Initialize(Project: IOTAProject); 252 | begin 253 | FProject := Project; 254 | end; 255 | 256 | class function TCCEContextMenuWizard.New: IOTAProjectMenuItemCreatorNotifier; 257 | begin 258 | result := Self.Create; 259 | end; 260 | 261 | procedure TCCEContextMenuWizard.OnExecuteCodeCoverage(const MenuContextList: IInterfaceList); 262 | var 263 | LCCe: ICCECodeCoverage; 264 | LProject: ICCEProject; 265 | begin 266 | LProject := TCCECoreProject.New(FProject); 267 | LCCe := TCCECoreCodeCoverage.New; 268 | LCCe 269 | .ExeFileName(LProject.ExeName) 270 | .Execute; 271 | end; 272 | 273 | procedure TCCEContextMenuWizard.OnExecuteCodeCoverageWizard(const MenuContextList: IInterfaceList); 274 | begin 275 | if not Assigned(CCEWizardForms) then 276 | CCEWizardForms := TCCEWizardForms.Create(nil); 277 | 278 | CCEWizardForms 279 | .Project(FProject) 280 | .Show; 281 | end; 282 | 283 | procedure TCCEContextMenuWizard.OnExecuteHTMLReport(const MenuContextList: IInterfaceList); 284 | var 285 | LCCe: ICCECodeCoverage; 286 | LProject: ICCEProject; 287 | LPathReport: String; 288 | begin 289 | LProject := TCCECoreProject.New(FProject); 290 | LPathReport := ExtractFilePath(LProject.ExeName) + 'report'; 291 | LCCe := TCCECoreCodeCoverage.New; 292 | LCCe 293 | .ExeFileName(LProject.ExeName) 294 | .OutputReport(LPathReport) 295 | .ShowHTMLReport; 296 | end; 297 | 298 | initialization 299 | 300 | finalization 301 | if IndexContextMenuCoverage >= 0 then 302 | (BorlandIDEServices as IOTAProjectManager) 303 | .RemoveMenuItemCreatorNotifier(IndexContextMenuCoverage); 304 | 305 | end. 306 | -------------------------------------------------------------------------------- /Source/Src/IDE/CCE.Wizard.Forms.pas: -------------------------------------------------------------------------------- 1 | unit CCE.Wizard.Forms; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, 8 | ToolsAPI, Vcl.ExtCtrls, Vcl.StdCtrls, Vcl.ExtDlgs, 9 | System.IOUtils, 10 | Vcl.FileCtrl, 11 | CCE.Core.Interfaces, 12 | CCE.Core.Project, 13 | CCE.Core.CodeCoverage, 14 | CCE.Core.Utils, 15 | CCE.Helpers.TreeView, 16 | System.Generics.Collections, Vcl.CheckLst, Vcl.Menus, Vcl.Buttons, 17 | System.ImageList, Vcl.ImgList, Vcl.Imaging.pngimage, Vcl.Mask; 18 | 19 | const 20 | COLOR_PRIMARY = $00FB7E15; 21 | COLOR_DISABLED = $00aba6a0; 22 | 23 | type 24 | TCCEWizardForms = class(TForm) 25 | pgcWizard: TPageControl; 26 | tsFiles: TTabSheet; 27 | pnlBottom: TPanel; 28 | openTextDialog: TOpenTextFileDialog; 29 | tsTreeView: TTabSheet; 30 | tvPaths: TTreeView; 31 | iltreeView: TImageList; 32 | Panel1: TPanel; 33 | imgSetDetailed: TImage; 34 | imgXml: TImage; 35 | imgTxt: TImage; 36 | imgHtml: TImage; 37 | imgBuild: TImage; 38 | imgRun: TImage; 39 | imgSave: TImage; 40 | imgFolder: TImage; 41 | pnlContentFiles: TPanel; 42 | pnlBody: TPanel; 43 | edtCoverageExeName: TLabeledEdit; 44 | edtExeName: TLabeledEdit; 45 | edtMapFileName: TLabeledEdit; 46 | edtOutputReport: TLabeledEdit; 47 | grpOutputFormat: TGroupBox; 48 | chkXmlReport: TCheckBox; 49 | chkHtmlReport: TCheckBox; 50 | chkEmmaReport: TCheckBox; 51 | chkLog: TCheckBox; 52 | chkUseRelativePath: TCheckBox; 53 | pnlTitle: TPanel; 54 | lblTitleSettings: TLabel; 55 | btnNext: TPanel; 56 | btnPrevious: TPanel; 57 | btnClose: TPanel; 58 | imgGithub: TImage; 59 | btnSelectCodeCoverage2: TImage; 60 | btnSelectExeName: TImage; 61 | btnSelectMapFile: TImage; 62 | btnOutputReport: TImage; 63 | tsIgnoredFiles: TTabSheet; 64 | Panel2: TPanel; 65 | Panel3: TPanel; 66 | Panel4: TPanel; 67 | Label1: TLabel; 68 | lstIgnoreUnits: TListBox; 69 | edtIgnoreUnit: TLabeledEdit; 70 | pnlAddIgnoreUnit: TPanel; 71 | imgAddIgnoreUnit: TImage; 72 | pmIgnoreUnits: TPopupMenu; 73 | Delete1: TMenuItem; 74 | procedure tvPathsDblClick(Sender: TObject); 75 | procedure imgRunClick(Sender: TObject); 76 | procedure imgSaveClick(Sender: TObject); 77 | procedure imgSetDetailedClick(Sender: TObject); 78 | procedure imgBuildClick(Sender: TObject); 79 | procedure imgHtmlClick(Sender: TObject); 80 | procedure imgXmlClick(Sender: TObject); 81 | procedure imgTxtClick(Sender: TObject); 82 | procedure imgFolderClick(Sender: TObject); 83 | procedure btnPreviousClick(Sender: TObject); 84 | procedure btnNextClick(Sender: TObject); 85 | procedure btnCloseClick(Sender: TObject); 86 | procedure btnSelectCodeCoverage2Click(Sender: TObject); 87 | procedure btnSelectExeNameClick(Sender: TObject); 88 | procedure btnSelectMapFileClick(Sender: TObject); 89 | procedure btnOutputReportClick(Sender: TObject); 90 | procedure imgGithubClick(Sender: TObject); 91 | procedure Delete1Click(Sender: TObject); 92 | procedure imgAddIgnoreUnitClick(Sender: TObject); 93 | private 94 | FProject: ICCEProject; 95 | FCoverage: ICCECodeCoverage; 96 | FTreeNodes: TDictionary; 97 | 98 | function GetNode(APath: String): TTreeNode; 99 | procedure AddPathInTreeView(APath: String); 100 | function GetKeyNode(ANode: TTreeNode): String; 101 | 102 | procedure SetCoverage(ASetUnits: Boolean = True); 103 | procedure SetCoverageUnits; 104 | 105 | procedure SetStateTreeView; 106 | procedure SetStateChilds(ANode: TTreeNode; AStateIndex: Integer); 107 | procedure SetStateParents(ANode: TTreeNode); 108 | procedure SetSelectedUnits; 109 | procedure SetIgnoreUnits; 110 | 111 | procedure searchFile(FilterText, FilterExt: string; AComponent: TCustomEdit); 112 | procedure selectFolder(AComponent: TCustomEdit); 113 | 114 | procedure ListPaths; 115 | procedure ListUnits(Path: String); 116 | 117 | procedure InitialValues; 118 | procedure HideTabs; 119 | procedure SelectPageNext; 120 | procedure SelectPagePrevious; 121 | procedure SetColorButtons; 122 | public 123 | function Project(Value: IOTAProject): TCCEWizardForms; 124 | 125 | constructor Create(AOwner: TComponent); override; 126 | destructor Destroy; override; 127 | { Public declarations } 128 | end; 129 | 130 | var 131 | CCEWizardForms: TCCEWizardForms; 132 | 133 | implementation 134 | 135 | {$R *.dfm} 136 | 137 | { TCCEWizardForms } 138 | 139 | procedure TCCEWizardForms.AddPathInTreeView(APath: String); 140 | var 141 | i: Integer; 142 | nodeParent: TTreeNode; 143 | node: TTreeNode; 144 | text: String; 145 | pathParent: String; 146 | path: String; 147 | splittedPath: TArray; 148 | 149 | procedure SetImageIndex(ANode: TTreeNode; APath: String); 150 | var 151 | index: Integer; 152 | begin 153 | ANode.StateIndex := CHECKED_INDEX; 154 | index := FOLDER_INDEX; 155 | if APath.EndsWith('\') then 156 | APath := Copy(APath, 1, APath.Length - 1); 157 | if FileExists(APath) then 158 | index := UNIT_INDEX; 159 | 160 | ANode.ImageIndex := index; 161 | ANode.SelectedIndex := index; 162 | end; 163 | begin 164 | splittedPath := APath.Split(['\']); 165 | 166 | pathParent := ''; 167 | for i := 0 to Pred(Length(splittedPath)) do 168 | begin 169 | text := splittedPath[i]; 170 | if text = '' then 171 | Continue; 172 | path := path + text + '\'; 173 | node := GetNode(path); 174 | if Assigned(node) then 175 | Continue; 176 | 177 | if i = 0 then 178 | begin 179 | nodeParent := tvPaths.Items.AddChild(nil, text); 180 | SetImageIndex(nodeParent, path); 181 | FTreeNodes.Add(path, nodeParent); 182 | Continue; 183 | end; 184 | 185 | pathParent := Copy(path, 1, path.length - text.Length - 1); 186 | nodeParent := GetNode(pathParent); 187 | if Assigned(nodeParent) then 188 | begin 189 | nodeParent := tvPaths.Items.AddChild(nodeParent, text); 190 | SetImageIndex(nodeParent, path); 191 | FTreeNodes.Add(path, nodeParent); 192 | Continue; 193 | end; 194 | end; 195 | end; 196 | 197 | procedure TCCEWizardForms.btnSelectCodeCoverage2Click(Sender: TObject); 198 | begin 199 | searchFile('Code Coverage File', 'exe', edtCoverageExeName); 200 | end; 201 | 202 | procedure TCCEWizardForms.btnSelectExeNameClick(Sender: TObject); 203 | begin 204 | searchFile('Delphi Test Project', 'exe', edtExeName); 205 | end; 206 | 207 | procedure TCCEWizardForms.btnSelectMapFileClick(Sender: TObject); 208 | begin 209 | searchFile('Map File', 'map', edtMapFileName); 210 | end; 211 | 212 | procedure TCCEWizardForms.SetSelectedUnits; 213 | var 214 | i: Integer; 215 | LIndex: Integer; 216 | LText: String; 217 | 218 | function GetFullName(ANode: TTreeNode): String; 219 | var 220 | LParent: TTreeNode; 221 | begin 222 | result := ANode.Text; 223 | LParent := ANode.Parent; 224 | while LParent <> nil do 225 | begin 226 | result := LParent.Text + '\' + result; 227 | LParent := LParent.Parent; 228 | end; 229 | end; 230 | begin 231 | tvPaths.Items.BeginUpdate; 232 | try 233 | for i := 0 to Pred(tvPaths.Items.Count) do 234 | begin 235 | LText := GetFullName(tvPaths.Items[i]); 236 | if FileExists(LText) then 237 | begin 238 | LIndex := UNCHECKED_INDEX; 239 | if FCoverage.IsInCovUnits(LText) then 240 | LIndex := CHECKED_INDEX; 241 | 242 | tvPaths.Items[i].StateIndex := LIndex; 243 | SetStateParents(tvPaths.Items[i]); 244 | end; 245 | end; 246 | finally 247 | tvPaths.Items.EndUpdate; 248 | end; 249 | end; 250 | 251 | procedure TCCEWizardForms.SetStateChilds(ANode: TTreeNode; AStateIndex: Integer); 252 | var 253 | childNode: TTreeNode; 254 | begin 255 | childNode := ANode.getFirstChild; 256 | 257 | while childNode <> nil do 258 | begin 259 | childNode.StateIndex := AStateIndex; 260 | SetStateChilds(childNode, AStateIndex); 261 | 262 | childNode := ANode.GetNextChild(childNode); 263 | end; 264 | end; 265 | 266 | procedure TCCEWizardForms.SetStateParents(ANode: TTreeNode); 267 | var 268 | nodeParent: TTreeNode; 269 | hasCheck: Boolean; 270 | hasUnCheck: Boolean; 271 | hasGrayed: Boolean; 272 | childNode: TTreeNode; 273 | index: Integer; 274 | begin 275 | nodeParent := ANode.Parent; 276 | if not Assigned(nodeParent) then 277 | Exit; 278 | 279 | hasCheck := False; 280 | hasUnCheck := False; 281 | hasGrayed := False; 282 | 283 | childNode := nodeParent.getFirstChild; 284 | while childNode <> nil do 285 | begin 286 | index := childNode.StateIndex; 287 | hasCheck := (hasCheck) or (index = CHECKED_INDEX); 288 | hasUnCheck := (hasUnCheck) or (index = UNCHECKED_INDEX); 289 | hasGrayed := (hasGrayed) or (index = GRAYED_INDEX); 290 | 291 | childNode := nodeParent.GetNextChild(childNode); 292 | end; 293 | 294 | index := UNCHECKED_INDEX; 295 | if (hasCheck and hasUnCheck) or (hasGrayed) then 296 | index := GRAYED_INDEX 297 | else 298 | if hasCheck then 299 | index := CHECKED_INDEX; 300 | 301 | nodeParent.StateIndex := index; 302 | SetStateParents(nodeParent); 303 | end; 304 | 305 | procedure TCCEWizardForms.SetStateTreeView; 306 | var 307 | stateIndex: Integer; 308 | nodeSelected: TTreeNode; 309 | begin 310 | nodeSelected := tvPaths.Selected; 311 | nodeSelected.Expanded := not nodeSelected.Expanded; 312 | 313 | stateIndex := UNCHECKED_INDEX; 314 | if nodeSelected.StateIndex = UNCHECKED_INDEX then 315 | stateIndex := CHECKED_INDEX; 316 | 317 | nodeSelected.StateIndex := stateIndex; 318 | 319 | SetStateChilds(nodeSelected, stateIndex); 320 | SetStateParents(nodeSelected); 321 | end; 322 | 323 | constructor TCCEWizardForms.create(AOwner: TComponent); 324 | begin 325 | inherited; 326 | FTreeNodes := TDictionary.create; 327 | end; 328 | 329 | procedure TCCEWizardForms.Delete1Click(Sender: TObject); 330 | begin 331 | lstIgnoreUnits.DeleteSelected; 332 | end; 333 | 334 | destructor TCCEWizardForms.Destroy; 335 | begin 336 | FTreeNodes.Free; 337 | inherited; 338 | end; 339 | 340 | function TCCEWizardForms.GetKeyNode(ANode: TTreeNode): String; 341 | var 342 | nodeParent: TTreeNode; 343 | begin 344 | result := ANode.Text; 345 | nodeParent := ANode.Parent; 346 | while nodeParent <> nil do 347 | begin 348 | result := nodeParent.Text + '\' + Result; 349 | nodeParent := nodeParent.Parent; 350 | end; 351 | 352 | if result.EndsWith('\') then 353 | result := Copy(Result, 1, result.Length - 1); 354 | end; 355 | 356 | function TCCEWizardForms.GetNode(APath: String): TTreeNode; 357 | begin 358 | result := nil; 359 | if FTreeNodes.ContainsKey(APath) then 360 | result := FTreeNodes.Items[APath]; 361 | end; 362 | 363 | procedure TCCEWizardForms.HideTabs; 364 | var 365 | i: Integer; 366 | begin 367 | pgcWizard.ActivePage := tsFiles; 368 | 369 | for i := 0 to Pred(pgcWizard.PageCount) do 370 | pgcWizard.Pages[i].TabVisible := False; 371 | 372 | SelectPageNext; 373 | end; 374 | 375 | procedure TCCEWizardForms.imgAddIgnoreUnitClick(Sender: TObject); 376 | var 377 | LText: string; 378 | begin 379 | LText := edtIgnoreUnit.Text; 380 | if lstIgnoreUnits.Items.IndexOf(LText) < 0 then 381 | lstIgnoreUnits.Items.Add(LText); 382 | end; 383 | 384 | procedure TCCEWizardForms.imgBuildClick(Sender: TObject); 385 | begin 386 | FProject.Build; 387 | end; 388 | 389 | procedure TCCEWizardForms.imgFolderClick(Sender: TObject); 390 | begin 391 | SetCoverage; 392 | OpenFolder(FCoverage.BasePath); 393 | end; 394 | 395 | procedure TCCEWizardForms.imgGithubClick(Sender: TObject); 396 | begin 397 | OpenUrl('https://github.com/gabrielbaltazar/code-coverage-experts'); 398 | end; 399 | 400 | procedure TCCEWizardForms.imgHtmlClick(Sender: TObject); 401 | begin 402 | SetCoverage; 403 | FCoverage.ShowHTMLReport; 404 | end; 405 | 406 | procedure TCCEWizardForms.imgRunClick(Sender: TObject); 407 | begin 408 | SetCoverage; 409 | FCoverage 410 | .Save 411 | .Execute; 412 | end; 413 | 414 | procedure TCCEWizardForms.imgSaveClick(Sender: TObject); 415 | begin 416 | SetCoverage; 417 | FCoverage.Save; 418 | ShowMessage('OK'); 419 | end; 420 | 421 | procedure TCCEWizardForms.imgSetDetailedClick(Sender: TObject); 422 | begin 423 | FProject.SetDetailedMapFile; 424 | ShowMessage('OK'); 425 | end; 426 | 427 | procedure TCCEWizardForms.imgTxtClick(Sender: TObject); 428 | begin 429 | SetCoverage; 430 | FCoverage.ShowLogCoverage; 431 | end; 432 | 433 | procedure TCCEWizardForms.imgXmlClick(Sender: TObject); 434 | begin 435 | SetCoverage; 436 | FCoverage.ShowXMLReport; 437 | end; 438 | 439 | procedure TCCEWizardForms.InitialValues; 440 | begin 441 | edtExeName.Text := FProject.ExeName; 442 | edtMapFileName.Text := FProject.MapFileName; 443 | edtOutputReport.Text := ExtractFilePath(FProject.ExeName) + 'report'; 444 | end; 445 | 446 | procedure TCCEWizardForms.ListPaths; 447 | var 448 | paths: TArray; 449 | i: Integer; 450 | begin 451 | paths := FProject.ListAllPaths; 452 | 453 | for i := 0 to Pred(Length(paths)) do 454 | if TDirectory.Exists(paths[i]) then 455 | begin 456 | ListUnits(Paths[i]); 457 | end; 458 | end; 459 | 460 | procedure TCCEWizardForms.ListUnits(Path: String); 461 | var 462 | units: TArray; 463 | i: Integer; 464 | begin 465 | units := FProject.ListAllUnits(Path); 466 | for i := 0 to Pred(Length( units )) do 467 | AddPathInTreeView(units[i]); 468 | end; 469 | 470 | function TCCEWizardForms.Project(Value: IOTAProject): TCCEWizardForms; 471 | begin 472 | result := Self; 473 | 474 | // if (not Assigned(FProject)) or (FProject.DprFileName <> Value.FileName) then 475 | begin 476 | FTreeNodes.Clear; 477 | tvPaths.Items.Clear; 478 | 479 | FProject := TCCECoreProject.New(Value); 480 | FCoverage := TCCECoreCodeCoverage.New; 481 | 482 | ListPaths; 483 | tvPaths.FullCollapse; 484 | 485 | HideTabs; 486 | InitialValues; 487 | SetCoverage(False); 488 | SetSelectedUnits; 489 | SetIgnoreUnits; 490 | end; 491 | end; 492 | 493 | procedure TCCEWizardForms.btnCloseClick(Sender: TObject); 494 | begin 495 | Close; 496 | end; 497 | 498 | procedure TCCEWizardForms.btnNextClick(Sender: TObject); 499 | begin 500 | SelectPageNext; 501 | end; 502 | 503 | procedure TCCEWizardForms.btnOutputReportClick(Sender: TObject); 504 | begin 505 | selectFolder(edtOutputReport); 506 | end; 507 | 508 | procedure TCCEWizardForms.btnPreviousClick(Sender: TObject); 509 | begin 510 | SelectPagePrevious; 511 | end; 512 | 513 | procedure TCCEWizardForms.SetCoverageUnits; 514 | var 515 | nodeSelect: TArray; 516 | i: Integer; 517 | unitFile: string; 518 | begin 519 | FCoverage.Clear; 520 | nodeSelect := tvPaths.CheckedNodes; 521 | 522 | for i := 0 to Pred(lstIgnoreUnits.Count) do 523 | FCoverage.AddUnitIgnore(lstIgnoreUnits.Items[i]); 524 | 525 | for i := 0 to Pred(Length(nodeSelect)) do 526 | begin 527 | unitFile := GetKeyNode(nodeSelect[i]); 528 | if FileExists(unitFile) then 529 | begin 530 | FCoverage 531 | .AddUnit(unitFile) 532 | .AddPath(ExtractFilePath(unitFile)); 533 | end; 534 | end; 535 | 536 | end; 537 | 538 | procedure TCCEWizardForms.SetIgnoreUnits; 539 | var 540 | LIgnore: TArray; 541 | begin 542 | LIgnore := FCoverage.IgnoredUnits; 543 | lstIgnoreUnits.Clear; 544 | lstIgnoreUnits.Items.AddStrings(LIgnore); 545 | end; 546 | 547 | procedure TCCEWizardForms.searchFile(FilterText, FilterExt: string; AComponent: TCustomEdit); 548 | begin 549 | openTextDialog.Filter := Format('%s | *.%s', [FilterText, FilterExt]); 550 | if openTextDialog.Execute then 551 | AComponent.Text := openTextDialog.FileName; 552 | end; 553 | 554 | procedure TCCEWizardForms.selectFolder(AComponent: TCustomEdit); 555 | var 556 | path: string; 557 | begin 558 | path := FProject.ProjectPath; 559 | if SelectDirectory('Select Directory', '', path) then 560 | AComponent.Text := path; 561 | end; 562 | 563 | procedure TCCEWizardForms.SelectPageNext; 564 | begin 565 | pgcWizard.SelectNextPage(True, False); 566 | btnNext.Enabled := pgcWizard.ActivePageIndex < (pgcWizard.PageCount - 1); 567 | btnPrevious.Enabled := pgcWizard.ActivePageIndex > 0; // (pgcWizard.PageCount - 1); 568 | 569 | setColorButtons; 570 | end; 571 | 572 | procedure TCCEWizardForms.SelectPagePrevious; 573 | begin 574 | pgcWizard.SelectNextPage(False, False); 575 | btnPrevious.Enabled := pgcWizard.ActivePageIndex > 0; 576 | btnNext.Enabled := True; 577 | 578 | setColorButtons; 579 | end; 580 | 581 | procedure TCCEWizardForms.SetColorButtons; 582 | begin 583 | btnNext.Color := COLOR_PRIMARY; 584 | btnPrevious.Color := COLOR_PRIMARY; 585 | 586 | if not btnNext.Enabled then 587 | btnNext.Color := COLOR_DISABLED; 588 | 589 | if not btnPrevious.Enabled then 590 | btnPrevious.Color := COLOR_DISABLED; 591 | end; 592 | 593 | procedure TCCEWizardForms.SetCoverage(ASetUnits: Boolean = True); 594 | begin 595 | if ASetUnits then 596 | SetCoverageUnits; 597 | 598 | FCoverage 599 | .CodeCoverageFileName(edtCoverageExeName.Text) 600 | .ExeFileName(edtExeName.Text) 601 | .MapFileName(edtMapFileName.Text) 602 | .OutputReport(edtOutputReport.Text) 603 | .GenerateHtml(chkHtmlReport.Checked) 604 | .GenerateXml(chkXmlReport.Checked) 605 | .GenerateEmma(chkEmmaReport.Checked) 606 | .GenerateLog(chkLog.Checked) 607 | .UseRelativePath(chkUseRelativePath.Checked); 608 | end; 609 | 610 | procedure TCCEWizardForms.tvPathsDblClick(Sender: TObject); 611 | begin 612 | tvPaths.Items.BeginUpdate; 613 | try 614 | SetStateTreeView; 615 | finally 616 | tvPaths.Items.EndUpdate; 617 | end; 618 | end; 619 | 620 | initialization 621 | 622 | finalization 623 | CCEWizardForms.Free; 624 | 625 | end. 626 | -------------------------------------------------------------------------------- /Source/Src/Third/CCE.dpipes.pas: -------------------------------------------------------------------------------- 1 | { Freepascal pipes unit converted to Delphi. 2 | 3 | License: FPC Modified LGPL (okay to use in commercial projects) 4 | 5 | Changes to the code marked with "L505" in comments } 6 | 7 | { 8 | This file is part of the Free Pascal run time library. 9 | Copyright (c) 1999-2000 by Michael Van Canneyt 10 | 11 | Implementation of pipe stream. 12 | 13 | See the file COPYING.FPC, included in this distribution, 14 | for details about the copyright. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | **********************************************************************} 21 | 22 | 23 | unit CCE.dpipes; 24 | 25 | interface 26 | 27 | uses 28 | system.types, // L505 29 | sysutils, Classes; 30 | 31 | type 32 | EPipeError = Class(EStreamError); 33 | EPipeSeek = Class(EPipeError); 34 | EPipeCreation = Class(EPipeError); 35 | 36 | { TInputPipeStream } 37 | 38 | TInputPipeStream = Class(THandleStream) 39 | Private 40 | FPos : Int64; 41 | function GetNumBytesAvailable: DWord; 42 | procedure WriteNotImplemented; // L505 43 | procedure FakeSeekForward(Offset: Int64; const Origin: TSeekOrigin; 44 | const Pos: Int64); // L505 45 | procedure DiscardLarge(Count: int64; const MaxBufferSize: Longint); // L505 46 | procedure Discard(const Count: Int64); // L505 47 | 48 | protected 49 | function GetPosition: Int64; // override; //L505 50 | procedure InvalidSeek; // override; //L505 51 | public 52 | destructor Destroy; override; 53 | Function Write (Const Buffer; Count : Longint) :Longint; Override; 54 | function Seek(const Offset: int64; Origin: TSeekOrigin): int64; override; 55 | Function Read (Var Buffer; Count : Longint) : longint; Override; 56 | property NumBytesAvailable: DWord read GetNumBytesAvailable; 57 | end; 58 | 59 | TOutputPipeStream = Class(THandleStream) 60 | Private 61 | procedure ReadNotImplemented; // L505 62 | procedure InvalidSeek; // L505 63 | Public 64 | destructor Destroy; override; 65 | function Seek(const Offset: int64; Origin: TSeekOrigin): int64; override; 66 | Function Read(Var Buffer; Count : Longint) : longint; Override; 67 | end; 68 | 69 | Function CreatePipeHandles (Var Inhandle,OutHandle : THandle; APipeBufferSize : Cardinal = 1024) : Boolean; 70 | Procedure CreatePipeStreams (Var InPipe : TInputPipeStream; 71 | Var OutPipe : TOutputPipeStream); 72 | 73 | Const EPipeMsg = 'Failed to create pipe.'; 74 | ENoSeekMsg = 'Cannot seek on pipes'; 75 | 76 | 77 | Implementation 78 | 79 | {$IFDEF MACOS} // L505 80 | {$i CCE.pipes_macos.inc} 81 | {$ENDIF} 82 | 83 | {$IFDEF MSWINDOWS} // L505 84 | {$i CCE.pipes_win.inc} 85 | {$ENDIF} 86 | 87 | 88 | Procedure CreatePipeStreams (Var InPipe : TInputPipeStream; 89 | Var OutPipe : TOutputPipeStream); 90 | Var InHandle,OutHandle: THandle; 91 | begin 92 | if CreatePipeHandles(InHandle, OutHandle) then 93 | begin 94 | InPipe:=TInputPipeStream.Create(InHandle); 95 | OutPipe:=TOutputPipeStream.Create(OutHandle); 96 | end 97 | Else 98 | Raise EPipeCreation.Create(EPipeMsg) 99 | end; 100 | 101 | destructor TInputPipeStream.Destroy; 102 | begin 103 | PipeClose(Handle); 104 | inherited; 105 | end; 106 | 107 | // L505 108 | procedure TInputPipeStream.DiscardLarge(Count: int64; const MaxBufferSize: Longint); 109 | var 110 | Buffer: array of Byte; 111 | begin 112 | if Count=0 then 113 | Exit; 114 | if Count>MaxBufferSize then 115 | SetLength(Buffer,MaxBufferSize) 116 | else 117 | SetLength(Buffer,Count); 118 | while (Count>=Length(Buffer)) do 119 | begin 120 | ReadBuffer(Buffer[0],Length(Buffer)); 121 | Dec(Count,Length(Buffer)); 122 | end; 123 | if Count>0 then 124 | ReadBuffer(Buffer[0],Count); 125 | end; 126 | 127 | // L505 128 | procedure TInputPipeStream.Discard(const Count: Int64); 129 | const 130 | CSmallSize =255; 131 | CLargeMaxBuffer =32*1024; // 32 KiB 132 | var 133 | Buffer: array[1..CSmallSize] of Byte; 134 | begin 135 | if Count=0 then 136 | Exit; 137 | if Count<=SizeOf(Buffer) then 138 | ReadBuffer(Buffer,Count) 139 | else 140 | DiscardLarge(Count,CLargeMaxBuffer); 141 | end; 142 | 143 | // L505 144 | procedure TInputPipeStream.FakeSeekForward(Offset: Int64; const Origin: TSeekOrigin; const Pos: Int64); 145 | //var 146 | // Buffer: Pointer; 147 | // BufferSize, i: LongInt; 148 | begin 149 | if Origin=soBeginning then 150 | Dec(Offset,Pos); 151 | if (Offset<0) or (Origin=soEnd) then 152 | InvalidSeek; 153 | if Offset>0 then 154 | Discard(Offset); 155 | end; 156 | 157 | // L505 158 | procedure TInputPipeStream.WriteNotImplemented; 159 | begin 160 | raise EStreamError.CreateFmt('Cannot write to this stream, not implemented', []); 161 | end; 162 | 163 | // L505 164 | procedure TOutputPipeStream.ReadNotImplemented; 165 | begin 166 | raise EStreamError.CreateFmt('Cannot read from this stream, not implemented', []); 167 | end; 168 | 169 | Function TInputPipeStream.Write(Const Buffer; Count : Longint) : longint; 170 | begin 171 | WriteNotImplemented; 172 | Result := 0; 173 | end; 174 | 175 | Function TInputPipeStream.Read(Var Buffer; Count : Longint) : longint; 176 | begin 177 | Result:=Inherited Read(Buffer,Count); 178 | Inc(FPos,Result); 179 | end; 180 | 181 | function TInputPipeStream.Seek(const Offset: int64; Origin: TSeekOrigin): int64; 182 | begin 183 | FakeSeekForward(Offset,Origin,FPos); 184 | Result:=FPos; 185 | end; 186 | 187 | destructor TOutputPipeStream.Destroy; 188 | begin 189 | PipeClose(Handle); 190 | inherited; 191 | end; 192 | 193 | Function TOutputPipeStream.Read(Var Buffer; Count : Longint) : longint; 194 | begin 195 | ReadNotImplemented; 196 | Result := 0; 197 | end; 198 | 199 | procedure TOutputPipeStream.InvalidSeek; 200 | begin 201 | raise EStreamError.CreateFmt('Invalid seek in TProcess', []); 202 | end; 203 | 204 | function TOutputPipeStream.Seek(const Offset: int64; Origin: TSeekOrigin): int64; 205 | begin 206 | Result:=0; { to silence warning mostly } 207 | InvalidSeek; 208 | end; 209 | 210 | end. 211 | 212 | -------------------------------------------------------------------------------- /Source/Src/Third/CCE.dprocess.pas: -------------------------------------------------------------------------------- 1 | { Freepascal TProcess ported to Delphi 2 | 3 | License: FPC Modified LGPL (can use in commercial apps) 4 | 5 | Changes to the code marked with "L505" in comments } 6 | 7 | { 8 | This file is part of the Free Component Library (FCL) 9 | Copyright (c) 1999-2000 by the Free Pascal development team 10 | 11 | See the file COPYING.FPC, included in this distribution, 12 | for details about the copyright. 13 | 14 | This program is distributed in the hope that it will be useful, 15 | but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 17 | 18 | **********************************************************************} 19 | 20 | unit CCE.dprocess; 21 | 22 | interface 23 | 24 | uses 25 | classes, 26 | CCE.dpipes, // L505 27 | system.types,//L505 28 | sysutils; 29 | 30 | 31 | Type 32 | TProcessOption = (poRunSuspended,poWaitOnExit, 33 | poUsePipes,poStderrToOutPut, 34 | poNoConsole,poNewConsole, 35 | poDefaultErrorMode,poNewProcessGroup, 36 | poDebugProcess,poDebugOnlyThisProcess); 37 | 38 | TShowWindowOptions = (swoNone,swoHIDE,swoMaximize,swoMinimize,swoRestore,swoShow, 39 | swoShowDefault,swoShowMaximized,swoShowMinimized, 40 | swoshowMinNOActive,swoShowNA,swoShowNoActivate,swoShowNormal); 41 | 42 | TStartupOption = (suoUseShowWindow,suoUseSize,suoUsePosition, 43 | suoUseCountChars,suoUseFillAttribute); 44 | 45 | TProcessPriority = (ppHigh,ppIdle,ppNormal,ppRealTime); 46 | 47 | TProcessOptions = set of TProcessOption; 48 | TStartupOptions = set of TStartupOption; 49 | 50 | 51 | Type 52 | {$ifdef MACOS} //L505 53 | TProcessForkEvent = procedure(Sender : TObject) of object; 54 | {$endif} 55 | 56 | { TProcess } 57 | 58 | TProcess = Class (TComponent) 59 | Private 60 | FProcessOptions : TProcessOptions; 61 | FStartupOptions : TStartupOptions; 62 | FProcessID : Integer; 63 | FThreadID : Integer; 64 | FProcessHandle : Thandle; 65 | FThreadHandle : Thandle; 66 | FFillAttribute : Cardinal; 67 | FApplicationName : string; 68 | FConsoleTitle : String; 69 | FCommandLine : String; 70 | FCurrentDirectory : String; 71 | FDesktop : String; 72 | FEnvironment : Tstrings; 73 | FExecutable : String; 74 | FParameters : TStrings; 75 | FShowWindow : TShowWindowOptions; 76 | FInherithandles : Boolean; 77 | {$ifdef MACOS} // L505 78 | FForkEvent : TProcessForkEvent; 79 | {$endif} 80 | FProcessPriority : TProcessPriority; 81 | dwXCountchars, 82 | dwXSize, 83 | dwYsize, 84 | dwx, 85 | dwYcountChars, 86 | dwy : Cardinal; 87 | FXTermProgram: String; 88 | FPipeBufferSize : cardinal; 89 | Procedure FreeStreams; 90 | Function GetExitStatus : Integer; 91 | Function GetExitCode : Integer; 92 | Function GetRunning : Boolean; 93 | Function GetWindowRect : TRect; 94 | procedure SetCommandLine(const AValue: String); 95 | procedure SetParameters(const AValue: TStrings); 96 | Procedure SetWindowRect (Value : TRect); 97 | Procedure SetShowWindow (Value : TShowWindowOptions); 98 | Procedure SetWindowColumns (Value : Cardinal); 99 | Procedure SetWindowHeight (Value : Cardinal); 100 | Procedure SetWindowLeft (Value : Cardinal); 101 | Procedure SetWindowRows (Value : Cardinal); 102 | Procedure SetWindowTop (Value : Cardinal); 103 | Procedure SetWindowWidth (Value : Cardinal); 104 | procedure SetApplicationName(const Value: String); 105 | procedure SetProcessOptions(const Value: TProcessOptions); 106 | procedure SetActive(const Value: Boolean); 107 | procedure SetEnvironment(const Value: TStrings); 108 | Procedure ConvertCommandLine; 109 | function PeekExitStatus: Boolean; 110 | Protected 111 | FRunning : Boolean; 112 | FExitCode : Cardinal; 113 | FInputStream : TOutputPipeStream; 114 | FOutputStream : TInputPipeStream; 115 | FStderrStream : TInputPipeStream; 116 | procedure CloseProcessHandles; virtual; 117 | Procedure CreateStreams(InHandle,OutHandle,ErrHandle : Longint);virtual; 118 | procedure FreeStream(var AStream: THandleStream); 119 | procedure Loaded; override; 120 | Public 121 | Constructor Create (AOwner : TComponent);override; 122 | Destructor Destroy; override; 123 | Procedure Execute; virtual; 124 | procedure CloseInput; virtual; 125 | procedure CloseOutput; virtual; 126 | procedure CloseStderr; virtual; 127 | Function Resume : Integer; virtual; 128 | Function Suspend : Integer; virtual; 129 | Function Terminate (AExitCode : Integer): Boolean; virtual; 130 | Function WaitOnExit : Boolean; 131 | Property WindowRect : Trect Read GetWindowRect Write SetWindowRect; 132 | Property Handle : THandle Read FProcessHandle; 133 | Property ProcessHandle : THandle Read FProcessHandle; 134 | Property ThreadHandle : THandle Read FThreadHandle; 135 | Property ProcessID : Integer Read FProcessID; 136 | Property ThreadID : Integer Read FThreadID; 137 | Property Input : TOutputPipeStream Read FInputStream; 138 | Property Output : TInputPipeStream Read FOutputStream; 139 | Property Stderr : TinputPipeStream Read FStderrStream; 140 | Property ExitStatus : Integer Read GetExitStatus; 141 | Property ExitCode : Integer Read GetExitCode; 142 | Property InheritHandles : Boolean Read FInheritHandles Write FInheritHandles; 143 | {$ifdef MACOS} // L505 144 | property OnForkEvent : TProcessForkEvent Read FForkEvent Write FForkEvent; 145 | {$endif} 146 | Published 147 | property PipeBufferSize : cardinal read FPipeBufferSize write FPipeBufferSize default 1024; 148 | Property Active : Boolean Read GetRunning Write SetActive; 149 | Property ApplicationName : String Read FApplicationName Write SetApplicationName; //deprecated; //L505 150 | Property CommandLine : String Read FCommandLine Write SetCommandLine ; //deprecated; //L505 151 | Property Executable : String Read FExecutable Write FExecutable; 152 | Property Parameters : TStrings Read FParameters Write SetParameters; 153 | Property ConsoleTitle : String Read FConsoleTitle Write FConsoleTitle; 154 | Property CurrentDirectory : String Read FCurrentDirectory Write FCurrentDirectory; 155 | Property Desktop : String Read FDesktop Write FDesktop; 156 | Property Environment : TStrings Read FEnvironment Write SetEnvironment; 157 | Property Options : TProcessOptions Read FProcessOptions Write SetProcessOptions; 158 | Property Priority : TProcessPriority Read FProcessPriority Write FProcessPriority; 159 | Property StartupOptions : TStartupOptions Read FStartupOptions Write FStartupOptions; 160 | Property Running : Boolean Read GetRunning; 161 | Property ShowWindow : TShowWindowOptions Read FShowWindow Write SetShowWindow; 162 | Property WindowColumns : Cardinal Read dwXCountChars Write SetWindowColumns; 163 | Property WindowHeight : Cardinal Read dwYSize Write SetWindowHeight; 164 | Property WindowLeft : Cardinal Read dwX Write SetWindowLeft; 165 | Property WindowRows : Cardinal Read dwYCountChars Write SetWindowRows; 166 | Property WindowTop : Cardinal Read dwY Write SetWindowTop ; 167 | Property WindowWidth : Cardinal Read dwXSize Write SetWindowWidth; 168 | Property FillAttribute : Cardinal read FFillAttribute Write FFillAttribute; 169 | Property XTermProgram : String Read FXTermProgram Write FXTermProgram; 170 | end; 171 | 172 | EProcess = Class(Exception); 173 | 174 | Procedure CommandToList(S : String; List : TStrings); 175 | 176 | {$ifdef MACOS} //L505 177 | Var 178 | TryTerminals : Array of string; 179 | XTermProgram : String; 180 | Function DetectXTerm : String; 181 | {$endif} 182 | 183 | { // L505: changed to ansistring 184 | function RunCommandIndir(const curdir:string;const exename:string;const commands:array of string;out outputstring:string; out exitstatus:integer; Options : TProcessOptions = []):integer; overload; //L505 185 | function RunCommandIndir(const curdir:string;const exename:string;const commands:array of string;out outputstring:string; Options : TProcessOptions = []):boolean; overload; // L505 186 | function RunCommand(const exename:string;const commands:array of string;out outputstring:string; Options : TProcessOptions = []):boolean; overload;// L505 187 | 188 | 189 | function RunCommandInDir(const curdir,cmdline:string;out outputstring:string):boolean; deprecated; overload; // L505 190 | function RunCommand(const cmdline:string;out outputstring:string):boolean; deprecated; overload; // L505 191 | } 192 | 193 | function RunCommandIndir(const curdir: string; const exename: string; const commands: array of string; out outputstring: ansistring; out exitstatus:integer; Options : TProcessOptions = []):integer; overload; //L505 194 | function RunCommandIndir(const curdir: string; const exename: string; const commands: array of string; out outputstring: ansistring; Options : TProcessOptions = []):boolean; overload; // L505 195 | function RunCommand(const exename: string; const commands: array of string; out outputstring: ansistring; Options : TProcessOptions = []):boolean; overload;// L505 196 | 197 | 198 | function RunCommandInDir(const curdir,cmdline:string;out outputstring:ansistring):boolean; deprecated; overload; // L505 199 | function RunCommand(const cmdline:string;out outputstring:ansistring):boolean; deprecated; overload; // L505 200 | 201 | 202 | implementation 203 | 204 | {$IFDEF MACOS} //L505 205 | {$i CCE.process_macos.inc} 206 | {$ENDIF} 207 | 208 | {$IFDEF MSWINDOWS} //L505 209 | {$i CCE.process_win.inc} 210 | {$ENDIF} 211 | 212 | Procedure CommandToList(S : String; List : TStrings); 213 | 214 | Function GetNextWord : String; 215 | 216 | Const 217 | WhiteSpace = [' ',#9,#10,#13]; 218 | Literals = ['"','''']; 219 | 220 | Var 221 | Wstart,wend : Integer; 222 | InLiteral : Boolean; 223 | LastLiteral : char; 224 | 225 | begin 226 | WStart:=1; 227 | // L505 change "in" to CharInSet 228 | While (WStart<=Length(S)) and (CharInSet(S[WStart], WhiteSpace)) do 229 | Inc(WStart); 230 | WEnd:=WStart; 231 | InLiteral:=False; 232 | LastLiteral:=#0; 233 | // L505 234 | // While (Wend<=Length(S)) and (Not (S[Wend] in WhiteSpace) or InLiteral) do 235 | While (Wend<=Length(S)) and (Not (CharInSet(S[Wend], WhiteSpace)) or InLiteral) do 236 | begin 237 | // L505 changed "in" to CharInSet 238 | if CharInSet(S[Wend], Literals) then 239 | If InLiteral then 240 | InLiteral:=Not (S[Wend]=LastLiteral) 241 | else 242 | begin 243 | InLiteral:=True; 244 | LastLiteral:=S[Wend]; 245 | end; 246 | inc(wend); 247 | end; 248 | 249 | Result:=Copy(S,WStart,WEnd-WStart); 250 | // L505 changed "in" to CharInSet 251 | if (Length(Result) > 0) 252 | and (Result[1] = Result[Length(Result)]) // if 1st char = last char and.. 253 | and (CharInSet(Result[1], Literals)) then // it's one of the literals, then 254 | Result:=Copy(Result, 2, Length(Result) - 2); //delete the 2 (but not others in it) 255 | // L505 256 | // While (WEnd<=Length(S)) and (S[Wend] in WhiteSpace) do 257 | While (WEnd<=Length(S)) and (CharInSet(S[Wend], WhiteSpace)) do 258 | inc(Wend); 259 | Delete(S,1,WEnd-1); 260 | 261 | end; 262 | 263 | Var 264 | W : String; 265 | 266 | begin 267 | While Length(S)>0 do 268 | begin 269 | W:=GetNextWord; 270 | If (W<>'') then 271 | List.Add(W); 272 | end; 273 | end; 274 | 275 | Constructor TProcess.Create (AOwner : TComponent); 276 | begin 277 | Inherited; 278 | FProcessPriority:=ppNormal; 279 | FShowWindow:=swoNone; 280 | FInheritHandles:=True; 281 | {$ifdef MACOS} // L505 282 | FForkEvent:=nil; 283 | {$endif} 284 | FPipeBufferSize := 1024; 285 | FEnvironment:=TStringList.Create; 286 | FParameters:=TStringList.Create; 287 | end; 288 | 289 | Destructor TProcess.Destroy; 290 | begin 291 | FParameters.Free; 292 | FEnvironment.Free; 293 | FreeStreams; 294 | CloseProcessHandles; 295 | Inherited Destroy; 296 | end; 297 | 298 | Procedure TProcess.FreeStreams; 299 | begin 300 | If FStderrStream<>FOutputStream then 301 | FreeStream(THandleStream(FStderrStream)); 302 | FreeStream(THandleStream(FOutputStream)); 303 | FreeStream(THandleStream(FInputStream)); 304 | end; 305 | 306 | Function TProcess.GetExitStatus : Integer; 307 | begin 308 | GetRunning; 309 | Result:=FExitCode; 310 | end; 311 | 312 | {$IFNDEF OS_HASEXITCODE} 313 | Function TProcess.GetExitCode : Integer; 314 | begin 315 | if Not Running then 316 | Result:=GetExitStatus 317 | else 318 | Result:=0 319 | end; 320 | {$ENDIF} 321 | 322 | Function TProcess.GetRunning : Boolean; 323 | begin 324 | IF FRunning then 325 | FRunning:=Not PeekExitStatus; 326 | Result:=FRunning; 327 | end; 328 | 329 | Procedure TProcess.CreateStreams(InHandle,OutHandle,ErrHandle : Longint); 330 | 331 | begin 332 | FreeStreams; 333 | FInputStream:=TOutputPipeStream.Create (InHandle); 334 | FOutputStream:=TInputPipeStream.Create (OutHandle); 335 | if Not (poStderrToOutput in FProcessOptions) then 336 | FStderrStream:=TInputPipeStream.Create(ErrHandle); 337 | end; 338 | 339 | procedure TProcess.FreeStream(var AStream: THandleStream); 340 | begin 341 | if AStream = nil then exit; 342 | FreeAndNil(AStream); 343 | end; 344 | 345 | procedure TProcess.Loaded; 346 | begin 347 | inherited Loaded; 348 | If (csDesigning in ComponentState) and (FCommandLine<>'') then 349 | ConvertCommandLine; 350 | end; 351 | 352 | procedure TProcess.CloseInput; 353 | begin 354 | FreeStream(THandleStream(FInputStream)); 355 | end; 356 | 357 | procedure TProcess.CloseOutput; 358 | begin 359 | FreeStream(THandleStream(FOutputStream)); 360 | end; 361 | 362 | procedure TProcess.CloseStderr; 363 | begin 364 | FreeStream(THandleStream(FStderrStream)); 365 | end; 366 | 367 | Procedure TProcess.SetWindowColumns (Value : Cardinal); 368 | begin 369 | if Value<>0 then 370 | Include(FStartupOptions,suoUseCountChars); 371 | dwXCountChars:=Value; 372 | end; 373 | 374 | 375 | Procedure TProcess.SetWindowHeight (Value : Cardinal); 376 | begin 377 | if Value<>0 then 378 | include(FStartupOptions,suoUsePosition); 379 | dwYSize:=Value; 380 | end; 381 | 382 | Procedure TProcess.SetWindowLeft (Value : Cardinal); 383 | begin 384 | if Value<>0 then 385 | Include(FStartupOptions,suoUseSize); 386 | dwx:=Value; 387 | end; 388 | 389 | Procedure TProcess.SetWindowTop (Value : Cardinal); 390 | begin 391 | if Value<>0 then 392 | Include(FStartupOptions,suoUsePosition); 393 | dwy:=Value; 394 | end; 395 | 396 | Procedure TProcess.SetWindowWidth (Value : Cardinal); 397 | begin 398 | If (Value<>0) then 399 | Include(FStartupOptions,suoUseSize); 400 | dwXSize:=Value; 401 | end; 402 | 403 | Function TProcess.GetWindowRect : TRect; 404 | begin 405 | With Result do 406 | begin 407 | Left:=dwx; 408 | Right:=dwx+dwxSize; 409 | Top:=dwy; 410 | Bottom:=dwy+dwysize; 411 | end; 412 | end; 413 | 414 | procedure TProcess.SetCommandLine(const AValue: String); 415 | begin 416 | if FCommandLine=AValue then exit; 417 | FCommandLine:=AValue; 418 | If Not (csLoading in ComponentState) then 419 | ConvertCommandLine; 420 | end; 421 | 422 | procedure TProcess.SetParameters(const AValue: TStrings); 423 | begin 424 | FParameters.Assign(AValue); 425 | end; 426 | 427 | Procedure TProcess.SetWindowRect (Value : Trect); 428 | begin 429 | Include(FStartupOptions,suoUseSize); 430 | Include(FStartupOptions,suoUsePosition); 431 | With Value do 432 | begin 433 | dwx:=Left; 434 | dwxSize:=Right-Left; 435 | dwy:=Top; 436 | dwySize:=Bottom-top; 437 | end; 438 | end; 439 | 440 | Procedure TProcess.SetWindowRows (Value : Cardinal); 441 | begin 442 | if Value<>0 then 443 | Include(FStartupOptions,suoUseCountChars); 444 | dwYCountChars:=Value; 445 | end; 446 | 447 | procedure TProcess.SetApplicationName(const Value: String); 448 | begin 449 | FApplicationName := Value; 450 | If (csDesigning in ComponentState) and 451 | (FCommandLine='') then 452 | FCommandLine:=Value; 453 | end; 454 | 455 | procedure TProcess.SetProcessOptions(const Value: TProcessOptions); 456 | begin 457 | FProcessOptions := Value; 458 | If poNewConsole in FProcessOptions then 459 | Exclude(FProcessOptions,poNoConsole); 460 | if poRunSuspended in FProcessOptions then 461 | Exclude(FProcessOptions,poWaitOnExit); 462 | end; 463 | 464 | procedure TProcess.SetActive(const Value: Boolean); 465 | begin 466 | if (Value<>GetRunning) then 467 | If Value then 468 | Execute 469 | else 470 | Terminate(0); 471 | end; 472 | 473 | procedure TProcess.SetEnvironment(const Value: TStrings); 474 | begin 475 | FEnvironment.Assign(Value); 476 | end; 477 | 478 | procedure TProcess.ConvertCommandLine; 479 | begin 480 | FParameters.Clear; 481 | CommandToList(FCommandLine,FParameters); 482 | If FParameters.Count>0 then 483 | begin 484 | Executable:=FParameters[0]; 485 | FParameters.Delete(0); 486 | end; 487 | end; 488 | 489 | Const 490 | READ_BYTES = 65536; // not too small to avoid fragmentation when reading large files. 491 | 492 | // helperfunction that does the bulk of the work. 493 | // We need to also collect stderr output in order to avoid 494 | // lock out if the stderr pipe is full. 495 | // L505: changed to ansistring 496 | // function internalRuncommand(p:TProcess;out outputstring: string; 497 | // out stderrstring: string; out exitstatus:integer):integer; 498 | function internalRuncommand(p:TProcess;out outputstring: ansistring; 499 | out stderrstring: ansistring; out exitstatus:integer):integer; 500 | var 501 | numbytes,bytesread,available : integer; 502 | outputlength, stderrlength : integer; 503 | stderrnumbytes,stderrbytesread : integer; 504 | begin 505 | bytesread:=0; 506 | outputlength:=0; 507 | stderrbytesread:=0; 508 | stderrlength:=0; 509 | 510 | try 511 | try 512 | p.Options := p.Options + [poUsePipes]; 513 | p.Execute; 514 | 515 | while p.Running do 516 | begin 517 | // Only call ReadFromStream if Data from corresponding stream 518 | // is already available, otherwise, on linux, the read call 519 | // is blocking, and thus it is not possible to be sure to handle 520 | // big data amounts bboth on output and stderr pipes. PM. 521 | available:=P.Output.NumBytesAvailable; 522 | // writeln('DEBUG: bytesavail: ', P.Output.NumBytesAvailable); 523 | if available > 0 then 524 | begin 525 | if (BytesRead + available > outputlength) then 526 | begin 527 | outputlength:=BytesRead + READ_BYTES; 528 | Setlength(outputstring,outputlength); 529 | end; 530 | NumBytes := p.Output.Read(outputstring[1+bytesread], available); 531 | // L505 if in the future above string is unicodestring, above may need work NOTE: pchar is zero based . http://docwiki.embarcadero.com/RADStudio/Seattle/en/Using_Streams_to_Read_or_Write_Data 532 | // NumBytes := p.Output.Read(pchar(outputstring)[bytesread], available); 533 | 534 | if NumBytes > 0 then 535 | Inc(BytesRead, NumBytes); 536 | end 537 | // The check for assigned(P.stderr) is mainly here so that 538 | // if we use poStderrToOutput in p.Options, we do not access invalid memory. 539 | else if assigned(P.stderr) and (P.StdErr.NumBytesAvailable > 0) then 540 | begin 541 | available:=P.StdErr.NumBytesAvailable; 542 | if (StderrBytesRead + available > stderrlength) then 543 | begin 544 | stderrlength:=StderrBytesRead + READ_BYTES; 545 | Setlength(stderrstring,stderrlength); 546 | end; 547 | StderrNumBytes := p.StdErr.Read(stderrstring[1+StderrBytesRead], available); 548 | // L505 in the future if the above is a unicodestring this may need work, and NOTE: pchar is zero based 549 | // StderrNumBytes := p.StdErr.Read(pchar(stderrstring)[StderrBytesRead], available); 550 | 551 | if StderrNumBytes > 0 then 552 | Inc(StderrBytesRead, StderrNumBytes); 553 | end 554 | else 555 | Sleep(100); 556 | end; 557 | // Get left output after end of execution 558 | available:=P.Output.NumBytesAvailable; 559 | while available > 0 do 560 | begin 561 | if (BytesRead + available > outputlength) then 562 | begin 563 | outputlength:=BytesRead + READ_BYTES; 564 | Setlength(outputstring,outputlength); 565 | end; 566 | NumBytes := p.Output.Read(outputstring[1+bytesread], available); 567 | // L505 if above is unicodestring in the future it may need work, and NOTE: pchar is zero based 568 | // NumBytes := p.Output.Read(pchar(outputstring)[bytesread], available); 569 | 570 | if NumBytes > 0 then 571 | Inc(BytesRead, NumBytes); 572 | available:=P.Output.NumBytesAvailable; 573 | end; 574 | setlength(outputstring,BytesRead); 575 | while assigned(P.stderr) and (P.Stderr.NumBytesAvailable > 0) do 576 | begin 577 | available:=P.Stderr.NumBytesAvailable; 578 | if (StderrBytesRead + available > stderrlength) then 579 | begin 580 | stderrlength:=StderrBytesRead + READ_BYTES; 581 | Setlength(stderrstring,stderrlength); 582 | end; 583 | StderrNumBytes := p.StdErr.Read(stderrstring[1+StderrBytesRead], available); 584 | // L505 if above is unicodestring in the future, it may need work and NOTE: pchar is zero based 585 | // StderrNumBytes := p.StdErr.Read(pchar(stderrstring)[StderrBytesRead], available); 586 | 587 | if StderrNumBytes > 0 then 588 | Inc(StderrBytesRead, StderrNumBytes); 589 | end; 590 | setlength(stderrstring,StderrBytesRead); 591 | exitstatus:=p.exitstatus; 592 | result:=0; // we came to here, document that. 593 | except 594 | on e : Exception do 595 | begin 596 | result:=1; 597 | setlength(outputstring,BytesRead); 598 | end; 599 | end; 600 | finally 601 | p.free; 602 | end; 603 | end; 604 | 605 | { Functions without StderrString } 606 | 607 | Const 608 | ForbiddenOptions = [poRunSuspended,poWaitOnExit]; 609 | 610 | // L505 changed to ansistring 611 | // function RunCommandIndir(const curdir:string;const exename:string;const commands:array of string;out outputstring:string;out exitstatus:integer; Options : TProcessOptions = []):integer; 612 | function RunCommandIndir(const curdir: string; const exename: string; const commands:array of string; out outputstring: ansistring;out exitstatus:integer; Options : TProcessOptions = []):integer; 613 | Var 614 | p : TProcess; 615 | i : integer; 616 | // ErrorString : String; // L505 617 | ErrorString: ansistring; 618 | begin 619 | p:=TProcess.create(nil); 620 | if Options<>[] then 621 | P.Options:=Options - ForbiddenOptions; 622 | p.Executable:=exename; 623 | if curdir<>'' then 624 | p.CurrentDirectory:=curdir; 625 | if high(commands)>=0 then 626 | for i:=low(commands) to high(commands) do 627 | p.Parameters.add(commands[i]); 628 | result:=internalruncommand(p,outputstring,errorstring,exitstatus); 629 | end; 630 | 631 | // L505 changed to ansistring 632 | // function RunCommandInDir(const curdir,cmdline:string;out outputstring:string):boolean; deprecated; 633 | function RunCommandInDir(const curdir,cmdline:string;out outputstring: ansistring):boolean; deprecated; 634 | Var 635 | p : TProcess; 636 | exitstatus : integer; 637 | // ErrorString : String; // L505 638 | ErrorString: ansistring; // L505 639 | begin 640 | p:=TProcess.create(nil); 641 | p.setcommandline(cmdline); 642 | if curdir<>'' then 643 | p.CurrentDirectory:=curdir; 644 | result:=internalruncommand(p,outputstring,errorstring,exitstatus)=0; 645 | if exitstatus<>0 then result:=false; 646 | end; 647 | 648 | // L505 changed to ansistring 649 | // function RunCommandIndir(const curdir:string;const exename:string;const commands:array of string;out outputstring:string; Options : TProcessOptions = []):boolean; 650 | function RunCommandIndir(const curdir: string; const exename: string; const commands:array of string; out outputstring: ansistring; Options : TProcessOptions = []):boolean; 651 | Var 652 | p : TProcess; 653 | i, 654 | exitstatus : integer; 655 | // ErrorString : String; // L505 656 | ErrorString: ansistring; // L505 657 | begin 658 | p:=TProcess.create(nil); 659 | if Options<>[] then 660 | P.Options:=Options - ForbiddenOptions; 661 | p.Executable:=exename; 662 | if curdir<>'' then 663 | p.CurrentDirectory:=curdir; 664 | if high(commands)>=0 then 665 | for i:=low(commands) to high(commands) do 666 | p.Parameters.add(commands[i]); 667 | result:=internalruncommand(p,outputstring,errorstring,exitstatus)=0; 668 | if exitstatus<>0 then result:=false; 669 | end; 670 | 671 | // L505 changed to ansistring 672 | // function RunCommand(const cmdline:string; out outputstring:string):boolean; deprecated; 673 | function RunCommand(const cmdline: string; out outputstring: ansistring):boolean; deprecated; 674 | Var 675 | p : TProcess; 676 | exitstatus : integer; 677 | // ErrorString : String; // L505 678 | ErrorString: ansistring; // L505 679 | begin 680 | p:=TProcess.create(nil); 681 | p.setcommandline(cmdline); 682 | result:=internalruncommand(p,outputstring,errorstring,exitstatus)=0; 683 | if exitstatus<>0 then result:=false; 684 | end; 685 | 686 | // L505: Changed to ansistring 687 | // function RunCommand(const exename:string;const commands:array of string;out outputstring:string; Options : TProcessOptions = []):boolean; 688 | function RunCommand(const exename:string; const commands:array of string; out outputstring: ansistring; Options : TProcessOptions = []):boolean; 689 | Var 690 | p : TProcess; 691 | i, 692 | exitstatus : integer; 693 | // ErrorString : String; // L505 694 | ErrorString: ansistring; // L505 695 | begin 696 | p:=TProcess.create(nil); 697 | if Options<>[] then 698 | P.Options:=Options - ForbiddenOptions; 699 | p.Executable:=exename; 700 | if high(commands)>=0 then 701 | for i:=low(commands) to high(commands) do 702 | p.Parameters.add(commands[i]); 703 | result:=internalruncommand(p,outputstring,errorstring,exitstatus)=0; 704 | if exitstatus<>0 then result:=false; 705 | end; 706 | 707 | end. 708 | 709 | -------------------------------------------------------------------------------- /Source/Src/Third/CCE.pipes_win.inc: -------------------------------------------------------------------------------- 1 | { Freepascal pipes unit converted to Delphi (needed for TProcess) 2 | 3 | License: FPC Modified LGPL (okay to use in commercial projects) 4 | 5 | Changes to the code marked with "L505" in comments } 6 | 7 | { 8 | This file is part of the Free Pascal run time library. 9 | Copyright (c) 1998 by Michael Van Canneyt 10 | 11 | Win part of pipe stream. 12 | 13 | See the file COPYING.FPC, included in this distribution, 14 | for details about the copyright. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 19 | 20 | **********************************************************************} 21 | uses 22 | windows; //L505 23 | 24 | // L505 25 | type 26 | PSecurityAttributes = ^TSecurityAttributes; 27 | TSecurityAttributes = record 28 | nLength : DWORD; 29 | lpSecurityDescriptor : Pointer; 30 | bInheritHandle : BOOL; 31 | end; 32 | 33 | Const piInheritablePipe : TSecurityAttributes = ( 34 | nlength:SizeOF(TSecurityAttributes); 35 | lpSecurityDescriptor:Nil; 36 | Binherithandle:True); 37 | piNonInheritablePipe : TSecurityAttributes = ( 38 | nlength:SizeOF(TSecurityAttributes); 39 | lpSecurityDescriptor:Nil; 40 | Binherithandle:False); 41 | 42 | 43 | PipeBufSize = 1024; 44 | 45 | 46 | Function CreatePipeHandles (Var Inhandle,OutHandle : THandle; APipeBufferSize : Cardinal = PipeBufSize) : Boolean; 47 | begin 48 | // L505 49 | // Result := CreatePipe(@Inhandle,@OutHandle,@piNonInheritablePipe,APipeBufferSize); 50 | Result := CreatePipe(Inhandle,OutHandle,@piNonInheritablePipe,APipeBufferSize); 51 | //writeln('DEBUG: createpipe result: ', result); 52 | end; 53 | 54 | Function TInputPipeStream.GetNumBytesAvailable: DWord; 55 | begin 56 | if not PeekNamedPipe(Handle, nil, 0, nil, @Result, nil) then 57 | Result := 0; 58 | end; 59 | 60 | function TInputPipeStream.GetPosition: Int64; 61 | begin 62 | Result:=FPos; 63 | end; 64 | 65 | procedure TInputPipeStream.InvalidSeek; 66 | begin 67 | Raise EPipeSeek.Create(ENoSeekMsg); 68 | end; 69 | 70 | procedure PipeClose(const FHandle: THandle); inline; 71 | begin 72 | FileClose(FHandle); 73 | end; -------------------------------------------------------------------------------- /Source/Src/Third/CCE.process_win.inc: -------------------------------------------------------------------------------- 1 | { Freepascal TProcess ported to Delphi 2 | 3 | License: FPC Modified LGPL (can use in commercial apps) 4 | 5 | Changes to the code marked with "L505" in comments } 6 | 7 | { 8 | This file is part of the Free Component Library (FCL) 9 | Copyright (c) 1999-2008 by the Free Pascal development team 10 | 11 | See the file COPYING.FPC, included in this distribution, 12 | for details about the copyright. 13 | 14 | This program is distributed in the hope that it will be useful, 15 | but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 17 | 18 | **********************************************************************} 19 | 20 | Uses 21 | Windows; 22 | 23 | 24 | Resourcestring 25 | SNoCommandLine = 'Cannot execute empty command-line'; 26 | SErrCannotExecute = 'Failed to execute %s : %d'; 27 | { SErrNoSuchProgram = 'Executable not found: "%s"'; 28 | SErrNoTerminalProgram = 'Could not detect X-Terminal program'; 29 | } 30 | 31 | Const 32 | PriorityConstants : Array [TProcessPriority] of Cardinal = 33 | (HIGH_PRIORITY_CLASS,IDLE_PRIORITY_CLASS, 34 | NORMAL_PRIORITY_CLASS,REALTIME_PRIORITY_CLASS); 35 | 36 | procedure TProcess.CloseProcessHandles; 37 | begin 38 | if (FProcessHandle<>0) then 39 | CloseHandle(FProcessHandle); 40 | if (FThreadHandle<>0) then 41 | CloseHandle(FThreadHandle); 42 | end; 43 | 44 | Function TProcess.PeekExitStatus : Boolean; 45 | 46 | begin 47 | GetExitCodeProcess(ProcessHandle,FExitCode); 48 | Result:=(FExitCode<>Still_Active); 49 | end; 50 | 51 | Function GetStartupFlags (P : TProcess): Cardinal; 52 | 53 | begin 54 | With P do 55 | begin 56 | Result:=0; 57 | if poUsePipes in FProcessOptions then 58 | Result:=Result or Startf_UseStdHandles; 59 | if suoUseShowWindow in FStartupOptions then 60 | Result:=Result or startf_USESHOWWINDOW; 61 | if suoUSESIZE in FStartupOptions then 62 | Result:=Result or startf_usesize; 63 | if suoUsePosition in FStartupOptions then 64 | Result:=Result or startf_USEPOSITION; 65 | if suoUSECOUNTCHARS in FStartupoptions then 66 | Result:=Result or startf_usecountchars; 67 | if suoUsefIllAttribute in FStartupOptions then 68 | Result:=Result or startf_USEFILLATTRIBUTE; 69 | end; 70 | end; 71 | 72 | Function GetCreationFlags(P : TProcess) : Cardinal; 73 | 74 | begin 75 | With P do 76 | begin 77 | Result:=0; 78 | if poNoConsole in FProcessOptions then 79 | Result:=Result or Detached_Process; 80 | if poNewConsole in FProcessOptions then 81 | Result:=Result or Create_new_console; 82 | if poNewProcessGroup in FProcessOptions then 83 | Result:=Result or CREATE_NEW_PROCESS_GROUP; 84 | If poRunSuspended in FProcessOptions Then 85 | Result:=Result or Create_Suspended; 86 | if poDebugProcess in FProcessOptions Then 87 | Result:=Result or DEBUG_PROCESS; 88 | if poDebugOnlyThisProcess in FProcessOptions Then 89 | Result:=Result or DEBUG_ONLY_THIS_PROCESS; 90 | if poDefaultErrorMode in FProcessOptions Then 91 | Result:=Result or CREATE_DEFAULT_ERROR_MODE; 92 | result:=result or PriorityConstants[FProcessPriority]; 93 | end; 94 | end; 95 | 96 | //L505 note: unicode string could be used, but msdn says CREATE_UNICODE_ENVIRONMENT 97 | // must be used with CreateProcessW. For now, ansistring will be used instead 98 | Function StringsToPChars(List : TStrings): pointer; 99 | var 100 | EnvBlock, item: ansistring; 101 | I: Integer; 102 | memsize: integer; 103 | begin 104 | EnvBlock := ''; 105 | For I:=0 to Pred(List.Count) do begin 106 | item := AnsiString(List[i]); 107 | EnvBlock := EnvBlock + item + #0; 108 | end; 109 | EnvBlock := EnvBlock + #0; 110 | memsize := Length(EnvBlock); // if using unicode in the future, remember CHAR size (4) for memory allocation 111 | GetMem(Result, memsize); 112 | CopyMemory(Result, @EnvBlock[1], memsize); 113 | end; 114 | 115 | Procedure InitProcessAttributes(P : TProcess; Var PA : TSecurityAttributes); 116 | 117 | begin 118 | FillChar(PA,SizeOf(PA),0); 119 | PA.nLength := SizeOf(PA); 120 | end; 121 | 122 | Procedure InitThreadAttributes(P : TProcess; Var TA : TSecurityAttributes); 123 | 124 | begin 125 | FillChar(TA,SizeOf(TA),0); 126 | TA.nLength := SizeOf(TA); 127 | end; 128 | 129 | // L505 changed to STARTUPINFOW 130 | // Procedure InitStartupInfo(P : TProcess; Var SI : STARTUPINFOA); 131 | procedure InitStartupInfo(P : TProcess; Var SI : STARTUPINFOW); 132 | Const 133 | SWC : Array [TShowWindowOptions] of Cardinal = 134 | (0,SW_HIDE,SW_Maximize,SW_Minimize,SW_Restore,SW_Show, 135 | SW_ShowDefault,SW_ShowMaximized,SW_ShowMinimized, 136 | SW_showMinNOActive,SW_ShowNA,SW_ShowNoActivate,SW_ShowNormal); 137 | 138 | begin 139 | FillChar(SI,SizeOf(SI),0); 140 | With SI do 141 | begin 142 | dwFlags:=GetStartupFlags(P); 143 | if P.FShowWindow<>swoNone then 144 | dwFlags:=dwFlags or Startf_UseShowWindow 145 | else 146 | dwFlags:=dwFlags and not Startf_UseShowWindow; 147 | wShowWindow:=SWC[P.FShowWindow]; 148 | if (poUsePipes in P.Options) then 149 | begin 150 | dwFlags:=dwFlags or Startf_UseStdHandles; 151 | end; 152 | if P.FillAttribute<>0 then 153 | begin 154 | dwFlags:=dwFlags or Startf_UseFillAttribute; 155 | dwFillAttribute:=P.FillAttribute; 156 | end; 157 | dwXCountChars:=P.WindowColumns; 158 | dwYCountChars:=P.WindowRows; 159 | dwYsize:=P.WindowHeight; 160 | dwXsize:=P.WindowWidth; 161 | dwy:=P.WindowTop; 162 | dwX:=P.WindowLeft; 163 | end; 164 | end; 165 | 166 | { The handles that are to be passed to the child process must be 167 | inheritable. On the other hand, only non-inheritable handles 168 | allow the sending of EOF when the write-end is closed. This 169 | function is used to duplicate the child process's ends of the 170 | handles into inheritable ones, leaving the parent-side handles 171 | non-inheritable. 172 | } 173 | function DuplicateHandleFP(var handle: THandle): Boolean; 174 | var 175 | oldHandle: THandle; 176 | begin 177 | oldHandle := handle; 178 | Result := DuplicateHandle 179 | ( GetCurrentProcess(), 180 | oldHandle, 181 | GetCurrentProcess(), 182 | @handle, 183 | 0, 184 | true, 185 | DUPLICATE_SAME_ACCESS 186 | ); 187 | if Result then 188 | Result := CloseHandle(oldHandle); 189 | end; 190 | 191 | // L505 changed to TStartupInfoW 192 | // Procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfoA; CE : Boolean; APipeBufferSize : Cardinal); 193 | procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfoW; CE : Boolean; APipeBufferSize : Cardinal); 194 | begin 195 | CreatePipeHandles(SI.hStdInput,HI, APipeBufferSize); 196 | DuplicateHandleFP(SI.hStdInput); 197 | CreatePipeHandles(HO,Si.hStdOutput, APipeBufferSize); 198 | DuplicateHandleFP(Si.hStdOutput); 199 | if CE then begin 200 | CreatePipeHandles(HE,SI.hStdError, APipeBufferSize); 201 | DuplicateHandleFP( SI.hStdError); 202 | end 203 | else 204 | begin 205 | SI.hStdError:=SI.hStdOutput; 206 | HE:=HO; 207 | end; 208 | end; 209 | 210 | Function MaybeQuote(Const S : String) : String; 211 | begin 212 | If (Pos(' ',S)<>0) then 213 | Result:='"'+S+'"' 214 | else 215 | Result:=S; 216 | end; 217 | 218 | Function MaybeQuoteIfNotQuoted(Const S : String) : String; 219 | begin 220 | If (Pos(' ',S)<>0) and (pos('"',S)=0) then 221 | Result:='"'+S+'"' 222 | else 223 | Result:=S; 224 | end; 225 | 226 | Procedure TProcess.Execute; 227 | Var 228 | i : Integer; 229 | PName,PDir,PCommandLine : PChar; 230 | FEnv: pointer; 231 | FCreationFlags : Cardinal; 232 | FProcessAttributes : TSecurityAttributes; 233 | FThreadAttributes : TSecurityAttributes; 234 | FProcessInformation : TProcessInformation; 235 | // FStartupInfo : STARTUPINFOA; // L505 236 | FStartupInfo : STARTUPINFOW; // L505 237 | HI,HO,HE : THandle; 238 | Cmd : String; 239 | 240 | begin 241 | PName:=Nil; 242 | PCommandLine:=Nil; 243 | PDir:=Nil; 244 | 245 | if (FApplicationName='') and (FCommandLine='') and (FExecutable='') then 246 | Raise EProcess.Create(SNoCommandline); 247 | if (FApplicationName<>'') then 248 | begin 249 | PName:=PChar(FApplicationName); 250 | PCommandLine:=PChar(FCommandLine); 251 | end 252 | else If (FCommandLine<>'') then 253 | PCommandLine:=PChar(FCommandLine) 254 | else if (Fexecutable<>'') then 255 | begin 256 | Cmd:=MaybeQuoteIfNotQuoted(Executable); 257 | For I:=0 to Parameters.Count-1 do 258 | Cmd:=Cmd+' '+MaybeQuoteIfNotQuoted(Parameters[i]); 259 | PCommandLine:=PChar(Cmd); 260 | end; 261 | If FCurrentDirectory<>'' then 262 | PDir:=PChar(FCurrentDirectory); 263 | if FEnvironment.Count<>0 then 264 | FEnv:=StringsToPChars(FEnvironment) 265 | else begin 266 | // writeln('DEBUG: environment nil'); 267 | FEnv:=Nil; 268 | end; 269 | 270 | Try 271 | FCreationFlags:=GetCreationFlags(Self); 272 | InitProcessAttributes(Self,FProcessAttributes); 273 | InitThreadAttributes(Self,FThreadAttributes); 274 | InitStartupInfo(Self,FStartUpInfo); 275 | If poUsePipes in FProcessOptions then begin 276 | CreatePipes(HI,HO,HE,FStartupInfo,Not(poStdErrToOutPut in FProcessOptions), FPipeBufferSize); 277 | end; 278 | 279 | Try 280 | // L505: changed to CreateProcessW, fpc uses CreateProcess which is CreateProcessA 281 | If Not CreateProcessW(PName,PCommandLine,@FProcessAttributes,@FThreadAttributes, 282 | FInheritHandles,FCreationFlags,FEnv,PDir,FStartupInfo, 283 | fProcessInformation) then 284 | Raise EProcess.CreateFmt(SErrCannotExecute,[FCommandLine,GetLastError]); 285 | FProcessHandle:=FProcessInformation.hProcess; 286 | FThreadHandle:=FProcessInformation.hThread; 287 | FProcessID:=FProcessINformation.dwProcessID; 288 | Finally 289 | if POUsePipes in FProcessOptions then 290 | begin 291 | FileClose(FStartupInfo.hStdInput); 292 | FileClose(FStartupInfo.hStdOutput); 293 | if Not (poStdErrToOutPut in FProcessOptions) then 294 | FileClose(FStartupInfo.hStdError); 295 | CreateStreams(HI,HO,HE); 296 | end; 297 | end; 298 | FRunning:=True; 299 | Finally 300 | If FEnv<>Nil then 301 | FreeMem(FEnv); 302 | end; 303 | if not (csDesigning in ComponentState) and // This would hang the IDE ! 304 | (poWaitOnExit in FProcessOptions) and 305 | not (poRunSuspended in FProcessOptions) then 306 | WaitOnExit; 307 | end; 308 | 309 | Function TProcess.WaitOnExit : Boolean; 310 | Var 311 | R : DWord; 312 | begin 313 | R:=WaitForSingleObject (FProcessHandle,Infinite); 314 | Result:=(R<>Wait_Failed); 315 | If Result then 316 | GetExitStatus; 317 | FRunning:=False; 318 | end; 319 | 320 | Function TProcess.Suspend : Longint; 321 | begin 322 | Result:=SuspendThread(ThreadHandle); 323 | end; 324 | 325 | Function TProcess.Resume : LongInt; 326 | begin 327 | Result:=ResumeThread(ThreadHandle); 328 | end; 329 | 330 | Function TProcess.Terminate(AExitCode : Integer) : Boolean; 331 | begin 332 | Result:=False; 333 | If ExitStatus=Still_active then 334 | Result:=TerminateProcess(Handle,AexitCode); 335 | end; 336 | 337 | Procedure TProcess.SetShowWindow (Value : TShowWindowOptions); 338 | begin 339 | FShowWindow:=Value; 340 | end; --------------------------------------------------------------------------------