├── .gitignore ├── Images └── CodeCoverage.ico ├── LICENSE ├── Packages ├── Delphi 10.2 Tokyo │ ├── CodeCoverage.dpk │ ├── CodeCoverage.dproj │ └── CodeCoverage.prjmgc ├── Delphi 10.3 Rio │ ├── CodeCoverage.dpk │ ├── CodeCoverage.dproj │ └── CodeCoverage.prjmgc ├── Delphi 10.4 Sydney │ ├── CodeCoverage.dpk │ ├── CodeCoverage.dproj │ └── CodeCoverage.prjmgc ├── Delphi 11 Alexandria │ ├── CodeCoverage.dpk │ ├── CodeCoverage.dproj │ └── CodeCoverage.prjmgc └── Delphi 12 Athens │ ├── CodeCoverage.dpk │ ├── CodeCoverage.dproj │ └── CodeCoverage.prjmgc ├── README.md └── Source ├── CodeCoverage.ApiHelper.pas ├── CodeCoverage.Consts.pas ├── CodeCoverage.DM.dfm ├── CodeCoverage.DM.pas ├── CodeCoverage.Handler.pas ├── CodeCoverage.KeyBindings.pas ├── CodeCoverage.Main.pas ├── CodeCoverage.Notifier.pas ├── CodeCoverage.SyntaxTypes.pas ├── CodeCoverage.Tools.pas ├── CodeCoverage.Types.pas ├── DelphiAST ├── CodeCoverage.DelphiAST.Classes.pas ├── CodeCoverage.DelphiAST.Consts.pas ├── CodeCoverage.DelphiAST.SimpleParserEx.pas ├── CodeCoverage.DelphiAST.pas ├── CodeCoverage.SimpleParser.Lexer.Types.pas ├── CodeCoverage.SimpleParser.Lexer.pas ├── CodeCoverage.SimpleParser.Types.pas ├── CodeCoverage.SimpleParser.pas └── SimpleParser.inc ├── HighDPI ├── CodeCoverage.Images.DM.dfm └── CodeCoverage.Images.DM.pas ├── LowDPI ├── CodeCoverage.Images.DM.dfm └── CodeCoverage.Images.DM.pas ├── PngComponents ├── CodeCoverage.PngFunctions.pas └── CodeCoverage.PngImageList.pas ├── TestProject.dpr ├── TestProject.dproj ├── TestUnit1.pas └── TestedUnit1.pas /.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 | -------------------------------------------------------------------------------- /Images/CodeCoverage.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UweRaabe/DelphiCodeCoveragePlugin/8f1246759e6ef6bb22c443c4e3b495d137319f98/Images/CodeCoverage.ico -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Uwe Raabe 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Packages/Delphi 10.2 Tokyo/CodeCoverage.dpk: -------------------------------------------------------------------------------- 1 | package CodeCoverage; 2 | 3 | {$R *.res} 4 | {$R *.dres} 5 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 6 | {$ALIGN 8} 7 | {$ASSERTIONS ON} 8 | {$BOOLEVAL OFF} 9 | {$DEBUGINFO OFF} 10 | {$EXTENDEDSYNTAX ON} 11 | {$IMPORTEDDATA ON} 12 | {$IOCHECKS ON} 13 | {$LOCALSYMBOLS ON} 14 | {$LONGSTRINGS ON} 15 | {$OPENSTRINGS ON} 16 | {$OPTIMIZATION OFF} 17 | {$OVERFLOWCHECKS OFF} 18 | {$RANGECHECKS OFF} 19 | {$REFERENCEINFO ON} 20 | {$SAFEDIVIDE OFF} 21 | {$STACKFRAMES ON} 22 | {$TYPEDADDRESS OFF} 23 | {$VARSTRINGCHECKS ON} 24 | {$WRITEABLECONST OFF} 25 | {$MINENUMSIZE 1} 26 | {$IMAGEBASE $400000} 27 | {$DEFINE DEBUG} 28 | {$ENDIF IMPLICITBUILDING} 29 | {$DESCRIPTION 'Code Coverage Magician'} 30 | {$LIBSUFFIX '250'} 31 | {$DESIGNONLY} 32 | {$IMPLICITBUILD ON} 33 | 34 | requires 35 | DesignIDE; 36 | 37 | contains 38 | CodeCoverage.ApiHelper in '..\..\Source\CodeCoverage.ApiHelper.pas', 39 | CodeCoverage.Consts in '..\..\Source\CodeCoverage.Consts.pas', 40 | CodeCoverage.DM in '..\..\Source\CodeCoverage.DM.pas' {dmCodeCoverage: TDataModule}, 41 | CodeCoverage.Handler in '..\..\Source\CodeCoverage.Handler.pas', 42 | CodeCoverage.KeyBindings in '..\..\Source\CodeCoverage.KeyBindings.pas', 43 | CodeCoverage.Main in '..\..\Source\CodeCoverage.Main.pas', 44 | CodeCoverage.Notifier in '..\..\Source\CodeCoverage.Notifier.pas', 45 | CodeCoverage.SyntaxTypes in '..\..\Source\CodeCoverage.SyntaxTypes.pas', 46 | CodeCoverage.Tools in '..\..\Source\CodeCoverage.Tools.pas', 47 | CodeCoverage.Types in '..\..\Source\CodeCoverage.Types.pas', 48 | CodeCoverage.Images.DM in '..\..\Source\LowDPI\CodeCoverage.Images.DM.pas' {dmCodeCoverageImages: TDataModule}; 49 | 50 | end. 51 | -------------------------------------------------------------------------------- /Packages/Delphi 10.2 Tokyo/CodeCoverage.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | True 4 | Package 5 | Release 6 | VCL 7 | CodeCoverage.dpk 8 | Win32 9 | {39F1CBBC-9BB2-4B75-B856-8E53C0E014D9} 10 | 18.4 11 | 1 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 | Cfg_1 29 | true 30 | true 31 | 32 | 33 | true 34 | Base 35 | true 36 | 37 | 38 | CodeCoverage 39 | All 40 | .\$(Platform)\$(Config) 41 | Code Coverage Magician 42 | .\$(Platform)\$(Config) 43 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;CodeCoverage;$(DCC_Namespace) 44 | ..\..\Source\DelphiAST;..\..\Source\PngComponents;$(DCC_UnitSearchPath) 45 | true 46 | 250 47 | true 48 | true 49 | 1031 50 | 51 | 52 | Debug 53 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 54 | CodeSiteLoggingPkg;DelphiASTPkg;PngComponents;$(DCC_UsePackage) 55 | 56 | 57 | true 58 | true 59 | DEBUG;$(DCC_Define) 60 | true 61 | false 62 | true 63 | 64 | 65 | false 66 | C:\Program Files (x86)\Embarcadero\Studio\19.0\bin\bds.exe 67 | C:\Program Files (x86)\Embarcadero\Studio\19.0\bin\bds.exe 68 | -rDebugIDE -pDelphi -np 69 | 70 | 71 | 0 72 | RELEASE;$(DCC_Define) 73 | false 74 | 0 75 | 76 | 77 | 78 | MainSource 79 | 80 | 81 | 82 | 83 | 84 |
dmCodeCoverage
85 | dfm 86 | TDataModule 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 |
dmCodeCoverageImages
97 | dfm 98 | TDataModule 99 | 100 | 101 | ICON 102 | CodeCoverage 103 | 104 | 105 | Base 106 | 107 | 108 | Cfg_1 109 | Base 110 | 111 | 112 | Cfg_2 113 | Base 114 | 115 | 116 | 117 | Delphi.Personality.12 118 | Package 119 | 120 | 121 | 122 | CodeCoverage.dpk 123 | 124 | 125 | 126 | 127 | True 128 | 129 | 130 | 131 | (ToolsApi);WinApi;System.Win;System;Data;Vcl;Png* 132 | 133 | 134 | 135 | 12 136 | 137 | 138 | 139 | 140 | 141 | -------------------------------------------------------------------------------- /Packages/Delphi 10.2 Tokyo/CodeCoverage.prjmgc: -------------------------------------------------------------------------------- 1 | [Settings] 2 | AutoLibSuffix=1 3 | ClearChildAppSettings=0 4 | ClearChildPackageSettings=1 5 | ClearChildVersionInfo=1 6 | NormalizeDproj=1 7 | SplitDproj=0 8 | EnableMissingPlatforms=0 9 | RemoveUnusedPlatforms=1 10 | RefreshFormType=1 11 | RemoveExcludedPackages=1 12 | RemoveDeployment=1 13 | RemoveUWP=1 14 | 15 | -------------------------------------------------------------------------------- /Packages/Delphi 10.3 Rio/CodeCoverage.dpk: -------------------------------------------------------------------------------- 1 | package CodeCoverage; 2 | 3 | {$R *.res} 4 | {$R *.dres} 5 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 6 | {$ALIGN 8} 7 | {$ASSERTIONS ON} 8 | {$BOOLEVAL OFF} 9 | {$DEBUGINFO OFF} 10 | {$EXTENDEDSYNTAX ON} 11 | {$IMPORTEDDATA ON} 12 | {$IOCHECKS ON} 13 | {$LOCALSYMBOLS ON} 14 | {$LONGSTRINGS ON} 15 | {$OPENSTRINGS ON} 16 | {$OPTIMIZATION OFF} 17 | {$OVERFLOWCHECKS OFF} 18 | {$RANGECHECKS OFF} 19 | {$REFERENCEINFO ON} 20 | {$SAFEDIVIDE OFF} 21 | {$STACKFRAMES ON} 22 | {$TYPEDADDRESS OFF} 23 | {$VARSTRINGCHECKS ON} 24 | {$WRITEABLECONST OFF} 25 | {$MINENUMSIZE 1} 26 | {$IMAGEBASE $400000} 27 | {$DEFINE DEBUG} 28 | {$ENDIF IMPLICITBUILDING} 29 | {$DESCRIPTION 'Code Coverage Magician'} 30 | {$LIBSUFFIX '260'} 31 | {$DESIGNONLY} 32 | {$IMPLICITBUILD ON} 33 | 34 | requires 35 | DesignIDE; 36 | 37 | contains 38 | CodeCoverage.ApiHelper in '..\..\Source\CodeCoverage.ApiHelper.pas', 39 | CodeCoverage.Consts in '..\..\Source\CodeCoverage.Consts.pas', 40 | CodeCoverage.DM in '..\..\Source\CodeCoverage.DM.pas' {dmCodeCoverage: TDataModule}, 41 | CodeCoverage.Handler in '..\..\Source\CodeCoverage.Handler.pas', 42 | CodeCoverage.KeyBindings in '..\..\Source\CodeCoverage.KeyBindings.pas', 43 | CodeCoverage.Main in '..\..\Source\CodeCoverage.Main.pas', 44 | CodeCoverage.Notifier in '..\..\Source\CodeCoverage.Notifier.pas', 45 | CodeCoverage.SyntaxTypes in '..\..\Source\CodeCoverage.SyntaxTypes.pas', 46 | CodeCoverage.Tools in '..\..\Source\CodeCoverage.Tools.pas', 47 | CodeCoverage.Types in '..\..\Source\CodeCoverage.Types.pas', 48 | CodeCoverage.Images.DM in '..\..\Source\LowDPI\CodeCoverage.Images.DM.pas' {dmCodeCoverageImages: TDataModule}; 49 | 50 | end. 51 | -------------------------------------------------------------------------------- /Packages/Delphi 10.3 Rio/CodeCoverage.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | True 4 | Package 5 | Release 6 | VCL 7 | CodeCoverage.dpk 8 | Win32 9 | {39F1CBBC-9BB2-4B75-B856-8E53C0E014D9} 10 | 18.8 11 | 1 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 | Cfg_1 29 | true 30 | true 31 | 32 | 33 | true 34 | Base 35 | true 36 | 37 | 38 | CodeCoverage 39 | All 40 | .\$(Platform)\$(Config) 41 | Code Coverage Magician 42 | .\$(Platform)\$(Config) 43 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;CodeCoverage;$(DCC_Namespace) 44 | ..\..\Source\DelphiAST;..\..\Source\PngComponents;$(DCC_UnitSearchPath) 45 | true 46 | 260 47 | true 48 | true 49 | 1031 50 | 51 | 52 | Debug 53 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 54 | CodeSiteLoggingPkg;DelphiASTPkg;PngComponents;$(DCC_UsePackage) 55 | 56 | 57 | true 58 | true 59 | DEBUG;$(DCC_Define) 60 | true 61 | false 62 | true 63 | 64 | 65 | false 66 | C:\Program Files (x86)\Embarcadero\Studio\19.0\bin\bds.exe 67 | C:\Program Files (x86)\Embarcadero\Studio\19.0\bin\bds.exe 68 | -rDebugIDE -pDelphi -np 69 | 70 | 71 | 0 72 | RELEASE;$(DCC_Define) 73 | false 74 | 0 75 | 76 | 77 | 78 | MainSource 79 | 80 | 81 | 82 | 83 | 84 |
dmCodeCoverage
85 | dfm 86 | TDataModule 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 |
dmCodeCoverageImages
97 | dfm 98 | TDataModule 99 | 100 | 101 | ICON 102 | CodeCoverage 103 | 104 | 105 | Base 106 | 107 | 108 | Cfg_1 109 | Base 110 | 111 | 112 | Cfg_2 113 | Base 114 | 115 | 116 | 117 | Delphi.Personality.12 118 | Package 119 | 120 | 121 | 122 | CodeCoverage.dpk 123 | 124 | 125 | 126 | 127 | True 128 | 129 | 130 | 131 | (ToolsApi);WinApi;System.Win;System;Data;Vcl;Png* 132 | 133 | 134 | 135 | 12 136 | 137 | 138 | 139 | 140 | 141 | -------------------------------------------------------------------------------- /Packages/Delphi 10.3 Rio/CodeCoverage.prjmgc: -------------------------------------------------------------------------------- 1 | [Settings] 2 | AutoLibSuffix=1 3 | ClearChildAppSettings=0 4 | ClearChildPackageSettings=1 5 | ClearChildVersionInfo=1 6 | NormalizeDproj=1 7 | SplitDproj=0 8 | EnableMissingPlatforms=0 9 | RemoveUnusedPlatforms=1 10 | RefreshFormType=1 11 | RemoveExcludedPackages=1 12 | RemoveDeployment=1 13 | RemoveUWP=1 14 | 15 | -------------------------------------------------------------------------------- /Packages/Delphi 10.4 Sydney/CodeCoverage.dpk: -------------------------------------------------------------------------------- 1 | package CodeCoverage; 2 | 3 | {$R *.res} 4 | {$R *.dres} 5 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 6 | {$ALIGN 8} 7 | {$ASSERTIONS ON} 8 | {$BOOLEVAL OFF} 9 | {$DEBUGINFO OFF} 10 | {$EXTENDEDSYNTAX ON} 11 | {$IMPORTEDDATA ON} 12 | {$IOCHECKS ON} 13 | {$LOCALSYMBOLS ON} 14 | {$LONGSTRINGS ON} 15 | {$OPENSTRINGS ON} 16 | {$OPTIMIZATION OFF} 17 | {$OVERFLOWCHECKS OFF} 18 | {$RANGECHECKS OFF} 19 | {$REFERENCEINFO ON} 20 | {$SAFEDIVIDE OFF} 21 | {$STACKFRAMES ON} 22 | {$TYPEDADDRESS OFF} 23 | {$VARSTRINGCHECKS ON} 24 | {$WRITEABLECONST OFF} 25 | {$MINENUMSIZE 1} 26 | {$IMAGEBASE $400000} 27 | {$DEFINE DEBUG} 28 | {$ENDIF IMPLICITBUILDING} 29 | {$DESCRIPTION 'Code Coverage Magician'} 30 | {$LIBSUFFIX '270'} 31 | {$DESIGNONLY} 32 | {$IMPLICITBUILD ON} 33 | 34 | requires 35 | DesignIDE; 36 | 37 | contains 38 | CodeCoverage.ApiHelper in '..\..\Source\CodeCoverage.ApiHelper.pas', 39 | CodeCoverage.Consts in '..\..\Source\CodeCoverage.Consts.pas', 40 | CodeCoverage.DM in '..\..\Source\CodeCoverage.DM.pas' {dmCodeCoverage: TDataModule}, 41 | CodeCoverage.Handler in '..\..\Source\CodeCoverage.Handler.pas', 42 | CodeCoverage.KeyBindings in '..\..\Source\CodeCoverage.KeyBindings.pas', 43 | CodeCoverage.Main in '..\..\Source\CodeCoverage.Main.pas', 44 | CodeCoverage.Notifier in '..\..\Source\CodeCoverage.Notifier.pas', 45 | CodeCoverage.SyntaxTypes in '..\..\Source\CodeCoverage.SyntaxTypes.pas', 46 | CodeCoverage.Tools in '..\..\Source\CodeCoverage.Tools.pas', 47 | CodeCoverage.Types in '..\..\Source\CodeCoverage.Types.pas', 48 | CodeCoverage.Images.DM in '..\..\Source\LowDPI\CodeCoverage.Images.DM.pas' {dmCodeCoverageImages: TDataModule}; 49 | 50 | end. 51 | -------------------------------------------------------------------------------- /Packages/Delphi 10.4 Sydney/CodeCoverage.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | True 4 | Package 5 | Release 6 | VCL 7 | CodeCoverage.dpk 8 | Win32 9 | {39F1CBBC-9BB2-4B75-B856-8E53C0E014D9} 10 | 19.2 11 | 1 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 | Cfg_1 29 | true 30 | true 31 | 32 | 33 | true 34 | Base 35 | true 36 | 37 | 38 | CodeCoverage 39 | All 40 | .\$(Platform)\$(Config) 41 | Code Coverage Magician 42 | .\$(Platform)\$(Config) 43 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;CodeCoverage;$(DCC_Namespace) 44 | ..\..\Source\DelphiAST;..\..\Source\PngComponents;$(DCC_UnitSearchPath) 45 | true 46 | 270 47 | true 48 | true 49 | 1031 50 | 51 | 52 | Debug 53 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 54 | CodeSiteLoggingPkg;DelphiASTPkg;PngComponents;$(DCC_UsePackage) 55 | 56 | 57 | true 58 | true 59 | DEBUG;$(DCC_Define) 60 | true 61 | false 62 | true 63 | 64 | 65 | false 66 | C:\Program Files (x86)\Embarcadero\Studio\19.0\bin\bds.exe 67 | C:\Program Files (x86)\Embarcadero\Studio\19.0\bin\bds.exe 68 | -rDebugIDE -pDelphi -np 69 | 70 | 71 | 0 72 | RELEASE;$(DCC_Define) 73 | false 74 | 0 75 | 76 | 77 | 78 | MainSource 79 | 80 | 81 | 82 | 83 | 84 |
dmCodeCoverage
85 | dfm 86 | TDataModule 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 |
dmCodeCoverageImages
97 | dfm 98 | TDataModule 99 | 100 | 101 | ICON 102 | CodeCoverage 103 | 104 | 105 | Base 106 | 107 | 108 | Cfg_1 109 | Base 110 | 111 | 112 | Cfg_2 113 | Base 114 | 115 | 116 | 117 | Delphi.Personality.12 118 | Package 119 | 120 | 121 | 122 | CodeCoverage.dpk 123 | 124 | 125 | 126 | 127 | True 128 | False 129 | 130 | 131 | 132 | (ToolsApi);WinApi;System.Win;System;Data;Vcl;Png* 133 | 134 | 135 | 136 | 12 137 | 138 | 139 | 140 | 141 | 142 | -------------------------------------------------------------------------------- /Packages/Delphi 10.4 Sydney/CodeCoverage.prjmgc: -------------------------------------------------------------------------------- 1 | [Settings] 2 | AutoLibSuffix=1 3 | ClearChildAppSettings=0 4 | ClearChildPackageSettings=1 5 | ClearChildVersionInfo=1 6 | NormalizeDproj=1 7 | SplitDproj=0 8 | EnableMissingPlatforms=0 9 | RemoveUnusedPlatforms=1 10 | RefreshFormType=1 11 | RemoveExcludedPackages=1 12 | RemoveDeployment=1 13 | RemoveUWP=1 14 | 15 | -------------------------------------------------------------------------------- /Packages/Delphi 11 Alexandria/CodeCoverage.dpk: -------------------------------------------------------------------------------- 1 | package CodeCoverage; 2 | 3 | {$R *.res} 4 | {$R *.dres} 5 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 6 | {$ALIGN 8} 7 | {$ASSERTIONS ON} 8 | {$BOOLEVAL OFF} 9 | {$DEBUGINFO OFF} 10 | {$EXTENDEDSYNTAX ON} 11 | {$IMPORTEDDATA ON} 12 | {$IOCHECKS ON} 13 | {$LOCALSYMBOLS ON} 14 | {$LONGSTRINGS ON} 15 | {$OPENSTRINGS ON} 16 | {$OPTIMIZATION OFF} 17 | {$OVERFLOWCHECKS OFF} 18 | {$RANGECHECKS OFF} 19 | {$REFERENCEINFO ON} 20 | {$SAFEDIVIDE OFF} 21 | {$STACKFRAMES ON} 22 | {$TYPEDADDRESS OFF} 23 | {$VARSTRINGCHECKS ON} 24 | {$WRITEABLECONST OFF} 25 | {$MINENUMSIZE 1} 26 | {$IMAGEBASE $400000} 27 | {$DEFINE DEBUG} 28 | {$ENDIF IMPLICITBUILDING} 29 | {$DESCRIPTION 'Code Coverage Magician'} 30 | {$LIBSUFFIX '280'} 31 | {$DESIGNONLY} 32 | {$IMPLICITBUILD ON} 33 | 34 | requires 35 | DesignIDE; 36 | 37 | contains 38 | CodeCoverage.ApiHelper in '..\..\Source\CodeCoverage.ApiHelper.pas', 39 | CodeCoverage.Consts in '..\..\Source\CodeCoverage.Consts.pas', 40 | CodeCoverage.DM in '..\..\Source\CodeCoverage.DM.pas' {dmCodeCoverage: TDataModule}, 41 | CodeCoverage.Handler in '..\..\Source\CodeCoverage.Handler.pas', 42 | CodeCoverage.KeyBindings in '..\..\Source\CodeCoverage.KeyBindings.pas', 43 | CodeCoverage.Main in '..\..\Source\CodeCoverage.Main.pas', 44 | CodeCoverage.Notifier in '..\..\Source\CodeCoverage.Notifier.pas', 45 | CodeCoverage.SyntaxTypes in '..\..\Source\CodeCoverage.SyntaxTypes.pas', 46 | CodeCoverage.Tools in '..\..\Source\CodeCoverage.Tools.pas', 47 | CodeCoverage.Types in '..\..\Source\CodeCoverage.Types.pas', 48 | CodeCoverage.Images.DM in '..\..\Source\HighDPI\CodeCoverage.Images.DM.pas' {dmCodeCoverageImages: TDataModule}; 49 | 50 | end. 51 | -------------------------------------------------------------------------------- /Packages/Delphi 11 Alexandria/CodeCoverage.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | True 4 | Package 5 | Debug 6 | VCL 7 | CodeCoverage.dpk 8 | Win32 9 | {39F1CBBC-9BB2-4B75-B856-8E53C0E014D9} 10 | 19.3 11 | 1 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 | Cfg_1 29 | true 30 | true 31 | 32 | 33 | true 34 | Base 35 | true 36 | 37 | 38 | CodeCoverage 39 | All 40 | .\$(Platform)\$(Config) 41 | Code Coverage Magician 42 | .\$(Platform)\$(Config) 43 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;CodeCoverage;$(DCC_Namespace) 44 | ..\..\Source\DelphiAST;..\..\Source\PngComponents;$(DCC_UnitSearchPath) 45 | true 46 | 280 47 | true 48 | true 49 | 1031 50 | 51 | 52 | Debug 53 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 54 | CodeSiteLoggingPkg;DelphiASTPkg;PngComponents;$(DCC_UsePackage) 55 | 56 | 57 | true 58 | true 59 | DEBUG;$(DCC_Define) 60 | true 61 | false 62 | true 63 | 64 | 65 | false 66 | C:\Program Files (x86)\Embarcadero\Studio\19.0\bin\bds.exe 67 | C:\Program Files (x86)\Embarcadero\Studio\19.0\bin\bds.exe 68 | -rDebugIDE -pDelphi -np 69 | 70 | 71 | 0 72 | RELEASE;$(DCC_Define) 73 | false 74 | 0 75 | 76 | 77 | 78 | MainSource 79 | 80 | 81 | 82 | 83 | 84 |
dmCodeCoverage
85 | TDataModule 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 |
dmCodeCoverageImages
96 | TDataModule 97 | 98 | 99 | ICON 100 | CodeCoverage 101 | 102 | 103 | Base 104 | 105 | 106 | Cfg_1 107 | Base 108 | 109 | 110 | Cfg_2 111 | Base 112 | 113 | 114 | 115 | Delphi.Personality.12 116 | Package 117 | 118 | 119 | 120 | CodeCoverage.dpk 121 | 122 | 123 | 124 | 125 | True 126 | False 127 | 128 | 129 | 130 | (ToolsApi);WinApi;System.Win;System;Data;Vcl;Png* 131 | 132 | 133 | 134 | 12 135 | 136 | 137 | 138 | 139 | 140 | -------------------------------------------------------------------------------- /Packages/Delphi 11 Alexandria/CodeCoverage.prjmgc: -------------------------------------------------------------------------------- 1 | [Settings] 2 | AutoLibSuffix=1 3 | ClearChildAppSettings=0 4 | ClearChildPackageSettings=1 5 | ClearChildVersionInfo=1 6 | NormalizeDproj=1 7 | SplitDproj=0 8 | EnableMissingPlatforms=0 9 | RemoveUnusedPlatforms=1 10 | RefreshFormType=1 11 | RemoveExcludedPackages=1 12 | RemoveDeployment=1 13 | RemoveUWP=1 14 | 15 | -------------------------------------------------------------------------------- /Packages/Delphi 12 Athens/CodeCoverage.dpk: -------------------------------------------------------------------------------- 1 | package CodeCoverage; 2 | 3 | {$R *.res} 4 | {$R *.dres} 5 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 6 | {$ALIGN 8} 7 | {$ASSERTIONS ON} 8 | {$BOOLEVAL OFF} 9 | {$DEBUGINFO OFF} 10 | {$EXTENDEDSYNTAX ON} 11 | {$IMPORTEDDATA ON} 12 | {$IOCHECKS ON} 13 | {$LOCALSYMBOLS ON} 14 | {$LONGSTRINGS ON} 15 | {$OPENSTRINGS ON} 16 | {$OPTIMIZATION OFF} 17 | {$OVERFLOWCHECKS OFF} 18 | {$RANGECHECKS OFF} 19 | {$REFERENCEINFO ON} 20 | {$SAFEDIVIDE OFF} 21 | {$STACKFRAMES ON} 22 | {$TYPEDADDRESS OFF} 23 | {$VARSTRINGCHECKS ON} 24 | {$WRITEABLECONST OFF} 25 | {$MINENUMSIZE 1} 26 | {$IMAGEBASE $400000} 27 | {$DEFINE DEBUG} 28 | {$ENDIF IMPLICITBUILDING} 29 | {$DESCRIPTION 'Code Coverage Magician'} 30 | {$LIBSUFFIX '290'} 31 | {$DESIGNONLY} 32 | {$IMPLICITBUILD ON} 33 | 34 | requires 35 | DesignIDE; 36 | 37 | contains 38 | CodeCoverage.ApiHelper in '..\..\Source\CodeCoverage.ApiHelper.pas', 39 | CodeCoverage.Consts in '..\..\Source\CodeCoverage.Consts.pas', 40 | CodeCoverage.DM in '..\..\Source\CodeCoverage.DM.pas' {dmCodeCoverage: TDataModule}, 41 | CodeCoverage.Handler in '..\..\Source\CodeCoverage.Handler.pas', 42 | CodeCoverage.KeyBindings in '..\..\Source\CodeCoverage.KeyBindings.pas', 43 | CodeCoverage.Main in '..\..\Source\CodeCoverage.Main.pas', 44 | CodeCoverage.Notifier in '..\..\Source\CodeCoverage.Notifier.pas', 45 | CodeCoverage.SyntaxTypes in '..\..\Source\CodeCoverage.SyntaxTypes.pas', 46 | CodeCoverage.Tools in '..\..\Source\CodeCoverage.Tools.pas', 47 | CodeCoverage.Types in '..\..\Source\CodeCoverage.Types.pas', 48 | CodeCoverage.Images.DM in '..\..\Source\HighDPI\CodeCoverage.Images.DM.pas' {dmCodeCoverageImages: TDataModule}; 49 | 50 | end. 51 | -------------------------------------------------------------------------------- /Packages/Delphi 12 Athens/CodeCoverage.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | True 4 | Package 5 | Debug 6 | VCL 7 | CodeCoverage.dpk 8 | Win32 9 | {39F1CBBC-9BB2-4B75-B856-8E53C0E014D9} 10 | CodeCoverage 11 | 20.3 12 | 1 13 | 14 | 15 | true 16 | 17 | 18 | true 19 | Base 20 | true 21 | 22 | 23 | true 24 | Base 25 | true 26 | 27 | 28 | true 29 | Cfg_1 30 | true 31 | true 32 | 33 | 34 | true 35 | Base 36 | true 37 | 38 | 39 | CodeCoverage 40 | All 41 | .\$(Platform)\$(Config) 42 | Code Coverage Magician 43 | .\$(Platform)\$(Config) 44 | System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;CodeCoverage;$(DCC_Namespace) 45 | ..\..\Source\DelphiAST;..\..\Source\PngComponents;$(DCC_UnitSearchPath) 46 | true 47 | 290 48 | true 49 | true 50 | 1031 51 | 52 | 53 | Debug 54 | Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 55 | CodeSiteLoggingPkg;DelphiASTPkg;PngComponents;$(DCC_UsePackage) 56 | 57 | 58 | true 59 | true 60 | DEBUG;$(DCC_Define) 61 | true 62 | false 63 | true 64 | 65 | 66 | false 67 | C:\Program Files (x86)\Embarcadero\Studio\19.0\bin\bds.exe 68 | C:\Program Files (x86)\Embarcadero\Studio\19.0\bin\bds.exe 69 | -rDebugIDE -pDelphi -np 70 | 71 | 72 | 0 73 | RELEASE;$(DCC_Define) 74 | false 75 | 0 76 | 77 | 78 | 79 | MainSource 80 | 81 | 82 | 83 | 84 | 85 |
dmCodeCoverage
86 | dfm 87 | TDataModule 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 |
dmCodeCoverageImages
98 | dfm 99 | TDataModule 100 | 101 | 102 | ICON 103 | CodeCoverage 104 | 105 | 106 | Base 107 | 108 | 109 | Cfg_1 110 | Base 111 | 112 | 113 | Cfg_2 114 | Base 115 | 116 | 117 | 118 | Delphi.Personality.12 119 | Package 120 | 121 | 122 | 123 | CodeCoverage.dpk 124 | 125 | 126 | 127 | 128 | True 129 | False 130 | False 131 | 132 | 133 | 134 | (ToolsApi);WinApi;System.Win;System;Data;Vcl;Png* 135 | 136 | 137 | 138 | 139 | Win64,Win64x,Win32 140 | 141 | 142 | 143 | 12 144 | 145 | 146 | 147 | 148 | 149 | -------------------------------------------------------------------------------- /Packages/Delphi 12 Athens/CodeCoverage.prjmgc: -------------------------------------------------------------------------------- 1 | [Settings] 2 | AutoLibSuffix=1 3 | ClearChildAppSettings=0 4 | ClearChildPackageSettings=1 5 | ClearChildVersionInfo=1 6 | NormalizeDproj=1 7 | SplitDproj=0 8 | EnableMissingPlatforms=0 9 | RemoveUnusedPlatforms=1 10 | RefreshFormType=1 11 | RemoveExcludedPackages=1 12 | RemoveDeployment=1 13 | RemoveUWP=1 14 | 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DelphiCodeCoveragePlugin 2 | Delphi Code Coverage Plugin 3 | 4 | The DelphiCode Coverage Plugin adds code coverage to teh Delphi IDE. It supports Delphi 10.2 Tokyo, Delphi 10.3 Rio, Delphi 10.4 Sydney, Delphi 11 Alexandria and Delphi 12 Athens. 5 | 6 | To install the plugin open the appropriate package for your Delpih version, compile and install it into the IDE. Due to a display problem of the main toolbar a restart of the IDE is suggested. After that you should see two code coverage buttons: 7 | 8 | ![RunCodeCoverage](https://user-images.githubusercontent.com/9463873/138177527-34b6e174-ccd4-4de2-b3e4-3b4c0f9651fb.png) Run Code Coverage: starts the test project in code coverage mode and displays the results. 9 | 10 | ![CodeCoverage](https://user-images.githubusercontent.com/9463873/138177322-9422fa74-9a9d-4138-8bca-29bf4ade604a.png) Switch Code Coverage: enables or disables code coverage for the current method (where the cursor is in). 11 | 12 | 13 | The plugin is meant for Test Driven Development (TDD) to control which code parts are covered by tests and which are not. 14 | 15 | For a demonstration after installing the plugin, open the TestProject from the source folder. It consists of TestedUnit1, which declares a class TTestedClass with two methods to test. TestUnit1 contains the test class for DUnitX. The test class has two tests, each for one method in TTestedClass, and several test cases with different parameters for the tested methods. Initially only the first test case of each test is enabled, the others are commented out. 16 | Now open TestedUnit and place the cursor inside the implementation of TestedMethod1. Click on the Switch Code Coverage button in the toolbar or press Ctrl-Alt-F5. If code coverage for a method is enabled the code coverage symbol appears in the gutter left of the method header. Switching code coverage also works when the cursor is placed inside the method declaration in the class. 17 | 18 | ![image](https://user-images.githubusercontent.com/9463873/138178387-3a67ca3d-2f23-4c6f-aa1c-0562debf641c.png) 19 | 20 | 21 | Click the Run Code Coverage toolbar button. The test programm will run and at the end the code coverage will be displayed. 22 | 23 | ![image](https://user-images.githubusercontent.com/9463873/138178682-f7a4a8e8-5c55-44fc-ac47-c88b330705d9.png) 24 | 25 | Right to the method header you can see the code coverage of the method in percent (lines executed vs. total lines). The number in brackets behind each line shows the number of executions of that line. The red arrow after a line shows a line never executed. Little circles in the first column of each code line give a quick overview which lines are executed (filled blue circle), which are not executed (filled red circle) and which cannot be executed (hollow blue circle). The last also have no blue debugger dots in the gutter. 26 | 27 | Uncommenting the different test cases will result in more code covered. The goal is to have as much test cases to get 100% code coverage. 28 | -------------------------------------------------------------------------------- /Source/CodeCoverage.ApiHelper.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.ApiHelper; 2 | 3 | interface 4 | 5 | uses 6 | System.Generics.Collections, System.Classes, System.SysUtils, 7 | Vcl.Menus, 8 | ToolsAPI, PlatformAPI; 9 | 10 | type 11 | OTA = record 12 | strict private 13 | class var 14 | FIDELibSuffix: string; 15 | public 16 | class function AboutBoxServices: IOTAAboutBoxServices; static; 17 | class function DebuggerServices: IOTADebuggerServices; static; 18 | class function EditorServices: IOTAEditorServices; static; 19 | class function IDELibSuffix: string; static; 20 | class function IsPackageInstalled(const APackageName: string): Boolean; static; 21 | class function KeyboardServices: IOTAKeyboardServices; static; 22 | class function ModuleServices: IOTAModuleServices; static; 23 | class function PackageServices: IOTAPackageServices; static; 24 | class function PlatformServices: IOTAPlatformServices; static; 25 | class function Services: IOTAServices; static; 26 | end; 27 | 28 | NTA = record 29 | public 30 | class function EnvironmentOptionsServices: INTAEnvironmentOptionsServices; static; 31 | class function FindMenuItem(const AName: string): TMenuItem; overload; static; 32 | class function FindMenuItem(const BreadCrumbs: array of string): TMenuItem; overload; static; 33 | class function Services: INTAServices; static; 34 | end; 35 | 36 | type 37 | TCommonNotifier = class(TInterfacedObject, IOTANotifier) 38 | private 39 | FID: Integer; 40 | procedure Unregister; 41 | protected 42 | { IOTANotifier } 43 | procedure AfterSave; 44 | procedure BeforeSave; 45 | procedure Destroyed; 46 | procedure Modified; 47 | 48 | function DoRegister: Integer; virtual; 49 | procedure DoUnregister(ID: Integer); virtual; 50 | procedure InternalAfterSave; virtual; 51 | procedure InternalBeforeSave; virtual; 52 | procedure InternalDestroyed; virtual; 53 | procedure InternalModified; virtual; 54 | public 55 | constructor Create; 56 | destructor Destroy; override; 57 | procedure AfterConstruction; override; 58 | procedure Release; 59 | end; 60 | 61 | TNotifierHost = class(TInterfacedPersistent) 62 | private 63 | FNotifiers: TList; 64 | protected 65 | property Notifiers: TList read FNotifiers; 66 | public 67 | constructor Create; 68 | destructor Destroy; override; 69 | procedure AddNotifier(Value: TCommonNotifier); 70 | procedure ClearNotifiers; 71 | function FindNotifier(Predicate: TPredicate): Boolean; overload; 72 | function FindNotifier(Predicate: TPredicate; out Instance: T): Boolean; overload; 73 | procedure RemoveNotifier(Value: TCommonNotifier); 74 | end; 75 | 76 | THostedNotifier = class(TCommonNotifier) 77 | private 78 | FNotifierHost: TNotifierHost; 79 | protected 80 | procedure CheckNotifierHost(ANotifierHost: TNotifierHost); virtual; 81 | property NotifierHost: TNotifierHost read FNotifierHost; 82 | public 83 | constructor Create(ANotifierHost: TNotifierHost); overload; 84 | destructor Destroy; override; 85 | end; 86 | 87 | implementation 88 | 89 | uses 90 | System.IOUtils; 91 | 92 | type 93 | TMenuItemHelper = class helper for TMenuItem 94 | public 95 | function FindByName(const AName: string): TMenuItem; 96 | end; 97 | 98 | procedure TCommonNotifier.AfterConstruction; 99 | begin 100 | inherited; 101 | FID := DoRegister; 102 | end; 103 | 104 | procedure TCommonNotifier.AfterSave; 105 | begin 106 | InternalAfterSave; 107 | end; 108 | 109 | procedure TCommonNotifier.BeforeSave; 110 | begin 111 | InternalBeforeSave; 112 | end; 113 | 114 | constructor TCommonNotifier.Create; 115 | begin 116 | inherited; 117 | FID := -1; 118 | end; 119 | 120 | destructor TCommonNotifier.Destroy; 121 | begin 122 | Unregister; 123 | inherited; 124 | end; 125 | 126 | procedure TCommonNotifier.Destroyed; 127 | begin 128 | InternalDestroyed; 129 | end; 130 | 131 | function TCommonNotifier.DoRegister: Integer; 132 | begin 133 | Result := -1; 134 | end; 135 | 136 | procedure TCommonNotifier.Modified; 137 | begin 138 | InternalModified; 139 | end; 140 | 141 | procedure TCommonNotifier.DoUnregister(ID: Integer); 142 | begin 143 | end; 144 | 145 | procedure TCommonNotifier.InternalAfterSave; 146 | begin 147 | end; 148 | 149 | procedure TCommonNotifier.InternalBeforeSave; 150 | begin 151 | end; 152 | 153 | procedure TCommonNotifier.InternalDestroyed; 154 | begin 155 | Unregister; 156 | end; 157 | 158 | procedure TCommonNotifier.InternalModified; 159 | begin 160 | end; 161 | 162 | procedure TCommonNotifier.Release; 163 | begin 164 | Unregister; 165 | end; 166 | 167 | procedure TCommonNotifier.Unregister; 168 | var 169 | tmpID: Integer; 170 | begin 171 | if FID >= 0 then begin 172 | { to avoid recursive call } 173 | tmpID := FID; 174 | FID := -1; 175 | DoUnregister(tmpID); 176 | end; 177 | end; 178 | 179 | function TMenuItemHelper.FindByName(const AName: string): TMenuItem; 180 | var 181 | item: TMenuItem; 182 | begin 183 | for item in Self do begin 184 | if SameText(item.Name, AName) then 185 | Exit(item); 186 | Result := item.FindByName(AName); 187 | if Result <> nil then 188 | Exit; 189 | end; 190 | Result := nil; 191 | end; 192 | 193 | constructor TNotifierHost.Create; 194 | begin 195 | inherited Create; 196 | FNotifiers := TList.Create(); 197 | end; 198 | 199 | destructor TNotifierHost.Destroy; 200 | begin 201 | ClearNotifiers; 202 | FNotifiers.Free; 203 | inherited Destroy; 204 | end; 205 | 206 | procedure TNotifierHost.AddNotifier(Value: TCommonNotifier); 207 | begin 208 | FNotifiers.Add(Value); 209 | end; 210 | 211 | procedure TNotifierHost.ClearNotifiers; 212 | var 213 | I: Integer; 214 | item: TCommonNotifier; 215 | begin 216 | for I := FNotifiers.Count - 1 downto 0 do begin 217 | item := FNotifiers[I]; 218 | FNotifiers.Delete(I); 219 | item.Release; 220 | end; 221 | end; 222 | 223 | function TNotifierHost.FindNotifier(Predicate: TPredicate): Boolean; 224 | var 225 | instance: T; 226 | begin 227 | Result := FindNotifier(Predicate, instance); 228 | end; 229 | 230 | function TNotifierHost.FindNotifier(Predicate: TPredicate; out Instance: T): Boolean; 231 | var 232 | notifier: TCommonNotifier; 233 | item: T; 234 | begin 235 | Result := False; 236 | Instance := nil; 237 | for notifier in Notifiers do begin 238 | if notifier is T then begin 239 | item := notifier as T; 240 | if Predicate(item) then begin 241 | Instance := Item; 242 | Result := True; 243 | Break; 244 | end; 245 | end; 246 | end; 247 | end; 248 | 249 | procedure TNotifierHost.RemoveNotifier(Value: TCommonNotifier); 250 | begin 251 | FNotifiers.Remove(Value); 252 | end; 253 | 254 | class function OTA.AboutBoxServices: IOTAAboutBoxServices; 255 | begin 256 | BorlandIDEServices.GetService(IOTAAboutBoxServices, Result); 257 | end; 258 | 259 | class function OTA.DebuggerServices: IOTADebuggerServices; 260 | begin 261 | BorlandIDEServices.GetService(IOTADebuggerServices, Result); 262 | end; 263 | 264 | class function OTA.EditorServices: IOTAEditorServices; 265 | begin 266 | BorlandIDEServices.GetService(IOTAEditorServices, Result); 267 | end; 268 | 269 | class function OTA.IDELibSuffix: string; 270 | var 271 | I: Integer; 272 | myInfo: IOTAPackageInfo; 273 | begin 274 | if FIDELibSuffix = '' then begin 275 | { Extract LibSuffix from RTL package } 276 | for I := 0 to PackageServices.PackageCount - 1 do 277 | begin 278 | myInfo := PackageServices.Package[I]; 279 | if SameText(myInfo.SymbolFileName, 'rtl') then begin // do not localize 280 | FIDELibSuffix := Copy(TPath.GetFileNameWithoutExtension(myInfo.Name), Length(myInfo.SymbolFileName) + 1); 281 | Break; 282 | end; 283 | end; 284 | end; 285 | Result := FIDELibSuffix; 286 | end; 287 | 288 | class function OTA.IsPackageInstalled(const APackageName: string): Boolean; 289 | var 290 | fullName: string; 291 | I: Integer; 292 | begin 293 | fullName := APackageName + IDELibSuffix + '.bpl'; // do not localize 294 | for I := 0 to PackageServices.PackageCount - 1 do begin 295 | if SameText(PackageServices.PackageNames[I], fullName) then Exit(True); 296 | end; 297 | Result := False; 298 | end; 299 | 300 | class function OTA.KeyboardServices: IOTAKeyboardServices; 301 | begin 302 | BorlandIDEServices.GetService(IOTAKeyboardServices, Result); 303 | end; 304 | 305 | class function OTA.ModuleServices: IOTAModuleServices; 306 | begin 307 | BorlandIDEServices.GetService(IOTAModuleServices, Result); 308 | end; 309 | 310 | class function OTA.PackageServices: IOTAPackageServices; 311 | begin 312 | BorlandIDEServices.GetService(IOTAPAckageServices, Result); 313 | end; 314 | 315 | class function OTA.PlatformServices: IOTAPlatformServices; 316 | begin 317 | BorlandIDEServices.GetService(IOTAPlatformServices, Result); 318 | end; 319 | 320 | class function OTA.Services: IOTAServices; 321 | begin 322 | BorlandIDEServices.GetService(IOTAServices, Result); 323 | end; 324 | 325 | class function NTA.EnvironmentOptionsServices: INTAEnvironmentOptionsServices; 326 | begin 327 | BorlandIDEServices.GetService(INTAEnvironmentOptionsServices, Result); 328 | end; 329 | 330 | class function NTA.FindMenuItem(const AName: string): TMenuItem; 331 | begin 332 | Result := Services.MainMenu.Items.FindByName(AName); 333 | end; 334 | 335 | class function NTA.FindMenuItem(const BreadCrumbs: array of string): TMenuItem; 336 | var 337 | item: TMenuItem; 338 | S: string; 339 | begin 340 | item := Services.MainMenu.Items; 341 | for S in BreadCrumbs do begin 342 | item := item.Find(S); 343 | if item = nil then Exit(nil); 344 | end; 345 | Result := item; 346 | end; 347 | 348 | class function NTA.Services: INTAServices; 349 | begin 350 | BorlandIDEServices.GetService(INTAServices, Result); 351 | end; 352 | 353 | constructor THostedNotifier.Create(ANotifierHost: TNotifierHost); 354 | begin 355 | CheckNotifierHost(ANotifierHost); 356 | inherited Create; 357 | FNotifierHost := ANotifierHost; 358 | FNotifierHost.AddNotifier(Self); 359 | end; 360 | 361 | destructor THostedNotifier.Destroy; 362 | begin 363 | FNotifierHost.RemoveNotifier(Self); 364 | inherited; 365 | end; 366 | 367 | procedure THostedNotifier.CheckNotifierHost(ANotifierHost: TNotifierHost); 368 | begin 369 | if ANotifierHost = nil then 370 | raise EProgrammerNotFound.Create('NotifierHost must not be nil!'); 371 | end; 372 | 373 | end. 374 | -------------------------------------------------------------------------------- /Source/CodeCoverage.Consts.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UweRaabe/DelphiCodeCoveragePlugin/8f1246759e6ef6bb22c443c4e3b495d137319f98/Source/CodeCoverage.Consts.pas -------------------------------------------------------------------------------- /Source/CodeCoverage.DM.dfm: -------------------------------------------------------------------------------- 1 | object dmCodeCoverage: TdmCodeCoverage 2 | OldCreateOrder = True 3 | Height = 302 4 | Width = 584 5 | object Actions: TActionList 6 | Images = dmCodeCoverageImages.Images 7 | Left = 120 8 | Top = 40 9 | object actSwitchCodeCoverage: TAction 10 | Category = 'Code Coverage' 11 | Caption = 'Switch Code Coverage' 12 | Hint = 'Switch code coverage for current method' 13 | ImageIndex = 1 14 | OnExecute = actSwitchCodeCoverageExecute 15 | OnUpdate = actSwitchCodeCoverageUpdate 16 | end 17 | object actRunCodeCoverage: TAction 18 | Category = 'Code Coverage' 19 | Caption = 'Run Code Coverage' 20 | Hint = 'Runs the test project for code coverage' 21 | ImageIndex = 2 22 | OnExecute = actRunCodeCoverageExecute 23 | OnUpdate = actRunCodeCoverageUpdate 24 | end 25 | end 26 | object MenuItems: TPopupMenu 27 | Left = 296 28 | Top = 40 29 | object mnuRunCodeCoverage: TMenuItem 30 | Action = actRunCodeCoverage 31 | end 32 | end 33 | end 34 | -------------------------------------------------------------------------------- /Source/CodeCoverage.DM.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.DM; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, System.Actions, System.Contnrs, 7 | Vcl.Graphics, Vcl.Menus, Vcl.ActnList, Vcl.ImgList, 8 | CodeCoverage.Handler; 9 | 10 | type 11 | TdmCodeCoverage = class(TDataModule) 12 | Actions: TActionList; 13 | actSwitchCodeCoverage: TAction; 14 | actRunCodeCoverage: TAction; 15 | MenuItems: TPopupMenu; 16 | mnuRunCodeCoverage: TMenuItem; 17 | procedure actRunCodeCoverageExecute(Sender: TObject); 18 | procedure actRunCodeCoverageUpdate(Sender: TObject); 19 | procedure actSwitchCodeCoverageExecute(Sender: TObject); 20 | procedure actSwitchCodeCoverageUpdate(Sender: TObject); 21 | private 22 | FCodeCoverage: TCodeCoverage; 23 | FActions: TComponentList; 24 | FImageIndexOffset: Integer; 25 | FMenuItems: TComponentList; 26 | procedure RememberActions; 27 | procedure RememberMenuItems; 28 | procedure SetCodeCoverage(const Value: TCodeCoverage); 29 | strict protected 30 | procedure ExecuteRunCodeCoverage; 31 | procedure ExecuteSwitchCodeCoverage; 32 | procedure UpdateRunCodeCoverage; 33 | procedure UpdateSwitchCodeCoverage; 34 | protected 35 | function GetImageList: TCustomImageList; 36 | public 37 | constructor Create(AOwner: TComponent); override; 38 | constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override; 39 | destructor Destroy; override; 40 | function FindImageIndexByName(const AImageName: string): Integer; 41 | function IsMyAction(Action: TBasicAction): Boolean; 42 | procedure RemoveActions; 43 | procedure RemoveMenuItems; 44 | property CodeCoverage: TCodeCoverage read FCodeCoverage write SetCodeCoverage; 45 | property ImageIndexOffset: Integer read FImageIndexOffset write FImageIndexOffset; 46 | property ImageList: TCustomImageList read GetImageList; 47 | end; 48 | 49 | var 50 | dmCodeCoverage: TdmCodeCoverage; 51 | 52 | implementation 53 | 54 | uses 55 | CodeCoverage.Images.DM; 56 | 57 | {%CLASSGROUP 'Vcl.Controls.TControl'} 58 | 59 | {$R *.dfm} 60 | 61 | constructor TdmCodeCoverage.Create(AOwner: TComponent); 62 | begin 63 | inherited Create(AOwner); 64 | FActions := TComponentList.Create(False); 65 | FMenuItems := TComponentList.Create(False); 66 | RememberActions; 67 | RememberMenuItems; 68 | end; 69 | 70 | constructor TdmCodeCoverage.CreateNew(AOwner: TComponent; Dummy: Integer); 71 | begin 72 | { avoids the datamodule being added to Screen.Datamodules } 73 | // Dummy := -1; 74 | inherited; 75 | end; 76 | 77 | destructor TdmCodeCoverage.Destroy; 78 | begin 79 | FMenuItems.Free; 80 | FActions.Free; 81 | inherited Destroy; 82 | end; 83 | 84 | procedure TdmCodeCoverage.actRunCodeCoverageExecute(Sender: TObject); 85 | begin 86 | ExecuteRunCodeCoverage; 87 | end; 88 | 89 | procedure TdmCodeCoverage.actRunCodeCoverageUpdate(Sender: TObject); 90 | begin 91 | UpdateRunCodeCoverage; 92 | end; 93 | 94 | procedure TdmCodeCoverage.actSwitchCodeCoverageExecute(Sender: TObject); 95 | begin 96 | ExecuteSwitchCodeCoverage; 97 | end; 98 | 99 | procedure TdmCodeCoverage.actSwitchCodeCoverageUpdate(Sender: TObject); 100 | begin 101 | UpdateSwitchCodeCoverage; 102 | end; 103 | 104 | function TdmCodeCoverage.IsMyAction(Action: TBasicAction): Boolean; 105 | begin 106 | Result := (FActions.IndexOf(Action) >= 0); 107 | end; 108 | 109 | procedure TdmCodeCoverage.RememberActions; 110 | var 111 | item: TContainedAction; 112 | begin 113 | for item in Actions do begin 114 | item.Tag := item.ImageIndex; 115 | FActions.Add(item); 116 | end; 117 | end; 118 | 119 | procedure TdmCodeCoverage.RememberMenuItems; 120 | var 121 | item: TMenuItem; 122 | begin 123 | for item in MenuItems.Items do begin 124 | FMenuItems.Add(item); 125 | end; 126 | end; 127 | 128 | procedure TdmCodeCoverage.RemoveActions; 129 | var 130 | I: Integer; 131 | begin 132 | for I := FActions.Count - 1 downto 0 do begin 133 | FActions[I].Free; 134 | end; 135 | end; 136 | 137 | procedure TdmCodeCoverage.RemoveMenuItems; 138 | var 139 | I: Integer; 140 | begin 141 | for I := FMenuItems.Count - 1 downto 0 do begin 142 | FMenuItems[I].Free; 143 | end; 144 | end; 145 | 146 | procedure TdmCodeCoverage.UpdateSwitchCodeCoverage; 147 | var 148 | state: TCoverState; 149 | begin 150 | state := TCoverState.noncoverable; 151 | if CodeCoverage <> nil then begin 152 | if CodeCoverage.IsAvailable then begin 153 | state := CodeCoverage.CurrentMethodState; 154 | end; 155 | end; 156 | actSwitchCodeCoverage.Enabled := (state > TCoverState.noncoverable); 157 | actSwitchCodeCoverage.Checked := (state = TCoverState.covered); 158 | end; 159 | 160 | procedure TdmCodeCoverage.UpdateRunCodeCoverage; 161 | var 162 | enabled: Boolean; 163 | begin 164 | enabled := False; 165 | if CodeCoverage <> nil then begin 166 | enabled := CodeCoverage.HasCodeCoverage; 167 | end; 168 | actRunCodeCoverage.Enabled := enabled; 169 | end; 170 | 171 | procedure TdmCodeCoverage.ExecuteRunCodeCoverage; 172 | begin 173 | if CodeCoverage <> nil then begin 174 | CodeCoverage.Execute; 175 | end; 176 | end; 177 | 178 | procedure TdmCodeCoverage.ExecuteSwitchCodeCoverage; 179 | begin 180 | if CodeCoverage <> nil then begin 181 | CodeCoverage.SwitchCodeCoverage; 182 | UpdateSwitchCodeCoverage; 183 | end; 184 | end; 185 | 186 | function TdmCodeCoverage.FindImageIndexByName(const AImageName: string): Integer; 187 | begin 188 | Result := dmCodeCoverageImages.FindImageIndexByName(AImageName); 189 | end; 190 | 191 | function TdmCodeCoverage.GetImageList: TCustomImageList; 192 | begin 193 | Result := Actions.Images; 194 | end; 195 | 196 | procedure TdmCodeCoverage.SetCodeCoverage(const Value: TCodeCoverage); 197 | begin 198 | if FCodeCoverage <> Value then 199 | begin 200 | FCodeCoverage := Value; 201 | if FCodeCoverage <> nil then begin 202 | FCodeCoverage.ImageList := ImageList; 203 | FCodeCoverage.ImageIndexCodeCoverage := FindImageIndexByName('CodeCoverage'); // do not localize 204 | FCodeCoverage.ImageIndexNoCoverage := FindImageIndexByName('NoCoverage'); // do not localize 205 | end; 206 | end; 207 | end; 208 | 209 | end. 210 | -------------------------------------------------------------------------------- /Source/CodeCoverage.Handler.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.Handler; 2 | 3 | interface 4 | 5 | uses 6 | ToolsAPI, 7 | System.Classes, 8 | Vcl.Menus, Vcl.Graphics, Vcl.ImgList, 9 | CodeCoverage.ApiHelper, CodeCoverage.Types, CodeCoverage.SyntaxTypes, CodeCoverage.Notifier; 10 | 11 | type 12 | {$SCOPEDENUMS ON} 13 | TCoverState = (noncoverable, coverable, covered); 14 | {$SCOPEDENUMS OFF} 15 | 16 | type 17 | TCodeCoverage = class(TNotifierHost, ICodeCoverage) 18 | private const 19 | cBreakpointGroupName = 'CodeCoverage'; 20 | private 21 | FActive: Boolean; 22 | FCodeSyntaxTrees: TCodeSyntaxTrees; 23 | FCoveredLines: TCoveredLines; 24 | FCoveredMethods: TCoveredMethods; 25 | FCurFileName: string; 26 | FCurLineMax: Integer; 27 | FCurLineMin: Integer; 28 | FCurProcess: IOTAProcess; 29 | FCurrentMethodState: TCoverState; 30 | FFullRepaint: TStringList; 31 | FImageIndexCodeCoverage: Integer; 32 | FImageIndexNoCoverage: Integer; 33 | FImageList: TCustomImageList; 34 | FRunMenuItem: TMenuItem; 35 | FValid: Boolean; 36 | function AddBreakpoint(ALineNumber: Integer): IOTABreakpoint; 37 | procedure AddCoverage(const AFileName: string; ALineNumber, ACount: Integer); 38 | function AddLineTracker(const EditBuffer: IOTAEditBuffer; ALineNumber: Integer): Integer; 39 | procedure CalcCoverage(const AFileName: string; const Data: TCoveredMethod); 40 | procedure CheckCodeCoverage; 41 | function CheckFullRepaint(const EditView: IOTAEditView): Boolean; 42 | procedure ClearAllCodeCoverage; 43 | procedure CoverMethod(const AFileName: string; const Data: TCoveredMethod); 44 | function CreateEditLineNotifier(const Tracker: IOTAEditLineTracker): Integer; 45 | procedure CreateEditorNotifier(const Editor: IOTASourceEditor); 46 | procedure CreateEditViewNotifier(const View: IOTAEditView); 47 | procedure CreateModuleNotifier(const Module: IOTAModule); 48 | function CreateSyntaxTree(const Editor: IOTASourceEditor): TCodeSyntaxTree; 49 | procedure DrawImage(ACanvas: TCanvas; X, Y, Index: Integer); 50 | procedure EnableCodeCoverage(const AProcess: IOTAProcess); 51 | function FindCoveredLinesList(const EditView: IOTAEditView): TCoveredLinesList; 52 | function FindCoveredMethodList(const EditView: IOTAEditView): TCoveredMethodList; 53 | function FindEditLineNotifier(const Tracker: IOTAEditLineTracker): TEditLineNotifier; 54 | function FindMethod(const EditBuffer: IOTAEditBuffer; Line: Integer; out Data: TCoveredMethod): Boolean; 55 | function FindSourceEditor(const AFileName: string): IOTASourceEditor; 56 | function FindSyntaxTree(const AFileName: string): TCodeSyntaxTree; overload; 57 | function FindSyntaxTree(const Editor: IOTASourceEditor): TCodeSyntaxTree; overload; 58 | function GetHasCodeCoverage: Boolean; 59 | function GetImageIndexCodeCoverage: Integer; 60 | function GetImageIndexNoCoverage: Integer; 61 | function GetValid: Boolean; 62 | function HandleSourceLine(ALineNumber: Integer): Boolean; 63 | function HasNotifier(const Target: T): Boolean; overload; 64 | procedure MarkFullRepaint(const AFileName: string); 65 | procedure MarkModified(const EditView: IOTAEditView); 66 | function MethodIdByLineNumber(const EditBuffer: IOTAEditBuffer; Line: Integer; out AID: TMethodID): Boolean; 67 | procedure ModuleRenamed(const OldName: string; const NewName: string); 68 | procedure RemoveEditLineNotifier(const Tracker: IOTAEditLineTracker); 69 | procedure RemoveEditor(const Editor: IOTASourceEditor); 70 | procedure RemoveLineTracker(const EditBuffer: IOTAEditBuffer); overload; 71 | procedure RemoveLineTracker(const EditBuffer: IOTAEditBuffer; ALineNumber, AID: Integer); overload; 72 | procedure RetrieveResults; 73 | function SelectCurrentMethod(const EditBuffer: IOTAEditBuffer; out AFileName, AMethodName: string; out LineMin, 74 | LineMax: Integer): Boolean; overload; 75 | function SelectMethod(const AFileName: string; const AMethod: TCoveredMethod; 76 | out LineMin, LineMax: Integer): Boolean; 77 | procedure TrackedLineChanged(const Tracker: IOTAEditLineTracker; OldLine, NewLine, Data: Integer); 78 | procedure UpdateCurrentMethodState; 79 | protected 80 | property Active: Boolean read FActive write FActive; 81 | property CodeSyntaxTrees: TCodeSyntaxTrees read FCodeSyntaxTrees; 82 | property CoveredLines: TCoveredLines read FCoveredLines; 83 | property CoveredMethods: TCoveredMethods read FCoveredMethods; 84 | property CurFileName: string read FCurFileName write FCurFileName; 85 | property CurLineMax: Integer read FCurLineMax write FCurLineMax; 86 | property CurLineMin: Integer read FCurLineMin write FCurLineMin; 87 | property CurProcess: IOTAProcess read FCurProcess write FCurProcess; 88 | property FullRepaint: TStringList read FFullRepaint; 89 | property Valid: Boolean read GetValid write FValid; 90 | public 91 | constructor Create; 92 | destructor Destroy; override; 93 | procedure Execute; 94 | procedure Initialize; 95 | function IsAvailable: Boolean; 96 | function SwitchCodeCoverage: Boolean; 97 | property CurrentMethodState: TCoverState read FCurrentMethodState; 98 | property HasCodeCoverage: Boolean read GetHasCodeCoverage; 99 | property ImageIndexCodeCoverage: Integer read GetImageIndexCodeCoverage write FImageIndexCodeCoverage; 100 | property ImageIndexNoCoverage: Integer read GetImageIndexNoCoverage write FImageIndexNoCoverage; 101 | property ImageList: TCustomImageList read FImageList write FImageList; 102 | property RunMenuItem: TMenuItem read FRunMenuItem write FRunMenuItem; 103 | end; 104 | 105 | implementation 106 | 107 | uses 108 | System.Math, System.StrUtils, System.Types, System.SysUtils, 109 | Vcl.Dialogs; 110 | 111 | function GetSourceLines(LineNum: Integer; ClientArg: Pointer): Integer pascal; 112 | begin 113 | Result := 0; 114 | if TCodeCoverage(ClientArg).HandleSourceLine(LineNum) then begin 115 | Result := 1; 116 | end; 117 | end; 118 | 119 | constructor TCodeCoverage.Create; 120 | begin 121 | inherited Create; 122 | FCoveredLines := TCoveredLines.Create(); 123 | FCoveredMethods := TCoveredMethods.Create(); 124 | FCodeSyntaxTrees := TCodeSyntaxTrees.Create(); 125 | 126 | FFullRepaint := TStringList.Create(dupIgnore, true, false); 127 | 128 | TDebuggerNotifier.Create(Self); 129 | TEditServicesNotifier.Create(Self); 130 | 131 | CreateEditViewNotifier(OTA.EditorServices.TopView); 132 | end; 133 | 134 | destructor TCodeCoverage.Destroy; 135 | begin 136 | FFullRepaint.Free; 137 | FCodeSyntaxTrees.Free; 138 | FCoveredMethods.Free; 139 | FCoveredLines.Free; 140 | inherited; 141 | end; 142 | 143 | procedure TCodeCoverage.DrawImage(ACanvas: TCanvas; X, Y, Index: Integer); 144 | begin 145 | ImageList.Draw(ACanvas, X, Y, Index); 146 | end; 147 | 148 | function TCodeCoverage.AddBreakpoint(ALineNumber: Integer): IOTABreakpoint; 149 | begin 150 | Result := OTA.DebuggerServices.NewSourceBreakpoint(CurFileName, ALineNumber, CurProcess); 151 | if Result <> nil then begin 152 | Result.DoBreak := false; 153 | Result.GroupName := cBreakpointGroupName; 154 | if ALineNumber = CurLineMin then begin 155 | Result.DoIgnoreExceptions := True; 156 | end 157 | else if ALineNumber = CurLineMax then begin 158 | Result.DoHandleExceptions := True; 159 | end 160 | else begin 161 | Result.PassCount := MaxInt; 162 | CoveredLines.Initialize(CurFileName, ALineNumber, 0); 163 | end; 164 | end; 165 | end; 166 | 167 | procedure TCodeCoverage.AddCoverage(const AFileName: string; ALineNumber, ACount: Integer); 168 | begin 169 | CoveredLines.Add(AFileName, ALineNumber, ACount); 170 | end; 171 | 172 | function TCodeCoverage.AddLineTracker(const EditBuffer: IOTAEditBuffer; ALineNumber: Integer): Integer; 173 | var 174 | Tracker: IOTAEditLineTracker; 175 | begin 176 | Tracker := EditBuffer.GetEditLineTracker; 177 | Result := CreateEditLineNotifier(Tracker); 178 | Tracker.AddLine(ALineNumber, Result); 179 | end; 180 | 181 | procedure TCodeCoverage.CalcCoverage(const AFileName: string; const Data: TCoveredMethod); 182 | var 183 | Count: Integer; 184 | covered: Integer; 185 | I: Integer; 186 | percent: Integer; 187 | total: Integer; 188 | begin 189 | total := 0; 190 | covered := 0; 191 | for I := Data.LineMin to Data.LineMax do begin 192 | Count := CoveredLines.Find(AFileName, I); 193 | if Count >= 0 then begin 194 | Inc(total); 195 | if Count > 0 then begin 196 | Inc(covered); 197 | end; 198 | end; 199 | end; 200 | if total = covered then begin 201 | percent := 100; 202 | end 203 | else if covered = 0 then begin 204 | percent := 0; 205 | end 206 | else begin 207 | percent := EnsureRange(Round(100*covered/total), 1, 99); 208 | end; 209 | CoveredMethods.UpdatePercent(AFileName, Data.ID, percent); 210 | end; 211 | 212 | procedure TCodeCoverage.CheckCodeCoverage; 213 | var 214 | bp: IOTABreakpoint; 215 | I: Integer; 216 | begin 217 | for I := 0 to OTA.DebuggerServices.SourceBkptCount - 1 do begin 218 | bp := OTA.DebuggerServices.SourceBkpts[I]; 219 | if MatchStr(bp.GroupName, [cBreakpointGroupName]) then begin 220 | if not (bp.DoHandleExceptions or bp.DoIgnoreExceptions) then begin 221 | AddCoverage(bp.FileName, bp.LineNumber, bp.CurPassCount); 222 | end; 223 | end; 224 | end; 225 | CoveredMethods.Iterate(CalcCoverage); 226 | 227 | Valid := true; 228 | end; 229 | 230 | function TCodeCoverage.CheckFullRepaint(const EditView: IOTAEditView): Boolean; 231 | var 232 | idx: Integer; 233 | begin 234 | Result := FullRepaint.Find(EditView.Buffer.FileName, idx); 235 | if Result then begin 236 | FullRepaint.Delete(idx); 237 | end; 238 | end; 239 | 240 | procedure TCodeCoverage.ClearAllCodeCoverage; 241 | var 242 | bp: IOTABreakpoint; 243 | I: Integer; 244 | begin 245 | for I := OTA.DebuggerServices.SourceBkptCount - 1 downto 0 do begin 246 | bp := OTA.DebuggerServices.SourceBkpts[I]; 247 | if bp.GroupName = cBreakpointGroupName then begin 248 | OTA.DebuggerServices.RemoveBreakpoint(bp); 249 | end; 250 | end; 251 | 252 | FCurProcess := nil; 253 | end; 254 | 255 | procedure TCodeCoverage.CoverMethod(const AFileName: string; const Data: TCoveredMethod); 256 | var 257 | I: Integer; 258 | begin 259 | if CurProcess.SourceIsDebuggable[AFileName] then begin 260 | if SelectMethod(AFileName, Data, FCurLineMin, FCurLineMax) then begin 261 | CoveredMethods.Update(AFileName, Data.ID, FCurLineMin + 1, FCurLineMax - 1); 262 | FCurFileName := AFileName; 263 | for I := FCurLineMin + 1 to FCurLineMax - 1 do begin 264 | CoveredLines.Initialize(FCurFileName, I, -1); 265 | end; 266 | CurProcess.GetSourceLines(FCurFileName, FCurLineMin, GetSourceLines, Self); 267 | end; 268 | end; 269 | end; 270 | 271 | function TCodeCoverage.CreateEditLineNotifier(const Tracker: IOTAEditLineTracker): Integer; 272 | var 273 | instance: TEditLineNotifier; 274 | begin 275 | if Tracker = nil then 276 | Exit(-1); 277 | 278 | { check if Tracker already has a notifier } 279 | instance := FindEditLineNotifier(Tracker); 280 | if instance = nil then begin 281 | instance := TEditLineNotifier.Create(Self, Tracker); 282 | end; 283 | Result := instance.NextID; 284 | end; 285 | 286 | procedure TCodeCoverage.CreateEditorNotifier(const Editor: IOTASourceEditor); 287 | begin 288 | if not HasNotifier(Editor) then begin 289 | TEditorNotifier.Create(Self, Editor); 290 | end; 291 | end; 292 | 293 | procedure TCodeCoverage.CreateEditViewNotifier(const View: IOTAEditView); 294 | begin 295 | if not HasNotifier(View) then begin 296 | TEditViewNotifier.Create(Self, View); 297 | end; 298 | end; 299 | 300 | procedure TCodeCoverage.CreateModuleNotifier(const Module: IOTAModule); 301 | begin 302 | if not HasNotifier(Module) then begin 303 | TModuleNotifier.Create(Self, Module); 304 | end; 305 | end; 306 | 307 | function TCodeCoverage.CreateSyntaxTree(const Editor: IOTASourceEditor): TCodeSyntaxTree; 308 | begin 309 | Result := CodeSyntaxTrees.Add(Editor); 310 | if Result <> nil then begin 311 | CreateEditorNotifier(Editor); 312 | CreateModuleNotifier(Editor.Module); 313 | end; 314 | end; 315 | 316 | procedure TCodeCoverage.EnableCodeCoverage(const AProcess: IOTAProcess); 317 | begin 318 | if not Active then 319 | Exit; 320 | 321 | CoveredLines.Clear; 322 | Valid := false; 323 | FCurProcess := AProcess; 324 | CoveredMethods.Iterate(CoverMethod); 325 | Active := not CoveredLines.IsEmpty; 326 | end; 327 | 328 | procedure TCodeCoverage.Execute; 329 | var 330 | builder: IOTAProjectBuilder; 331 | project: IOTAProject; 332 | begin 333 | project := OTA.ModuleServices.GetActiveProject; 334 | if project = nil then begin 335 | ShowMessage('No active project!'); 336 | Exit; 337 | end; 338 | 339 | ClearAllCodeCoverage; 340 | 341 | builder := project.ProjectBuilder; 342 | if builder = nil then begin 343 | ShowMessage('Active project has no project buidler!'); 344 | Exit; 345 | end; 346 | 347 | if builder.BuildProject(cmOTABuild, false, true) then begin 348 | // OTADebuggerServices.CreateProcess(project.ProjectOptions.TargetName, ''); 349 | if (RunMenuItem <> nil) and RunMenuItem.Enabled then begin 350 | Active := true; 351 | try 352 | RunMenuItem.Click; 353 | except 354 | Active := false; 355 | end; 356 | end; 357 | end; 358 | end; 359 | 360 | function TCodeCoverage.FindCoveredLinesList(const EditView: IOTAEditView): TCoveredLinesList; 361 | begin 362 | Result := CoveredLines.Find(EditView.Buffer.FileName); 363 | end; 364 | 365 | function TCodeCoverage.FindCoveredMethodList(const EditView: IOTAEditView): TCoveredMethodList; 366 | begin 367 | Result := CoveredMethods.Find(EditView.Buffer.FileName); 368 | end; 369 | 370 | function TCodeCoverage.FindEditLineNotifier(const Tracker: IOTAEditLineTracker): TEditLineNotifier; 371 | var 372 | instance: TEditLineNotifier; 373 | begin 374 | Result := nil; 375 | if Tracker = nil then 376 | Exit; 377 | 378 | 379 | if FindNotifier( 380 | function(Arg: TEditLineNotifier): Boolean 381 | begin 382 | Result := Arg.HandlesTarget(Tracker); 383 | end, 384 | instance) then 385 | begin 386 | Result := instance; 387 | end; 388 | end; 389 | 390 | function TCodeCoverage.FindMethod(const EditBuffer: IOTAEditBuffer; Line: Integer; out Data: TCoveredMethod): Boolean; 391 | var 392 | curID: TMethodID; 393 | begin 394 | Result := MethodIdByLineNumber(EditBuffer, Line, curID) and CoveredMethods.Find(EditBuffer.FileName, curID, Data); 395 | end; 396 | 397 | function TCodeCoverage.FindSourceEditor(const AFileName: string): IOTASourceEditor; 398 | var 399 | Editor: IOTAEditor; 400 | I: Integer; 401 | module: IOTAModule; 402 | sourceEditor: IOTASourceEditor; 403 | begin 404 | Result := nil; 405 | 406 | module := OTA.ModuleServices.FindModule(AFileName); 407 | for I := 0 to module.ModuleFileCount - 1 do begin 408 | Editor := module.ModuleFileEditors[I]; 409 | if Supports(Editor, IOTASourceEditor, sourceEditor) then begin 410 | Exit(sourceEditor); 411 | end; 412 | end; 413 | end; 414 | 415 | function TCodeCoverage.FindSyntaxTree(const AFileName: string): TCodeSyntaxTree; 416 | begin 417 | if AFileName = '' then 418 | Exit(nil); 419 | 420 | if not CodeSyntaxTrees.Find(AFileName, Result) then begin 421 | Result := CreateSyntaxTree(FindSourceEditor(AFileName)); 422 | end; 423 | end; 424 | 425 | function TCodeCoverage.FindSyntaxTree(const Editor: IOTASourceEditor): TCodeSyntaxTree; 426 | begin 427 | if Editor = nil then 428 | Exit(nil); 429 | 430 | if not CodeSyntaxTrees.Find(Editor.FileName, Result) then begin 431 | Result := CreateSyntaxTree(Editor); 432 | end; 433 | end; 434 | 435 | function TCodeCoverage.GetHasCodeCoverage: Boolean; 436 | begin 437 | Result := IsAvailable and not CoveredMethods.IsEmpty; 438 | end; 439 | 440 | function TCodeCoverage.GetImageIndexCodeCoverage: Integer; 441 | begin 442 | Result := FImageIndexCodeCoverage; 443 | end; 444 | 445 | function TCodeCoverage.GetImageIndexNoCoverage: Integer; 446 | begin 447 | Result := FImageIndexNoCoverage; 448 | end; 449 | 450 | function TCodeCoverage.GetValid: Boolean; 451 | begin 452 | Result := FValid; 453 | end; 454 | 455 | function TCodeCoverage.HandleSourceLine(ALineNumber: Integer): Boolean; 456 | begin 457 | Result := false; 458 | if ALineNumber <= CurLineMax then begin 459 | AddBreakpoint(ALineNumber); 460 | Result := true; 461 | end; 462 | end; 463 | 464 | function TCodeCoverage.HasNotifier(const Target: T): Boolean; 465 | begin 466 | Result := FindNotifier>( 467 | function(Arg: TCodeCoverageNotifier): Boolean 468 | begin 469 | Result := Arg.HandlesTarget(Target); 470 | end); 471 | end; 472 | 473 | procedure TCodeCoverage.Initialize; 474 | var 475 | Editor: IOTAEditor; 476 | I: Integer; 477 | J: Integer; 478 | K: Integer; 479 | module: IOTAModule; 480 | moduleServices: IOTAModuleServices; 481 | sourceEditor: IOTASourceEditor; 482 | view: IOTAEditView; 483 | begin 484 | moduleServices := OTA.ModuleServices; 485 | for I := 0 to moduleServices.ModuleCount - 1 do begin 486 | module := moduleServices.Modules[I]; 487 | for J := 0 to module.ModuleFileCount - 1 do begin 488 | Editor := module.ModuleFileEditors[J]; 489 | if Supports(Editor, IOTASourceEditor, sourceEditor) then begin 490 | for K := 0 to sourceEditor.EditViewCount - 1 do begin 491 | view := sourceEditor.EditViews[K]; 492 | CreateEditViewNotifier(view); 493 | end; 494 | end; 495 | end; 496 | end; 497 | UpdateCurrentMethodState; 498 | end; 499 | 500 | function TCodeCoverage.IsAvailable: Boolean; 501 | var 502 | project: IOTAProject; 503 | begin 504 | Result := False; 505 | 506 | project := OTA.ModuleServices.GetActiveProject; 507 | if project = nil then 508 | Exit; 509 | if not MatchText(project.ApplicationType, [sApplication, sConsole]) then 510 | Exit; 511 | 512 | Result := true; 513 | end; 514 | 515 | procedure TCodeCoverage.MarkFullRepaint(const AFileName: string); 516 | begin 517 | FullRepaint.Add(AFileName); 518 | end; 519 | 520 | procedure TCodeCoverage.MarkModified(const EditView: IOTAEditView); 521 | begin 522 | CodeSyntaxTrees.Remove(EditView.Buffer.FileName); 523 | end; 524 | 525 | function TCodeCoverage.MethodIdByLineNumber(const EditBuffer: IOTAEditBuffer; Line: Integer; out AID: TMethodID): 526 | Boolean; 527 | var 528 | idx: Integer; 529 | Tracker: IOTAEditLineTracker; 530 | begin 531 | Result := false; 532 | if EditBuffer = nil then 533 | Exit; 534 | 535 | Tracker := EditBuffer.GetEditLineTracker; 536 | if Tracker = nil then 537 | Exit; 538 | 539 | idx := Tracker.IndexOfLine(Line); 540 | if idx < 0 then 541 | Exit; 542 | 543 | AID := Tracker.Data[idx]; 544 | Result := true; 545 | end; 546 | 547 | procedure TCodeCoverage.ModuleRenamed(const OldName, NewName: string); 548 | var 549 | idx: Integer; 550 | begin 551 | CoveredMethods.RenameFile(OldName, NewName); 552 | CoveredLines.RenameFile(OldName, NewName); 553 | CodeSyntaxTrees.RenameFile(OldName, NewName); 554 | if FullRepaint.Find(OldName, idx) then begin 555 | FullRepaint.Delete(idx); 556 | FullRepaint.Add(NewName); 557 | end; 558 | end; 559 | 560 | procedure TCodeCoverage.RemoveEditLineNotifier(const Tracker: IOTAEditLineTracker); 561 | var 562 | instance: TEditLineNotifier; 563 | begin 564 | instance := FindEditLineNotifier(Tracker); 565 | if instance <> nil then begin 566 | instance.Release; 567 | end; 568 | end; 569 | 570 | procedure TCodeCoverage.RemoveEditor(const Editor: IOTASourceEditor); 571 | var 572 | EditBuffer: IOTAEditBuffer; 573 | begin 574 | if Supports(Editor, IOTAEditBuffer, EditBuffer) then begin 575 | RemoveLineTracker(EditBuffer); 576 | end; 577 | CoveredLines.Remove(Editor.FileName); 578 | CoveredMethods.Remove(Editor.FileName); 579 | CodeSyntaxTrees.Remove(Editor.FileName); 580 | end; 581 | 582 | procedure TCodeCoverage.RemoveLineTracker(const EditBuffer: IOTAEditBuffer); 583 | var 584 | Tracker: IOTAEditLineTracker; 585 | begin 586 | Tracker := EditBuffer.GetEditLineTracker; 587 | RemoveEditLineNotifier(Tracker); 588 | end; 589 | 590 | procedure TCodeCoverage.RemoveLineTracker(const EditBuffer: IOTAEditBuffer; ALineNumber, AID: Integer); 591 | var 592 | idx: Integer; 593 | Tracker: IOTAEditLineTracker; 594 | begin 595 | Tracker := EditBuffer.GetEditLineTracker; 596 | idx := Tracker.IndexOfData(AID); 597 | if idx < 0 then begin 598 | idx := Tracker.IndexOfLine(ALineNumber); 599 | end; 600 | if idx >= 0 then begin 601 | Tracker.Delete(idx); 602 | end; 603 | end; 604 | 605 | procedure TCodeCoverage.RetrieveResults; 606 | begin 607 | if not Active then 608 | Exit; 609 | 610 | CheckCodeCoverage; 611 | ClearAllCodeCoverage; 612 | Active := false; 613 | end; 614 | 615 | function TCodeCoverage.SelectCurrentMethod(const EditBuffer: IOTAEditBuffer; out AFileName, AMethodName: string; out 616 | LineMin, LineMax: Integer): Boolean; 617 | var 618 | code: TCodeSyntaxTree; 619 | begin 620 | Result := false; 621 | 622 | code := FindSyntaxTree(EditBuffer); 623 | if code <> nil then begin 624 | AFileName := code.FileName; 625 | Result := code.FindCurrentMethod(EditBuffer.TopView, AMethodName, LineMin, LineMax); 626 | end; 627 | end; 628 | 629 | function TCodeCoverage.SelectMethod(const AFileName: string; const AMethod: TCoveredMethod; 630 | out LineMin, LineMax: Integer): Boolean; 631 | var 632 | code: TCodeSyntaxTree; 633 | begin 634 | Result := false; 635 | 636 | code := FindSyntaxTree(AFileName); 637 | if code <> nil then begin 638 | Result := code.SelectMethod(AMethod, LineMin, LineMax); 639 | end; 640 | end; 641 | 642 | function TCodeCoverage.SwitchCodeCoverage: Boolean; 643 | var 644 | curLine: TLineNumber; 645 | curMethod: string; 646 | Data: TCoveredMethod; 647 | EditBuffer: IOTAEditBuffer; 648 | FileName: string; 649 | ID: Integer; 650 | LineMax: Integer; 651 | LineMin: Integer; 652 | begin 653 | EditBuffer := OTA.EditorServices.TopBuffer; 654 | Result := SelectCurrentMethod(EditBuffer, FileName, curMethod, LineMin, LineMax); 655 | if Result then begin 656 | if FindMethod(EditBuffer, LineMin, Data) then begin 657 | CoveredMethods.Remove(FileName, Data.ID); 658 | CoveredLines.Remove(FileName, LineMin, LineMax); 659 | RemoveLineTracker(EditBuffer, Data.Line, Data.ID); 660 | FCurrentMethodState := TCoverState.coverable; 661 | end 662 | else begin 663 | curLine := LineMin; 664 | ID := AddLineTracker(EditBuffer, LineMin); 665 | CoveredMethods.Add(FileName, TCoveredMethod.Create(curMethod, curLine, ID)); 666 | FCurrentMethodState := TCoverState.covered; 667 | end; 668 | MarkFullRepaint(FileName); 669 | EditBuffer.TopView.Paint; 670 | end 671 | else begin 672 | ShowMessage('No method body found at cursor!'); 673 | FCurrentMethodState := TCoverState.noncoverable; 674 | end; 675 | end; 676 | 677 | procedure TCodeCoverage.TrackedLineChanged(const Tracker: IOTAEditLineTracker; OldLine, NewLine, Data: Integer); 678 | var 679 | FileName: string; 680 | ID: TMethodID; 681 | newLineNumber: TLineNumber; 682 | begin 683 | Valid := false; 684 | FileName := Tracker.GetEditBuffer.FileName; 685 | CoveredLines.Remove(FileName); 686 | ID := Data; 687 | newLineNumber := NewLine; 688 | CoveredMethods.ChangeLineNumber(FileName, ID, newLineNumber); 689 | end; 690 | 691 | procedure TCodeCoverage.UpdateCurrentMethodState; 692 | var 693 | curMethod: string; 694 | Data: TCoveredMethod; 695 | EditBuffer: IOTAEditBuffer; 696 | FileName: string; 697 | LineMax: Integer; 698 | LineMin: Integer; 699 | state: TCoverState; 700 | begin 701 | state := TCoverState.noncoverable; 702 | EditBuffer := OTA.EditorServices.TopBuffer; 703 | if SelectCurrentMethod(EditBuffer, FileName, curMethod, LineMin, LineMax) then begin 704 | state := TCoverState.coverable; 705 | if FindMethod(EditBuffer, LineMin, Data) then begin 706 | state := TCoverState.covered; 707 | end; 708 | end; 709 | FCurrentMethodState := state; 710 | end; 711 | 712 | end. 713 | 714 | -------------------------------------------------------------------------------- /Source/CodeCoverage.KeyBindings.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.KeyBindings; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, 7 | CodeCoverage.Notifier, 8 | ToolsAPI; 9 | 10 | type 11 | TKeyboardBinding = class(TCodeCoverageNotifier, IOTAKeyboardBinding) 12 | private 13 | FSwitchKeyCode: TShortCut; 14 | procedure SwitchCodeCoverage(const Context: IOTAKeyContext; KeyCode: TShortcut; var BindingResult: TKeyBindingResult); 15 | protected 16 | function DoRegister: Integer; override; 17 | procedure DoUnregister(ID: Integer); override; 18 | public 19 | procedure BindKeyboard(const BindingServices: IOTAKeyBindingServices); 20 | function GetBindingType: TBindingType; 21 | function GetDisplayName: string; 22 | function GetName: string; 23 | end; 24 | 25 | implementation 26 | 27 | uses 28 | Winapi.Windows, 29 | CodeCoverage.ApiHelper; 30 | 31 | resourcestring 32 | SCodeCoverageBindings = 'Code Coverage Bindings'; 33 | 34 | const 35 | cCodeCoverageBindings = 'CodeCoverageBindings'; 36 | 37 | procedure TKeyboardBinding.BindKeyboard(const BindingServices: IOTAKeyBindingServices); 38 | begin 39 | FSwitchKeyCode := scCtrl or scAlt or VK_F5; 40 | BindingServices.AddKeyBinding([FSwitchKeyCode], SwitchCodeCoverage, nil) 41 | end; 42 | 43 | function TKeyboardBinding.DoRegister: Integer; 44 | begin 45 | Result := OTA.KeyboardServices.AddKeyboardBinding(Self); 46 | end; 47 | 48 | procedure TKeyboardBinding.DoUnregister(ID: Integer); 49 | begin 50 | OTA.KeyboardServices.RemoveKeyboardBinding(ID); 51 | inherited; 52 | end; 53 | 54 | function TKeyboardBinding.GetBindingType: TBindingType; 55 | begin 56 | result := btPartial; 57 | end; 58 | 59 | function TKeyboardBinding.GetDisplayName: string; 60 | begin 61 | result := SCodeCoverageBindings; 62 | end; 63 | 64 | function TKeyboardBinding.GetName: string; 65 | begin 66 | result := cCodeCoverageBindings; 67 | end; 68 | 69 | procedure TKeyboardBinding.SwitchCodeCoverage(const Context: IOTAKeyContext; KeyCode: TShortcut; var BindingResult: TKeyBindingResult); 70 | begin 71 | CodeCoverage.SwitchCodeCoverage; 72 | BindingResult := krHandled; 73 | end; 74 | 75 | end. 76 | -------------------------------------------------------------------------------- /Source/CodeCoverage.Main.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.Main; 2 | 3 | interface 4 | 5 | uses 6 | Vcl.Graphics, Vcl.ComCtrls, 7 | CodeCoverage.Handler; 8 | 9 | type 10 | TMagician = class 11 | private 12 | FAboutBitmap: TBitmap; 13 | FCodeCoverage: TCodeCoverage; 14 | FPluginInfoID: Integer; 15 | FSplashBitmap: TBitmap; 16 | FVersion: string; 17 | class var 18 | FInstance: TMagician; 19 | function CreateFromIconResource(ASize: Integer): TBitmap; overload; 20 | function GetAboutBitmap: TBitmap; 21 | function GetDescription: string; 22 | function GetSplashBitmap: TBitmap; 23 | function GetTitle: string; 24 | function GetVersion: string; 25 | protected 26 | procedure AddMenuItems; 27 | procedure AddToolbars; 28 | procedure RemoveMenuItem; 29 | procedure RemoveToolButtons; overload; 30 | procedure RemoveToolButtons(ToolBar: TToolBar); overload; 31 | property AboutBitmap: TBitmap read GetAboutBitmap; 32 | property CodeCoverage: TCodeCoverage read FCodeCoverage; 33 | property Description: string read GetDescription; 34 | property SplashBitmap: TBitmap read GetSplashBitmap; 35 | property Title: string read GetTitle; 36 | property Version: string read GetVersion; 37 | public 38 | constructor Create; 39 | destructor Destroy; override; 40 | class procedure CreateInstance; 41 | class procedure DestroyInstance; 42 | end; 43 | 44 | procedure Register; 45 | 46 | implementation 47 | 48 | uses 49 | System.IOUtils, System.Types, System.StrUtils, System.Classes, 50 | Vcl.Controls, Vcl.Forms, 51 | ToolsApi, CodeCoverage.Tools, CodeCoverage.Consts, CodeCoverage.DM, CodeCoverage.KeyBindings, CodeCoverage.ApiHelper, 52 | CodeCoverage.Images.DM; 53 | 54 | resourcestring 55 | SCodeCoverage = 'Code Coverage'; 56 | 57 | const 58 | cRunDebugMenuItemName = 'RunRunNoDebugItem'; 59 | cRunMenuItemName = 'RunRunItem'; 60 | cSplashBitmapSize = 24; 61 | cAboutBitmapSize = 48; 62 | cCodeCoverageIni = 'CodeCoverage.ini'; 63 | cCodeCoverageToolbar = 'CodeCoverageToolbar'; 64 | 65 | type 66 | TToolButtonHelper = class helper for TToolButton 67 | public 68 | function GetToolBar: TToolBar; 69 | procedure SetToolBar(const Value: TToolBar); 70 | property ToolBar: TToolBar read GetToolBar write SetToolBar; 71 | end; 72 | 73 | function TToolButtonHelper.GetToolBar: TToolBar; 74 | begin 75 | Result := FToolBar; 76 | end; 77 | 78 | procedure TToolButtonHelper.SetToolBar(const Value: TToolBar); 79 | begin 80 | inherited SetToolBar(Value); 81 | end; 82 | 83 | constructor TMagician.Create; 84 | begin 85 | inherited; 86 | 87 | FCodeCoverage := TCodeCoverage.Create; 88 | FCodeCoverage.Initialize; 89 | 90 | dmCodeCoverageImages := TdmCodeCoverageImages.Create(nil); 91 | dmCodeCoverage := TdmCodeCoverage.Create(nil); 92 | dmCodeCoverage.CodeCoverage := CodeCoverage; 93 | 94 | {$IF Declared(TGraphicArray) } 95 | SplashScreenServices.AddPluginBitmap(Title, dmCodeCoverageImages.ImageArray[cIconName], False, '', ''); 96 | FPluginInfoID := OTA.AboutBoxServices.AddPluginInfo(Title, Description, dmCodeCoverageImages.ImageArray[cIconName]); 97 | {$ELSE} 98 | SplashScreenServices.AddPluginBitmap(Title, SplashBitmap.Handle); 99 | FPluginInfoID := OTA.AboutBoxServices.AddPluginInfo(Title, Description, AboutBitmap.Handle, False, '', '', otaafDefined); 100 | {$IFEND} 101 | TKeyboardBinding.Create(CodeCoverage); 102 | 103 | dmCodeCoverage.ImageIndexOffset := NTA.Services.AddImages(dmCodeCoverage.ImageList, cInternalName); 104 | AddMenuItems; 105 | AddToolbars; 106 | end; 107 | 108 | destructor TMagician.Destroy; 109 | begin 110 | CodeCoverage.ClearNotifiers; 111 | 112 | RemoveToolButtons; 113 | RemoveMenuItem; 114 | NTA.Services.AddImages(nil, cInternalName); 115 | 116 | if FPluginInfoID > 0 then begin 117 | OTA.AboutBoxServices.RemovePluginInfo(FPluginInfoID); 118 | end; 119 | 120 | dmCodeCoverage.Free; 121 | dmCodeCoverage := nil; 122 | dmCodeCoverageImages.Free; 123 | dmCodeCoverageImages := nil; 124 | 125 | FCodeCoverage.Free; 126 | FAboutBitmap.Free; 127 | FSplashBitmap.Free; 128 | inherited; 129 | end; 130 | 131 | procedure TMagician.AddMenuItems; 132 | begin 133 | CodeCoverage.RunMenuItem := NTA.FindMenuItem(cRunMenuItemName); 134 | 135 | NTA.Services.AddActionMenu('', dmCodeCoverage.actSwitchCodeCoverage, nil, False); 136 | NTA.Services.AddActionMenu(cRunDebugMenuItemName, dmCodeCoverage.actRunCodeCoverage, dmCodeCoverage.mnuRunCodeCoverage, True); 137 | end; 138 | 139 | procedure TMagician.AddToolbars; 140 | const 141 | cBtnSwitch = cCodeCoverageToolbar + 'BtnSwitch'; 142 | cBtnRun = cCodeCoverageToolbar + 'BtnRun'; 143 | var 144 | btn: TToolButton; 145 | dbgR: TRect; 146 | I: Integer; 147 | tlb: TToolBar; 148 | tlbDebug: TToolBar; 149 | begin 150 | tlb := NTA.Services.ToolBar[cCodeCoverageToolbar]; 151 | if tlb <> nil then begin 152 | { remove existent buttons - just in case... } 153 | for I := tlb.ButtonCount - 1 downto 0 do begin 154 | btn := tlb.Buttons[I]; 155 | if MatchStr(btn.Name, [cBtnRun, cBtnSwitch]) then begin 156 | btn.ToolBar := nil; 157 | btn.Free; 158 | end; 159 | end; 160 | end 161 | else begin 162 | tlbDebug := NTA.Services.ToolBar[sDebugToolBar]; 163 | dbgR := tlbDebug.BoundsRect; 164 | tlb := NTA.Services.NewToolbar(cCodeCoverageToolbar, SCodeCoverage, tlbDebug.Name, False); 165 | tlb.AutoSize := True; 166 | tlb.SetBounds(dbgR.Right + 1, dbgR.Top, tlb.Width, dbgR.Height); 167 | end; 168 | NTA.Services.AddToolButton(tlb.Name, cBtnRun, dmCodeCoverage.actRunCodeCoverage); 169 | NTA.Services.AddToolButton(tlb.Name, cBtnSwitch, dmCodeCoverage.actSwitchCodeCoverage); 170 | tlb.Visible := True; 171 | end; 172 | 173 | function TMagician.CreateFromIconResource(ASize: Integer): TBitmap; 174 | begin 175 | Result := TTools.CreateFromIconResource(cIconName, ASize); 176 | end; 177 | 178 | class procedure TMagician.CreateInstance; 179 | begin 180 | FInstance := TMagician.Create; 181 | end; 182 | 183 | class procedure TMagician.DestroyInstance; 184 | begin 185 | FInstance.Free; 186 | end; 187 | 188 | function TMagician.GetAboutBitmap: TBitmap; 189 | begin 190 | if FAboutBitmap = nil then begin 191 | FAboutBitmap := CreateFromIconResource(cAboutBitmapSize); 192 | end; 193 | result := FAboutBitmap; 194 | end; 195 | 196 | function TMagician.GetDescription: string; 197 | begin 198 | Result := SDescription + sLineBreak + sLineBreak + cCopyRight; 199 | end; 200 | 201 | function TMagician.GetSplashBitmap: TBitmap; 202 | begin 203 | if FSplashBitmap = nil then begin 204 | FSplashBitmap := CreateFromIconResource(cSplashBitmapSize); 205 | end; 206 | result := FSplashBitmap; 207 | end; 208 | 209 | function TMagician.GetTitle: string; 210 | begin 211 | Result := cTitle + ' ' + Version; 212 | end; 213 | 214 | function TMagician.GetVersion: string; 215 | begin 216 | if FVersion = '' then begin 217 | FVersion := TTools.AppVersion; 218 | end; 219 | Result := FVersion; 220 | end; 221 | 222 | procedure TMagician.RemoveMenuItem; 223 | begin 224 | dmCodeCoverage.RemoveMenuItems; 225 | dmCodeCoverage.RemoveActions; 226 | end; 227 | 228 | procedure TMagician.RemoveToolButtons; 229 | const 230 | { IDE's Toolbar names } 231 | cToolBarNames: array of string = [sCustomToolBar, sStandardToolBar, sDebugToolBar, sViewToolBar, sDesktopToolBar, 232 | sInternetToolBar, sCORBAToolBar, sAlignToolbar, sBrowserToolbar, sHTMLDesignToolbar, sHTMLFormatToolbar, 233 | sHTMLTableToolbar, sPersonalityToolBar, sPositionToolbar, sSpacingToolbar, sIDEInsightToolbar, 234 | sPlatformDeviceToolbar]; 235 | var 236 | S: string; 237 | tlb: TToolBar; 238 | begin 239 | tlb := NTA.Services.ToolBar[cCodeCoverageToolbar]; 240 | if tlb <> nil then begin 241 | RemoveToolButtons(tlb); 242 | tlb.Visible := (tlb.ButtonCount > 0); 243 | end; 244 | 245 | for S in cToolBarNames do begin 246 | RemoveToolButtons(NTA.Services.ToolBar[S]); 247 | end; 248 | end; 249 | 250 | procedure TMagician.RemoveToolButtons(ToolBar: TToolBar); 251 | var 252 | I: Integer; 253 | Btn: TToolButton; 254 | begin 255 | if ToolBar = nil then Exit; 256 | 257 | for I := ToolBar.ButtonCount - 1 downto 0 do begin 258 | Btn := ToolBar.Buttons[I]; 259 | { someone could have just created a new button from our actions in the customize dialog } 260 | if dmCodeCoverage.IsMyAction(Btn.Action) then begin 261 | Btn.ToolBar := nil; 262 | Btn.Free; 263 | end; 264 | end; 265 | end; 266 | 267 | procedure Register; 268 | begin 269 | TMagician.CreateInstance; 270 | end; 271 | 272 | initialization 273 | finalization 274 | TMagician.DestroyInstance; 275 | end. 276 | 277 | -------------------------------------------------------------------------------- /Source/CodeCoverage.Notifier.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.Notifier; 2 | 3 | interface 4 | 5 | uses 6 | System.Types, System.Classes, 7 | Vcl.Graphics, 8 | CodeCoverage.ApiHelper, CodeCoverage.Types, 9 | ToolsAPI, DockForm; 10 | 11 | type 12 | ICodeCoverage = interface 13 | ['{BCF35C6D-C396-4A3E-8237-D5B99328D72D}'] 14 | function CheckFullRepaint(const EditView: IOTAEditView): Boolean; 15 | procedure CreateEditViewNotifier(const View: IOTAEditView); 16 | procedure DrawImage(ACanvas: TCanvas; X, Y, Index: Integer); 17 | procedure EnableCodeCoverage(const AProcess: IOTAProcess); 18 | function FindCoveredLinesList(const EditView: IOTAEditView): TCoveredLinesList; 19 | function FindCoveredMethodList(const EditView: IOTAEditView): TCoveredMethodList; 20 | function GetImageIndexCodeCoverage: Integer; 21 | function GetImageIndexNoCoverage: Integer; 22 | function GetValid: Boolean; 23 | procedure MarkModified(const EditView: IOTAEditView); 24 | function MethodIdByLineNumber(const EditBuffer: IOTAEditBuffer; Line: Integer; out AID: TMethodID): Boolean; 25 | procedure ModuleRenamed(const OldName, NewName: string); 26 | procedure RemoveEditor(const Editor: IOTASourceEditor); 27 | procedure RetrieveResults; 28 | function SwitchCodeCoverage: Boolean; 29 | procedure TrackedLineChanged(const Tracker: IOTAEditLineTracker; OldLine, NewLine, Data: Integer); 30 | procedure UpdateCurrentMethodState; 31 | property ImageIndexCodeCoverage: Integer read GetImageIndexCodeCoverage; 32 | property ImageIndexNoCoverage: Integer read GetImageIndexNoCoverage; 33 | property Valid: Boolean read GetValid; 34 | end; 35 | 36 | type 37 | TCodeCoverageNotifier = class(THostedNotifier) 38 | private 39 | FCodeCoverage: ICodeCoverage; 40 | protected 41 | procedure CheckNotifierHost(ANotifierHost: TNotifierHost); override; 42 | property CodeCoverage: ICodeCoverage read FCodeCoverage; 43 | public 44 | constructor Create(ANotifierHost: TNotifierHost); 45 | end; 46 | 47 | TCodeCoverageNotifier = class(TCodeCoverageNotifier) 48 | private 49 | FTarget: T; 50 | public 51 | constructor Create(AParentInstance: TNotifierHost; const ATarget: T); 52 | function HandlesTarget(const ATarget: T): Boolean; virtual; abstract; 53 | property Target: T read FTarget write FTarget; 54 | end; 55 | 56 | type 57 | TDebuggerNotifier = class(TCodeCoverageNotifier, IOTADebuggerNotifier, IOTADebuggerNotifier90) 58 | protected 59 | function DoRegister: Integer; override; 60 | procedure DoUnregister(ID: Integer); override; 61 | public 62 | function BeforeProgramLaunch(const Project: IOTAProject): Boolean; 63 | procedure BreakpointAdded(const Breakpoint: IOTABreakpoint); 64 | procedure BreakpointChanged(const Breakpoint: IOTABreakpoint); 65 | procedure BreakpointDeleted(const Breakpoint: IOTABreakpoint); 66 | procedure CurrentProcessChanged(const Process: IOTAProcess); 67 | procedure ProcessCreated(const Process: IOTAProcess); 68 | procedure ProcessDestroyed(const Process: IOTAProcess); 69 | procedure ProcessMemoryChanged; 70 | procedure ProcessStateChanged(const Process: IOTAProcess); 71 | end; 72 | 73 | type 74 | TEditLineNotifier = class(TCodeCoverageNotifier, IOTAEditLineNotifier) 75 | private 76 | FNextID: Integer; 77 | protected 78 | function DoRegister: Integer; override; 79 | procedure DoUnregister(ID: Integer); override; 80 | procedure InternalDestroyed; override; 81 | public 82 | function HandlesTarget(const ATarget: IOTAEditLineTracker): Boolean; override; 83 | procedure LineChanged(OldLine: Integer; NewLine: Integer; Data: Integer); 84 | function NextID: Integer; 85 | end; 86 | 87 | type 88 | TEditorNotifier = class(TCodeCoverageNotifier, IOTAEditorNotifier) 89 | private 90 | protected 91 | function DoRegister: Integer; override; 92 | procedure DoUnregister(ID: Integer); override; 93 | procedure InternalDestroyed; override; 94 | public 95 | function HandlesTarget(const ATarget: IOTASourceEditor): Boolean; override; 96 | procedure ViewActivated(const View: IOTAEditView); 97 | procedure ViewNotification(const View: IOTAEditView; Operation: TOperation); 98 | end; 99 | 100 | type 101 | TEditServicesNotifier = class(TCodeCoverageNotifier, INTAEditServicesNotifier) 102 | protected 103 | function DoRegister: Integer; override; 104 | procedure DoUnregister(ID: Integer); override; 105 | public 106 | procedure DockFormRefresh(const EditWindow: INTAEditWindow; DockForm: TDockableForm); 107 | procedure DockFormUpdated(const EditWindow: INTAEditWindow; DockForm: TDockableForm); 108 | procedure DockFormVisibleChanged(const EditWindow: INTAEditWindow; DockForm: TDockableForm); 109 | procedure EditorViewActivated(const EditWindow: INTAEditWindow; const EditView: IOTAEditView); 110 | procedure EditorViewModified(const EditWindow: INTAEditWindow; const EditView: IOTAEditView); 111 | procedure WindowActivated(const EditWindow: INTAEditWindow); 112 | procedure WindowCommand(const EditWindow: INTAEditWindow; Command: Integer; Param: Integer; var Handled: Boolean); 113 | procedure WindowNotification(const EditWindow: INTAEditWindow; Operation: TOperation); 114 | procedure WindowShow(const EditWindow: INTAEditWindow; Show: Boolean; LoadedFromDesktop: Boolean); 115 | end; 116 | 117 | type 118 | TEditViewNotifier = class(TCodeCoverageNotifier, INTAEditViewNotifier) 119 | private 120 | FCoveredLinesList: TCoveredLinesList; 121 | FCoveredMethodList: TCoveredMethodList; 122 | protected 123 | function DoRegister: Integer; override; 124 | procedure DoUnregister(ID: Integer); override; 125 | public 126 | procedure BeginPaint(const View: IOTAEditView; var FullRepaint: Boolean); 127 | procedure EditorIdle(const View: IOTAEditView); 128 | procedure EndPaint(const View: IOTAEditView); 129 | function HandlesTarget(const ATarget: IOTAEditView): Boolean; override; 130 | procedure PaintLine(const View: IOTAEditView; LineNumber: Integer; const LineText: PAnsiChar; const TextWidth: Word; 131 | const LineAttributes: TOTAAttributeArray; const Canvas: TCanvas; const TextRect: TRect; const LineRect: TRect; 132 | const CellSize: TSize); 133 | property CoveredLinesList: TCoveredLinesList read FCoveredLinesList; 134 | property CoveredMethodList: TCoveredMethodList read FCoveredMethodList; 135 | end; 136 | 137 | type 138 | TModuleNotifier = class(TCodeCoverageNotifier, IOTAModuleNotifier) 139 | private 140 | FFileName: string; 141 | protected 142 | function DoRegister: Integer; override; 143 | procedure DoUnregister(ID: Integer); override; 144 | public 145 | function CheckOverwrite: Boolean; 146 | function HandlesTarget(const ATarget: IOTAModule): Boolean; override; 147 | procedure ModuleRenamed(const NewName: string); 148 | property FileName: string read FFileName write FFileName; 149 | end; 150 | 151 | implementation 152 | 153 | uses 154 | System.SysUtils, System.StrUtils, System.Math; 155 | 156 | type 157 | TCanvasState = class 158 | private 159 | FBrush: TBrushRecall; 160 | FFont: TFontRecall; 161 | FPen: TPenRecall; 162 | public 163 | constructor Create(ACanvas: TCanvas); 164 | destructor Destroy; override; 165 | end; 166 | 167 | procedure TCodeCoverageNotifier.CheckNotifierHost(ANotifierHost: TNotifierHost); 168 | begin 169 | inherited; 170 | if not Supports(ANotifierHost, ICodeCoverage) then 171 | raise EProgrammerNotFound.Create('NotifierHost must support ICodeCoverage!'); 172 | end; 173 | 174 | constructor TCodeCoverageNotifier.Create(ANotifierHost: TNotifierHost); 175 | begin 176 | inherited Create(ANotifierHost); 177 | { We know that this will succeed } 178 | FCodeCoverage := NotifierHost as ICodeCoverage; 179 | end; 180 | 181 | function TDebuggerNotifier.BeforeProgramLaunch(const Project: IOTAProject): Boolean; 182 | begin 183 | Result := True; 184 | end; 185 | 186 | procedure TDebuggerNotifier.BreakpointAdded(const Breakpoint: IOTABreakpoint); 187 | begin 188 | end; 189 | 190 | procedure TDebuggerNotifier.BreakpointChanged(const Breakpoint: IOTABreakpoint); 191 | begin 192 | end; 193 | 194 | procedure TDebuggerNotifier.BreakpointDeleted(const Breakpoint: IOTABreakpoint); 195 | begin 196 | end; 197 | 198 | procedure TDebuggerNotifier.CurrentProcessChanged(const Process: IOTAProcess); 199 | begin 200 | end; 201 | 202 | function TDebuggerNotifier.DoRegister: Integer; 203 | begin 204 | Result := OTA.DebuggerServices.AddNotifier(Self); 205 | end; 206 | 207 | procedure TDebuggerNotifier.DoUnregister(ID: Integer); 208 | begin 209 | OTA.DebuggerServices.RemoveNotifier(ID); 210 | inherited; 211 | end; 212 | 213 | procedure TDebuggerNotifier.ProcessCreated(const Process: IOTAProcess); 214 | begin 215 | end; 216 | 217 | procedure TDebuggerNotifier.ProcessDestroyed(const Process: IOTAProcess); 218 | begin 219 | end; 220 | 221 | procedure TDebuggerNotifier.ProcessMemoryChanged; 222 | begin 223 | end; 224 | 225 | procedure TDebuggerNotifier.ProcessStateChanged(const Process: IOTAProcess); 226 | begin 227 | case Process.ProcessState of 228 | psNothing: ; 229 | psRunning: CodeCoverage.EnableCodeCoverage(Process); 230 | psStopping: ; 231 | psStopped: ; 232 | psFault: ; 233 | psResFault: ; 234 | psTerminated: CodeCoverage.RetrieveResults; 235 | psException: ; 236 | psNoProcess: ; 237 | end; 238 | end; 239 | 240 | function TEditLineNotifier.DoRegister: Integer; 241 | begin 242 | Result := inherited DoRegister; 243 | if Target <> nil then begin 244 | Result := Target.AddNotifier(Self); 245 | end; 246 | end; 247 | 248 | procedure TEditLineNotifier.DoUnregister(ID: Integer); 249 | begin 250 | if Target <> nil then begin 251 | Target.RemoveNotifier(ID); 252 | end; 253 | inherited; 254 | end; 255 | 256 | function TEditLineNotifier.HandlesTarget(const ATarget: IOTAEditLineTracker): Boolean; 257 | begin 258 | Result := (ATarget = Target); 259 | end; 260 | 261 | procedure TEditLineNotifier.InternalDestroyed; 262 | var 263 | I: Integer; 264 | begin 265 | for I := Target.Count - 1 downto 0 do begin 266 | Target.Delete(I); 267 | end; 268 | inherited; 269 | end; 270 | 271 | procedure TEditLineNotifier.LineChanged(OldLine, NewLine, Data: Integer); 272 | begin 273 | CodeCoverage.TrackedLineChanged(Target, OldLine, NewLine, Data); 274 | end; 275 | 276 | function TEditLineNotifier.NextID: Integer; 277 | begin 278 | if Target.Count = 0 then begin 279 | FNextID := 0; 280 | end; 281 | Result := FNextID; 282 | Inc(FNextID); 283 | end; 284 | 285 | function TEditorNotifier.DoRegister: Integer; 286 | begin 287 | Result := inherited DoRegister; 288 | if Target <> nil then begin 289 | Result := Target.AddNotifier(Self); 290 | end; 291 | end; 292 | 293 | procedure TEditorNotifier.DoUnregister(ID: Integer); 294 | begin 295 | if Target <> nil then begin 296 | Target.RemoveNotifier(ID); 297 | end; 298 | inherited; 299 | end; 300 | 301 | function TEditorNotifier.HandlesTarget(const ATarget: IOTASourceEditor): Boolean; 302 | begin 303 | Result := (ATarget.FileName = Target.FileName); 304 | end; 305 | 306 | procedure TEditorNotifier.InternalDestroyed; 307 | begin 308 | if Target <> nil then begin 309 | CodeCoverage.RemoveEditor(Target); 310 | end; 311 | inherited; 312 | end; 313 | 314 | procedure TEditorNotifier.ViewActivated(const View: IOTAEditView); 315 | begin 316 | end; 317 | 318 | procedure TEditorNotifier.ViewNotification(const View: IOTAEditView; Operation: TOperation); 319 | begin 320 | case Operation of 321 | opInsert: CodeCoverage.CreateEditViewNotifier(View); 322 | opRemove: ; 323 | end; 324 | end; 325 | 326 | procedure TEditServicesNotifier.DockFormRefresh(const EditWindow: INTAEditWindow; DockForm: TDockableForm); 327 | begin 328 | end; 329 | 330 | procedure TEditServicesNotifier.DockFormUpdated(const EditWindow: INTAEditWindow; DockForm: TDockableForm); 331 | begin 332 | end; 333 | 334 | procedure TEditServicesNotifier.DockFormVisibleChanged(const EditWindow: INTAEditWindow; DockForm: TDockableForm); 335 | begin 336 | end; 337 | 338 | function TEditServicesNotifier.DoRegister: Integer; 339 | begin 340 | Result := OTA.EditorServices.AddNotifier(Self); 341 | end; 342 | 343 | procedure TEditServicesNotifier.DoUnregister(ID: Integer); 344 | begin 345 | OTA.EditorServices.RemoveNotifier(ID); 346 | inherited; 347 | end; 348 | 349 | procedure TEditServicesNotifier.EditorViewActivated(const EditWindow: INTAEditWindow; const EditView: IOTAEditView); 350 | begin 351 | CodeCoverage.CreateEditViewNotifier(EditView); 352 | CodeCoverage.UpdateCurrentMethodState; 353 | end; 354 | 355 | procedure TEditServicesNotifier.EditorViewModified(const EditWindow: INTAEditWindow; const EditView: IOTAEditView); 356 | begin 357 | CodeCoverage.MarkModified(EditView); 358 | end; 359 | 360 | procedure TEditServicesNotifier.WindowActivated(const EditWindow: INTAEditWindow); 361 | begin 362 | end; 363 | 364 | procedure TEditServicesNotifier.WindowCommand(const EditWindow: INTAEditWindow; Command, Param: Integer; 365 | var Handled: Boolean); 366 | begin 367 | end; 368 | 369 | procedure TEditServicesNotifier.WindowNotification(const EditWindow: INTAEditWindow; Operation: TOperation); 370 | begin 371 | end; 372 | 373 | procedure TEditServicesNotifier.WindowShow(const EditWindow: INTAEditWindow; Show, LoadedFromDesktop: Boolean); 374 | begin 375 | end; 376 | 377 | procedure TEditViewNotifier.BeginPaint(const View: IOTAEditView; var FullRepaint: Boolean); 378 | begin 379 | if CodeCoverage.CheckFullRepaint(View) then begin 380 | FullRepaint := True; 381 | end; 382 | 383 | FCoveredMethodList := CodeCoverage.FindCoveredMethodList(View); 384 | 385 | if CodeCoverage.Valid then begin 386 | FCoveredLinesList := CodeCoverage.FindCoveredLinesList(View); 387 | end 388 | else begin 389 | FCoveredLinesList := nil; 390 | end; 391 | end; 392 | 393 | function TEditViewNotifier.DoRegister: Integer; 394 | begin 395 | Result := inherited DoRegister; 396 | if Target <> nil then begin 397 | Result := Target.AddNotifier(Self); 398 | end; 399 | end; 400 | 401 | procedure TEditViewNotifier.DoUnregister(ID: Integer); 402 | begin 403 | if Target <> nil then begin 404 | Target.RemoveNotifier(ID); 405 | Target := nil; 406 | end; 407 | inherited; 408 | end; 409 | 410 | procedure TEditViewNotifier.EditorIdle(const View: IOTAEditView); 411 | begin 412 | if View.SameView(OTA.EditorServices.TopView) then begin 413 | CodeCoverage.UpdateCurrentMethodState; 414 | end; 415 | end; 416 | 417 | procedure TEditViewNotifier.EndPaint(const View: IOTAEditView); 418 | begin 419 | FCoveredMethodList := nil; 420 | FCoveredLinesList := nil; 421 | end; 422 | 423 | function TEditViewNotifier.HandlesTarget(const ATarget: IOTAEditView): Boolean; 424 | begin 425 | Result := ATarget.SameView(Target); 426 | end; 427 | 428 | procedure TEditViewNotifier.PaintLine(const View: IOTAEditView; LineNumber: Integer; const LineText: PAnsiChar; 429 | const TextWidth: Word; const LineAttributes: TOTAAttributeArray; const Canvas: TCanvas; const TextRect, 430 | LineRect: TRect; const CellSize: TSize); 431 | var 432 | coveredMethod: TCoveredMethod; 433 | gutterPos: TPoint; 434 | PassCount: THitCount; 435 | S: string; 436 | canvasState: TCanvasState; 437 | afterText: TPoint; 438 | beforeText: TPoint; 439 | curID: TMethodID; 440 | begin 441 | canvasState := TCanvasState.Create(Canvas); 442 | try 443 | gutterPos := TPoint.Create(LineRect.TopLeft); 444 | afterText := TPoint.Create(TextRect.Right + CellSize.cx, LineRect.Top); 445 | beforeText := TPoint.Create(TextRect.Left, LineRect.Top); 446 | 447 | if CoveredMethodList <> nil then begin 448 | if CodeCoverage.MethodIdByLineNumber(View.Buffer, LineNumber, curID) then begin 449 | if CoveredMethodList.Find(curID, coveredMethod) then begin 450 | CodeCoverage.DrawImage(Canvas, gutterPos.X, gutterPos.Y, CodeCoverage.ImageIndexCodeCoverage); 451 | if CodeCoverage.Valid then begin 452 | canvas.Brush.Style := bsClear; 453 | canvas.Font.Color := clLtGray; 454 | Canvas.TextOut(afterText.X, afterText.Y, Format('[%d%%]', [coveredMethod.Percent])); 455 | end; 456 | end; 457 | end; 458 | end; 459 | 460 | if CoveredLinesList <> nil then begin 461 | if CoveredLinesList.TryGetValue(LineNumber, PassCount) then begin 462 | S := IfThen(PassCount < 0, '○', '●'); 463 | canvas.Brush.Style := bsClear; 464 | canvas.Font.Color := IfThen(PassCount = 0, clRed, clBlue); 465 | Canvas.TextOut(beforeText.X, beforeText.Y, S); 466 | if PassCount = 0 then begin 467 | CodeCoverage.DrawImage(Canvas, afterText.X, afterText.Y, CodeCoverage.ImageIndexNoCoverage); 468 | end 469 | else if PassCount > 0 then begin 470 | canvas.Font.Color := clLtGray; 471 | Canvas.TextOut(afterText.X, afterText.Y, Format('[%d]', [PassCount])); 472 | end; 473 | end; 474 | end; 475 | 476 | finally 477 | canvasState.Free; 478 | end; 479 | end; 480 | 481 | function TModuleNotifier.DoRegister: Integer; 482 | begin 483 | Result := inherited DoRegister; 484 | if Target <> nil then begin 485 | Result := Target.AddNotifier(Self); 486 | FileName := Target.FileName; 487 | end; 488 | end; 489 | 490 | procedure TModuleNotifier.DoUnregister(ID: Integer); 491 | begin 492 | if Target <> nil then begin 493 | Target.RemoveNotifier(ID); 494 | Target := nil; 495 | end; 496 | inherited; 497 | end; 498 | 499 | function TModuleNotifier.CheckOverwrite: Boolean; 500 | begin 501 | Result := True; 502 | end; 503 | 504 | function TModuleNotifier.HandlesTarget(const ATarget: IOTAModule): Boolean; 505 | begin 506 | Result := (ATarget = Target); 507 | end; 508 | 509 | procedure TModuleNotifier.ModuleRenamed(const NewName: string); 510 | begin 511 | if FileName <> NewName then begin 512 | CodeCoverage.ModuleRenamed(FileName, NewName); 513 | FileName := NewName; 514 | end; 515 | end; 516 | 517 | constructor TCodeCoverageNotifier.Create(AParentInstance: TNotifierHost; const ATarget: T); 518 | begin 519 | inherited Create(AParentInstance); 520 | FTarget := ATarget; 521 | end; 522 | 523 | constructor TCanvasState.Create(ACanvas: TCanvas); 524 | begin 525 | inherited Create; 526 | FPen := TPenRecall.Create(ACanvas.Pen); 527 | FFont := TFontRecall.Create(ACanvas.Font); 528 | FBrush := TBrushRecall.Create(ACanvas.Brush); 529 | end; 530 | 531 | destructor TCanvasState.Destroy; 532 | begin 533 | FBrush.Free; 534 | FFont.Free; 535 | FPen.Free; 536 | inherited; 537 | end; 538 | 539 | end. 540 | -------------------------------------------------------------------------------- /Source/CodeCoverage.SyntaxTypes.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.SyntaxTypes; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | DelphiAST.Classes, 8 | CodeCoverage.Types, 9 | ToolsAPI; 10 | 11 | type 12 | TCodeSyntaxTree = class 13 | private 14 | FFileName: string; 15 | FNodeImplementation: TSyntaxNode; 16 | FSyntaxTree: TSyntaxNode; 17 | procedure InitNodes; 18 | procedure SetSyntaxTree(const Value: TSyntaxNode); 19 | protected 20 | function FindMethod(ALineNumber: Integer): TCompoundSyntaxNode; overload; 21 | function FindMethod(const AMethod: TCoveredMethod): TCompoundSyntaxNode; overload; 22 | function FindMethod(APredicate: TPredicate): TCompoundSyntaxNode; overload; 23 | function SelectMethod(ANode: TCompoundSyntaxNode; out LineMin, LineMax: Integer): Boolean; overload; 24 | property NodeImplementation: TSyntaxNode read FNodeImplementation; 25 | property SyntaxTree: TSyntaxNode read FSyntaxTree write SetSyntaxTree; 26 | public 27 | destructor Destroy; override; 28 | procedure Clear; 29 | function FindCurrentMethod(EditView: IOTAEditView; out AMethodName: string; out LineMin, LineMax: Integer): Boolean; 30 | function LoadFrom(Editor: IOTASourceEditor): Boolean; 31 | function SelectMethod(ALineNumber: Integer; out LineMin, LineMax: Integer): Boolean; overload; 32 | function SelectMethod(const AMethod: TCoveredMethod; out LineMin, LineMax: Integer): Boolean; overload; 33 | property FileName: string read FFileName; 34 | end; 35 | 36 | TCodeSyntaxTreeDict = class(TFileNameDict); 37 | 38 | TCodeSyntaxTrees = class 39 | private 40 | FData: TCodeSyntaxTreeDict; 41 | public 42 | constructor Create; 43 | destructor Destroy; override; 44 | function Add(Editor: IOTASourceEditor): TCodeSyntaxTree; 45 | function Find(const AFileName: string; out Value: TCodeSyntaxTree): Boolean; 46 | procedure Remove(const AFileName: string); 47 | procedure RenameFile(const OldName, NewName: string); 48 | end; 49 | 50 | implementation 51 | 52 | uses 53 | System.Math, System.Classes, System.Generics.Collections, 54 | DelphiAST.Consts, DelphiAST; 55 | 56 | destructor TCodeSyntaxTree.Destroy; 57 | begin 58 | FSyntaxTree.Free; 59 | inherited Destroy; 60 | end; 61 | 62 | procedure TCodeSyntaxTree.Clear; 63 | begin 64 | FFileName := ''; 65 | FNodeImplementation := nil; 66 | FSyntaxTree.Free; 67 | FSyntaxTree := nil; 68 | end; 69 | 70 | function TCodeSyntaxTree.FindCurrentMethod(EditView: IOTAEditView; out AMethodName: string; out LineMin, LineMax: 71 | Integer): Boolean; 72 | var 73 | curPos: TOTAEditPos; 74 | node: TCompoundSyntaxNode; 75 | begin 76 | Result := False; 77 | 78 | curPos := EditView.CursorPos; 79 | node := FindMethod(curPos.Line); 80 | if node <> nil then begin 81 | if (node.Line = curPos.Line) and (curPos.Col < node.Col) then Exit; 82 | if (node.EndLine = curPos.Line) and (node.EndCol <= curPos.Col) then Exit; 83 | 84 | AMethodName := node.GetAttribute(anName); 85 | LineMin := node.Line; 86 | LineMax := node.EndLine; 87 | Result := True; 88 | end; 89 | end; 90 | 91 | function TCodeSyntaxTree.FindMethod(ALineNumber: Integer): TCompoundSyntaxNode; 92 | begin 93 | Result := FindMethod( 94 | function (Arg: TCompoundSyntaxNode): Boolean 95 | begin 96 | Result := InRange(ALineNumber, Arg.Line, Arg.EndLine - 1); 97 | end); 98 | end; 99 | 100 | function TCodeSyntaxTree.FindMethod(const AMethod: TCoveredMethod): TCompoundSyntaxNode; 101 | var 102 | targetLine: Integer; 103 | targetName: string; 104 | begin 105 | targetName := AMethod.Name; 106 | targetLine := AMethod.Line; 107 | Result := FindMethod( 108 | function (Arg: TCompoundSyntaxNode): Boolean 109 | begin 110 | Result := SameText(Arg.GetAttribute(anName), targetName) and (Arg.Line = targetLine); 111 | end); 112 | end; 113 | 114 | function TCodeSyntaxTree.FindMethod(APredicate: TPredicate): TCompoundSyntaxNode; 115 | var 116 | compNode: TCompoundSyntaxNode; 117 | node: TSyntaxNode; 118 | begin 119 | Result := nil; 120 | if NodeImplementation <> nil then begin 121 | for node in NodeImplementation.ChildNodes do begin 122 | if node is TCompoundSyntaxNode then begin 123 | compNode := node as TCompoundSyntaxNode; 124 | if (compNode.Typ = ntMethod) and APredicate(compNode) then begin 125 | Exit(compNode); 126 | end; 127 | end; 128 | end; 129 | end; 130 | end; 131 | 132 | procedure TCodeSyntaxTree.InitNodes; 133 | begin 134 | if SyntaxTree <> nil then begin 135 | FNodeImplementation := SyntaxTree.FindNode(ntImplementation); 136 | end 137 | else begin 138 | FNodeImplementation := nil; 139 | end; 140 | end; 141 | 142 | function TCodeSyntaxTree.LoadFrom(Editor: IOTASourceEditor): Boolean; 143 | const 144 | cBufferSize = 16*1024; 145 | var 146 | buffer: TBytes; 147 | cntRead: Integer; 148 | curPos: Integer; 149 | stream: TStringStream; 150 | builder: TPasSyntaxTreeBuilder; 151 | reader: IOTAEditReader; 152 | begin 153 | Result := False; 154 | Clear; 155 | if Editor = nil then Exit; 156 | 157 | FFileName := Editor.FileName; 158 | 159 | stream := TStringStream.Create('', TEncoding.UTF8); 160 | try 161 | SetLength(buffer, cBufferSize); 162 | curPos := 0; 163 | reader := Editor.CreateReader; 164 | repeat 165 | cntRead := reader.GetText(curPos, PAnsiChar(@buffer[0]), cBufferSize); 166 | if cntRead > 0 then begin 167 | stream.Write(buffer, cntRead); 168 | curPos := curPos + cntRead; 169 | end; 170 | until cntRead < cBufferSize; 171 | reader := nil; 172 | 173 | stream.Position := 0; 174 | builder := TPasSyntaxTreeBuilder.Create; 175 | try 176 | builder.InitDefinesDefinedByCompiler; 177 | try 178 | SyntaxTree := builder.Run(stream); 179 | Result := True; 180 | except 181 | { We can log the exception somehow, f.i. with CodeSite, but we don't show it! 182 | It is just code that cannot be parsed. Returning False is sufficient. } 183 | on E: Exception do begin 184 | // CodeSite.SendException(E); 185 | end; 186 | end; 187 | finally 188 | builder.Free; 189 | end; 190 | finally 191 | stream.Free; 192 | end; 193 | end; 194 | 195 | function TCodeSyntaxTree.SelectMethod(ALineNumber: Integer; out LineMin, LineMax: Integer): Boolean; 196 | begin 197 | Result := SelectMethod(FindMethod(ALineNumber), LineMin, LineMax); 198 | end; 199 | 200 | function TCodeSyntaxTree.SelectMethod(ANode: TCompoundSyntaxNode; out LineMin, LineMax: Integer): Boolean; 201 | var 202 | compNode: TCompoundSyntaxNode; 203 | begin 204 | Result := False; 205 | if ANode <> nil then begin 206 | compNode := ANode.FindNode(ntStatements) as TCompoundSyntaxNode; 207 | if compNode <> nil then begin 208 | LineMin := compNode.Line; 209 | LineMax := compNode.EndLine; 210 | Result := True; 211 | end; 212 | end; 213 | end; 214 | 215 | function TCodeSyntaxTree.SelectMethod(const AMethod: TCoveredMethod; out LineMin, LineMax: Integer): Boolean; 216 | begin 217 | Result := SelectMethod(FindMethod(AMethod), LineMin, LineMax); 218 | end; 219 | 220 | procedure TCodeSyntaxTree.SetSyntaxTree(const Value: TSyntaxNode); 221 | begin 222 | if FSyntaxTree <> Value then 223 | begin 224 | FSyntaxTree.Free; 225 | FSyntaxTree := Value; 226 | InitNodes; 227 | end; 228 | end; 229 | 230 | constructor TCodeSyntaxTrees.Create; 231 | begin 232 | inherited Create; 233 | FData := TCodeSyntaxTreeDict.Create(); 234 | end; 235 | 236 | destructor TCodeSyntaxTrees.Destroy; 237 | begin 238 | FData.Free; 239 | inherited Destroy; 240 | end; 241 | 242 | function TCodeSyntaxTrees.Add(Editor: IOTASourceEditor): TCodeSyntaxTree; 243 | var 244 | tree: TCodeSyntaxTree; 245 | begin 246 | if not FData.TryGetValue(Editor.FileName, Result) then begin 247 | Result := nil; 248 | tree := TCodeSyntaxTree.Create; 249 | try 250 | if tree.LoadFrom(Editor) then begin 251 | Result := tree; 252 | tree := nil; 253 | FData.Add(Editor.FileName, Result); 254 | end 255 | finally 256 | tree.Free; 257 | end; 258 | end; 259 | end; 260 | 261 | function TCodeSyntaxTrees.Find(const AFileName: string; out Value: TCodeSyntaxTree): Boolean; 262 | begin 263 | Result := FData.TryGetValue(AFileName, Value); 264 | end; 265 | 266 | procedure TCodeSyntaxTrees.Remove(const AFileName: string); 267 | begin 268 | FData.Remove(AFileName); 269 | end; 270 | 271 | procedure TCodeSyntaxTrees.RenameFile(const OldName, NewName: string); 272 | begin 273 | FData.RenameFile(OldName, NewName); 274 | end; 275 | 276 | end. 277 | -------------------------------------------------------------------------------- /Source/CodeCoverage.Tools.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.Tools; 2 | 3 | interface 4 | 5 | { assure Winapi.Windows appears before Vcl.Graphics, because both declare TBitmap } 6 | uses 7 | Winapi.Windows, 8 | System.Classes, 9 | Vcl.Graphics; 10 | 11 | type 12 | TTools = class 13 | private 14 | class var 15 | FVersion: string; 16 | class function GetDescription: string; static; 17 | class function GetTitle: string; static; 18 | class function GetVersion: string; static; 19 | public 20 | class function AppVersion: string; static; 21 | class function CreateFromIconResource(const AName: string; ASize: Integer): TBitmap; overload; 22 | class procedure LoadFromIconResource(Target: TIcon; const AName: string); 23 | class procedure Postpone(AProc: TThreadMethod; ADelayMS: Cardinal = 0); overload; 24 | class procedure Postpone(AProc: TThreadProcedure; ADelayMS: Cardinal = 0); overload; 25 | class property Description: string read GetDescription; 26 | class property Title: string read GetTitle; 27 | class property Version: string read GetVersion; 28 | end; 29 | 30 | implementation 31 | 32 | uses 33 | System.SysUtils, System.Threading, 34 | CodeCoverage.Consts; 35 | 36 | class function TTools.AppVersion: string; 37 | var 38 | build: Cardinal; 39 | major: Cardinal; 40 | minor: Cardinal; 41 | begin 42 | if GetProductVersion(GetModuleName(HInstance), major, minor, build) then begin 43 | Result := Format('V%d.%d.%d', [major, minor, build]); // do not localize 44 | end 45 | else begin 46 | Result := cVersion; 47 | end; 48 | end; 49 | 50 | class function TTools.CreateFromIconResource(const AName: string; ASize: Integer): TBitmap; 51 | var 52 | icon: TIcon; 53 | begin 54 | Result := TBitmap.Create; 55 | icon := TIcon.Create; 56 | try 57 | icon.SetSize(ASize, ASize); 58 | LoadFromIconResource(icon, AName); 59 | Result.Assign(icon); 60 | finally 61 | icon.Free; 62 | end; 63 | end; 64 | 65 | class function TTools.GetDescription: string; 66 | begin 67 | Result := SDescription + sLineBreak + sLineBreak + cCopyRight; 68 | end; 69 | 70 | class function TTools.GetTitle: string; 71 | begin 72 | Result := cTitle + ' ' + Version; 73 | end; 74 | 75 | class function TTools.GetVersion: string; 76 | begin 77 | if FVersion = '' then begin 78 | FVersion := TTools.AppVersion; 79 | end; 80 | Result := FVersion; 81 | end; 82 | 83 | class procedure TTools.LoadFromIconResource(Target: TIcon; const AName: string); 84 | begin 85 | Target.Handle := LoadImage(HInstance, PChar(AName), IMAGE_ICON, Target.Width, Target.Height, 0); 86 | end; 87 | 88 | class procedure TTools.Postpone(AProc: TThreadMethod; ADelayMS: Cardinal = 0); 89 | begin 90 | TTask.Run( 91 | procedure 92 | begin 93 | if ADelayMS > 0 then begin 94 | Sleep(ADelayMS); 95 | end; 96 | TThread.Queue(nil, AProc); 97 | end); 98 | end; 99 | 100 | class procedure TTools.Postpone(AProc: TThreadProcedure; ADelayMS: Cardinal = 0); 101 | begin 102 | TTask.Run( 103 | procedure 104 | begin 105 | if ADelayMS > 0 then begin 106 | Sleep(ADelayMS); 107 | end; 108 | TThread.Queue(nil, AProc); 109 | end); 110 | end; 111 | 112 | end. 113 | 114 | -------------------------------------------------------------------------------- /Source/CodeCoverage.Types.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.Types; 2 | 3 | interface 4 | 5 | uses 6 | System.Generics.Collections; 7 | 8 | type 9 | { Aliases to clarify the meaning of the type (especially with dictionaries) } 10 | TLineNumber = Integer; 11 | TMethodID = Integer; 12 | THitCount = Integer; 13 | TPercent = Integer; 14 | TFileName = string; 15 | 16 | type 17 | TFileNameDict = class(TObjectDictionary) 18 | public 19 | constructor Create; 20 | procedure RenameFile(const OldName, NewName: string); 21 | end; 22 | 23 | type 24 | TCoveredLinesHandler = reference to procedure(const AFileName: string; ALineNumber, APassCount: Integer); 25 | 26 | TCoveredLinesList = class(TDictionary); 27 | 28 | TCoveredLinesDict = class(TFileNameDict); 29 | 30 | TCoveredLines = class 31 | private 32 | FData: TCoveredLinesDict; 33 | function FindOrAddList(const AFileName: string): TCoveredLinesList; 34 | public 35 | constructor Create; 36 | destructor Destroy; override; 37 | procedure Add(const AFileName: string; const ALineNumber: TLineNumber; const ACount: THitCount); 38 | procedure Clear; 39 | function Find(const AFileName: string): TCoveredLinesList; overload; 40 | function Find(const AFileName: string; const ALineNumber: TLineNumber): THitCount; overload; 41 | procedure Initialize(const AFileName: string; const ALineNumber: TLineNumber; const ACount: THitCount); 42 | function IsEmpty: Boolean; 43 | procedure Iterate(Callback: TCoveredLinesHandler); 44 | procedure Remove(const AFileName: string; const LineMin, LineMax: TLineNumber); overload; 45 | procedure Remove(const AFileName: string); overload; 46 | procedure RenameFile(const OldName, NewName: string); 47 | end; 48 | 49 | type 50 | TCoveredMethod = record 51 | private 52 | FID: TMethodID; 53 | FLine: TLineNumber; 54 | FLineMax: Integer; 55 | FLineMin: Integer; 56 | FName: string; 57 | FPercent: TPercent; 58 | public 59 | constructor Create(const AName: string; const ALine: TLineNumber; const AID: TMethodID); 60 | property ID: TMethodID read FID; 61 | property Line: TLineNumber read FLine write FLine; 62 | property LineMax: Integer read FLineMax write FLineMax; 63 | property LineMin: Integer read FLineMin write FLineMin; 64 | property Name: string read FName write FName; 65 | property Percent: TPercent read FPercent write FPercent; 66 | end; 67 | 68 | TCoveredMethodHandler = reference to procedure(const AFileName: string; const Data: TCoveredMethod); 69 | 70 | TCoveredMethodIndex = class(TDictionary); 71 | 72 | TCoveredMethodList = class 73 | private 74 | FData: TCoveredMethodIndex; 75 | public 76 | constructor Create; 77 | destructor Destroy; override; 78 | procedure Add(const Value: TCoveredMethod); 79 | procedure ChangeLineNumber(const AID: TMethodID; const ALineNumber: TLineNumber); overload; 80 | function Find(const AID: TMethodID; out Value: TCoveredMethod): Boolean; 81 | function IsEmpty: Boolean; 82 | procedure Iterate(const AFileName: string; Callback: TCoveredMethodHandler); 83 | procedure Remove(const AID: TMethodID); overload; 84 | procedure Update(const AID: TMethodID; ALineMin, ALineMax: Integer); overload; 85 | procedure UpdatePercent(const AID: TMethodID; const APercent: TPercent); overload; 86 | end; 87 | 88 | TCoveredMethodDict = class(TFileNameDict); 89 | 90 | TCoveredMethods = class 91 | strict private 92 | function FindOrAddList(const AFileName: string): TCoveredMethodList; 93 | private 94 | FData: TCoveredMethodDict; 95 | public 96 | constructor Create; 97 | destructor Destroy; override; 98 | procedure Add(const AFileName: string; const Data: TCoveredMethod); 99 | procedure ChangeLineNumber(const AFileName: string; const AID: TMethodID; const ALineNumber: TLineNumber); 100 | function Find(const AFileName: string; const AID: TMethodID; out Value: TCoveredMethod): Boolean; overload; 101 | function Find(const AFileName: string): TCoveredMethodList; overload; 102 | function IsEmpty: Boolean; 103 | procedure Iterate(Callback: TCoveredMethodHandler); 104 | procedure Remove(const AFileName: string; const AID: TMethodID); overload; 105 | procedure Remove(const AFileName: string); overload; 106 | procedure RenameFile(const OldName, NewName: string); 107 | procedure Update(const AFileName: string; const AID: TMethodID; ALineMin, ALineMax: Integer); overload; 108 | procedure UpdatePercent(const AFileName: string; const AID: TMethodID; APercent: Integer); overload; 109 | end; 110 | 111 | implementation 112 | 113 | constructor TCoveredMethod.Create(const AName: string; const ALine: TLineNumber; const AID: TMethodID); 114 | begin 115 | FName := AName; 116 | FLine := ALine; 117 | FID := AID; 118 | end; 119 | 120 | constructor TCoveredLines.Create; 121 | begin 122 | inherited Create; 123 | FData := TCoveredLinesDict.Create; 124 | end; 125 | 126 | destructor TCoveredLines.Destroy; 127 | begin 128 | FData.Free; 129 | inherited Destroy; 130 | end; 131 | 132 | procedure TCoveredLines.Add(const AFileName: string; const ALineNumber: TLineNumber; const ACount: THitCount); 133 | var 134 | Count: THitCount; 135 | list: TCoveredLinesList; 136 | begin 137 | list := FindOrAddList(AFileName); 138 | if not list.TryGetValue(ALineNumber, Count) then begin 139 | Count := ACount; 140 | end 141 | else begin 142 | Count := Count + ACount; 143 | end; 144 | list.AddOrSetValue(ALineNumber, Count); 145 | end; 146 | 147 | procedure TCoveredLines.Clear; 148 | begin 149 | FData.Clear; 150 | end; 151 | 152 | function TCoveredLines.Find(const AFileName: string): TCoveredLinesList; 153 | begin 154 | if not FData.TryGetValue(AFileName, Result) then begin 155 | Result := nil; 156 | end; 157 | end; 158 | 159 | function TCoveredLines.Find(const AFileName: string; const ALineNumber: TLineNumber): THitCount; 160 | var 161 | count: THitCount; 162 | list: TCoveredLinesList; 163 | begin 164 | Result := -1; 165 | list := FindOrAddList(AFileName); 166 | if list <> nil then begin 167 | if list.TryGetValue(ALineNumber, count) then begin 168 | Result := count; 169 | end; 170 | end; 171 | end; 172 | 173 | function TCoveredLines.FindOrAddList(const AFileName: string): TCoveredLinesList; 174 | begin 175 | if not FData.TryGetValue(AFileName, Result) then begin 176 | Result := TCoveredLinesList.Create; 177 | FData.Add(AFileName, Result); 178 | end; 179 | end; 180 | 181 | procedure TCoveredLines.Initialize(const AFileName: string; const ALineNumber: TLineNumber; const ACount: THitCount); 182 | var 183 | list: TCoveredLinesList; 184 | begin 185 | list := FindOrAddList(AFileName); 186 | list.AddOrSetValue(ALineNumber, ACount); 187 | end; 188 | 189 | function TCoveredLines.IsEmpty: Boolean; 190 | begin 191 | Result := (FData.Count = 0); 192 | end; 193 | 194 | procedure TCoveredLines.Iterate(Callback: TCoveredLinesHandler); 195 | var 196 | arr: TArray; 197 | line: TLineNumber; 198 | passCount: TCoveredLinesList; 199 | pair: TPair; 200 | begin 201 | for pair in FData do begin 202 | passCount := pair.Value; 203 | arr := passCount.Keys.ToArray; 204 | TArray.Sort(arr); 205 | for line in arr do begin 206 | Callback(pair.Key, line, passCount[line]); 207 | end; 208 | end; 209 | end; 210 | 211 | procedure TCoveredLines.Remove(const AFileName: string; const LineMin, LineMax: TLineNumber); 212 | var 213 | list: TCoveredLinesList; 214 | I: TLineNumber; 215 | begin 216 | list := Find(AFileName); 217 | if list <> nil then begin 218 | for I := LineMin to LineMax do begin 219 | list.Remove(I); 220 | end; 221 | if list.Count = 0 then begin 222 | FData.Remove(AFileName); 223 | end; 224 | end; 225 | end; 226 | 227 | procedure TCoveredLines.Remove(const AFileName: string); 228 | begin 229 | FData.Remove(AFileName); 230 | end; 231 | 232 | procedure TCoveredLines.RenameFile(const OldName, NewName: string); 233 | begin 234 | FData.RenameFile(OldName, NewName); 235 | end; 236 | 237 | constructor TCoveredMethodList.Create; 238 | begin 239 | inherited Create; 240 | FData := TCoveredMethodIndex.Create; 241 | end; 242 | 243 | destructor TCoveredMethodList.Destroy; 244 | begin 245 | FData.Free; 246 | inherited Destroy; 247 | end; 248 | 249 | procedure TCoveredMethodList.Add(const Value: TCoveredMethod); 250 | begin 251 | FData.AddOrSetValue(Value.ID, Value); 252 | end; 253 | 254 | procedure TCoveredMethodList.ChangeLineNumber(const AID: TMethodID; const ALineNumber: TLineNumber); 255 | var 256 | value: TCoveredMethod; 257 | begin 258 | if FData.TryGetValue(AID, value) then begin 259 | value.Line := ALineNumber; 260 | FData.Items[AID] := value; 261 | end; 262 | end; 263 | 264 | function TCoveredMethodList.Find(const AID: TMethodID; out Value: TCoveredMethod): Boolean; 265 | begin 266 | Result := FData.TryGetValue(AID, Value); 267 | end; 268 | 269 | function TCoveredMethodList.IsEmpty: Boolean; 270 | begin 271 | Result := (FData.Count = 0); 272 | end; 273 | 274 | procedure TCoveredMethodList.Iterate(const AFileName: string; Callback: TCoveredMethodHandler); 275 | var 276 | pair: TPair; 277 | begin 278 | for pair in FData do begin 279 | Callback(AFileName, pair.Value); 280 | end; 281 | end; 282 | 283 | procedure TCoveredMethodList.Remove(const AID: TMethodID); 284 | var 285 | data: TCoveredMethod; 286 | begin 287 | if FData.TryGetValue(AID, data) then begin 288 | FData.Remove(AID); 289 | end; 290 | end; 291 | 292 | procedure TCoveredMethodList.Update(const AID: TMethodID; ALineMin, ALineMax: Integer); 293 | var 294 | data: TCoveredMethod; 295 | begin 296 | if FData.TryGetValue(AID, data) then begin 297 | data.LineMin := ALineMin; 298 | data.LineMax := ALineMax; 299 | FData[AID] := data; 300 | end; 301 | end; 302 | 303 | procedure TCoveredMethodList.UpdatePercent(const AID: TMethodID; const APercent: TPercent); 304 | var 305 | data: TCoveredMethod; 306 | begin 307 | if FData.TryGetValue(AID, data) then begin 308 | data.Percent := APercent; 309 | FData[AID] := data; 310 | end; 311 | end; 312 | 313 | constructor TCoveredMethods.Create; 314 | begin 315 | inherited Create; 316 | FData := TCoveredMethodDict.Create; 317 | end; 318 | 319 | destructor TCoveredMethods.Destroy; 320 | begin 321 | FData.Free; 322 | inherited Destroy; 323 | end; 324 | 325 | procedure TCoveredMethods.Add(const AFileName: string; const Data: TCoveredMethod); 326 | var 327 | list: TCoveredMethodList; 328 | begin 329 | list := FindOrAddList(AFileName); 330 | list.Add(Data); 331 | end; 332 | 333 | procedure TCoveredMethods.ChangeLineNumber(const AFileName: string; const AID: TMethodID; const ALineNumber: 334 | TLineNumber); 335 | var 336 | list: TCoveredMethodList; 337 | begin 338 | list := Find(AFileName); 339 | if list <> nil then begin 340 | list.ChangeLineNumber(AID, ALineNumber); 341 | end; 342 | end; 343 | 344 | function TCoveredMethods.Find(const AFileName: string; const AID: TMethodID; out Value: TCoveredMethod): Boolean; 345 | var 346 | list: TCoveredMethodList; 347 | begin 348 | Result := False; 349 | list := Find(AFileName); 350 | if list <> nil then begin 351 | Result := list.Find(AID, Value); 352 | end; 353 | end; 354 | 355 | function TCoveredMethods.Find(const AFileName: string): TCoveredMethodList; 356 | begin 357 | if not FData.TryGetValue(AFileName, Result) then begin 358 | Result := nil; 359 | end; 360 | end; 361 | 362 | function TCoveredMethods.FindOrAddList(const AFileName: string): TCoveredMethodList; 363 | begin 364 | if not FData.TryGetValue(AFileName, Result) then begin 365 | Result := TCoveredMethodList.Create; 366 | FData.Add(AFileName, Result); 367 | end; 368 | end; 369 | 370 | function TCoveredMethods.IsEmpty: Boolean; 371 | begin 372 | Result := (FData.Count = 0); 373 | end; 374 | 375 | procedure TCoveredMethods.Iterate(Callback: TCoveredMethodHandler); 376 | var 377 | pair: TPair; 378 | begin 379 | for pair in FData do begin 380 | pair.Value.Iterate(pair.Key, Callback); 381 | end; 382 | end; 383 | 384 | procedure TCoveredMethods.Remove(const AFileName: string; const AID: TMethodID); 385 | var 386 | list: TCoveredMethodList; 387 | begin 388 | list := Find(AFileName); 389 | if list <> nil then begin 390 | list.Remove(AID); 391 | if list.IsEmpty then begin 392 | FData.Remove(AFileName); 393 | end; 394 | end; 395 | end; 396 | 397 | procedure TCoveredMethods.Remove(const AFileName: string); 398 | begin 399 | FData.Remove(AFileName); 400 | end; 401 | 402 | procedure TCoveredMethods.RenameFile(const OldName, NewName: string); 403 | begin 404 | FData.RenameFile(OldName, NewName); 405 | end; 406 | 407 | procedure TCoveredMethods.Update(const AFileName: string; const AID: TMethodID; ALineMin, ALineMax: Integer); 408 | var 409 | list: TCoveredMethodList; 410 | begin 411 | list := Find(AFileName); 412 | if list <> nil then begin 413 | list.Update(AID, ALineMin, ALineMax); 414 | end; 415 | end; 416 | 417 | procedure TCoveredMethods.UpdatePercent(const AFileName: string; const AID: TMethodID; APercent: Integer); 418 | var 419 | list: TCoveredMethodList; 420 | begin 421 | list := Find(AFileName); 422 | if list <> nil then begin 423 | list.UpdatePercent(AID, APercent); 424 | end; 425 | end; 426 | 427 | constructor TFileNameDict.Create; 428 | begin 429 | inherited Create([doOwnsValues]); 430 | end; 431 | 432 | procedure TFileNameDict.RenameFile(const OldName, NewName: string); 433 | var 434 | pair: TPair; 435 | begin 436 | if ContainsKey(OldName) then begin 437 | if ContainsKey(NewName) then begin 438 | Remove(OldName); 439 | end 440 | else begin 441 | pair := ExtractPair(OldName); 442 | Add(NewName, pair.Value); 443 | end; 444 | end; 445 | end; 446 | 447 | end. 448 | -------------------------------------------------------------------------------- /Source/DelphiAST/CodeCoverage.DelphiAST.Classes.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UweRaabe/DelphiCodeCoveragePlugin/8f1246759e6ef6bb22c443c4e3b495d137319f98/Source/DelphiAST/CodeCoverage.DelphiAST.Classes.pas -------------------------------------------------------------------------------- /Source/DelphiAST/CodeCoverage.DelphiAST.Consts.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.DelphiAST.Consts; 2 | 3 | interface 4 | 5 | type 6 | TSyntaxNodeType = ( 7 | ntUnknown, 8 | ntAbsolute, 9 | ntAdd, 10 | ntAddr, 11 | ntAlignmentParam, 12 | ntAnd, 13 | ntAnonymousMethod, 14 | ntArguments, 15 | ntAs, 16 | ntAssign, 17 | ntAt, 18 | ntAttribute, 19 | ntAttributes, 20 | ntBounds, 21 | ntCall, 22 | ntCase, 23 | ntCaseElse, 24 | ntCaseLabel, 25 | ntCaseLabels, 26 | ntCaseSelector, 27 | ntClassConstraint, 28 | ntConstant, 29 | ntConstants, 30 | ntConstraints, 31 | ntConstructorConstraint, 32 | ntContains, 33 | ntDefault, 34 | ntDeref, 35 | ntDimension, 36 | ntDiv, 37 | ntDot, 38 | ntDownTo, 39 | ntElement, 40 | ntElse, 41 | ntEmptyStatement, 42 | ntEnum, 43 | ntEqual, 44 | ntExcept, 45 | ntExceptionHandler, 46 | ntExports, 47 | ntExpression, 48 | ntExpressions, 49 | ntExternal, 50 | ntFDiv, 51 | ntField, 52 | ntFields, 53 | ntFinalization, 54 | ntFinally, 55 | ntFor, 56 | ntFrom, 57 | ntGeneric, 58 | ntGoto, 59 | ntGreater, 60 | ntGreaterEqual, 61 | ntGuid, 62 | ntHelper, 63 | ntIdentifier, 64 | ntIf, 65 | ntImplementation, 66 | ntImplements, 67 | ntIn, 68 | ntIndex, 69 | ntIndexed, 70 | ntInherited, 71 | ntInitialization, 72 | ntInterface, 73 | ntIs, 74 | ntLabel, 75 | ntLHS, 76 | ntLiteral, 77 | ntLower, 78 | ntLowerEqual, 79 | ntMessage, 80 | ntMethod, 81 | ntMod, 82 | ntMul, 83 | ntName, 84 | ntNamedArgument, 85 | ntNotEqual, 86 | ntNot, 87 | ntOr, 88 | ntPackage, 89 | ntParameter, 90 | ntParameters, 91 | ntPath, 92 | ntPositionalArgument, 93 | ntProtected, 94 | ntPrivate, 95 | ntProperty, 96 | ntPublic, 97 | ntPublished, 98 | ntRaise, 99 | ntRead, 100 | ntRecordConstraint, 101 | ntRepeat, 102 | ntRequires, 103 | ntResolutionClause, 104 | ntResourceString, 105 | ntReturnType, 106 | ntRHS, 107 | ntRoundClose, 108 | ntRoundOpen, 109 | ntSet, 110 | ntShl, 111 | ntShr, 112 | ntStatement, 113 | ntStatements, 114 | ntStrictPrivate, 115 | ntStrictProtected, 116 | ntSub, 117 | ntSubrange, 118 | ntThen, 119 | ntTo, 120 | ntTry, 121 | ntType, 122 | ntTypeArgs, 123 | ntTypeDecl, 124 | ntTypeParam, 125 | ntTypeParams, 126 | ntTypeSection, 127 | ntValue, 128 | ntVariable, 129 | ntVariables, 130 | ntXor, 131 | ntUnaryMinus, 132 | ntUnit, 133 | ntUses, 134 | ntWhile, 135 | ntWith, 136 | ntWrite, 137 | 138 | ntAnsiComment, 139 | ntBorComment, 140 | ntSlashesComment 141 | ); 142 | 143 | TAttributeName = ( 144 | anType, 145 | anClass, 146 | anForwarded, 147 | anKind, 148 | anName, 149 | anVisibility, 150 | anCallingConvention, 151 | anPath, 152 | anMethodBinding, 153 | anReintroduce, 154 | anOverload, 155 | anAbstract, 156 | anInline, 157 | anAlign 158 | ); 159 | 160 | const 161 | SyntaxNodeNames: array [TSyntaxNodeType] of string = ( 162 | 'unknown', 163 | 'absolute', 164 | 'add', 165 | 'addr', 166 | 'alignmentparam', 167 | 'and', 168 | 'anonymousmethod', 169 | 'arguments', 170 | 'as', 171 | 'assign', 172 | 'at', 173 | 'attribute', 174 | 'attributes', 175 | 'bounds', 176 | 'call', 177 | 'case', 178 | 'caseelse', 179 | 'caselabel', 180 | 'caselabels', 181 | 'caseselector', 182 | 'classconstraint', 183 | 'constant', 184 | 'constants', 185 | 'constraints', 186 | 'constructorconstraint', 187 | 'contains', 188 | 'default', 189 | 'deref', 190 | 'dimension', 191 | 'div', 192 | 'dot', 193 | 'downto', 194 | 'element', 195 | 'else', 196 | 'emptystatement', 197 | 'enum', 198 | 'equal', 199 | 'except', 200 | 'exceptionhandler', 201 | 'exports', 202 | 'expression', 203 | 'expressions', 204 | 'external', 205 | 'fdiv', 206 | 'field', 207 | 'fields', 208 | 'finalization', 209 | 'finally', 210 | 'for', 211 | 'from', 212 | 'generic', 213 | 'goto', 214 | 'greater', 215 | 'greaterequal', 216 | 'guid', 217 | 'helper', 218 | 'identifier', 219 | 'if', 220 | 'implementation', 221 | 'implements', 222 | 'in', 223 | 'index', 224 | 'indexed', 225 | 'inherited', 226 | 'initialization', 227 | 'interface', 228 | 'is', 229 | 'label', 230 | 'lhs', 231 | 'literal', 232 | 'lower', 233 | 'lowerequal', 234 | 'message', 235 | 'method', 236 | 'mod', 237 | 'mul', 238 | 'name', 239 | 'namedargument', 240 | 'notequal', 241 | 'not', 242 | 'or', 243 | 'package', 244 | 'parameter', 245 | 'parameters', 246 | 'path', 247 | 'positionalargument', 248 | 'protected', 249 | 'private', 250 | 'property', 251 | 'public', 252 | 'published', 253 | 'raise', 254 | 'read', 255 | 'recordconstraint', 256 | 'repeat', 257 | 'requires', 258 | 'resolutionclause', 259 | 'resourcestring', 260 | 'returntype', 261 | 'rhs', 262 | 'roundclose', 263 | 'roundopen', 264 | 'set', 265 | 'shl', 266 | 'shr', 267 | 'statement', 268 | 'statements', 269 | 'strictprivate', 270 | 'strictprotected', 271 | 'sub', 272 | 'subrange', 273 | 'then', 274 | 'to', 275 | 'try', 276 | 'type', 277 | 'typeargs', 278 | 'typedecl', 279 | 'typeparam', 280 | 'typeparams', 281 | 'typesection', 282 | 'value', 283 | 'variable', 284 | 'variables', 285 | 'xor', 286 | 'unaryminus', 287 | 'unit', 288 | 'uses', 289 | 'while', 290 | 'with', 291 | 'write', 292 | 293 | 'ansicomment', 294 | 'borlandcomment', 295 | 'slashescomment' 296 | ); 297 | 298 | AttributeNameStrings: array[TAttributeName] of string = ( 299 | 'type', 300 | 'class', 301 | 'forwarded', 302 | 'kind', 303 | 'name', 304 | 'visibility', 305 | 'callingconvention', 306 | 'path', 307 | 'methodbinding', 308 | 'reintroduce', 309 | 'overload', 310 | 'abstract', 311 | 'inline', 312 | 'align' 313 | ); 314 | 315 | implementation 316 | 317 | end. 318 | -------------------------------------------------------------------------------- /Source/DelphiAST/CodeCoverage.DelphiAST.SimpleParserEx.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.DelphiAST.SimpleParserEx; 2 | 3 | interface 4 | 5 | uses 6 | SysUtils, Generics.Collections, SimpleParser, SimpleParser.Lexer.Types, 7 | SimpleParser.Lexer, Classes; 8 | 9 | type 10 | TStringEvent = procedure(var s: string) of object; 11 | 12 | TPasLexer = class 13 | private 14 | FLexer: TmwPasLex; 15 | FOnHandleString: TStringEvent; 16 | function GetToken: string; inline; 17 | function GetPosXY: TTokenPoint; inline; 18 | function GetFileName: string; 19 | public 20 | constructor Create(const ALexer: TmwPasLex; AOnHandleString: TStringEvent); 21 | property FileName: string read GetFileName; 22 | property PosXY: TTokenPoint read GetPosXY; 23 | property Token: string read GetToken; 24 | property Lexer: TmwPasLex read FLexer; 25 | end; 26 | 27 | TmwSimplePasParEx = class(TmwSimplePasPar) 28 | public type 29 | TNameListStack = class; 30 | TNameList = class 31 | public type 32 | TNameItem = class 33 | public type 34 | TNameItemToken = class 35 | strict private 36 | FTokenFileName: string; 37 | FTokenPoint: TTokenPoint; 38 | FTokenPos: Integer; 39 | FTokenLen: Integer; 40 | public 41 | constructor Create(const ATokenFileName: string; 42 | const ATokenPoint: TTokenPoint; const ATokenPos, ATokenLen: Integer); 43 | property TokenFileName: string read FTokenFileName; 44 | property TokenPoint: TTokenPoint read FTokenPoint; 45 | property TokenPos: Integer read FTokenPos; 46 | property TokenLen: Integer read FTokenLen; 47 | end; 48 | strict private 49 | FTokenList: TObjectList; 50 | FEndNameCalled: Boolean; 51 | function GetLastNameItemToken: TNameItemToken; 52 | public 53 | constructor Create(const ATokenFileName: string; 54 | const ATokenPoint: TTokenPoint; const ATokenID: TptTokenKind; 55 | const ATokenPos, ATokenLen: Integer); 56 | destructor Destroy; override; 57 | procedure AddToken(const ATokenFileName: string; 58 | const ATokenPoint: TTokenPoint; const ATokenID: TptTokenKind; 59 | const ATokenPos, ATokenLen: Integer); 60 | property TokenList: TObjectList read FTokenList; 61 | property LastNameItemToken: TNameItemToken read GetLastNameItemToken; 62 | property EndNameCalled: Boolean read FEndNameCalled write FEndNameCalled; 63 | end; 64 | strict private 65 | FParser: TmwSimplePasParEx; 66 | FNameItems: TObjectList; 67 | FAutoCreated: Boolean; 68 | function GetItems(const Index: Integer): TNameItem; inline; 69 | function GetLastItem: TNameItem; inline; 70 | function GetOriginalNames(const Index: Integer): string; 71 | function GetNames(const Index: Integer): string; 72 | function GetLastOriginalName: string; 73 | function GetLastName: string; 74 | function GetCount: Integer; inline; 75 | function GetLexer: TmwPasLex; inline; 76 | property Lexer: TmwPasLex read GetLexer; 77 | public 78 | constructor Create(const AParser: TmwSimplePasParEx; 79 | const AAutoCreated: Boolean); 80 | destructor Destroy; override; 81 | procedure BeginName; 82 | procedure EndName; 83 | procedure AddToken; 84 | property AutoCreated: Boolean read FAutoCreated; 85 | property Items[const Index: Integer]: TNameItem read GetItems; 86 | property LastItem: TNameItem read GetLastItem; 87 | property OriginalNames[const Index: Integer]: string read GetOriginalNames; 88 | property Names[const Index: Integer]: string read GetNames; default; 89 | property LastOriginalName: string read GetLastOriginalName; 90 | property LastName: string read GetLastName; 91 | property Count: Integer read GetCount; 92 | end; 93 | TNameListStack = class 94 | strict private 95 | FParser: TmwSimplePasParEx; 96 | FNameListStack: TObjectStack; 97 | public 98 | constructor Create(const AParser: TmwSimplePasParEx); 99 | destructor Destroy; override; 100 | procedure PushNames(const AAutoCreated: Boolean); inline; 101 | procedure PopNames; inline; 102 | function ExtractNames: TNameList; inline; 103 | function PeekNames: TNameList; inline; 104 | function ToArray: TArray; inline; 105 | function Count: Integer; inline; 106 | end; 107 | strict private 108 | FNameListStack: TNameListStack; 109 | FPreviousNames: TNameList; 110 | FLexer: TPasLexer; 111 | FLowerCaseNames: Boolean; 112 | FOnHandleString: TStringEvent; 113 | function GetCurrentNames: TNameList; inline; 114 | strict protected 115 | procedure DoHandleString(var AString: string); inline; 116 | procedure PushNames; inline; 117 | procedure PopNames; inline; 118 | function PeekNames: TNameList; inline; 119 | procedure BeginName; 120 | procedure EndName; 121 | property CurrentNames: TNameList read GetCurrentNames; 122 | property PreviousNames: TNameList read FPreviousNames; 123 | protected 124 | procedure NextToken; override; 125 | public 126 | constructor Create; override; 127 | destructor Destroy; override; 128 | property Lexer: TPasLexer read FLexer; 129 | property LowerCaseNames: Boolean read FLowerCaseNames write FLowerCaseNames; 130 | property OnHandleString: TStringEvent read FOnHandleString write FOnHandleString; 131 | end; 132 | 133 | implementation 134 | 135 | { TPasLexer } 136 | 137 | constructor TPasLexer.Create(const ALexer: TmwPasLex; AOnHandleString: TStringEvent); 138 | begin 139 | inherited Create; 140 | FLexer := ALexer; 141 | FOnHandleString := AOnHandleString; 142 | end; 143 | 144 | function TPasLexer.GetFileName: string; 145 | begin 146 | Result := FLexer.Buffer.FileName; 147 | end; 148 | 149 | function TPasLexer.GetPosXY: TTokenPoint; 150 | begin 151 | Result := FLexer.PosXY; 152 | end; 153 | 154 | function TPasLexer.GetToken: string; 155 | begin 156 | Result := FLexer.Token; 157 | FOnHandleString(Result); 158 | end; 159 | 160 | { TmwSimplePasParEx.TNameList.TNameItem.TNameItemToken } 161 | 162 | constructor TmwSimplePasParEx.TNameList.TNameItem.TNameItemToken.Create( 163 | const ATokenFileName: string; const ATokenPoint: TTokenPoint; 164 | const ATokenPos, ATokenLen: Integer); 165 | begin 166 | FTokenFileName := ATokenFileName; 167 | FTokenPoint := ATokenPoint; 168 | FTokenPos := ATokenPos; 169 | FTokenLen := ATokenLen; 170 | end; 171 | 172 | { TPasNamesBuilder.TNamesList.TNameItem } 173 | 174 | constructor TmwSimplePasParEx.TNameList.TNameItem.Create( 175 | const ATokenFileName: string; const ATokenPoint: TTokenPoint; 176 | const ATokenID: TptTokenKind; const ATokenPos, ATokenLen: Integer); 177 | begin 178 | FTokenList := TObjectList.Create(True); 179 | AddToken(ATokenFileName, ATokenPoint, ATokenID, ATokenPos, ATokenLen); 180 | end; 181 | 182 | destructor TmwSimplePasParEx.TNameList.TNameItem.Destroy; 183 | begin 184 | FTokenList.Free; 185 | inherited; 186 | end; 187 | 188 | procedure TmwSimplePasParEx.TNameList.TNameItem.AddToken( 189 | const ATokenFileName: string; const ATokenPoint: TTokenPoint; 190 | const ATokenID: TptTokenKind; const ATokenPos, ATokenLen: Integer); 191 | begin 192 | if not IsTokenIDJunk(ATokenID) and 193 | ((FTokenList.Count = 0) or (FTokenList.Last.TokenPos < ATokenPos)) then 194 | FTokenList.Add(TNameItemToken.Create( 195 | ATokenFileName, ATokenPoint, ATokenPos, ATokenLen)); 196 | end; 197 | 198 | function TmwSimplePasParEx.TNameList.TNameItem.GetLastNameItemToken: TNameItemToken; 199 | begin 200 | Result := TokenList.Last; 201 | end; 202 | 203 | { TPasNamesBuilder.TNamesList } 204 | 205 | constructor TmwSimplePasParEx.TNameList.Create(const AParser: TmwSimplePasParEx; 206 | const AAutoCreated: Boolean); 207 | begin 208 | FParser := AParser; 209 | FNameItems := TObjectList.Create(True); 210 | end; 211 | 212 | destructor TmwSimplePasParEx.TNameList.Destroy; 213 | begin 214 | FNameItems.Free; 215 | inherited; 216 | end; 217 | 218 | function TmwSimplePasParEx.TNameList.GetLexer: TmwPasLex; 219 | begin 220 | Result := FParser.Lexer.Lexer; 221 | end; 222 | 223 | procedure TmwSimplePasParEx.TNameList.BeginName; 224 | begin 225 | FNameItems.Add(TNameItem.Create(Lexer.FileName, Lexer.PosXY, Lexer.TokenID, 226 | Lexer.TokenPos, Lexer.TokenLen)); 227 | end; 228 | 229 | procedure TmwSimplePasParEx.TNameList.EndName; 230 | begin 231 | FNameItems.Last.EndNameCalled := True; 232 | end; 233 | 234 | procedure TmwSimplePasParEx.TNameList.AddToken; 235 | begin 236 | FNameItems.Last.AddToken(Lexer.FileName, Lexer.PosXY, Lexer.TokenID, 237 | Lexer.TokenPos, Lexer.TokenLen); 238 | end; 239 | 240 | function TmwSimplePasParEx.TNameList.GetItems(const Index: Integer): TNameItem; 241 | begin 242 | Result := FNameItems[Index]; 243 | end; 244 | 245 | function TmwSimplePasParEx.TNameList.GetLastItem: TNameItem; 246 | begin 247 | Result := FNameItems.Last; 248 | end; 249 | 250 | function TmwSimplePasParEx.TNameList.GetOriginalNames(const Index: Integer): string; 251 | var 252 | I: Integer; 253 | NameItem: TNameItem; 254 | Token: string; 255 | begin 256 | Result := ''; 257 | NameItem := Items[Index]; 258 | for I := 0 to NameItem.TokenList.Count - 1 do 259 | begin 260 | SetString(Token, Lexer.Buffer.Buf + NameItem.TokenList[I].TokenPos, 261 | NameItem.TokenList[I].TokenLen); 262 | Result := Result + Token; 263 | end; 264 | FParser.DoHandleString(Result); 265 | end; 266 | 267 | function TmwSimplePasParEx.TNameList.GetNames(const Index: Integer): string; 268 | begin 269 | Result := OriginalNames[Index]; 270 | if FParser.LowerCaseNames then 271 | begin 272 | Result := AnsiLowerCase(Result); 273 | FParser.DoHandleString(Result); 274 | end; 275 | end; 276 | 277 | function TmwSimplePasParEx.TNameList.GetLastOriginalName: string; 278 | begin 279 | Result := OriginalNames[Count - 1]; 280 | end; 281 | 282 | function TmwSimplePasParEx.TNameList.GetLastName: string; 283 | begin 284 | Result := Names[Count - 1]; 285 | end; 286 | 287 | function TmwSimplePasParEx.TNameList.GetCount: Integer; 288 | begin 289 | Result := FNameItems.Count; 290 | end; 291 | 292 | { TPasNamesBuilder.TNameListStack } 293 | 294 | function TmwSimplePasParEx.TNameListStack.Count: Integer; 295 | begin 296 | Result := FNameListStack.Count; 297 | end; 298 | 299 | constructor TmwSimplePasParEx.TNameListStack.Create( 300 | const AParser: TmwSimplePasParEx); 301 | begin 302 | FParser := AParser; 303 | FNameListStack := TObjectStack.Create(True); 304 | end; 305 | 306 | destructor TmwSimplePasParEx.TNameListStack.Destroy; 307 | begin 308 | FNameListStack.Free; 309 | inherited; 310 | end; 311 | 312 | procedure TmwSimplePasParEx.TNameListStack.PushNames(const AAutoCreated: Boolean); 313 | begin 314 | FNameListStack.Push(TNameList.Create(FParser, AAutoCreated)); 315 | end; 316 | 317 | procedure TmwSimplePasParEx.TNameListStack.PopNames; 318 | begin 319 | FNameListStack.Pop; 320 | end; 321 | 322 | function TmwSimplePasParEx.TNameListStack.ExtractNames: TNameList; 323 | begin 324 | Result := FNameListStack.Extract; 325 | end; 326 | 327 | function TmwSimplePasParEx.TNameListStack.PeekNames: TNameList; 328 | begin 329 | Result := FNameListStack.Peek; 330 | end; 331 | 332 | function TmwSimplePasParEx.TNameListStack.ToArray: TArray; 333 | begin 334 | Result := FNameListStack.ToArray; 335 | end; 336 | 337 | { TmwSimplePasParEx } 338 | 339 | constructor TmwSimplePasParEx.Create; 340 | begin 341 | inherited; 342 | FNameListStack := TNameListStack.Create(Self); 343 | FNameListStack.PushNames(True); 344 | FPreviousNames := TNameList.Create(Self, True); 345 | FLexer := TPasLexer.Create(inherited Lexer, DoHandleString); 346 | FLowerCaseNames := True; 347 | end; 348 | 349 | destructor TmwSimplePasParEx.Destroy; 350 | begin 351 | FLexer.Free; 352 | FPreviousNames.Free; 353 | FNameListStack.PopNames; 354 | FNameListStack.Free; 355 | inherited; 356 | end; 357 | 358 | procedure TmwSimplePasParEx.NextToken; 359 | var 360 | NameList: TNameList; 361 | begin 362 | if FNameListStack.Count > 0 then 363 | for NameList in FNameListStack.ToArray do 364 | if (NameList.Count > 0) and not NameList.LastItem.EndNameCalled then 365 | NameList.AddToken; 366 | inherited; 367 | end; 368 | 369 | procedure TmwSimplePasParEx.PushNames; 370 | begin 371 | FNameListStack.PushNames(False); 372 | end; 373 | 374 | procedure TmwSimplePasParEx.PopNames; 375 | begin 376 | FPreviousNames.Free; 377 | FPreviousNames := FNameListStack.ExtractNames; 378 | end; 379 | 380 | function TmwSimplePasParEx.PeekNames: TNameList; 381 | begin 382 | Result := FNameListStack.PeekNames; 383 | end; 384 | 385 | procedure TmwSimplePasParEx.BeginName; 386 | var 387 | NameList: TNameList; 388 | begin 389 | NameList := FNameListStack.PeekNames; 390 | if (NameList.Count > 0) and not NameList.LastItem.EndNameCalled then 391 | begin 392 | FNameListStack.PushNames(True); 393 | NameList := FNameListStack.PeekNames; 394 | end; 395 | NameList.BeginName; 396 | end; 397 | 398 | procedure TmwSimplePasParEx.EndName; 399 | var 400 | NameList: TNameList; 401 | begin 402 | NameList := FNameListStack.PeekNames; 403 | if NameList.LastItem.EndNameCalled then 404 | begin 405 | FNameListStack.PopNames; 406 | NameList := FNameListStack.PeekNames; 407 | end; 408 | NameList.EndName; 409 | end; 410 | 411 | procedure TmwSimplePasParEx.DoHandleString(var AString: string); 412 | begin 413 | if Assigned(FOnHandleString) then 414 | FOnHandleString(AString); 415 | end; 416 | 417 | function TmwSimplePasParEx.GetCurrentNames: TNameList; 418 | begin 419 | Result := PeekNames; 420 | end; 421 | 422 | end. 423 | -------------------------------------------------------------------------------- /Source/DelphiAST/CodeCoverage.SimpleParser.Lexer.Types.pas: -------------------------------------------------------------------------------- 1 | {--------------------------------------------------------------------------- 2 | The contents of this file are subject to the Mozilla Public License Version 3 | 1.1 (the "License"); you may not use this file except in compliance with the 4 | License. You may obtain a copy of the License at 5 | http://www.mozilla.org/NPL/NPL-1_1Final.html 6 | 7 | Software distributed under the License is distributed on an "AS IS" basis, 8 | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for 9 | the specific language governing rights and limitations under the License. 10 | 11 | The Original Code is: mwPasLexTypes, released November 14, 1999. 12 | 13 | The Initial Developer of the Original Code is Martin Waldenburg 14 | unit CastaliaPasLexTypes; 15 | 16 | ----------------------------------------------------------------------------} 17 | 18 | unit CodeCoverage.SimpleParser.Lexer.Types; 19 | 20 | {$IFDEF FPC}{$MODE DELPHI}{$ENDIF} 21 | 22 | interface 23 | 24 | uses 25 | SysUtils, 26 | TypInfo; 27 | 28 | {$INCLUDE SimpleParser.inc} 29 | 30 | {$IFNDEF D14_NEWER} 31 | type 32 | TArray = array of T; 33 | {$ENDIF} 34 | 35 | var 36 | CompTable: array[#0..#255] of byte; 37 | 38 | type 39 | TMessageEventType = (meError, meNotSupported); 40 | 41 | TMessageEvent = procedure(Sender: TObject; const Typ: TMessageEventType; 42 | const Msg: string; X, Y: Integer) of object; 43 | 44 | TCommentState = (csAnsi, csBor, csNo); 45 | 46 | TTokenPoint = packed record 47 | X: Integer; 48 | Y: Integer; 49 | end; 50 | 51 | TptTokenKind = ( 52 | ptAbort, 53 | ptAbsolute, 54 | ptAbstract, 55 | ptAdd, 56 | ptAddressOp, 57 | ptAlign, 58 | ptAmpersand, 59 | ptAnd, 60 | ptAnsiComment, 61 | ptAnsiString, 62 | ptArray, 63 | ptAs, 64 | ptAsciiChar, 65 | ptAsm, 66 | ptAssembler, 67 | ptAssign, 68 | ptAt, 69 | ptAutomated, 70 | ptBegin, 71 | ptBoolean, 72 | ptBorComment, 73 | ptBraceClose, 74 | ptBraceOpen, 75 | ptBreak, 76 | ptByte, 77 | ptByteBool, 78 | ptCardinal, 79 | ptCase, 80 | ptCdecl, 81 | ptChar, 82 | ptClass, 83 | ptClassForward, 84 | ptClassFunction, 85 | ptClassProcedure, 86 | ptColon, 87 | ptComma, 88 | ptComp, 89 | ptCompDirect, 90 | ptConst, 91 | ptConstructor, 92 | ptContains, 93 | ptContinue, 94 | ptCRLF, 95 | ptCRLFCo, 96 | ptCurrency, 97 | ptDefault, 98 | ptDefineDirect, 99 | ptDeprecated, 100 | ptDestructor, 101 | ptDispid, 102 | ptDispinterface, 103 | ptDiv, 104 | ptDo, 105 | ptDotDot, 106 | ptDouble, 107 | ptDoubleAddressOp, 108 | ptDownto, 109 | ptDWORD, 110 | ptDynamic, 111 | ptElse, 112 | ptElseDirect, 113 | ptEnd, 114 | ptEndIfDirect, 115 | ptEqual, 116 | ptError, 117 | ptExcept, 118 | ptExit, 119 | ptExport, 120 | ptExports, 121 | ptExtended, 122 | ptExternal, 123 | ptFar, 124 | ptFile, 125 | ptFinal, 126 | ptExperimental, 127 | ptDelayed, 128 | ptFinalization, 129 | ptFinally, 130 | ptFloat, 131 | ptFor, 132 | ptForward, 133 | ptFunction, 134 | ptGoto, 135 | ptGreater, 136 | ptGreaterEqual, 137 | ptHalt, 138 | ptHelper, 139 | ptIdentifier, 140 | ptIf, 141 | ptIfDirect, 142 | ptIfEndDirect, 143 | ptElseIfDirect, 144 | ptIfDefDirect, 145 | ptIfNDefDirect, 146 | ptIfOptDirect, 147 | ptImplementation, 148 | ptImplements, 149 | ptIn, 150 | ptIncludeDirect, 151 | ptIndex, 152 | ptInherited, 153 | ptInitialization, 154 | ptInline, 155 | ptInt64, 156 | ptInteger, 157 | ptIntegerConst, 158 | ptInterface, 159 | ptIs, 160 | ptLabel, 161 | ptLibrary, 162 | ptLocal, 163 | ptLongBool, 164 | ptLongint, 165 | ptLongword, 166 | ptLower, 167 | ptLowerEqual, 168 | ptMessage, 169 | ptMinus, 170 | ptMod, 171 | ptName, 172 | ptNear, 173 | ptNil, 174 | ptNodefault, 175 | ptNone, 176 | ptNot, 177 | ptNotEqual, 178 | ptNull, 179 | ptObject, 180 | ptOf, 181 | ptOleVariant, 182 | ptOn, 183 | ptOperator, 184 | ptOr, 185 | ptOut, 186 | ptOverload, 187 | ptOverride, 188 | ptPackage, 189 | ptPacked, 190 | ptPascal, 191 | ptPChar, 192 | ptPlatform, 193 | ptPlus, 194 | ptPoint, 195 | ptPointerSymbol, 196 | ptPrivate, 197 | ptProcedure, 198 | ptProgram, 199 | ptProperty, 200 | ptProtected, 201 | ptPublic, 202 | ptPublished, 203 | ptRaise, 204 | ptRead, 205 | ptReadonly, 206 | ptReal, 207 | ptReal48, 208 | ptRecord, 209 | ptReference, 210 | ptRegister, 211 | ptReintroduce, 212 | ptRemove, 213 | ptRepeat, 214 | ptRequires, 215 | ptResident, 216 | ptResourceDirect, 217 | ptResourcestring, 218 | ptRoundClose, 219 | ptRoundOpen, 220 | ptRunError, 221 | ptSafeCall, 222 | ptScopedEnumsDirect, 223 | ptSealed, 224 | ptSemiColon, 225 | ptSet, 226 | ptShl, 227 | ptShortint, 228 | ptShortString, 229 | ptShr, 230 | ptSingle, 231 | ptSlash, 232 | ptSlashesComment, 233 | ptSmallint, 234 | ptSpace, 235 | ptSquareClose, 236 | ptSquareOpen, 237 | ptStar, 238 | ptStatic, 239 | ptStdcall, 240 | ptStored, 241 | ptStrict, 242 | ptString, 243 | ptStringConst, 244 | ptStringDQConst, 245 | ptStringresource, 246 | ptSymbol, 247 | ptThen, 248 | ptThreadvar, 249 | ptTo, 250 | ptTry, 251 | ptType, 252 | ptUndefDirect, 253 | ptUnit, 254 | ptUnknown, 255 | ptUnsafe, 256 | ptUntil, 257 | ptUses, 258 | ptVar, 259 | ptVarargs, 260 | ptVariant, 261 | ptVirtual, 262 | ptWhile, 263 | ptWideChar, 264 | ptWideString, 265 | ptWith, 266 | ptWord, 267 | ptWordBool, 268 | ptWrite, 269 | ptWriteonly, 270 | ptXor); 271 | 272 | TmwPasLexStatus = record 273 | CommentState: TCommentState; 274 | ExID: TptTokenKind; 275 | LineNumber: Integer; 276 | LinePos: Integer; 277 | Origin: PChar; 278 | RunPos: Integer; 279 | TokenPos: Integer; 280 | TokenID: TptTokenKind; 281 | end; 282 | 283 | EIncludeError = class(Exception); 284 | IIncludeHandler = interface 285 | ['{C5F20740-41D2-43E9-8321-7FE5E3AA83B6}'] 286 | function GetIncludeFileContent(const ParentFileName, IncludeName: string; 287 | out Content: string; out FileName: string): Boolean; 288 | end; 289 | 290 | function TokenName(Value: TptTokenKind): string; 291 | function ptTokenName(Value: TptTokenKind): string; 292 | function IsTokenIDJunk(const aTokenID: TptTokenKind): Boolean; 293 | 294 | implementation 295 | 296 | function TokenName(Value: TptTokenKind): string; 297 | begin 298 | Result := Copy(ptTokenName(Value), 3, MaxInt); 299 | end; 300 | 301 | function ptTokenName(Value: TptTokenKind): string; 302 | begin 303 | result := GetEnumName(TypeInfo(TptTokenKind), Integer(Value)); 304 | end; 305 | 306 | function IsTokenIDJunk(const aTokenID: TptTokenKind): Boolean; 307 | begin 308 | Result := aTokenID in [ 309 | ptAnsiComment, 310 | ptBorComment, 311 | ptCRLF, 312 | ptCRLFCo, 313 | ptSlashesComment, 314 | ptSpace, 315 | ptIfDirect, 316 | ptElseDirect, 317 | ptIfEndDirect, 318 | ptElseIfDirect, 319 | ptIfDefDirect, 320 | ptIfNDefDirect, 321 | ptEndIfDirect, 322 | ptIfOptDirect, 323 | ptDefineDirect, 324 | ptScopedEnumsDirect, 325 | ptUndefDirect]; 326 | end; 327 | 328 | end. 329 | -------------------------------------------------------------------------------- /Source/DelphiAST/CodeCoverage.SimpleParser.Types.pas: -------------------------------------------------------------------------------- 1 | {--------------------------------------------------------------------------- 2 | The contents of this file are subject to the Mozilla Public License Version 3 | 1.1 (the "License"); you may not use this file except in compliance with the 4 | License. You may obtain a copy of the License at 5 | http://www.mozilla.org/NPL/NPL-1_1Final.html 6 | 7 | Software distributed under the License is distributed on an "AS IS" basis, 8 | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for 9 | the specific language governing rights and limitations under the License. 10 | 11 | The Original Code is: mwSimplePasParTypes, released November 14, 1999. 12 | 13 | The Initial Developer of the Original Code is Martin Waldenburg 14 | unit CastaliaPasLexTypes; 15 | 16 | ----------------------------------------------------------------------------} 17 | 18 | unit CodeCoverage.SimpleParser.Types; 19 | 20 | interface 21 | 22 | uses 23 | SysUtils, 24 | TypInfo; 25 | 26 | type 27 | TmwParseError = ( 28 | InvalidAdditiveOperator, 29 | InvalidAccessSpecifier, 30 | InvalidCharString, 31 | InvalidClassMethodHeading, 32 | InvalidConstantDeclaration, 33 | InvalidConstSection, 34 | InvalidDeclarationSection, 35 | InvalidDirective16Bit, 36 | InvalidDirectiveBinding, 37 | InvalidDirectiveCalling, 38 | InvalidExportedHeading, 39 | InvalidForStatement, 40 | InvalidInitializationSection, 41 | InvalidInterfaceDeclaration, 42 | InvalidInterfaceType, 43 | InvalidLabelId, 44 | InvalidLabeledStatement, 45 | InvalidMethodHeading, 46 | InvalidMultiplicativeOperator, 47 | InvalidNumber, 48 | InvalidOrdinalIdentifier, 49 | InvalidParameter, 50 | InvalidParseFile, 51 | InvalidProceduralDirective, 52 | InvalidProceduralType, 53 | InvalidProcedureDeclarationSection, 54 | InvalidProcedureMethodDeclaration, 55 | InvalidRealIdentifier, 56 | InvalidRelativeOperator, 57 | InvalidStorageSpecifier, 58 | InvalidStringIdentifier, 59 | InvalidStructuredType, 60 | InvalidTryStatement, 61 | InvalidTypeKind, 62 | InvalidVariantIdentifier, 63 | InvalidVarSection, 64 | vchInvalidClass, 65 | vchInvalidMethod, 66 | vchInvalidProcedure, 67 | vchInvalidCircuit, 68 | vchInvalidIncludeFile 69 | ); 70 | 71 | TmwPasCodeInfo = ( 72 | ciNone, 73 | ciAccessSpecifier, 74 | ciAdditiveOperator, 75 | ciArrayConstant, 76 | ciArrayType, 77 | ciAsmStatement, 78 | ciBlock, 79 | ciCaseLabel, 80 | ciCaseSelector, 81 | ciCaseStatement, 82 | ciCharString, 83 | ciClassClass, 84 | ciClassField, 85 | ciClassForward, 86 | ciClassFunctionHeading, 87 | ciClassHeritage, 88 | ciClassMemberList, 89 | ciClassMethodDirective, 90 | ciClassMethodHeading, 91 | ciClassMethodOrProperty, 92 | ciClassMethodResolution, 93 | ciClassProcedureHeading, 94 | ciClassProperty, 95 | ciClassReferenceType, 96 | ciClassType, 97 | ciClassTypeEnd, 98 | ciClassVisibility, 99 | ciCompoundStatement, 100 | ciConstantColon, 101 | ciConstantDeclaration, 102 | ciConstantEqual, 103 | ciConstantExpression, 104 | ciConstantName, 105 | ciConstantValue, 106 | ciConstantValueTyped, 107 | ciConstParameter, 108 | ciConstructorHeading, 109 | ciConstructorName, 110 | ciConstSection, 111 | ciContainsClause, 112 | ciContainsExpression, 113 | ciContainsIdentifier, 114 | ciContainsStatement, 115 | ciDeclarationSection, 116 | ciDesignator, 117 | ciDestructorHeading, 118 | ciDestructorName, 119 | ciDirective16Bit, 120 | ciDirectiveBinding, 121 | ciDirectiveCalling, 122 | ciDirectiveDeprecated, 123 | ciDirectiveLibrary, 124 | ciDirectiveLocal, 125 | ciDirectivePlatform, 126 | ciDirectiveVarargs, 127 | ciDispIDSpecifier, 128 | ciDispInterfaceForward, 129 | ciEmptyStatement, 130 | ciEnumeratedType, 131 | ciEnumeratedTypeItem, 132 | ciExceptBlock, 133 | ciExceptionBlockElseBranch, 134 | ciExceptionClassTypeIdentifier, 135 | ciExceptionHandler, 136 | ciExceptionHandlerList, 137 | ciExceptionIdentifier, 138 | ciExceptionVariable, 139 | ciExpliciteType, 140 | ciExportedHeading, 141 | ciExportsClause, 142 | ciExportsElement, 143 | ciExpression, 144 | ciExpressionList, 145 | ciExternalDirective, 146 | ciExternalDirectiveThree, 147 | ciExternalDirectiveTwo, 148 | ciFactor, 149 | ciFieldDeclaration, 150 | ciFieldList, 151 | ciFileType, 152 | ciFormalParameterList, 153 | ciFormalParameterSection, 154 | ciForStatement, 155 | ciForwardDeclaration, 156 | ciFunctionHeading, 157 | ciFunctionMethodDeclaration, 158 | ciFunctionMethodName, 159 | ciFunctionProcedureBlock, 160 | ciFunctionProcedureName, 161 | ciHandlePtCompDirect, 162 | ciHandlePtDefineDirect, 163 | ciHandlePtElseDirect, 164 | ciHandlePtIfDefDirect, 165 | ciHandlePtEndIfDirect, 166 | ciHandlePtIfNDefDirect, 167 | ciHandlePtIfOptDirect, 168 | ciHandlePtIncludeDirect, 169 | ciHandlePtResourceDirect, 170 | ciHandlePtUndefDirect, 171 | ciIdentifier, 172 | ciIdentifierList, 173 | ciIfStatement, 174 | ciImplementationSection, 175 | ciIncludeFile, 176 | ciIndexSpecifier, 177 | ciInheritedStatement, 178 | ciInitializationSection, 179 | ciInlineStatement, 180 | ciInterfaceDeclaration, 181 | ciInterfaceForward, 182 | ciInterfaceGUID, 183 | ciInterfaceHeritage, 184 | ciInterfaceMemberList, 185 | ciInterfaceSection, 186 | ciInterfaceType, 187 | ciLabelDeclarationSection, 188 | ciLabeledStatement, 189 | ciLabelId, 190 | ciLibraryFile, 191 | ciMainUsedUnitExpression, 192 | ciMainUsedUnitName, 193 | ciMainUsedUnitStatement, 194 | ciMainUsesClause, 195 | ciMultiplicativeOperator, 196 | ciNewFormalParameterType, 197 | ciNumber, 198 | ciNextToken, 199 | ciObjectConstructorHeading, 200 | ciObjectDestructorHeading, 201 | ciObjectField, 202 | ciObjectForward, 203 | ciObjectFunctionHeading, 204 | ciObjectHeritage, 205 | ciObjectMemberList, 206 | ciObjectMethodDirective, 207 | ciObjectMethodHeading, 208 | ciObjectNameOfMethod, 209 | ciObjectProcedureHeading, 210 | ciObjectProperty, 211 | ciObjectPropertySpecifiers, 212 | ciObjectType, 213 | ciObjectTypeEnd, 214 | ciObjectVisibility, 215 | ciOldFormalParameterType, 216 | ciOrdinalIdentifier, 217 | ciOrdinalType, 218 | ciOutParameter, 219 | ciPackageFile, 220 | ciParameterFormal, 221 | ciParameterName, 222 | ciParameterNameList, 223 | ciParseFile, 224 | ciPointerType, 225 | ciProceduralDirective, 226 | ciProceduralType, 227 | ciProcedureDeclarationSection, 228 | ciProcedureHeading, 229 | ciProcedureMethodDeclaration, 230 | ciProcedureMethodName, 231 | ciProgramBlock, 232 | ciProgramFile, 233 | ciPropertyDefault, 234 | ciPropertyInterface, 235 | ciPropertyName, 236 | ciPropertyParameterConst, 237 | ciPropertyParameterList, 238 | ciPropertySpecifiers, 239 | ciQualifiedIdentifier, 240 | ciQualifiedIdentifierList, 241 | ciRaiseStatement, 242 | ciReadAccessIdentifier, 243 | ciRealIdentifier, 244 | ciRealType, 245 | ciRecordConstant, 246 | ciRecordFieldConstant, 247 | ciRecordType, 248 | ciRecordVariant, 249 | ciRelativeOperator, 250 | ciRepeatStatement, 251 | ciRequiresClause, 252 | ciRequiresIdentifier, 253 | ciResolutionInterfaceName, 254 | ciResourceDeclaration, 255 | ciReturnType, 256 | ciSEMICOLON, 257 | ciSetConstructor, 258 | ciSetElement, 259 | ciSetType, 260 | ciSimpleExpression, 261 | ciSimpleStatement, 262 | ciSimpleType, 263 | ciSkipAnsiComment, 264 | ciSkipBorComment, 265 | ciSkipSlashesComment, 266 | ciSkipSpace, 267 | ciSkipCRLFco, 268 | ciSkipCRLF, 269 | ciStatement, 270 | ciStatementList, 271 | ciStorageExpression, 272 | ciStorageIdentifier, 273 | ciStorageDefault, 274 | ciStorageNoDefault, 275 | ciStorageSpecifier, 276 | ciStorageStored, 277 | ciStringIdentifier, 278 | ciStringStatement, 279 | ciStringType, 280 | ciStructuredType, 281 | ciSubrangeType, 282 | ciTagField, 283 | ciTagFieldName, 284 | ciTagFieldTypeName, 285 | ciTerm, 286 | ciTryStatement, 287 | ciTypedConstant, 288 | ciTypeDeclaration, 289 | ciTypeId, 290 | ciTypeKind, 291 | ciTypeName, 292 | ciTypeSection, 293 | ciUnitFile, 294 | ciUnitId, 295 | ciUsedUnitName, 296 | ciUsedUnitsList, 297 | ciUsesClause, 298 | ciVarAbsolute, 299 | ciVarEqual, 300 | ciVarDeclaration, 301 | ciVariable, 302 | ciVariableList, 303 | ciVariableReference, 304 | ciVariableTwo, 305 | ciVariantIdentifier, 306 | ciVariantSection, 307 | ciVarParameter, 308 | ciVarSection, 309 | ciVisibilityAutomated, 310 | ciVisibilityPrivate, 311 | ciVisibilityProtected, 312 | ciVisibilityPublic, 313 | ciVisibilityPublished, 314 | ciVisibilityUnknown, 315 | ciWhileStatement, 316 | ciWithStatement, 317 | ciWriteAccessIdentifier 318 | ); 319 | 320 | function ParserErrorName(Value: TmwParseError): string; 321 | 322 | implementation 323 | 324 | function ParserErrorName(Value: TmwParseError): string; 325 | begin 326 | result := GetEnumName(TypeInfo(TmwParseError), Integer(Value)); 327 | end; 328 | 329 | end. 330 | 331 | -------------------------------------------------------------------------------- /Source/DelphiAST/SimpleParser.inc: -------------------------------------------------------------------------------- 1 | {$IFDEF VER350} // Delphi 11 2 | {$DEFINE D8_NEWER} 3 | {$DEFINE D9_NEWER} 4 | {$DEFINE D10_NEWER} 5 | {$DEFINE D11_NEWER} 6 | {$DEFINE D12_NEWER} 7 | {$DEFINE D14_NEWER} 8 | {$DEFINE D15_NEWER} 9 | {$DEFINE D16_NEWER} 10 | {$DEFINE D17_NEWER} 11 | {$DEFINE D18_NEWER} 12 | {$DEFINE D19_NEWER} 13 | {$DEFINE D20_NEWER} 14 | {$DEFINE D21_NEWER} 15 | {$DEFINE D22_NEWER} 16 | {$DEFINE D23_NEWER} 17 | {$DEFINE D24_NEWER} 18 | {$DEFINE D25_NEWER} 19 | {$DEFINE D26_NEWER} 20 | {$DEFINE D27_NEWER} 21 | {$ENDIF} 22 | 23 | {$IFDEF VER340} // Delphi 10.4 24 | {$DEFINE D8_NEWER} 25 | {$DEFINE D9_NEWER} 26 | {$DEFINE D10_NEWER} 27 | {$DEFINE D11_NEWER} 28 | {$DEFINE D12_NEWER} 29 | {$DEFINE D14_NEWER} 30 | {$DEFINE D15_NEWER} 31 | {$DEFINE D16_NEWER} 32 | {$DEFINE D17_NEWER} 33 | {$DEFINE D18_NEWER} 34 | {$DEFINE D19_NEWER} 35 | {$DEFINE D20_NEWER} 36 | {$DEFINE D21_NEWER} 37 | {$DEFINE D22_NEWER} 38 | {$DEFINE D23_NEWER} 39 | {$DEFINE D24_NEWER} 40 | {$DEFINE D25_NEWER} 41 | {$DEFINE D26_NEWER} 42 | {$ENDIF} 43 | 44 | {$IFDEF VER330} // Delphi 10.3 45 | {$DEFINE D8_NEWER} 46 | {$DEFINE D9_NEWER} 47 | {$DEFINE D10_NEWER} 48 | {$DEFINE D11_NEWER} 49 | {$DEFINE D12_NEWER} 50 | {$DEFINE D14_NEWER} 51 | {$DEFINE D15_NEWER} 52 | {$DEFINE D16_NEWER} 53 | {$DEFINE D17_NEWER} 54 | {$DEFINE D18_NEWER} 55 | {$DEFINE D19_NEWER} 56 | {$DEFINE D20_NEWER} 57 | {$DEFINE D21_NEWER} 58 | {$DEFINE D22_NEWER} 59 | {$DEFINE D23_NEWER} 60 | {$DEFINE D24_NEWER} 61 | {$DEFINE D25_NEWER} 62 | {$DEFINE D26_NEWER} 63 | {$ENDIF} 64 | 65 | {$IFDEF VER320} // Delphi 10 Tokyo 66 | {$DEFINE D8_NEWER} 67 | {$DEFINE D9_NEWER} 68 | {$DEFINE D10_NEWER} 69 | {$DEFINE D11_NEWER} 70 | {$DEFINE D12_NEWER} 71 | {$DEFINE D14_NEWER} 72 | {$DEFINE D15_NEWER} 73 | {$DEFINE D16_NEWER} 74 | {$DEFINE D17_NEWER} 75 | {$DEFINE D18_NEWER} 76 | {$DEFINE D19_NEWER} 77 | {$DEFINE D20_NEWER} 78 | {$DEFINE D21_NEWER} 79 | {$DEFINE D22_NEWER} 80 | {$DEFINE D23_NEWER} 81 | {$DEFINE D24_NEWER} 82 | {$DEFINE D25_NEWER} 83 | {$ENDIF} 84 | 85 | {$IFDEF VER310} // Delphi 10 Berlin 86 | {$DEFINE D8_NEWER} 87 | {$DEFINE D9_NEWER} 88 | {$DEFINE D10_NEWER} 89 | {$DEFINE D11_NEWER} 90 | {$DEFINE D12_NEWER} 91 | {$DEFINE D14_NEWER} 92 | {$DEFINE D15_NEWER} 93 | {$DEFINE D16_NEWER} 94 | {$DEFINE D17_NEWER} 95 | {$DEFINE D18_NEWER} 96 | {$DEFINE D19_NEWER} 97 | {$DEFINE D20_NEWER} 98 | {$DEFINE D21_NEWER} 99 | {$DEFINE D22_NEWER} 100 | {$DEFINE D23_NEWER} 101 | {$DEFINE D24_NEWER} 102 | {$ENDIF} 103 | 104 | {$IFDEF VER300} // Delphi 10 Seattle 105 | {$DEFINE D8_NEWER} 106 | {$DEFINE D9_NEWER} 107 | {$DEFINE D10_NEWER} 108 | {$DEFINE D11_NEWER} 109 | {$DEFINE D12_NEWER} 110 | {$DEFINE D14_NEWER} 111 | {$DEFINE D15_NEWER} 112 | {$DEFINE D16_NEWER} 113 | {$DEFINE D17_NEWER} 114 | {$DEFINE D18_NEWER} 115 | {$DEFINE D19_NEWER} 116 | {$DEFINE D20_NEWER} 117 | {$DEFINE D21_NEWER} 118 | {$DEFINE D22_NEWER} 119 | {$DEFINE D23_NEWER} 120 | {$ENDIF} 121 | 122 | {$IFDEF VER290} // Delphi XE8 123 | {$DEFINE D8_NEWER} 124 | {$DEFINE D9_NEWER} 125 | {$DEFINE D10_NEWER} 126 | {$DEFINE D11_NEWER} 127 | {$DEFINE D12_NEWER} 128 | {$DEFINE D14_NEWER} 129 | {$DEFINE D15_NEWER} 130 | {$DEFINE D16_NEWER} 131 | {$DEFINE D17_NEWER} 132 | {$DEFINE D18_NEWER} 133 | {$DEFINE D19_NEWER} 134 | {$DEFINE D20_NEWER} 135 | {$DEFINE D21_NEWER} 136 | {$DEFINE D22_NEWER} 137 | {$ENDIF} 138 | 139 | {$IFDEF VER280} // Delphi XE7 140 | {$DEFINE D8_NEWER} 141 | {$DEFINE D9_NEWER} 142 | {$DEFINE D10_NEWER} 143 | {$DEFINE D11_NEWER} 144 | {$DEFINE D12_NEWER} 145 | {$DEFINE D14_NEWER} 146 | {$DEFINE D15_NEWER} 147 | {$DEFINE D16_NEWER} 148 | {$DEFINE D17_NEWER} 149 | {$DEFINE D18_NEWER} 150 | {$DEFINE D19_NEWER} 151 | {$DEFINE D20_NEWER} 152 | {$DEFINE D21_NEWER} 153 | {$ENDIF} 154 | 155 | {$IFDEF VER270} // Delphi XE6 156 | {$DEFINE D8_NEWER} 157 | {$DEFINE D9_NEWER} 158 | {$DEFINE D10_NEWER} 159 | {$DEFINE D11_NEWER} 160 | {$DEFINE D12_NEWER} 161 | {$DEFINE D14_NEWER} 162 | {$DEFINE D15_NEWER} 163 | {$DEFINE D16_NEWER} 164 | {$DEFINE D17_NEWER} 165 | {$DEFINE D18_NEWER} 166 | {$DEFINE D19_NEWER} 167 | {$DEFINE D20_NEWER} 168 | {$ENDIF} 169 | 170 | {$IFDEF VER260} // Delphi XE5 171 | {$DEFINE D8_NEWER} 172 | {$DEFINE D9_NEWER} 173 | {$DEFINE D10_NEWER} 174 | {$DEFINE D11_NEWER} 175 | {$DEFINE D12_NEWER} 176 | {$DEFINE D14_NEWER} 177 | {$DEFINE D15_NEWER} 178 | {$DEFINE D16_NEWER} 179 | {$DEFINE D17_NEWER} 180 | {$DEFINE D18_NEWER} 181 | {$DEFINE D19_NEWER} 182 | {$ENDIF} 183 | 184 | {$IFDEF VER250} // Delphi XE4 185 | {$DEFINE D8_NEWER} 186 | {$DEFINE D9_NEWER} 187 | {$DEFINE D10_NEWER} 188 | {$DEFINE D11_NEWER} 189 | {$DEFINE D12_NEWER} 190 | {$DEFINE D14_NEWER} 191 | {$DEFINE D15_NEWER} 192 | {$DEFINE D16_NEWER} 193 | {$DEFINE D17_NEWER} 194 | {$DEFINE D18_NEWER} 195 | {$ENDIF} 196 | 197 | {$IFDEF VER240} // Delphi XE3 198 | {$DEFINE D8_NEWER} 199 | {$DEFINE D9_NEWER} 200 | {$DEFINE D10_NEWER} 201 | {$DEFINE D11_NEWER} 202 | {$DEFINE D12_NEWER} 203 | {$DEFINE D14_NEWER} 204 | {$DEFINE D15_NEWER} 205 | {$DEFINE D16_NEWER} 206 | {$DEFINE D17_NEWER} 207 | {$ENDIF} 208 | 209 | {$IFDEF VER230} // Delphi XE2 210 | {$DEFINE D8_NEWER} 211 | {$DEFINE D9_NEWER} 212 | {$DEFINE D10_NEWER} 213 | {$DEFINE D11_NEWER} 214 | {$DEFINE D12_NEWER} 215 | {$DEFINE D14_NEWER} 216 | {$DEFINE D15_NEWER} 217 | {$DEFINE D16_NEWER} 218 | {$ENDIF} 219 | 220 | {$IFDEF VER220} // Delphi XE 221 | {$DEFINE D8_NEWER} 222 | {$DEFINE D9_NEWER} 223 | {$DEFINE D10_NEWER} 224 | {$DEFINE D11_NEWER} 225 | {$DEFINE D12_NEWER} 226 | {$DEFINE D14_NEWER} 227 | {$DEFINE D15_NEWER} 228 | {$ENDIF} 229 | 230 | {$IFDEF VER210} // Delphi 2010 231 | {$DEFINE D8_NEWER} 232 | {$DEFINE D9_NEWER} 233 | {$DEFINE D10_NEWER} 234 | {$DEFINE D11_NEWER} 235 | {$DEFINE D12_NEWER} 236 | {$DEFINE D14_NEWER} 237 | {$ENDIF} 238 | 239 | {$IFDEF VER200} // Delphi 2009 240 | {$DEFINE D8_NEWER} 241 | {$DEFINE D9_NEWER} 242 | {$DEFINE D10_NEWER} 243 | {$DEFINE D11_NEWER} 244 | {$DEFINE D12_NEWER} 245 | {$ENDIF} 246 | 247 | {$IFDEF VER190} // Delphi 2007 .NET 248 | {$DEFINE D8_NEWER} 249 | {$DEFINE D9_NEWER} 250 | {$DEFINE D10_NEWER} 251 | {$DEFINE D11_NEWER} 252 | {$ENDIF} 253 | 254 | {$IFDEF VER185} // Delphi 2007 255 | {$DEFINE D8_NEWER} 256 | {$DEFINE D9_NEWER} 257 | {$DEFINE D10_NEWER} 258 | {$ENDIF} 259 | 260 | {$IFDEF VER180} // Delphi 2006 261 | {$DEFINE D8_NEWER} 262 | {$DEFINE D9_NEWER} 263 | {$DEFINE D10_NEWER} 264 | {$ENDIF} 265 | 266 | {$IFDEF VER170} // Delphi 2005 267 | {$DEFINE D8_NEWER} 268 | {$DEFINE D9_NEWER} 269 | {$ENDIF} 270 | 271 | {$IFDEF VER160} // Delphi 8 272 | {$DEFINE D8_NEWER} 273 | {$ENDIF} 274 | 275 | {$IFDEF D18_NEWER} 276 | {$DEFINE SUPPORTS_INTRINSIC_HELPERS} 277 | {$ENDIF} 278 | 279 | {$IFNDEF D16_NEWER} 280 | {$DEFINE CPUX86} 281 | {$ENDIF} 282 | -------------------------------------------------------------------------------- /Source/HighDPI/CodeCoverage.Images.DM.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.Images.DM; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, 7 | System.ImageList, System.Classes, System.Actions, System.Messaging, 8 | Vcl.ImgList, Vcl.Controls, Vcl.Menus, Vcl.ActnList, Vcl.Graphics, Vcl.VirtualImageList, Vcl.BaseImageCollection, 9 | Vcl.ImageCollection, Vcl.Forms; 10 | 11 | type 12 | TdmCodeCoverageImages = class(TDatamodule) 13 | Images: TVirtualImageList; 14 | MainImageCollection: TImageCollection; 15 | private 16 | FDPIChangedMessageID: Integer; 17 | procedure DPIChangedMessageHandler(const Sender: TObject; const M: System.Messaging.TMessage); 18 | function GetImageArray(const AImageName: string): TGraphicArray; 19 | public 20 | constructor Create(AOwner: TComponent); override; 21 | destructor Destroy; override; 22 | function FindImageIndexByName(const AImageName: string): Integer; 23 | property ImageArray[const AImageName: string]: TGraphicArray read GetImageArray; 24 | end; 25 | 26 | var 27 | dmCodeCoverageImages: TdmCodeCoverageImages; 28 | 29 | implementation 30 | 31 | uses 32 | CodeCoverage.ApiHelper; 33 | 34 | {%CLASSGROUP 'Vcl.Controls.TControl'} 35 | 36 | {$R *.dfm} 37 | 38 | constructor TdmCodeCoverageImages.Create(AOwner: TComponent); 39 | begin 40 | inherited; 41 | FDPIChangedMessageID := TMessageManager.DefaultManager.SubscribeToMessage(TChangeScaleMessage, DPIChangedMessageHandler); 42 | end; 43 | 44 | destructor TdmCodeCoverageImages.Destroy; 45 | begin 46 | TMessageManager.DefaultManager.Unsubscribe(TChangeScaleMessage, FDPIChangedMessageID); 47 | inherited; 48 | end; 49 | 50 | procedure TdmCodeCoverageImages.DPIChangedMessageHandler(const Sender: TObject; const M: System.Messaging.TMessage); 51 | var 52 | size: Integer; 53 | begin 54 | size := NTA.Services.ImageList.Width; 55 | Images.SetSize(size, size); 56 | end; 57 | 58 | function TdmCodeCoverageImages.FindImageIndexByName(const AImageName: string): Integer; 59 | begin 60 | Result := Images.GetIndexByName(AImageName); 61 | end; 62 | 63 | function TdmCodeCoverageImages.GetImageArray(const AImageName: string): TGraphicArray; 64 | var 65 | idx: Integer; 66 | item: TImageCollectionItem; 67 | I: Integer; 68 | begin 69 | idx := MainImageCollection.GetIndexByName(AImageName); 70 | if idx < 0 then 71 | Exit(nil); 72 | item := MainImageCollection.Images[idx]; 73 | SetLength(Result, item.SourceImages.Count); 74 | for I := 0 to item.SourceImages.Count - 1 do 75 | Result[I] := item.SourceImages[I].Image; 76 | end; 77 | 78 | end. 79 | 80 | -------------------------------------------------------------------------------- /Source/LowDPI/CodeCoverage.Images.DM.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.Images.DM; 2 | 3 | interface 4 | 5 | uses 6 | System.ImageList, System.Classes, System.Actions, 7 | Vcl.ImgList, Vcl.Controls, Vcl.Menus, Vcl.ActnList, Vcl.Graphics, 8 | PngImageList; 9 | 10 | type 11 | TdmCodeCoverageImages = class(TDatamodule) 12 | Images: TPngImageList; 13 | public 14 | function FindImageIndexByName(const AImageName: string): Integer; 15 | end; 16 | 17 | var 18 | dmCodeCoverageImages: TdmCodeCoverageImages; 19 | 20 | implementation 21 | 22 | {%CLASSGROUP 'Vcl.Controls.TControl'} 23 | 24 | {$R *.dfm} 25 | 26 | function TdmCodeCoverageImages.FindImageIndexByName(const AImageName: string): Integer; 27 | begin 28 | Result := Images.FindIndexByName(AImageName); 29 | end; 30 | 31 | end. 32 | 33 | -------------------------------------------------------------------------------- /Source/PngComponents/CodeCoverage.PngFunctions.pas: -------------------------------------------------------------------------------- 1 | unit CodeCoverage.PngFunctions; 2 | 3 | interface 4 | 5 | uses 6 | Windows, Graphics, ImgList, Contnrs, pngimage; 7 | 8 | {$IF RTLVersion < 20.0 } 9 | {$IF RTLVersion < 15.0 } 10 | PngComponents are only compatible with Delphi 7 and higher! 11 | {$IFEND} 12 | type 13 | TPngImage = TPNGObject; 14 | {$IFEND} 15 | 16 | type 17 | TPngOption = (pngBlendOnDisabled, pngGrayscaleOnDisabled); 18 | TPngOptions = set of TPngOption; 19 | 20 | procedure MakeDisabledImage(Image: TPngImage; const Options: TPngOptions); 21 | procedure MakeImageBlended(Image: TPngImage; Amount: Byte = 127); 22 | procedure MakeImageGrayscale(Image: TPngImage; Amount: Byte = 255); 23 | procedure DrawPNG(Png: TPngImage; Canvas: TCanvas; const ARect: TRect; const Options: TPngOptions); 24 | procedure ConvertToPNG(Source: TGraphic; Dest: TPngImage); 25 | procedure CreatePNG(Color, Mask: TBitmap; Dest: TPngImage; InverseMask: Boolean = False); 26 | procedure CreatePNGMasked(Bitmap: TBitmap; Mask: TColor; Dest: TPngImage); 27 | procedure SlicePNG(JoinedPNG: TPngImage; Columns, Rows: Integer; out SlicedPNGs: TObjectList); 28 | 29 | implementation 30 | 31 | uses 32 | SysUtils; 33 | 34 | function ColorToTriple(Color: TColor): TRGBTriple; 35 | var 36 | ColorRGB: Longint; 37 | begin 38 | ColorRGB := ColorToRGB(Color); 39 | Result.rgbtBlue := ColorRGB shr 16 and $FF; 40 | Result.rgbtGreen := ColorRGB shr 8 and $FF; 41 | Result.rgbtRed := ColorRGB and $FF; 42 | end; 43 | 44 | procedure MakeImageBlended(Image: TPngImage; Amount: Byte = 127); 45 | 46 | procedure ForceAlphachannel(BitTransparency: Boolean; TransparentColor: TColor); 47 | var 48 | Assigner: TBitmap; 49 | Temp: TPngImage; 50 | X, Y: Integer; 51 | Line: pngimage.PByteArray; 52 | Current: TColor; 53 | begin 54 | //Not all formats of PNG support an alpha-channel (paletted images for example), 55 | //so with this function, I simply recreate the PNG as being 32-bits, effectivly 56 | //forcing an alpha-channel on it. 57 | Temp := TPngImage.Create; 58 | try 59 | Assigner := TBitmap.Create; 60 | try 61 | Assigner.Width := Image.Width; 62 | Assigner.Height := Image.Height; 63 | Temp.Assign(Assigner); 64 | finally 65 | Assigner.Free; 66 | end; 67 | Temp.CreateAlpha; 68 | for Y := 0 to Image.Height - 1 do begin 69 | Line := Temp.AlphaScanline[Y]; 70 | for X := 0 to Image.Width - 1 do begin 71 | Current := Image.Pixels[X, Y]; 72 | Temp.Pixels[X, Y] := Current; 73 | if BitTransparency and (Current = TransparentColor) then 74 | Line[X] := 0 75 | else 76 | Line[X] := Amount; 77 | end; 78 | end; 79 | Image.Assign(Temp); 80 | finally 81 | Temp.Free; 82 | end; 83 | end; 84 | 85 | var 86 | X, Y: Integer; 87 | Line: pngimage.PByteArray; 88 | Forced: Boolean; 89 | TransparentColor: TColor; 90 | BitTransparency: Boolean; 91 | begin 92 | //If the PNG doesn't have an alpha channel, then add one 93 | BitTransparency := Image.TransparencyMode = ptmBit; 94 | TransparentColor := Image.TransparentColor; 95 | Forced := False; 96 | if not (Image.Header.ColorType in [COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA]) then begin 97 | Forced := Image.Header.ColorType in [COLOR_GRAYSCALE, COLOR_PALETTE]; 98 | if Forced then 99 | ForceAlphachannel(BitTransparency, TransparentColor) 100 | else 101 | Image.CreateAlpha; 102 | end; 103 | 104 | //Divide the alpha values by 2 105 | if not Forced and (Image.Header.ColorType in [COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA]) then begin 106 | for Y := 0 to Image.Height - 1 do begin 107 | Line := Image.AlphaScanline[Y]; 108 | for X := 0 to Image.Width - 1 do begin 109 | if BitTransparency and (Image.Pixels[X, Y] = TransparentColor) then 110 | Line[X] := 0 111 | else 112 | Line[X] := Round(Line[X] / 256 * (Amount + 1)); 113 | end; 114 | end; 115 | end; 116 | end; 117 | 118 | procedure MakeImageGrayscale(Image: TPngImage; Amount: Byte = 255); 119 | 120 | procedure GrayscaleRGB(var R, G, B: Byte); 121 | { Performance optimized version without floating point operations by Christian Budde } 122 | var 123 | X: Byte; 124 | begin 125 | X := (R * 77 + G * 150 + B * 29) shr 8; 126 | R := ((R * (255 - Amount)) + (X * Amount) + 128) shr 8; 127 | G := ((G * (255 - Amount)) + (X * Amount) + 128) shr 8; 128 | B := ((B * (255 - Amount)) + (X * Amount) + 128) shr 8; 129 | (* original code 130 | X := Round(R * 0.30 + G * 0.59 + B * 0.11); 131 | R := Round(R / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1)); 132 | G := Round(G / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1)); 133 | B := Round(B / 256 * (256 - Amount - 1)) + Round(X / 256 * (Amount + 1)); 134 | *) 135 | end; 136 | 137 | var 138 | X, Y, PalCount: Integer; 139 | Line: PRGBLine; 140 | PaletteHandle: HPalette; 141 | Palette: array[Byte] of TPaletteEntry; 142 | begin 143 | //Don't do anything if the image is already a grayscaled one 144 | if not (Image.Header.ColorType in [COLOR_GRAYSCALE, COLOR_GRAYSCALEALPHA]) then begin 145 | if Image.Header.ColorType = COLOR_PALETTE then begin 146 | //Grayscale every palette entry 147 | PaletteHandle := Image.Palette; 148 | PalCount := GetPaletteEntries(PaletteHandle, 0, 256, Palette); 149 | for X := 0 to PalCount - 1 do 150 | GrayscaleRGB(Palette[X].peRed, Palette[X].peGreen, Palette[X].peBlue); 151 | SetPaletteEntries(PaletteHandle, 0, PalCount, Palette); 152 | Image.Palette := PaletteHandle; 153 | end 154 | else begin 155 | //Grayscale every pixel 156 | for Y := 0 to Image.Height - 1 do begin 157 | Line := Image.Scanline[Y]; 158 | for X := 0 to Image.Width - 1 do 159 | GrayscaleRGB(Line[X].rgbtRed, Line[X].rgbtGreen, Line[X].rgbtBlue); 160 | end; 161 | end; 162 | end; 163 | end; 164 | 165 | procedure DrawPNG(Png: TPngImage; Canvas: TCanvas; const ARect: TRect; const Options: TPngOptions); 166 | var 167 | PngCopy: TPngImage; 168 | begin 169 | if Options <> [] then begin 170 | PngCopy := TPngImage.Create; 171 | try 172 | PngCopy.Assign(Png); 173 | if pngBlendOnDisabled in Options then 174 | MakeImageBlended(PngCopy); 175 | if pngGrayscaleOnDisabled in Options then 176 | MakeImageGrayscale(PngCopy); 177 | PngCopy.Draw(Canvas, ARect); 178 | finally 179 | PngCopy.Free; 180 | end; 181 | end 182 | else begin 183 | Png.Draw(Canvas, ARect); 184 | end; 185 | end; 186 | 187 | procedure ConvertToPNG(Source: TGraphic; Dest: TPngImage); 188 | type 189 | TRGBALine = array[Word] of TRGBQuad; 190 | PRGBALine = ^TRGBALine; 191 | var 192 | MaskLines: array of pngimage.PByteArray; 193 | 194 | function ColorToTriple(const Color: TColor): TRGBTriple; 195 | begin 196 | Result.rgbtBlue := Color shr 16 and $FF; 197 | Result.rgbtGreen := Color shr 8 and $FF; 198 | Result.rgbtRed := Color and $FF; 199 | end; 200 | 201 | procedure GetAlphaMask(SourceColor: TBitmap); 202 | type 203 | TBitmapInfoV4 = packed record 204 | bmiHeader: TBitmapV4Header; //Otherwise I may not get per-pixel alpha values. 205 | bmiColors: array[0..2] of TRGBQuad; // reserve space for color lookup table 206 | end; 207 | var 208 | Bits: PRGBALine; 209 | { The BitmapInfo parameter to GetDIBits is delared as var parameter. So instead of casting around, we simply use 210 | the absolute directive to refer to the same memory area. } 211 | BitmapInfo: TBitmapInfoV4; 212 | BitmapInfoFake: TBitmapInfo absolute BitmapInfo; 213 | I, X, Y: Integer; 214 | HasAlpha: Boolean; 215 | BitsSize: Integer; 216 | bmpDC: HDC; 217 | bmpHandle: HBITMAP; 218 | begin 219 | BitsSize := 4 * SourceColor.Width * SourceColor.Height; 220 | Bits := AllocMem(BitsSize); 221 | try 222 | FillChar(BitmapInfo, SizeOf(BitmapInfo), 0); 223 | BitmapInfo.bmiHeader.bV4Size := SizeOf(BitmapInfo.bmiHeader); 224 | BitmapInfo.bmiHeader.bV4Width := SourceColor.Width; 225 | BitmapInfo.bmiHeader.bV4Height := -SourceColor.Height; //Otherwise the image is upside down. 226 | BitmapInfo.bmiHeader.bV4Planes := 1; 227 | BitmapInfo.bmiHeader.bV4BitCount := 32; 228 | BitmapInfo.bmiHeader.bV4V4Compression := BI_BITFIELDS; 229 | BitmapInfo.bmiHeader.bV4SizeImage := BitsSize; 230 | BitmapInfo.bmiColors[0].rgbRed := 255; 231 | BitmapInfo.bmiColors[1].rgbGreen := 255; 232 | BitmapInfo.bmiColors[2].rgbBlue := 255; 233 | 234 | { Getting the bitmap Handle will invalidate the Canvas.Handle, so it is important to retrieve them in the correct 235 | order. As parameter evaluation order is undefined and differs between Win32 and Win64, we get invalid values 236 | for Canvas.Handle when we use those properties directly in the call to GetDIBits. } 237 | bmpHandle := SourceColor.Handle; 238 | bmpDC := SourceColor.Canvas.Handle; 239 | if GetDIBits(bmpDC, bmpHandle, 0, SourceColor.Height, Bits, BitmapInfoFake, DIB_RGB_COLORS) > 0 then begin 240 | //Because Win32 API is a piece of crap when it comes to icons, I have to check 241 | //whether an has an alpha-channel the hard way. 242 | HasAlpha := False; 243 | for I := 0 to (SourceColor.Height * SourceColor.Width) - 1 do begin 244 | if Bits[I].rgbReserved <> 0 then begin 245 | HasAlpha := True; 246 | Break; 247 | end; 248 | end; 249 | if HasAlpha then begin 250 | //OK, so not all alpha-values are 0, which indicates the existence of an 251 | //alpha-channel. 252 | I := 0; 253 | for Y := 0 to SourceColor.Height - 1 do 254 | for X := 0 to SourceColor.Width - 1 do begin 255 | MaskLines[Y][X] := Bits[I].rgbReserved; 256 | Inc(I); 257 | end; 258 | end; 259 | end; 260 | finally 261 | FreeMem(Bits, BitsSize); 262 | end; 263 | end; 264 | 265 | function WinXPOrHigher: Boolean; 266 | var 267 | Info: TOSVersionInfo; 268 | begin 269 | Info.dwOSVersionInfoSize := SizeOf(Info); 270 | GetVersionEx(Info); 271 | Result := (Info.dwPlatformId = VER_PLATFORM_WIN32_NT) and 272 | ((Info.dwMajorVersion > 5) or 273 | ((Info.dwMajorVersion = 5) and (Info.dwMinorVersion >= 1))); 274 | end; 275 | 276 | var 277 | Temp, SourceColor, SourceMask: TBitmap; 278 | X, Y: Integer; 279 | Line: PRGBLine; 280 | MaskLine, AlphaLine: pngimage.PByteArray; 281 | TransparentColor, CurrentColor: TColor; 282 | IconInfo: TIconInfo; 283 | AlphaNeeded: Boolean; 284 | begin 285 | Assert(Dest <> nil, 'Dest is nil!'); 286 | //A PNG does not have to be converted 287 | if Source is TPngImage then begin 288 | Dest.Assign(Source); 289 | Exit; 290 | end; 291 | 292 | AlphaNeeded := False; 293 | Temp := TBitmap.Create; 294 | SetLength(MaskLines, Source.Height); 295 | for Y := 0 to Source.Height - 1 do begin 296 | MaskLines[Y] := AllocMem(Source.Width); 297 | FillMemory(MaskLines[Y], Source.Width, 255); 298 | end; 299 | try 300 | //Initialize intermediate color bitmap 301 | Temp.Width := Source.Width; 302 | Temp.Height := Source.Height; 303 | Temp.PixelFormat := pf24bit; 304 | 305 | //Now figure out the transparency 306 | if Source is TBitmap then begin 307 | if Source.Transparent then begin 308 | //TBitmap is just about comparing the drawn colors against the TransparentColor 309 | if TBitmap(Source).TransparentMode = tmFixed then 310 | TransparentColor := TBitmap(Source).TransparentColor 311 | else 312 | TransparentColor := TBitmap(Source).Canvas.Pixels[0, Source.Height - 1]; 313 | 314 | for Y := 0 to Temp.Height - 1 do begin 315 | Line := Temp.ScanLine[Y]; 316 | MaskLine := MaskLines[Y]; 317 | for X := 0 to Temp.Width - 1 do begin 318 | CurrentColor := GetPixel(TBitmap(Source).Canvas.Handle, X, Y); 319 | if CurrentColor = TransparentColor then begin 320 | MaskLine^[X] := 0; 321 | AlphaNeeded := True; 322 | end; 323 | Line[X] := ColorToTriple(CurrentColor); 324 | end; 325 | end; 326 | end 327 | else begin 328 | Temp.Canvas.Draw(0, 0, Source); 329 | end; 330 | end 331 | else if Source is TIcon then begin 332 | //TIcon is more complicated, because there are bitmasked (classic) icons and 333 | //alphablended (modern) icons. Not to forget about the "inverse" color. 334 | GetIconInfo(TIcon(Source).Handle, IconInfo); 335 | SourceColor := TBitmap.Create; 336 | SourceMask := TBitmap.Create; 337 | try 338 | SourceColor.Handle := IconInfo.hbmColor; 339 | SourceMask.Handle := IconInfo.hbmMask; 340 | Temp.Canvas.Draw(0, 0, SourceColor); 341 | for Y := 0 to Temp.Height - 1 do begin 342 | MaskLine := MaskLines[Y]; 343 | for X := 0 to Temp.Width - 1 do begin 344 | if GetPixel(SourceMask.Canvas.Handle, X, Y) <> 0 then begin 345 | MaskLine^[X] := 0; 346 | AlphaNeeded := True; 347 | end; 348 | end; 349 | end; 350 | if (GetDeviceCaps(SourceColor.Canvas.Handle, BITSPIXEL) = 32) and WinXPOrHigher then begin 351 | //This doesn't neccesarily mean we actually have 32bpp in the icon, because the 352 | //bpp of an icon is always the same as the display settings, regardless of the 353 | //actual color depth of the icon :( 354 | AlphaNeeded := True; 355 | GetAlphaMask(SourceColor); 356 | end; 357 | //This still doesn't work for alphablended icons... 358 | finally 359 | SourceColor.Free; 360 | SourceMask.Free 361 | end; 362 | end; 363 | 364 | //And finally, assign the destination PNG image 365 | Dest.Assign(Temp); 366 | if AlphaNeeded then begin 367 | Dest.CreateAlpha; 368 | for Y := 0 to Dest.Height - 1 do begin 369 | AlphaLine := Dest.AlphaScanline[Y]; 370 | CopyMemory(AlphaLine, MaskLines[Y], Temp.Width); 371 | end; 372 | end; 373 | 374 | finally 375 | for Y := 0 to Source.Height - 1 do 376 | FreeMem(MaskLines[Y], Source.Width); 377 | Temp.Free; 378 | end; 379 | end; 380 | 381 | procedure CreatePNG(Color, Mask: TBitmap; Dest: TPngImage; InverseMask: Boolean = False); 382 | var 383 | Temp: TBitmap; 384 | Line: pngimage.PByteArray; 385 | X, Y: Integer; 386 | begin 387 | Assert(Dest <> nil, 'Dest is nil!'); 388 | //Create a PNG from two separate color and mask bitmaps. InverseMask should be 389 | //True if white means transparent, and black means opaque. 390 | if not (Color.PixelFormat in [pf24bit, pf32bit]) then begin 391 | Temp := TBitmap.Create; 392 | try 393 | Temp.Assign(Color); 394 | Temp.PixelFormat := pf24bit; 395 | Dest.Assign(Temp); 396 | finally 397 | Temp.Free; 398 | end; 399 | end 400 | else begin 401 | Dest.Assign(Color); 402 | end; 403 | 404 | //Copy the alpha channel. 405 | Dest.CreateAlpha; 406 | for Y := 0 to Dest.Height - 1 do begin 407 | Line := Dest.AlphaScanline[Y]; 408 | for X := 0 to Dest.Width - 1 do begin 409 | if InverseMask then 410 | Line[X] := 255 - (GetPixel(Mask.Canvas.Handle, X, Y) and $FF) 411 | else 412 | Line[X] := GetPixel(Mask.Canvas.Handle, X, Y) and $FF; 413 | end; 414 | end; 415 | end; 416 | 417 | procedure CreatePNGMasked(Bitmap: TBitmap; Mask: TColor; Dest: TPngImage); 418 | var 419 | Temp: TBitmap; 420 | Line: pngimage.PByteArray; 421 | X, Y: Integer; 422 | begin 423 | Assert(Dest <> nil, 'Dest is nil!'); 424 | //Create a PNG from two separate color and mask bitmaps. InverseMask should be 425 | //True if white means transparent, and black means opaque. 426 | if not (Bitmap.PixelFormat in [pf24bit, pf32bit]) then begin 427 | Temp := TBitmap.Create; 428 | try 429 | Temp.Assign(Bitmap); 430 | Temp.PixelFormat := pf24bit; 431 | Dest.Assign(Temp); 432 | finally 433 | Temp.Free; 434 | end; 435 | end 436 | else begin 437 | Dest.Assign(Bitmap); 438 | end; 439 | 440 | //Copy the alpha channel. 441 | Dest.CreateAlpha; 442 | for Y := 0 to Dest.Height - 1 do begin 443 | Line := Dest.AlphaScanline[Y]; 444 | for X := 0 to Dest.Width - 1 do 445 | Line[X] := Integer(TColor(GetPixel(Bitmap.Canvas.Handle, X, Y)) <> Mask) * $FF; 446 | end; 447 | end; 448 | 449 | procedure SlicePNG(JoinedPNG: TPngImage; Columns, Rows: Integer; out SlicedPNGs: TObjectList); 450 | var 451 | X, Y, ImageX, ImageY, OffsetX, OffsetY: Integer; 452 | Width, Height: Integer; 453 | Bitmap: TBitmap; 454 | BitmapLine: PRGBLine; 455 | AlphaLineA, AlphaLineB: pngimage.PByteArray; 456 | PNG: TPngImage; 457 | begin 458 | //This function slices a large PNG file (e.g. an image with all images for a 459 | //toolbar) into smaller, equally-sized pictures. 460 | SlicedPNGs := TObjectList.Create(False); 461 | Width := JoinedPNG.Width div Columns; 462 | Height := JoinedPNG.Height div Rows; 463 | 464 | //Loop through the columns and rows to create each individual image 465 | for ImageY := 0 to Rows - 1 do begin 466 | for ImageX := 0 to Columns - 1 do begin 467 | OffsetX := ImageX * Width; 468 | OffsetY := ImageY * Height; 469 | Bitmap := TBitmap.Create; 470 | try 471 | Bitmap.Width := Width; 472 | Bitmap.Height := Height; 473 | Bitmap.PixelFormat := pf24bit; 474 | 475 | //Copy the color information into a temporary bitmap. We can't use TPngImage.Draw 476 | //here, because that would combine the color and alpha values. 477 | for Y := 0 to Bitmap.Height - 1 do begin 478 | BitmapLine := Bitmap.Scanline[Y]; 479 | for X := 0 to Bitmap.Width - 1 do 480 | BitmapLine[X] := ColorToTriple(JoinedPNG.Pixels[X + OffsetX, Y + OffsetY]); 481 | end; 482 | 483 | PNG := TPngImage.Create; 484 | PNG.Assign(Bitmap); 485 | 486 | if JoinedPNG.Header.ColorType in [COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA] then begin 487 | //Copy the alpha channel 488 | PNG.CreateAlpha; 489 | for Y := 0 to PNG.Height - 1 do begin 490 | AlphaLineA := JoinedPNG.AlphaScanline[Y + OffsetY]; 491 | AlphaLineB := PNG.AlphaScanline[Y]; 492 | for X := 0 to PNG.Width - 1 do 493 | AlphaLineB[X] := AlphaLineA[X + OffsetX]; 494 | end; 495 | end; 496 | 497 | SlicedPNGs.Add(PNG); 498 | finally 499 | Bitmap.Free; 500 | end; 501 | end; 502 | end; 503 | end; 504 | 505 | procedure MakeDisabledImage(Image: TPngImage; const Options: TPngOptions); 506 | begin 507 | if pngBlendOnDisabled in Options then 508 | MakeImageBlended(Image); 509 | if pngGrayscaleOnDisabled in Options then 510 | MakeImageGrayscale(Image); 511 | end; 512 | 513 | {$IF RTLVersion >= 20.0 } 514 | {$IFDEF RegisterOldPngFormat} 515 | type 516 | TPNGObject = class(TPngImage); 517 | initialization 518 | TPicture.RegisterFileFormat('', '', TPNGObject); 519 | finalization 520 | TPicture.UnregisterGraphicClass(TPNGObject); 521 | {$IFEND} 522 | {$IFEND} 523 | end. 524 | -------------------------------------------------------------------------------- /Source/TestProject.dpr: -------------------------------------------------------------------------------- 1 | program TestProject; 2 | 3 | {$IFNDEF TESTINSIGHT} 4 | {$APPTYPE CONSOLE} 5 | {$ENDIF}{$STRONGLINKTYPES ON} 6 | uses 7 | System.SysUtils, 8 | {$IFDEF TESTINSIGHT} 9 | TestInsight.DUnitX, 10 | {$ENDIF } 11 | DUnitX.Loggers.Console, 12 | DUnitX.Loggers.Xml.NUnit, 13 | DUnitX.TestFramework, 14 | TestUnit1 in 'TestUnit1.pas', 15 | TestedUnit1 in 'TestedUnit1.pas'; 16 | 17 | var 18 | runner : ITestRunner; 19 | results : IRunResults; 20 | logger : ITestLogger; 21 | nunitLogger : ITestLogger; 22 | begin 23 | {$IFDEF TESTINSIGHT} 24 | TestInsight.DUnitX.RunRegisteredTests; 25 | exit; 26 | {$ENDIF} 27 | try 28 | //Check command line options, will exit if invalid 29 | TDUnitX.CheckCommandLine; 30 | //Create the test runner 31 | runner := TDUnitX.CreateRunner; 32 | //Tell the runner to use RTTI to find Fixtures 33 | runner.UseRTTI := True; 34 | //tell the runner how we will log things 35 | //Log to the console window 36 | logger := TDUnitXConsoleLogger.Create(true); 37 | runner.AddLogger(logger); 38 | //Generate an NUnit compatible XML File 39 | nunitLogger := TDUnitXXMLNUnitFileLogger.Create(TDUnitX.Options.XMLOutputFile); 40 | runner.AddLogger(nunitLogger); 41 | runner.FailsOnNoAsserts := False; //When true, Assertions must be made during tests; 42 | 43 | //Run tests 44 | results := runner.Execute; 45 | if not results.AllPassed then 46 | System.ExitCode := EXIT_ERRORS; 47 | 48 | {$IFNDEF CI} 49 | //We don't want this happening when running under CI. 50 | if TDUnitX.Options.ExitBehavior = TDUnitXExitBehavior.Pause then 51 | begin 52 | System.Write('Done.. press key to quit.'); 53 | System.Readln; 54 | end; 55 | {$ENDIF} 56 | except 57 | on E: Exception do 58 | System.Writeln(E.ClassName, ': ', E.Message); 59 | end; 60 | end. 61 | -------------------------------------------------------------------------------- /Source/TestUnit1.pas: -------------------------------------------------------------------------------- 1 | unit TestUnit1; 2 | 3 | interface 4 | uses 5 | DUnitX.TestFramework, TestedUnit1; 6 | 7 | type 8 | 9 | [TestFixture] 10 | TMyTestObject = class(TObject) 11 | private 12 | FInstance: TTestedClass; 13 | public 14 | [Setup] 15 | procedure Setup; 16 | [TearDown] 17 | procedure TearDown; 18 | [Test] 19 | [TestCase('Test1', '2,1,1')] 20 | // [TestCase('Test2', '1,2,1')] 21 | // [TestCase('Test3', '-2,1,1')] 22 | // [TestCase('Test4', '1,-2,1')] 23 | procedure TestMethod1(A, B, C: Integer); 24 | [Test] 25 | [TestCase('Test1a', '2,1,1')] 26 | // [TestCase('Test2a', '1,2,1')] 27 | // [TestCase('Test3a', '-2,1,1')] 28 | // [TestCase('Test4a', '1,-2,1')] 29 | procedure TestMethod2(A, B, C: Integer); 30 | end; 31 | 32 | implementation 33 | 34 | procedure TMyTestObject.Setup; 35 | begin 36 | FInstance := TTestedClass.Create; 37 | end; 38 | 39 | procedure TMyTestObject.TearDown; 40 | begin 41 | FInstance.Free; 42 | FInstance := nil; 43 | end; 44 | 45 | 46 | procedure TMyTestObject.TestMethod1(A, B, C: Integer); 47 | var 48 | res: Integer; 49 | begin 50 | FInstance.TestedMethod1(A, B, res); 51 | Assert.AreEqual(C, res); 52 | end; 53 | 54 | procedure TMyTestObject.TestMethod2(A, B, C: Integer); 55 | var 56 | res: Integer; 57 | begin 58 | FInstance.TestedMethod2(A, B, res); 59 | Assert.AreEqual(C, res); 60 | end; 61 | 62 | initialization 63 | TDUnitX.RegisterTestFixture(TMyTestObject); 64 | end. 65 | -------------------------------------------------------------------------------- /Source/TestedUnit1.pas: -------------------------------------------------------------------------------- 1 | unit TestedUnit1; 2 | 3 | interface 4 | 5 | type 6 | TTestedClass = class 7 | public 8 | procedure TestedMethod1(A, B: Integer; out C: Integer); 9 | procedure TestedMethod2(A, B: Integer; out C: Integer); 10 | end; 11 | 12 | implementation 13 | 14 | procedure TTestedClass.TestedMethod1(A, B: Integer; out C: Integer); 15 | begin 16 | if A < 0 then begin 17 | A := -A; 18 | end; 19 | 20 | if B < 0 then 21 | begin 22 | B := -B; 23 | end; 24 | 25 | if B < A then begin 26 | C := A - B; 27 | end 28 | else begin 29 | C := B - A; 30 | end; 31 | end; 32 | 33 | procedure TTestedClass.TestedMethod2(A, B: Integer; out C: Integer); 34 | begin 35 | if A < 0 then begin 36 | A := -A; 37 | end; 38 | 39 | if B < 0 then 40 | begin 41 | B := -B; 42 | end; 43 | 44 | if B < A then begin 45 | C := A - B; 46 | end 47 | else begin 48 | C := B - A; 49 | end; 50 | end; 51 | 52 | end. 53 | --------------------------------------------------------------------------------