diff --git a/Docs/Design/FileFormats/vaults/native.html b/Docs/Design/FileFormats/vaults/native.html new file mode 100644 index 000000000..879242ca2 --- /dev/null +++ b/Docs/Design/FileFormats/vaults/native.html @@ -0,0 +1,928 @@ + + + + + + + + CodeSnip File Format Documentation - Native Vault Format + + + + + + + + +
+
+ DelphiDabbler CodeSnip +
+
+ File Format Documentation +
+
+ +

+ Native Vault Format +

+ +
+ +

+ Contents +

+ + + +
+ +
+ +

+ Introduction +

+ +

+ This file format is the default vault data format used by CodeSnip Vault. +

+ +

+ The format comprises a single XML file along with a number of data files located in the same directory. Each user can have zero or more snippet vaults that use this format. +

+ +

+ The XML file is named vault.xml. It contains all the information about about the vault, except for the source code of each snippet. +

+ +

+ Snippet source code is stored in separate data files – one per snippet. Each source code file is referenced by the XML file. +

+ +

+ The format allows for later revisions. Files are versioned and comply with the principles of Semantic Versioning. Details of all the changes between versions are listed in the Change Log at the end of this document. +

+ +
+ +
+ +

+ Encoding +

+ +

+ All files are text files that use UTF-8 encoding, without any UTF-8 preamble (BOM). The XML processing instruction of vault.xml has its encoding atrribute set to UTF-8. +

+ +
+ +
+ +

+ File Format +

+ +

+ XML File +

+ +

+ The following information applies to file format v1.0. +

+ +
+
+ XML processing instruction +
+
+

+ Attributes: +

+

+
+ version +
+
+ Always set to 1.0. +
+
+ encoding +
+
+ Character encoding used for file. Always set to UTF-8. +
+
+
+ +
+ vault +
+
+

+ Parent node that contains all the vault data. +

+

+ Attributes: +

+
+
+ watermark +
+
+ Identifies the file as the correct type. It is always set to 882BAD68-8C3E-44E3-BBF4-17E55143DAF8, regardless of the file version. +
+
+ version-major +
+
+ Identifies the major version of the file format. Must be 1. +
+
+ version-minor +
+
+ Identifies the minor version of the file format. Must be 0. +
+
+
+ +
+ vault/categories +
+
+

+ Contains a list of all categories used by the vault. +

+
+ +
+ vault/categories/category +
+
+

+ Contains information about a single category. There is one node per category. +

+

+ Attributes: +

+
+
+ id +
+
+ Unique id of the category. +
+
+
+ +
+ vault/categories/category/description +
+
+

+ Description of the category. +

+
+ +
+ vault/categories/category/snippet-keys +
+
+

+ Contains list of the unique keys of all snippets in this category. May be omitted if there are no snippets in the category. +

+
+ +
+ vault/categories/category/snippet-keys/key +
+
+

+ Contains the key of a snippet in the category. There is one node for each snippet in the category. +

+

+ The value must be: +

+
    +
  • unique withing the vault
  • +
  • a valid Unicode Pascal identifier
  • +
+
+ +
+ vault/snippets +
+
+

+ Contains defintiions of all snippets in the vault. +

+
+ +
+ vault/snippets/snippet +
+
+

+ Contains information about a snippet. There is one node per snippet. +

+

+ Attributes: +

+
+
+ key +
+
+

+ The snippet key. +

+

+ The value must be: +

+
    +
  • unique withing the vault
  • +
  • a valid Unicode Pascal identifier
  • +
+
+
+ category +
+
+

+ The unique id of the category to which the snippet belongs. +

+

+ The value must correspond to the id attribute of one of the vault/categories/category nodes. +

+
+
+ kind +
+
+

+ The type of snippet. +

+

+ Valid values are: +

+
    +
  • freeform
  • +
  • routine
  • +
  • type
  • +
  • const
  • +
  • class
  • +
  • unit
  • +
+

+ The values are not case sensitive. +

+

+ If vault/snippets/snippet/source-code/language has any value other than Pascal then this attribute must have value freeform. +

+
+
+
+ +
+ vault/snippets/snippet/display-name +
+
+

+ The snippet's display name. +

+
+ +
+ vault/snippets/snippet/description +
+
+

+ Description of the snippet. +

+

+ Content must be valid REML markup. REML v6 is supported. +

+

+ This node may be omitted if there is no description. +

+
+ +
+ vault/snippets/snippet/notes +
+
+

+ Additional information about the snippet. +

+

+ Content must be valid REML markup. REML v6 is supported. +

+

+ This node may be omitted if there are no notes. +

+
+ +
+ vault/snippets/snippet/source-code +
+
+

+ Contains information about a snippet's source code. +

+

+ Attributes: +

+
+
+ file-name +
+
+

+ Name of the file containing the snippet's source code. +

+

+ The named file must exist in the same directory as this XML file. +

+
+
+ language +
+
+

+ Identifies the programming language, if any, used by the source code. +

+

+ Valid values are: +

+
    +
  • + text – the snippet is plain text, not source code. +
  • +
  • + unknown – the snippet's source code language is unknown to CodeSnip. +
  • +
  • + pascal – the snippet's source code is written in Object Pascal. +
  • +
+
+
+
+ +
+ vault/snippets/snippet/compile-results +
+
+

+ Contains a list of compile results for the snippet. +

+

+ This node has no meaning and must be omitted if either of the following two conditions apply: +

+
    +
  1. + The source code language is not pascal. +
  2. +
  3. + The snippet kind is freeform. +
  4. +
+
+ +
+ vault/snippets/snippet/compile-results/compiler + +
+
+

+ The compile result for a given compiler. There is an entry for each known compiler. +

+

+ Attributes: +

+
+
+ id +
+
+

+ Identifies the compiler. Valid identifiers are are one of: +

+
    +
  • + d2 – Delphi 2 compiler +
  • +
  • + d3 – Delphi 3 compiler +
  • +
  • + d4 – Delphi 4 compiler +
  • +
  • + d5 – Delphi 5 compiler +
  • +
  • + d6 – Delphi 6 compiler +
  • +
  • + d7 – Delphi 7 compiler +
  • +
  • + d2005 – Delphi 2005 compiler +
  • +
  • + d2006 – Delphi 2006 compiler +
  • +
  • + d2007 – Delphi 2007 compiler +
  • +
  • + d2009 – Delphi 2009 compiler +
  • +
  • + d2010 – Delphi 2010 compiler +
  • +
  • + dXE – Delphi XE compiler +
  • +
  • + dxe2 – Delphi XE2 compiler +
  • +
  • + dxe3 – Delphi XE3 compiler +
  • +
  • + dxe4 – Delphi XE4 compiler +
  • +
  • + dxe5 – Delphi XE5 compiler +
  • +
  • + dxe6 – Delphi XE6 compiler +
  • +
  • + dxe7 – Delphi XE7 compiler +
  • +
  • + dxe8 – Delphi XE8 compiler +
  • +
  • + d10.0 – Delphi 10 Seattle compiler +
  • +
  • + d10.1 – Delphi 10.1 Berlin compiler +
  • +
  • + d10.2 – Delphi 10.2 Tokyo compiler +
  • +
  • + d10.3 – Delphi 10.3 Rio compiler +
  • +
  • + d10.4 – Delphi 10.4 Sydney compiler +
  • +
  • + d11 – Delphi 11.x Alexandria compiler +
  • +
  • + d12 – Delphi 12 Athens compiler +
  • +
  • + fpc – Free Pascal compiler +
  • +
+

+ The values are not case sensitive. +

+
+
+ result +
+
+

+ The compile result for the compiler. Valid values are: +

+
    +
  • + y – Compiles with the identified compiler. +
  • +
  • + n – Does not compile with the identified compiler. +
  • +
  • + q – Compile result for this compiler is not known. +
  • +
+

+ The values are not case sensitive. +

+
+
+

+ There is no text content. +

+

+ Omitting a node for any compiler is permitted and is equivalent to specifying q. +

+
+ +
+ vault/snippets/snippet/tests +
+
+

+ Provides information about the level of testing applied to this snippet. +

+

+ Attributes: +

+
+
+ level +
+
+

+ The level of testing achieved. Valid values are: +

+
    +
  • + none – the snippet has not been tested. +
  • +
  • + basic – the snippet has passed some simple, unspecified testing. +
  • +
  • + advanced – the snippet has passed more advanced, but unspecified testing. +
  • +
  • + unit-tests – the snippet has passed unit tests. +
  • +
  • + demo-code – there exists demo code that exercises the snippet. +
  • +
+
+
+ url +
+
+

+ The URL of any unit tests or demo code. +

+

+ This attribute must only be provided when the level attribute has value unit-tests or demo-code. +

+
+
+

+ There is no text content. +

+

+ This node may be omitted if the unit has not been tested. In this case a testing level of none will be assumed. +

+
+ +
+ vault/snippets/snippet/required-units +
+
+

+ List of units required to compile the snippet. +

+

+ The node may be omitted if there are no required units. +

+

+ If vault/snippets/snippet/source-code/language has any value other than Pascal then this node has no meaning and must be omitted. +

+ +
+ +
+ vault/snippets/snippet/required-units/unit +
+
+

+ Name of a unit within the required units list. +

+

+ Must be a valid Pascal identifier. +

+
+ +
+ vault/snippets/snippet/required-snippets +
+
+

+ List of snippets that are required to compile the snippet. +

+

+ The node may be omitted if there are no required snippets. +

+

+ If vault/snippets/snippet/source-code/language has any value other than Pascal then this node has no meaning and must be omitted. +

+
+ +
+ vault/snippets/snippet/required-snippets/key +
+
+

+ Key of a snippet within the required snippets list. +

+
+ +
+ vault/snippets/snippet/xrefs +
+
+

+ List of cross-referenced snippets. +

+

+ The node may be omitted if there are no cross referenced snippets. +

+
+ +
+ vault/snippets/snippet/xrefs/key +
+
+

+ Key of a snippet within the cross-references list. +

+
+ +
+ vault/license +
+
+

+ Contains license information for the vault. +

+

+ Attributes: +

+
+
+ spdx +
+
+

+ The license's SPDX identifier. +

+

+ If the license has a SPDX identifier the attribute's value must be a valid SPDX identifier from the SPDX License List. +

+

+ If the license has no associated SPDX identifier then this attribute may be either omitted or have an empty value. +

+
+
+ name +
+
+

+ The name of the license. +

+

+ If the spdx attribute refers to a valid SPDX identifier then this attribute should, but is not required to, contain the name of the matching license per the SPDX License List. +

+ If no license name is provided then this attribute may be either omitted or have an empty value. +

+
+
+ url +
+
+

+ The URL of the full license text. +

+

+ If a URL is provided then the linked license should, but is not required to, have the same text as any license text in the file referenced by the license-file-name attribute. +

+

+ If no license URL is provided then this attribute may be either omitted or have an empty value. +

+
+
+ license-file-name +
+
+

+ The name of a file containing the full license text. +

+

+ If a file name is provided then it must refer to an existing, non-empty, file in the same folder as the XML file. +

+

+ If no such license files exists then this attribute may be either omitted or have an empty value. +

+
+
+

+ This node has no text content. +

+

+ The node may be omitted if there are no values for any attributes. A missing node is taken to mean that there is no license information. +

+
+ +
+ vault/copyright +
+
+

+ Contains information about the copyright that applies to the vault. +

+

+ Attributes: +

+
+
+ date +
+
+

+ The date of the copyright. +

+

+ The copyright date may be either a year (e.g. 2024) or a range of years (e.g. 2009-2021). +

+

+ If no copyright date is provided then this attribute may be either omitted or have an empty value. +

+
+
+ holder +
+
+

+ The name(s) of the copyright holder(s). +

+

+ If there are numerous contributors to the vault, who each have a claim on copyright, they must be listed under the vault/copyright/contributors node and this attribute's value should refer to the fact, e.g. Alice Jones & contributors or simply Contributors. +

+

+ If no copyright holder is provided then this attribute may be either omitted or have an empty value. +

+
+
+ holder-url +
+
+

+ A URL where additional copyright information can be found. +

+

+ If there is no such URL then this attribute may be either omitted or have an empty value. +

+
+

+ The node may be omitted if there are no values for any attributes the vault/copyright/contributors is not present. A missing node is taken to mean that there is no copyright information. +

+
+
+ +
+ vault/copyright/contributors +
+
+

+ Contains a list of contributors to the project who have a claim on copyright. +

+

+ The node may be omitted if there are no contributors. +

+
+ +
+ vault/copyright/contributors/name +
+
+

+ The name of a contributor. One node per contributor. +

+
+ +
+ vault/acknowledgements +
+
+

+ Contains a list of names of people who have contributed in some way the the project. +

+

+ The node may be omitted if no people are acknowledged. +

+
+ +
+ vault/acknowledgements/name +
+
+

+ Name being acknowledged. One node per name in the list. +

+
+ +
+ +

+ Source Code Files +

+ +

+ Source code is stored separately from the main XML file. The source code of each snippet has its own file. File names relate to the relevant snippet's key and have extension .source. +

+ +

+ Source code files are referenced by the file-name attribute of a snippet's vault/snippets/snippet/source-code node in the XML file. +

+ +

+ License File +

+ +

+ Any license text is stored in separately from the main XML file. +

+ +

+ This file may not be present if there is no license text specified. +

+ +

+ The file is named according to the license-file-name attribute of the vault/license node. +

+ +
+ +
+ +

+ Change Log +

+ +

+ This section describes the changes between versions of the file format. +

+ +

+ Version 1.0 +

+ + + +
diff --git a/Docs/Design/database-io.md b/Docs/Design/database-io.md new file mode 100644 index 000000000..200271862 --- /dev/null +++ b/Docs/Design/database-io.md @@ -0,0 +1,150 @@ +# Database IO Design + +Both user defined and "main" snippets are stored in the same data structure. + +## Loading + +When the database is loaded the following happens: + +### Top level + +`TDatabaseIOFactory` is called twice, in a predefined, significant order: + +1. `TDatabaseIOFactory.CreateMainDBLoader` is called to create a `IDatabaseLoader` object for the main database. That object's `Load` method is called. +2. `TDatabaseIOFactory.CreateUserDBLoader` is called to create another `IDatabaseLoader` object, this time for the user databse. That object's `Load` method is then called. + +> ⭐ When adding further data sources, instead of hard wiring the `TDatabaseIOFactory.CreateXXX` methods, we will need to create `IDatabaseLoader` instances for each registered data source. It may be a good idea initially to hard wire the "main" and "user" databases at the start of the data source registry and ensure they are all called in the right order. + +The order the loading is done is to ensure any references to snippets in the main database are valid when the user database is loaded. This is because the user database can reference snippets in the main database, but not vice versa. + +> ⭐ When implementing additional data sources we may need to prevent references across data sources. + +### Level 2: `IDatabaseLoader` + +`IDatabaseLoader` is defined as: + +```pascal + IDatabaseLoader = interface(IInterface) + ['{C6AF94FC-F56F-44AE-9E79-3B0CD0BB21D4}'] + procedure Load(const SnipList: TSnippetList; + const Categories: TCategoryList; + const DBDataItemFactory: IDBDataItemFactory); + end; +``` + +Implementations of the single `Load` method create and store loaded snippets and categories in `SnipList` & `Categories` respectively. They use `IDBDataItemFactory` methods to create snippet and category objects. + +There are the following `IDatabaseLoader` implementations: + +1. `TMainDatabaseLoader` for loading the main database from the main database directory. +2. `TUserDatabaseLoader` for loading the user database from its directory. + +Both the above classes use the template design pattern and descend from an abstract parent class named `TDatabaseLoader`. One of the overridden template methods requires an object to be returned that can read data from the correct database format and expose methods that are called from `TDatabaseLoader`. These reader object are of type `IDataReader`. + +> ⭐ When implementing additional data formats we will need further `IDatabaseLoader` implementations that can read each supported format. If we choose to sub class `TDatabaseLoader` then we will need to provide a suitable `IDataReader` implementation. + +In either case, if no database of either type is found a null object of type `TNulDataReader` (sic) is created that implements `IDataReader` to do nothing. + +### Level 3: `IDataReader` + +`IDataReader` is defined as: + +```pascal + IDataReader = interface(IInterface) + ['{72A8EAD4-05CE-41BF-AE0F-33495757BBFC}'] + function DatabaseExists: Boolean; + function GetAllCatIDs: IStringList; + procedure GetCatProps(const CatID: string; var Props: TCategoryData); + function GetCatSnippets(const CatID: string): IStringList; + procedure GetSnippetProps(const Snippet: string; var Props: TSnippetData); + function GetSnippetXRefs(const Snippet: string): IStringList; + function GetSnippetDepends(const Snippet: string): IStringList; + function GetSnippetUnits(const Snippet: string): IStringList; + end; +``` + +Where: + +* `DatabaseExists` -- Checks if the database exists. This method is always called first. No other methods of `IDataReader` are called if this method returns false. +* `GetAllCatIDs` -- Gets the names of all categories defined in the database. +* `GetCatProps` -- Gets the properties of the category identified by `CatID` and returns them in the `Props` record. +* `GetCatSnippets` -- Returns a list of the names of all snippets in category with ID `CatID`. +* `GetSnippetProps` -- Gets the properties if the snippet with unique `Snippet` and returns them in the `Props` record. +* `GetSnippetXRefs` -- Returns a list of the names of all snippets XRefd by snippet with name `Snippet`. +* `GetSnippetDepends` -- Returns a list of the names of all snippets on which the snippet with name `Snippet` depends. +* `GetSnippetUnits` -- Returns a list of the names of all the units referenced by the snippet with name `Snippet`. + +There are the following `IDataReader` implementations: + +1. `TIniDataReader` that reads the main database's .ini based data format. Instances of this class are created by `TMainDatabaseLoader`. +2. `TXMLDataReader` that read the user database's XML based data format. Instances of this class are created by `TUserDatabaseLoader`. + +> ⭐ Note that, although there is a one-one correspondence between `TMainDatabaseLoader` & `TIniDataReader` and `TUserDatabaseLoader` and `TXMLDataReader`, this does not generalise to other data sources and data format readers. More than one data source could use the same data format. + +> ⭐ When implementing additional data sources we will need `IDataReader` implementations that can read each supported data format. + +## Saving + +Only the user database gets saved, because only this database is editable. When the user database is saved, the following happens: + +`TDatabaseIOFactory` is called to create a `IDatabaseWriter` database writer object. That object's `Write` method is then called. + +> ⭐ When adding further data sources we will need to extend the factory class to create a suitable `IDatabaseWriter` object for the data format being written. + +### Level 2: `IDatabaseWriter` + +`IDatabaseWriter` is defined as: + +```pascal + IDatabaseWriter = interface(IInterface) + ['{F46EE2E3-68A7-4877-9E04-192D15D29BB1}'] + procedure Write(const SnipList: TSnippetList; + const Categories: TCategoryList; const Provider: IDBDataProvider); + end; +``` + +The sole `Write` method writes user data from database object, where `SnipList` and `Categories` contain the snippets and categories to be saved, respectively, and the `Provider` object is used to get snippet and category properties to be written. + +There is just the one `IDatabaseWriter` implementation: `TDatabaseWriter` that saves the user database. It creates and uses a `IDataWriter` instance to perform the actual output. + +> ⭐ When adding further data formats we will need different `IDataWriter` implementations that can write data in the correct format. + +### Level 3: `IDataWriter` + +`IDataWriter` is defined as follows: + +```pascal + IDataWriter = interface(IInterface) + ['{71E892C4-6E0F-480A-9DF4-70835F83A0CA}'] + procedure Initialise; + procedure WriteCatProps(const CatID: string; const Props: TCategoryData); + procedure WriteCatSnippets(const CatID: string; + const SnipList: IStringList); + procedure WriteSnippetProps(const SnippetName: string; + const Props: TSnippetData); + procedure WriteSnippetUnits(const SnippetName: string; + const Units: IStringList); + procedure WriteSnippetDepends(const SnippetName: string; + const Depends: IStringList); + procedure WriteSnippetXRefs(const SnippetName: string; + const XRefs: IStringList); + procedure Finalise; + end; +``` + +Where: + +* `Initialise` -- Initialise the output. Always called before any other methods. +* `WriteCatProps` -- Writes the properties per `Props` of the category with ID `CatID`. +* `WriteCatSnippets` -- Writes the list of snippets whose names are in `SnipList` belonging to category `CatID`. Always called after `WriteCatProps` for a given category. +* `WriteSnippetProps` -- Writes the properties from `Props` for snippet named `SnippetName`. Always called after all categories are written and before `WriteSnippetUnits`, so can be used to perform any per-snippet intialisation. +* `WriteSnippetUnits` -- Writes the list of units per `Units` referenced by the snippet named `SnippetName`. +* `WriteSnippetDepends` -- Writes the list of snippets names in `Depends` that are depended upon by the snippet named `SnippetName`. +* `WriteSnippetXRef` -- Writes the list of snippets names in `XRefs` that are cross referenced by the snippet named `SnippetName`. +* `Finalise` -- Finalises the writing. Always called after all other methods. + +There is only the one `IDataWriter` implementation. That is `TXMLDataWriter` that writes the user database data in the required XML format. + +> ⭐ When adding further data formats we will need further data writer implementations + +> ⭐ There is not necessarily a one-one correspondence between data sources and formats, so the same `IDataWriter` implementation could be used for more than one data source. diff --git a/Docs/Design/database-structure.md b/Docs/Design/database-structure.md new file mode 100644 index 000000000..1a363d539 --- /dev/null +++ b/Docs/Design/database-structure.md @@ -0,0 +1,29 @@ +# Database Structure Design + +## Overview + +CodeSnip maintains a database comprising snippets from two data sources: + +1. The _"main"_ data source -- Read only snippets read from data downloaded from the [DelphiDabbler Code Snippets Collection](https://github.com/delphidabbler/code-snippets). + +2. The _"user"_ data source -- Snippets created by the user that can be created, edited and deleted from within CodeSnip. These snippets are stored on the user's computer in a special directory. It is possible to import snippets exported from another user's snippets collection or from the [SWAG Archive](https://github.com/delphidabbler/swag). Such imported snippets become part of the user's own "user" data source and retain no knowledge of where they originally came from. + +The database also contains various category records. Categories read from the main data source can't be edited. Categories created by the user are stored in the user data source. Snippets from the user data source can reference categories from the main data source, but the reverse never happens. + +Throughout much of CodeSnip's documentation, the "main" and "user" data sources will be referred to as the "main" and "user" databases. However, there is only one database that has two data sources: "main" and "user". + +## Tables + +Internally, CodeSnip maintains two in-memory tables: + +1. The _snippets_ table -- Contains a record for each snippet +2. The _categories_ table -- Contains a record for each category + +Both Snippet and Category records identify which data source they belong to by means of a `UserDefined` field. This is true for the "user" data source and false for the "main" data source. + +> ⭐ When adding further data sources we will need to change the `UserDefined` fields to something like `DataSource` or `Origin` so we know which data source the snippet belongs to. + +> ⭐ When creating snippets we will need to get the user to specify a data source for. Since it's very likely that a snippet will be mis-allocated we will also need to provide a way to move snippets between data sources. + +> ⭐ For as long as the "main" data source is special, we will need a property or method for snippets like `IsEditable` or `IsMain` that can be used to prevent editing a snippet. + diff --git a/Src/CodeSnip.dpr b/Src/CodeSnip.dpr index fa718dacc..9d28b75d1 100644 --- a/Src/CodeSnip.dpr +++ b/Src/CodeSnip.dpr @@ -63,16 +63,15 @@ uses Compilers.UGlobals in 'Compilers.UGlobals.pas', Compilers.URunner in 'Compilers.URunner.pas', Compilers.USearchDirs in 'Compilers.USearchDirs.pas', - DB.UCategory in 'DB.UCategory.pas', - DB.UDatabaseIO in 'DB.UDatabaseIO.pas', - DB.UMain in 'DB.UMain.pas', - DB.UMetaData in 'DB.UMetaData.pas', - DB.USnippet in 'DB.USnippet.pas', - DB.USnippetKind in 'DB.USnippetKind.pas', - DBIO.UFileIOIntf in 'DBIO.UFileIOIntf.pas', - DBIO.UIniDataReader in 'DBIO.UIniDataReader.pas', - DBIO.UNulDataReader in 'DBIO.UNulDataReader.pas', - DBIO.UXMLDataIO in 'DBIO.UXMLDataIO.pas', + DB.Categories in 'DB.Categories.pas', + DB.IO.Manager in 'DB.IO.Manager.pas', + DB.Main in 'DB.Main.pas', + DB.Snippets in 'DB.Snippets.pas', + DB.SnippetKind in 'DB.SnippetKind.pas', + DB.IO.Vault in 'DB.IO.Vault.pas', + DB.IO.Vault.DCSCv2 in 'DB.IO.Vault.DCSCv2.pas', + DB.IO.Vault.Null in 'DB.IO.Vault.Null.pas', + DB.IO.Vault.CS4 in 'DB.IO.Vault.CS4.pas', Favourites.UManager in 'Favourites.UManager.pas', Favourites.UFavourites in 'Favourites.UFavourites.pas', Favourites.UPersist in 'Favourites.UPersist.pas', @@ -131,7 +130,7 @@ uses FmTestCompileDlg in 'FmTestCompileDlg.pas' {TestCompileDlg}, FmTrappedBugReportDlg in 'FmTrappedBugReportDlg.pas' {TrappedBugReportDlg}, FmUserBugReportDlg in 'FmUserBugReportDlg.pas' {UserBugReportDlg}, - FmUserDataPathDlg in 'FmUserDataPathDlg.pas' {UserDataPathDlg}, + UI.Forms.MoveVaultDlg in 'UI.Forms.MoveVaultDlg.pas' {MoveVaultDlg}, FrProgress in 'FrProgress.pas' {ProgressFrame: TFrame}, FmUserHiliterMgrDlg in 'FmUserHiliterMgrDlg.pas' {UserHiliterMgrDlg}, FmWaitDlg in 'FmWaitDlg.pas' {WaitDlg}, @@ -191,10 +190,10 @@ uses UBrowseForFolderDlg in 'UBrowseForFolderDlg.pas', UBrowseProtocol in 'UBrowseProtocol.pas', UCategoryAction in 'UCategoryAction.pas', - UCategoryListAdapter in 'UCategoryListAdapter.pas', + UI.Adapters.CategoryList in 'UI.Adapters.CategoryList.pas', ClassHelpers.UControls in 'ClassHelpers.UControls.pas', UClipboardHelper in 'UClipboardHelper.pas', - UCodeImportExport in 'UCodeImportExport.pas', + DB.IO.ImportExport.CS4 in 'DB.IO.ImportExport.CS4.pas', UCodeImportMgr in 'UCodeImportMgr.pas', UCodeShareMgr in 'UCodeShareMgr.pas', UColorBoxEx in 'UColorBoxEx.pas', @@ -258,7 +257,6 @@ uses UHTMLUtils in 'UHTMLUtils.pas', UHTTPProtocol in 'UHTTPProtocol.pas', UImageTags in 'UImageTags.pas', - UIniDataLoader in 'UIniDataLoader.pas', UInitialLetter in 'UInitialLetter.pas', UIOUtils in 'UIOUtils.pas', UIStringList in 'UIStringList.pas', @@ -267,7 +265,6 @@ uses ULEDImageList in 'ULEDImageList.pas', ULinkAction in 'ULinkAction.pas', ULocales in 'ULocales.pas', - UMainDBFileReader in 'UMainDBFileReader.pas', UMainDisplayMgr in 'UMainDisplayMgr.pas', UMarquee in 'UMarquee.pas', UMeasurement in 'UMeasurement.pas', @@ -297,7 +294,6 @@ uses UProtocols in 'UProtocols.pas', UQuery in 'UQuery.pas', UREMLDataIO in 'UREMLDataIO.pas', - UReservedCategories in 'UReservedCategories.pas', UResourceUtils in 'UResourceUtils.pas', URTFBuilder in 'URTFBuilder.pas', URTFCategoryDoc in 'URTFCategoryDoc.pas', @@ -315,13 +311,13 @@ uses UShowCaseCtrl in 'UShowCaseCtrl.pas', USimpleDispatch in 'USimpleDispatch.pas', USingleton in 'USingleton.pas', - USnipKindListAdapter in 'USnipKindListAdapter.pas', + UI.Adapters.SnippetKindList in 'UI.Adapters.SnippetKindList.pas', USnippetAction in 'USnippetAction.pas', USnippetDoc in 'USnippetDoc.pas', USnippetExtraHelper in 'USnippetExtraHelper.pas', USnippetHTML in 'USnippetHTML.pas', USnippetIDListIOHandler in 'USnippetIDListIOHandler.pas', - USnippetIDs in 'USnippetIDs.pas', + DB.SnippetIDs in 'DB.SnippetIDs.pas', USnippetPageHTML in 'USnippetPageHTML.pas', USnippetPageStructure in 'USnippetPageStructure.pas', USnippetsChkListMgr in 'USnippetsChkListMgr.pas', @@ -352,9 +348,9 @@ uses UURIEncode in 'UURIEncode.pas', UUrl in 'UUrl.pas', UUrlMonEx in 'UUrlMonEx.pas', - UUserDBBackup in 'UUserDBBackup.pas', + VaultBackup in 'VaultBackup.pas', UUserDBMgr in 'UUserDBMgr.pas', - UUserDBMove in 'UUserDBMove.pas', + VaultMover in 'VaultMover.pas', UUtils in 'UUtils.pas', UVersionInfo in 'UVersionInfo.pas', UView in 'UView.pas', @@ -366,15 +362,23 @@ uses UWBExternal in 'UWBExternal.pas', UWBPopupMenus in 'UWBPopupMenus.pas', UWindowSettings in 'UWindowSettings.pas', - UXMLDocConsts in 'UXMLDocConsts.pas', UXMLDocHelper in 'UXMLDocHelper.pas', UXMLDocumentEx in 'UXMLDocumentEx.pas', - FmDeleteUserDBDlg in 'FmDeleteUserDBDlg.pas' {DeleteUserDBDlg}, + UI.Forms.DeleteVaultDlg in 'UI.Forms.DeleteVaultDlg.pas' {DeleteVaultDlg}, Compilers.UAutoDetect in 'Compilers.UAutoDetect.pas', Compilers.USettings in 'Compilers.USettings.pas', FmRegisterCompilersDlg in 'FmRegisterCompilersDlg.pas' {RegisterCompilersDlg}, ClassHelpers.UGraphics in 'ClassHelpers.UGraphics.pas', ClassHelpers.UActions in 'ClassHelpers.UActions.pas', + DB.Vaults in 'DB.Vaults.pas', + UTabSeparatedFileIO in 'UTabSeparatedFileIO.pas', + DB.IO.Categories in 'DB.IO.Categories.pas', + UI.Adapters.VaultList in 'UI.Adapters.VaultList.pas', + UI.Forms.BackupVaultDlg in 'UI.Forms.BackupVaultDlg.pas' {VaultBackupDlg}, + DB.DataFormats in 'DB.DataFormats.pas', + DB.IO.Vault.Native in 'DB.IO.Vault.Native.pas', + DB.MetaData in 'DB.MetaData.pas', + DB.IO.Common.CS4 in 'DB.IO.Common.CS4.pas', USaveInfoMgr in 'USaveInfoMgr.pas', ClassHelpers.RichEdit in 'ClassHelpers.RichEdit.pas', UHTMLSnippetDoc in 'UHTMLSnippetDoc.pas', diff --git a/Src/CodeSnip.dproj b/Src/CodeSnip.dproj index 5eaa734a3..034651479 100644 --- a/Src/CodeSnip.dproj +++ b/Src/CodeSnip.dproj @@ -66,16 +66,15 @@ - - - - - - - - - - + + + + + + + + + @@ -238,8 +237,8 @@
UserBugReportDlg
- -
UserDataPathDlg
+ +
MoveVaultDlg
ProgressFrame
@@ -393,10 +392,10 @@ - + - + @@ -460,7 +459,6 @@ - @@ -469,7 +467,6 @@ - @@ -499,7 +496,6 @@ - @@ -517,13 +513,13 @@ - + - + @@ -554,9 +550,9 @@ - + - + @@ -568,11 +564,10 @@ - - -
DeleteUserDBDlg
+ +
DeleteVaultDlg
@@ -581,6 +576,17 @@ + + + + + +
VaultBackupDlg
+
+ + + + diff --git a/Src/DB.UCategory.pas b/Src/DB.Categories.pas similarity index 84% rename from Src/DB.UCategory.pas rename to Src/DB.Categories.pas index c5860d3c0..8c3882709 100644 --- a/Src/DB.UCategory.pas +++ b/Src/DB.Categories.pas @@ -10,7 +10,7 @@ } -unit DB.UCategory; +unit DB.Categories; interface @@ -20,7 +20,8 @@ interface // Delphi Generics.Collections, // Project - DB.USnippet; + DB.Snippets, + DB.Vaults; type @@ -51,7 +52,6 @@ TCategory = class(TObject) fSnippets: TSnippetList; // List of snippet objects in category fID: string; // Category id fDescription: string; // Category description - fUserDefined: Boolean; // Whether this is a user-defined snippet function CompareIDTo(const Cat: TCategory): Integer; {Compares this category's ID to that of a given category. The check is not case sensitive. @@ -60,14 +60,35 @@ TCategory = class(TObject) are equal or +1 if this category's ID is greater than Cat's. } public - constructor Create(const CatID: string; const UserDefined: Boolean; - const Data: TCategoryData); - {Class contructor. Sets up category object with given property values. - @param Data [in] Contains required property values. - } + const + /// ID of default category. + DefaultID = '__default__'; + + public + /// Object constructor. Sets up category object with given + /// property values. + /// CatID [in] Category ID. + /// TCategoryData [in] category properties. + /// + constructor Create(const CatID: string; const Data: TCategoryData); + + /// Creates the default category with its default description. + /// + class function CreateDefault: TCategory; + destructor Destroy; override; {Destructor. Tears down object. } + + /// Updates category properties. + /// TCategoryData [in] Updated category + /// properties. + procedure Update(const Data: TCategoryData); + + /// Returns a record containing all editable data of a category. + /// + function GetEditData: TCategoryData; + function IsEqual(const Cat: TCategory): Boolean; {Checks if this category is same as another category. Categories are considered equal if they have the same ID. @@ -93,20 +114,6 @@ TCategory = class(TObject) {Description of category} property Snippets: TSnippetList read fSnippets; {List of snippets in this category} - property UserDefined: Boolean read fUserDefined; - {Flag that indicates if this is a user defined category} - end; - - { - TCategoryEx: - Private extension of TCategory for use internally by Snippets object. - } - TCategoryEx = class(TCategory) - public - function GetEditData: TCategoryData; - {Gets details of all editable data of category. - @return Required editable data. - } end; { @@ -143,6 +150,12 @@ TCategoryList = class(TObject) @param Category [in] Category to be added. @return Index where category inserted in list. } + + /// Deletes a category from the list. + /// TCategory [in] Category to be deleted. + /// + procedure Delete(const Category: TCategory); + function Find(const CatID: string): TCategory; {Finds a named category in list. @param CatID [in] ID of required category. @@ -164,18 +177,6 @@ TCategoryList = class(TObject) {Number of categories in list} end; - { - TCategoryListEx: - Private extension of TCategoryList for use internally by snippets object. - } - TCategoryListEx = class(TCategoryList) - public - procedure Delete(const Category: TCategory); - {Deletes a category from the list. - @param Category [in] Category to be deleted. - } - end; - implementation @@ -184,7 +185,7 @@ implementation // Delphi SysUtils, // Project - UReservedCategories, UStrUtils; + UStrUtils; { TCategory } @@ -194,8 +195,7 @@ function TCategory.CanDelete: Boolean; @return True if deletion allowed, False if not. } begin - Result := fUserDefined and fSnippets.IsEmpty - and not TReservedCategories.IsReserved(Self); + Result := fSnippets.IsEmpty; end; function TCategory.CompareDescriptionTo(const Cat: TCategory): Integer; @@ -224,20 +224,24 @@ function TCategory.CompareIDTo(const Cat: TCategory): Integer; Result := StrCompareText(Self.ID, Cat.ID); end; -constructor TCategory.Create(const CatID: string; const UserDefined: Boolean; - const Data: TCategoryData); - {Class contructor. Sets up category object with given property values. - @param Data [in] Contains required property values. - } +constructor TCategory.Create(const CatID: string; const Data: TCategoryData); begin - Assert(ClassType <> TCategory, - ClassName + '.Create: must only be called from descendants.'); inherited Create; fID := CatID; fDescription := Data.Desc; - fUserDefined := UserDefined; // Create list to store snippets in category - fSnippets := TSnippetListEx.Create; + fSnippets := TSnippetList.Create; +end; + +class function TCategory.CreateDefault: TCategory; +var + Data: TCategoryData; +resourcestring + sDefCatDesc = 'My Snippets'; +begin + Data.Init; + Data.Desc := sDefCatDesc; + Result := Create(DefaultID, Data); end; destructor TCategory.Destroy; @@ -248,6 +252,11 @@ destructor TCategory.Destroy; inherited; end; +function TCategory.GetEditData: TCategoryData; +begin + Result.Desc := Self.Description; +end; + function TCategory.IsEqual(const Cat: TCategory): Boolean; {Checks if this category is same as another category. Categories are considered equal if they have the same ID. @@ -258,14 +267,9 @@ function TCategory.IsEqual(const Cat: TCategory): Boolean; Result := CompareIDTo(Cat) = 0; end; -{ TCategoryEx } - -function TCategoryEx.GetEditData: TCategoryData; - {Gets details of all editable data of category. - @return Required editable data. - } +procedure TCategory.Update(const Data: TCategoryData); begin - Result.Desc := Self.Description; + fDescription := Data.Desc; end; { TCategoryList } @@ -307,6 +311,16 @@ constructor TCategoryList.Create(const OwnsObjects: Boolean); fList := TObjectList.Create(OwnsObjects); end; +procedure TCategoryList.Delete(const Category: TCategory); +var + Idx: Integer; // index of snippet in list. +begin + Idx := fList.IndexOf(Category); + if Idx = -1 then + Exit; + fList.Delete(Idx); // this frees category if list owns objects +end; + destructor TCategoryList.Destroy; {Destructor. Tears down object. } @@ -360,21 +374,6 @@ function TCategoryList.GetItem(Idx: Integer): TCategory; Result := fList[Idx]; end; -{ TCategoryListEx } - -procedure TCategoryListEx.Delete(const Category: TCategory); - {Deletes a category from the list. - @param Category [in] Category to be deleted. - } -var - Idx: Integer; // index of snippet in list. -begin - Idx := fList.IndexOf(Category); - if Idx = -1 then - Exit; - fList.Delete(Idx); // this frees category if list owns objects -end; - { TCategoryData } procedure TCategoryData.Assign(const Src: TCategoryData); diff --git a/Src/DB.DataFormats.pas b/Src/DB.DataFormats.pas new file mode 100644 index 000000000..45ba879ef --- /dev/null +++ b/Src/DB.DataFormats.pas @@ -0,0 +1,143 @@ +unit DB.DataFormats; + +interface + +type + + /// Enumeration of the kinds of supported snippet vault data + /// formats. + /// + /// Error -- Invalid format. Used to indicate an unknown format + /// or other error. + /// DCSC_v2 -- Format used by the DelphiDabbler Code Snippets + /// Collection v2. + /// Native_v4 -- Native format used by CodeSnip v4 to store user + /// snippets. + /// Native_Vault -- Native format used by CodeSnip Vault to + /// store user snippets. + /// + TDataFormatKind = ( + // NEVER specify a literal ordinal value in this enumeration. + // NEVER delete or re-order the enumeration items: the ordinal values may + // be written to a config file and changing the ordinal value here can + // cause hard to trace bugs. If an item goes out of use then leave it + // in place & possibly rename the item to indicate its redundancy. + // NEVER associate error with a format loader or saver class. + Error, + DCSC_v2, + Native_v4, + Native_Vault + ); + + /// Record containing details of the data format and location in + /// which data is stored. + TDataStorageDetails = record + strict private + var + /// Value of the Directory property. + fDirectory: string; + /// Value of the Format property. + fFormat: TDataFormatKind; + /// Write access method for Directory property. + procedure SetDirectory(const AValue: string); + public + /// Constructs a new record instance with the given property + /// values. + constructor Create(const AFormat: TDataFormatKind; + const ADirectory: string); + /// The format in which the data is stored. + property Format: TDataFormatKind read fFormat; + /// The directory in which the data is stored. + property Directory: string read fDirectory write SetDirectory; + end; + + TDataFormatInfo = record + strict private + type + TMapRecord = record + /// Data format kind. + Kind: TDataFormatKind; + /// Data format name. + Name: string; + end; + const + // There are so few entries in this table it's not worth the overhead + // of using a dictionary for the lookup. + LookupTable: array[0..2] of TMapRecord = ( + (Kind: TDataFormatKind.Native_Vault; + Name: 'CodeSnip Vault Native Snippet Format'), + (Kind: TDataFormatKind.Native_v4; + Name: 'CodeSnip 4 Native Snippet Format'), + (Kind: TDataFormatKind.DCSC_v2; + Name: 'DelphiDabbler Code Snippets Collection v2 Format') + ); + class function IndexOf(const AKind: TDataFormatKind): Integer; static; + public + const + /// Specifies the data format used for the default format. + /// + DefaultFormat = TDataFormatKind.Native_v4; + public + /// Gets the name of the data format specified by + /// AKind. Returns an empty string if no name is associated with + /// AKind. + class function GetName(const AKind: TDataFormatKind): string; static; + /// Returns an array of all supported data formats. + /// TArray<TDataFormatKind>. Array of values + /// that identify the supported data formats. + class function GetSupportedFormats: TArray; static; + end; + +implementation + +{ TDataFormatInfo } + +class function TDataFormatInfo.GetName(const AKind: TDataFormatKind): string; +var + Idx: Integer; +begin + Idx := IndexOf(AKind); + if Idx < 0 then + Exit(''); + Result := LookupTable[Idx].Name; +end; + +class function TDataFormatInfo.GetSupportedFormats: TArray; +var + Idx: Integer; + Item: TMapRecord; +begin + SetLength(Result, Length(LookupTable)); + Idx := 0; + for Item in LookupTable do + begin + Result[Idx] := Item.Kind; + Inc(Idx); + end; +end; + +class function TDataFormatInfo.IndexOf(const AKind: TDataFormatKind): Integer; +var + Idx: Integer; +begin + Result := -1; + for Idx := Low(LookupTable) to High(LookupTable) do + if LookupTable[Idx].Kind = AKind then + Exit(Idx); +end; + +{ TDataStorageDetails } + +constructor TDataStorageDetails.Create(const AFormat: TDataFormatKind; + const ADirectory: string); +begin + fFormat := AFormat; + fDirectory := ADirectory; +end; + +procedure TDataStorageDetails.SetDirectory(const AValue: string); +begin + fDirectory := AValue; +end; + +end. diff --git a/Src/DB.IO.Categories.pas b/Src/DB.IO.Categories.pas new file mode 100644 index 000000000..1de67e7fe --- /dev/null +++ b/Src/DB.IO.Categories.pas @@ -0,0 +1,165 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2024, Peter Johnson (gravatar.com/delphidabbler). + * + * Class that read and write category information from and to files. +} + +unit DB.IO.Categories; + +interface + +uses + // Delphi + SysUtils, + Generics.Collections, + // Project + DB.Categories, + UExceptions, + UTabSeparatedFileIO; + +type + /// Base class for category storage reader and writer classes. + /// + TCategoryStorage = class abstract(TObject) + strict protected + const + /// Watermark that is present on the first line of a valid + /// categories file. + Watermark = #$25BA + ' CodeSnip Categories v1 ' + #$25C4; + end; + + /// Reads category information from storage. + TCategoryStorageReader = class sealed(TCategoryStorage) + public + type + /// Key / Value pair associating the category ID (key) with the + /// category data (value). + TCategoryIDAndData = TPair; + strict private + var + /// Object that read data from a tab delimited UTF8 text file. + /// + fFileReader: TTabSeparatedReader; + /// List of category data read from file. + fCatData: TList; + /// Parses fields that have been split out from each text line. + /// + /// ECategoryStorageReader raised if the fields are not + /// valid. + procedure ParseFields(AFields: TArray); + public + /// Creates object to read from file AFileName. + constructor Create(const AFileName: string); + /// Object destructor. + destructor Destroy; override; + /// Reads data about each category defined in file. + /// TArray<TCategoryIDAndData>. Array of category + /// data. + /// ECategoryStorageReader raised if the file can't be + /// read or if its contents are invalid. + function Read: TArray; + end; + + /// Class of exception raised by TCategoryStorageReader. + /// + ECategoryStorageReader = class(ECodeSnip); + + /// Writes category information to storage. + TCategoryStorageWriter = class sealed(TCategoryStorage) + strict private + var + /// Object that writes data to a tab delimited UTF8 text file. + /// + fFileWriter: TTabSeparatedFileWriter; + public + /// Creates object to write to file AFileName. + constructor Create(const AFileName: string); + /// Object destructor. + destructor Destroy; override; + /// Writes information about each category in ACategoryList + /// + procedure Write(const ACategoryList: TCategoryList); + end; + +implementation + +uses + // Project + UStrUtils; + +{ TCategoryStorageReader } + +constructor TCategoryStorageReader.Create(const AFileName: string); +begin + Assert(not StrIsEmpty(AFileName), ClassName + '.Create: AFileName is empty'); + inherited Create; + fFileReader := TTabSeparatedReader.Create(AFileName, Watermark); + fCatData := TList.Create; +end; + +destructor TCategoryStorageReader.Destroy; +begin + fCatData.Free; + fFileReader.Free; + inherited; +end; + +procedure TCategoryStorageReader.ParseFields(AFields: TArray); +resourcestring + sMalformedLine = 'Malformed line in categories file'; +var + CatID: string; + Data: TCategoryData; +begin + if Length(AFields) <> 2 then + raise ECategoryStorageReader.Create(sMalformedLine); + if StrIsEmpty(AFields[0]) or StrIsEmpty(AFields[1]) then + raise ECategoryStorageReader.Create(sMalformedLine); + CatID := StrTrim(AFields[0]); + Data.Init; + Data.Desc := StrTrim(AFields[1]); + fCatData.Add(TCategoryIDAndData.Create(CatID, Data)); +end; + +function TCategoryStorageReader.Read: TArray; +begin + fCatData.Clear; + try + fFileReader.Read(ParseFields); + except + on E: ETabSeparatedReader do + raise ECategoryStorageReader.Create(E); + else + raise; + end; + Result := fCatData.ToArray; +end; + +{ TCategoryStorageWriter } + +constructor TCategoryStorageWriter.Create(const AFileName: string); +begin + Assert(not StrIsEmpty(AFileName), ClassName + '.Create: AFileName is empty'); + inherited Create; + fFileWriter := TTabSeparatedFileWriter.Create(AFileName, Watermark); +end; + +destructor TCategoryStorageWriter.Destroy; +begin + fFileWriter.Free; + inherited; +end; + +procedure TCategoryStorageWriter.Write(const ACategoryList: TCategoryList); +var + Cat: TCategory; +begin + for Cat in ACategoryList do + fFileWriter.WriteLine(TArray.Create(Cat.ID, Cat.Description)); +end; + +end. diff --git a/Src/DB.IO.Common.CS4.pas b/Src/DB.IO.Common.CS4.pas new file mode 100644 index 000000000..84237d7d6 --- /dev/null +++ b/Src/DB.IO.Common.CS4.pas @@ -0,0 +1,430 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2025, Peter Johnson (gravatar.com/delphidabbler). + * + * Implements a static class that helps with input and output that is common to + * more than one supported CodeSnip v4 XML data format. +} + + +unit DB.IO.Common.CS4; + +interface + +uses + // Delphi + XMLIntf, + // Project + Compilers.UGlobals, + DB.SnippetKind, + UIStringList, + UStructs, + UXMLDocHelper, + UXMLDocumentEx; + +type + /// Static class that helps with input and output that is common to + /// more than one supported CodeSnip v4 XML data format. + TCS4FormatHelper = class(TXMLDocHelper) + strict private + const + RootWatermarkAttr = 'watermark'; + SnippetKindNodeName = 'kind'; + CompilerResultsNodeName = 'compiler-results'; + CompilerResultNodeName = 'compiler-result'; + CompilerResultIdAttr = 'id'; + StandardFormatNodeName = 'standard-format'; + CompilerIDValues: array[TCompilerID] of string = ( + 'd2', 'd3', 'd4', 'd5', 'd6', 'd7', + 'd2005', 'd2006', 'd2007', 'd2009', 'd2010', + 'dXE', 'dXE2', 'dXE3', 'dDX4' {error, but in use so can't fix}, + 'dXE5', 'dXE6', 'dXE7', 'dXE8', + 'd10s', 'd101b', 'd102t', 'd103r', 'd104s', 'd11a', 'd12y', + 'fpc' + ); + SnippetKindValues: array[TSnippetKind] of string = ( + 'freeform', 'routine', 'const', 'type', 'unit', 'class' + ); + public + const + RootVersionAttr = 'version'; + HighlightSourceNodeName = 'highlight-source'; + ExtraNodeName = 'extra'; + {TODO -cRefactor: Remove support for old file formats that used + credits, credits URL & comments nodes} + CommentsNodeName = 'comments'; + CreditsNodeName = 'credits'; + CreditsUrlNodeName = 'credits-url'; + DependsNodeName = 'depends'; + UnitsNodeName = 'units'; + DescriptionNodeName = 'description'; + SnippetNodeName = 'routine'; + SnippetNodeNameAttr = 'name'; + SnippetsNodeName = 'routines'; + DisplayNameNodeName = 'display-name'; + PascalNameNodeName = 'pascal-name'; + public + /// Creates an XML document root node. + /// IXMLDocumentEx [in] Document in which to + /// insert root node. + /// string [in] Name of root node. + /// string [in] Value of root node's + /// watermark attribute. + /// Integer [in] Value of root node's version + /// attribute. + /// IXMLNode. Reference to new root node. + class function CreateRootNode(const AXMLDoc: IXMLDocumentEx; + const ANodeName, AWatermark: string; const AVersion: Integer): IXMLNode; + + /// Validates the root node of an XML document. + /// IXMLDocumentEx [in] XML document to be + /// validated. + /// string> [in] Name of root mode. + /// string [in] Required value of root + /// node's watermark attribute. + /// TRange [in] Range of acceptable file + /// version numbers. + /// Integer. Document version. + /// ECodeSnipXML is raised if validation fails. + /// + class function ValidateRootNode(const AXMLDoc: IXMLDocumentEx; + const ANodeName, AWatermark: string; const AVersions: TRange): Integer; + + /// Creates a comment at the top level of an XML document. + /// + /// IXMLDocumentEx [in] XML document in which + /// comment is inserted. + /// string [in] Comment to be inserted. + /// + class procedure CreateComment(const AXMLDoc: IXMLDocumentEx; + const AComment: string); + + {TODO -cVault: query whether GetStandardFormat is needed if support dropped + for early CS4 XML formats.} + /// Gets value of a <standard-format> node of a snippet in + /// an XML document. + /// IXMLDocumentEx [in] XML document + /// containing snippet. + /// IXMLNode [in] Snippet node that + /// contains the <standard-format> tag. + /// Boolean [in] Value to use if node doesn't + /// exist or has a non-standard value. + /// Boolean. Value of node, or default value. + class function GetStandardFormat(const AXMLDoc: IXMLDocumentEx; + const ASnippetNode: IXMLNode; const ADefault: Boolean): Boolean; + + /// Sets value of a <highlight-source> node of a snippet in + /// an XML document. + /// IXMLDocumentEx [in] XML document + /// containing snippet. + /// IXMLNode [in] Snippet node that + /// contains the <highlight-source> tag. + /// Boolean [in] Value to use if node doesn't + /// exist or has a non-standard value. + /// Boolean. Value of node, or default value. + class function GetHiliteSource(const AXMLDoc: IXMLDocumentEx; + const ASnippetNode: IXMLNode; const ADefault: Boolean): Boolean; + + /// Gets value of <kind> node of a snippet in an XML + /// document. + /// IXMLDocumentEx [in] XML document + /// containing snippet. + /// IXMLNode [in] Snippet node that + /// contains the <kind> tag. + /// TSnippetKind [in] Value to use if node + /// doesn't exist or has a non-standard value. + /// TSnippetKind. Required snippet kind. + class function GetSnippetKind(const AXMLDoc: IXMLDocumentEx; + const ASnippetNode: IXMLNode; const ADefault: TSnippetKind): TSnippetKind; + + /// Writes a <kind> node to a an XML document. + /// IXMLDocumentEx [in] XML document that will + /// be updated. + /// IXMLNode [in] Snippet node that will + /// contain the <kind> tag. + /// TSnippetKind [in] Value of the <kind> + /// node. + class procedure WriteSnippetKind(const AXMLDoc: IXMLDocumentEx; + const ASnippetNode: IXMLNode; const AValue: TSnippetKind); + + /// Gets compile results for a snippet in an XML document. + /// + /// IXMLDocumentEx [in] XML document + /// containing snippet. + /// IXMLNode [in] Snippet node that + /// contains compile results. + /// TCompileResults. Array of compile results. Includes + /// default results for missing compilers. + class function GetCompilerResults(const AXMLDoc: IXMLDocumentEx; + const ASnippetNode: IXMLNode): TCompileResults; + + /// Writes compile results for a snippet to an XML document. + /// + /// IXMLDocumentEx [in] XML document that will + /// be updated. + /// IXMLNode [in] Snippet node that will + /// contain the compile results. + /// TCompileResults [in] Array of compile + /// results. + class procedure WriteCompilerResults(const AXMLDoc: IXMLDocumentEx; + const ASnippetNode: IXMLNode; const ACompRes: TCompileResults); + + /// Gets a list of names from <pascal-name> elements in an + /// XML document. + /// IXMLDocumentEx [in] XML document + /// containing the name list. + /// IXMLNode [in] XML node that contains all + /// the list nodes. + /// IStringList [in] Receives text of all + /// the <pascal-name> elements in the list. + class procedure GetPascalNameList(const AXMLDoc: IXMLDocumentEx; + const AListNode: IXMLNode; const ANameList: IStringList); + + /// Writes a Pascal name list to an XML document. + /// IXMLDocumentEx [in] XML document into + /// which the list is written. + /// IXMLNode [in] Parent node that is to + /// contain the list. + /// string [in] Name of new list node that + /// is to be the parent of the list. + /// IStringList [in] List of Pascal names + /// to be written. + class procedure WritePascalNameList(const AXMLDoc: IXMLDocumentEx; + const AParent: IXMLNode; const AListName: string; + const ANameList: IStringList); + end; + +implementation + +uses + // Project + UStrUtils; + +{ TCS4FormatHelper } + +class procedure TCS4FormatHelper.CreateComment(const AXMLDoc: IXMLDocumentEx; + const AComment: string); +begin + AXMLDoc.ChildNodes.Add(AXMLDoc.CreateNode(' ' + AComment + ' ', ntComment)); +end; + +class function TCS4FormatHelper.CreateRootNode(const AXMLDoc: IXMLDocumentEx; + const ANodeName, AWatermark: string; const AVersion: Integer): IXMLNode; +begin + Result := AXMLDoc.CreateNode(ANodeName); + Result.SetAttribute(RootWatermarkAttr, AWatermark); + Result.SetAttribute(RootVersionAttr, AVersion); + AXMLDoc.ChildNodes.Add(Result); +end; + +class function TCS4FormatHelper.GetCompilerResults( + const AXMLDoc: IXMLDocumentEx; const ASnippetNode: IXMLNode): TCompileResults; + + // Converts an identifier string to a compiler ID. Returns True if AIDStr is + // valid, False if not. + function IDStrToCompID(AIDStr: string; out AMatch: TCompilerID): Boolean; + var + CompID: TCompilerID; // loops thru all compiler IDs + begin + {TODO -cVault: drop support for detecting CodeSnip v3 entries} + // 'dXE4' can be encountered when reading files written by CodeSnip 3, which + // uses correct 'dXE4' symbol for Delphi XE4 instead of 'dDX4' used + // (erroneously) by CodeSnip 4. So the following two lines convert the + // CodeSnip 3 value to the CodeSnip 4 value before testing. + if AIDStr = 'dXE4' then + AIDStr := CompilerIDValues[ciDXE4]; + Result := False; + for CompID := Low(TCompilerID) to High(TCompilerID) do + begin + if CompilerIDValues[CompID] = AIDStr then + begin + Result := True; + AMatch := CompID; + Break; + end; + end; + end; + +var + ListNode: IXMLNode; // node that enclose compiler result nodes + ResultsNodes: IXMLSimpleNodeList; // list of compiler-result nodes + ResultNode: IXMLNode; // a compiler-result node + CompID: TCompilerID; // loops thru compiler IDs + CompResultStr: string; // compiler id string from result node +begin + // Initialise all results to unknown (query) + for CompID := Low(TCompilerID) to High(TCompilerID) do + Result[CompID] := crQuery; + + // Find enclosing node: valid if this is not present + ListNode := AXMLDoc.FindFirstChildNode(ASnippetNode, CompilerResultsNodeName); + if not Assigned(ListNode) then + Exit; + + // Get list of compiler result nodes contained in list and process each one + ResultsNodes := AXMLDoc.FindChildNodes(ListNode, CompilerResultNodeName); + for ResultNode in ResultsNodes do + begin + if ResultNode.IsTextElement then + begin + // get compile result identifier + CompResultStr := ResultNode.Text; + if CompResultStr = '' then + CompResultStr := '?'; + // add specified result to returned array + if IDStrToCompID( + ResultNode.Attributes[CompilerResultIdAttr], CompID + ) then + begin + {TODO -cRefactor: Use a lookup table instead of case statement} + case CompResultStr[1] of + 'Y': Result[CompID] := crSuccess; + 'N': Result[CompID] := crError; + 'W': Result[CompiD] := crWarning; + else Result[CompID] := crQuery; + end; + end; + end; + end; +end; + +class function TCS4FormatHelper.GetHiliteSource(const AXMLDoc: IXMLDocumentEx; + const ASnippetNode: IXMLNode; const ADefault: Boolean): Boolean; +var + ValueText: string; +begin + ValueText := GetSubTagText(AXMLDoc, ASnippetNode, HighlightSourceNodeName); + if ValueText <> '' then + Result := ValueText <> '0' + else + Result := ADefault; +end; + +class procedure TCS4FormatHelper.GetPascalNameList(const AXMLDoc: IXMLDocumentEx; + const AListNode: IXMLNode; const ANameList: IStringList); +var + NameNode: IXMLNode; + NodeList: IXMLSimpleNodeList; +begin + ANameList.Clear; + if not Assigned(AListNode) then + Exit; // this is permitted since Pascal name lists may be empty or missing + NodeList := AXMLDoc.FindChildNodes(AListNode, PascalNameNodeName); + for NameNode in NodeList do + if NameNode.IsTextElement then + ANameList.Add(NameNode.Text); +end; + +class function TCS4FormatHelper.GetSnippetKind(const AXMLDoc: IXMLDocumentEx; + const ASnippetNode: IXMLNode; const ADefault: TSnippetKind): TSnippetKind; +var + ValueText: string; +begin + {TODO -cRefactor: Use a lookup table instead of if ... else if .. else tests} + ValueText := GetSubTagText(AXMLDoc, ASnippetNode, SnippetKindNodeName); + if StrSameText(ValueText, SnippetKindValues[skFreeform]) then + Result := skFreeform + else if StrSameText(ValueText, SnippetKindValues[skRoutine]) then + Result := skRoutine + else if StrSameText(ValueText, SnippetKindValues[skConstant]) then + Result := skConstant + else if StrSameText(ValueText, SnippetKindValues[skTypeDef]) then + Result := skTypeDef + else if StrSameText(ValueText, SnippetKindValues[skUnit]) then + Result := skUnit + else if StrSameText(ValueText, SnippetKindValues[skClass]) then + Result := skClass + else + Result := ADefault; +end; + +class function TCS4FormatHelper.GetStandardFormat(const AXMLDoc: IXMLDocumentEx; + const ASnippetNode: IXMLNode; const ADefault: Boolean): Boolean; +var + ValueText: string; +begin + ValueText := GetSubTagText(AXMLDoc, ASnippetNode, StandardFormatNodeName); + if ValueText <> '' then + Result := ValueText <> '0' + else + Result := ADefault; +end; + +class function TCS4FormatHelper.ValidateRootNode(const AXMLDoc: IXMLDocumentEx; + const ANodeName, AWatermark: string; const AVersions: TRange): Integer; +var + RootNode: IXMLNode; // document root node +resourcestring + // Error messages + sNoRootNode = 'Invalid document: no root element present'; + sBadRootName = 'Invalid document: root element must be named <%s>'; + sBadWatermark = 'Invalid document: watermark is incorrect'; + sBadVersion = 'Invalid document: unsupported document version %d'; +begin + RootNode := AXMLDoc.DocumentElement; + // There must be a root node + if not Assigned(RootNode) then + raise ECodeSnipXML.Create(sNoRootNode); + // Correct root node must be present, with valid watermark and version + if RootNode.NodeName <> ANodeName then + raise ECodeSnipXML.CreateFmt(sBadRootName, [ANodeName]); + if RootNode.Attributes[RootWatermarkAttr] <> AWatermark then + raise ECodeSnipXML.Create(sBadWatermark); + Result := RootNode.Attributes[RootVersionAttr]; + if not AVersions.Contains(Result) then + raise ECodeSnipXML.CreateFmt(sBadVersion, [Result]); +end; + +class procedure TCS4FormatHelper.WriteCompilerResults( + const AXMLDoc: IXMLDocumentEx; const ASnippetNode: IXMLNode; + const ACompRes: TCompileResults); +const + {TODO -cRefactor: Move this map to private class consts to make available to + GetCompilerResults.} + {TODO -cVault: Make CompResMap comply with CS4 XML doc specs - ? should be Q} + // Map of compiler results onto character representation store in XML file. + CompResMap: array[TCompileResult] of Char = ('Y', 'W', 'N', '?'); +var + CompResultsNode: IXMLNode; // node that stores all compiler results + CompResultNode: IXMLNode; // each compiler result node + CompID: TCompilerID; // loops thru all supported compilers +begin + // compiler results value: only write known results + CompResultsNode := AXMLDoc.CreateElement(ASnippetNode, CompilerResultsNodeName); + for CompID := Low(TCompilerID) to High(TCompilerID) do + begin + if ACompRes[CompID] <> crQuery then + begin + CompResultNode := AXMLDoc.CreateElement( + CompResultsNode, CompilerResultNodeName, CompResMap[ACompRes[CompID]] + ); + CompResultNode.Attributes[CompilerResultIdAttr] := + CompilerIDValues[CompID]; + end; + end; +end; + +class procedure TCS4FormatHelper.WritePascalNameList( + const AXMLDoc: IXMLDocumentEx; const AParent: IXMLNode; + const AListName: string; const ANameList: IStringList); +var + ListNode: IXMLNode; + Name: string; +begin + ListNode := AXMLDoc.CreateElement(AParent, AListName); + for Name in ANameList do + AXMLDoc.CreateElement(ListNode, PascalNameNodeName, Name); +end; + +class procedure TCS4FormatHelper.WriteSnippetKind(const AXMLDoc: IXMLDocumentEx; + const ASnippetNode: IXMLNode; const AValue: TSnippetKind); +begin + AXMLDoc.CreateElement( + ASnippetNode, SnippetKindNodeName, SnippetKindValues[AValue] + ); +end; + +end. diff --git a/Src/UCodeImportExport.pas b/Src/DB.IO.ImportExport.CS4.pas similarity index 53% rename from Src/UCodeImportExport.pas rename to Src/DB.IO.ImportExport.CS4.pas index b4dfffd29..3ceeccedd 100644 --- a/Src/UCodeImportExport.pas +++ b/Src/DB.IO.ImportExport.CS4.pas @@ -5,12 +5,11 @@ * * Copyright (C) 2008-2025. Peter Johnson (gravatar.com/delphidabbler). * - * Implements classes that can import and export user defined snippets from and - * to XML. + * Implements classes that can import and export snippets from and to XML. } -unit UCodeImportExport; +unit DB.IO.ImportExport.CS4; interface @@ -21,8 +20,11 @@ interface SysUtils, Classes, XMLIntf, + Generics.Collections, // Project - DB.USnippet, + DB.Categories, + DB.SnippetIDs, + DB.Snippets, UBaseObjects, UEncodings, UIStringList, @@ -34,8 +36,8 @@ interface /// Encapsulates data that describes a snippet that has been read /// from an import file. TSnippetInfo = record - /// Snippet name. - Name: string; + /// Snippet key. + Key: string; /// Description of snippet. Data: TSnippetEditData; /// Copies given TSnippetInfo record to this one. @@ -49,13 +51,20 @@ TSnippetInfo = record TSnippetInfoList = array of TSnippetInfo; type - /// Imports code snippets from XML. - TCodeImporter = class(TNoPublicConstructObject) + /// Imports code snippets from CodeSnip 4 import/export format + /// files. + TCS4SnippetImporter = class(TNoPublicConstructObject) strict private - /// Version of file being imported. - fVersion: Integer; - /// List of snippets read from XML. - fSnippetInfo: TSnippetInfoList; + const + {TODO -cVault: Let user select or create a category rather than imposing + this one} + /// ID of category used to import snippets. + ImportCatID = 'imports'; + var + /// Version of file being imported. + fVersion: Integer; + /// List of snippets read from XML. + fSnippetInfo: TSnippetInfoList; /// Extended XML document object. fXMLDoc: IXMLDocumentEx; /// Retrieves a list of all snippet nodes from XML document. @@ -69,9 +78,13 @@ TCodeImporter = class(TNoPublicConstructObject) /// /// ECodeImporter raised if XML is not valid. function ValidateDoc: Integer; + /// Checks if the special import category exists and creates it if + /// not. + class procedure EnsureImportCategoryExists; /// Constructs and initialises object ready to perform import. /// constructor InternalCreate; + public /// Destroys object. destructor Destroy; override; @@ -84,15 +97,17 @@ TCodeImporter = class(TNoPublicConstructObject) end; type - /// Class of exception raised when TCodeImporter encounters invalid - /// XML. - ECodeImporter = class(ECodeSnipXML); + /// Class of exception raised when TCS4SnippetImporter + /// encounters invalid XML. + ECS4SnippetImporter = class(ECodeSnipXML); type - /// Exports code snippets to XML. - TCodeExporter = class(TNoPublicConstructObject) + /// Exports code snippets to CodeSnip 4 import/export format file + /// + TCS4SnippetExporter = class(TNoPublicConstructObject) strict private var + fSnippetKeyMap: TDictionary; /// List of snippets to be exported. fSnippets: TSnippetList; /// Extended XML document object. @@ -102,8 +117,11 @@ TCodeExporter = class(TNoPublicConstructObject) /// /// An exception is always raised. procedure HandleException(const EObj: TObject); - /// Returns a list of snippet names from snippets list. - function SnippetNames(const SnipList: TSnippetList): IStringList; + /// Returns a list of snippet keys for each snippet in + /// SnipList. Returned keys are found by looking up the new key + /// corresponding to the snippet's original key in fSnippetKeyMap. + /// + function SnippetKeys(const SnipList: TSnippetList): IStringList; /// Writes a XML node that contains a list of pascal names. /// /// IXMLNode [in] Node under which this name list @@ -151,9 +169,9 @@ TCodeExporter = class(TNoPublicConstructObject) end; type - /// Class of exception raised when TCodeExporter detects an expected - /// error. - ECodeExporter = class(ECodeSnipXML); + /// Class of exception raised when TCS4SnippetExporter + /// detects an expected error. + ECS4SnippetExporter = class(ECodeSnipXML); implementation @@ -165,33 +183,40 @@ implementation XMLDom, // Project ActiveText.UMain, - DB.UMain, - DB.USnippetKind, + DB.Main, + DB.SnippetKind, + DB.Vaults, + DB.IO.Common.CS4, UAppInfo, - UReservedCategories, USnippetExtraHelper, - USnippetIDs, UStructs, - UXMLDocConsts; + UStrUtils; +type + TCS4ImportExportDocHelper = class(TCS4FormatHelper) + public + const + // watermark (never changes for all versions) + Watermark = 'B46969D4-D367-4F5F-833E-F165FBA78631'; + // file version numbers + EarliestVersion = 1; // earliest file version supported by importer + LatestVersion = 8; // current file version written by exporter + // XML node names + ExportRootNodeName = 'codesnip-export'; + ProgVersionNodeName = 'prog-version'; + SourceCodeTextNodeName= 'source-code-text'; + end; -const - // XML file markers: attributes of root node - // watermark (never changes for all versions) - cWatermark = 'B46969D4-D367-4F5F-833E-F165FBA78631'; - // file version numbers - cEarliestVersion = 1; // earliest file version supported by importer - cLatestVersion = 8; // current file version written by exporter - -{ TCodeExporter } +{ TCS4SnippetExporter } -destructor TCodeExporter.Destroy; +destructor TCS4SnippetExporter.Destroy; begin + fSnippetKeyMap.Free; fXMLDoc := nil; inherited; end; -function TCodeExporter.Execute: TEncodedData; +function TCS4SnippetExporter.Execute: TEncodedData; var RootNode: IXMLNode; // document root node resourcestring @@ -199,15 +224,18 @@ function TCodeExporter.Execute: TEncodedData; sFileComment = 'This file was generated by CodeSnip. Do not edit.'; begin // Create and configure XML document - fXMLDoc := TXMLDocHelper.CreateXMLDoc; + fXMLDoc := TCS4ImportExportDocHelper.CreateXMLDoc; try fXMLDoc.Active := True; // Add XML root nodes - TXMLDocHelper.CreateXMLProcInst(fXMLDoc); - TXMLDocHelper.CreateComment(fXMLDoc, sFileComment); - RootNode := TXMLDocHelper.CreateRootNode( - fXMLDoc, cExportRootNode, cWatermark, cLatestVersion + TCS4ImportExportDocHelper.CreateXMLProcInst(fXMLDoc); + TCS4ImportExportDocHelper.CreateComment(fXMLDoc, sFileComment); + RootNode := TCS4ImportExportDocHelper.CreateRootNode( + fXMLDoc, + TCS4ImportExportDocHelper.ExportRootNodeName, + TCS4ImportExportDocHelper.Watermark, + TCS4ImportExportDocHelper.LatestVersion ); // Write document content @@ -222,10 +250,10 @@ function TCodeExporter.Execute: TEncodedData; end; end; -class function TCodeExporter.ExportSnippets(const SnipList: TSnippetList): +class function TCS4SnippetExporter.ExportSnippets(const SnipList: TSnippetList): TEncodedData; var - Instance: TCodeExporter; + Instance: TCS4SnippetExporter; begin Instance := InternalCreate(SnipList); try @@ -235,129 +263,191 @@ class function TCodeExporter.ExportSnippets(const SnipList: TSnippetList): end; end; -procedure TCodeExporter.HandleException(const EObj: TObject); +procedure TCS4SnippetExporter.HandleException(const EObj: TObject); begin if (EObj is EFileStreamError) or (EObj is ECodeSnipXML) then - raise ECodeExporter.Create(EObj as Exception); + raise ECS4SnippetExporter.Create(EObj as Exception); raise EObj; end; -constructor TCodeExporter.InternalCreate(const SnipList: TSnippetList); +constructor TCS4SnippetExporter.InternalCreate(const SnipList: TSnippetList); +var + Snippet: TSnippet; begin inherited InternalCreate; fSnippets := SnipList; + fSnippetKeyMap := TDictionary.Create( + TSnippetID.TComparer.Create + ); + // Create map of actual snippet ID to new unique key with default vault + for Snippet in SnipList do + fSnippetKeyMap.Add( + Snippet.ID, Database.GetUniqueSnippetKey(TVaultID.Default) + ); end; -function TCodeExporter.SnippetNames( - const SnipList: TSnippetList): IStringList; +function TCS4SnippetExporter.SnippetKeys(const SnipList: TSnippetList): + IStringList; var Snippet: TSnippet; // references each snippet in list begin Result := TIStringList.Create; for Snippet in SnipList do - Result.Add(Snippet.Name); + if fSnippetKeyMap.ContainsKey(Snippet.ID) then + Result.Add(fSnippetKeyMap[Snippet.ID]); end; -procedure TCodeExporter.WriteProgInfo(const ParentNode: IXMLNode); +procedure TCS4SnippetExporter.WriteProgInfo(const ParentNode: IXMLNode); begin fXMLDoc.CreateElement( - ParentNode, cProgVersionNode, TAppInfo.ProgramReleaseVersion + ParentNode, + TCS4ImportExportDocHelper.ProgVersionNodeName, + TAppInfo.ProgramReleaseVersion ); end; -procedure TCodeExporter.WriteReferenceList(const ParentNode: IXMLNode; +procedure TCS4SnippetExporter.WriteReferenceList(const ParentNode: IXMLNode; const ListNodeName: string; PasNames: IStringList); begin // Don't write list tags if no items if PasNames.Count = 0 then Exit; // Write the list - TXMLDocHelper.WritePascalNameList( + TCS4ImportExportDocHelper.WritePascalNameList( fXMLDoc, ParentNode, ListNodeName, PasNames ); end; -procedure TCodeExporter.WriteSnippet(const ParentNode: IXMLNode; +procedure TCS4SnippetExporter.WriteSnippet(const ParentNode: IXMLNode; const Snippet: TSnippet); var SnippetNode: IXMLNode; // new snippet node begin - // Create snippet node with attribute that specifies snippet name - SnippetNode := fXMLDoc.CreateElement(ParentNode, cSnippetNode); - SnippetNode.Attributes[cSnippetNameAttr] := Snippet.Name; + // Create snippet node with attribute that specifies snippet key. + // Snippet is exported under a new, unique key within the Default vault. + // Since no vault information is saved, we need choose one vault in order + // to generate the key, and the Default vault is the only one guaranteed to be + // present. + SnippetNode := fXMLDoc.CreateElement( + ParentNode, TCS4ImportExportDocHelper.SnippetNodeName + ); + SnippetNode.Attributes[ + TCS4ImportExportDocHelper.SnippetNodeNameAttr + ] := fSnippetKeyMap[Snippet.ID]; // Add nodes for properties: (ignore category and xrefs) // description node is written even if empty (which it shouldn't be) fXMLDoc.CreateElement( SnippetNode, - cDescriptionNode, + TCS4ImportExportDocHelper.DescriptionNodeName, TSnippetExtraHelper.BuildREMLMarkup(Snippet.Description) ); - // Snippet's display name is only written if different to Snippet's name - if Snippet.Name <> Snippet.DisplayName then - fXMLDoc.CreateElement(SnippetNode, cDisplayNameNode, Snippet.DisplayName); + // Snippet's display name always written: if display name is specified we use + // it, otherwise we use the original snippet key. + if not StrIsEmpty(Snippet.DisplayName, True) then + fXMLDoc.CreateElement( + SnippetNode, + TCS4ImportExportDocHelper.DisplayNameNodeName, + Snippet.DisplayName + ) + else + fXMLDoc.CreateElement( + SnippetNode, TCS4ImportExportDocHelper.DisplayNameNodeName, Snippet.Key + ); // source code is stored directly in XML, not in external file - fXMLDoc.CreateElement(SnippetNode, cSourceCodeTextNode, Snippet.SourceCode); + fXMLDoc.CreateElement( + SnippetNode, + TCS4ImportExportDocHelper.SourceCodeTextNodeName, + Snippet.SourceCode + ); // write highlight source flag + {TODO -cRefactor: Move following method call into TCS4FormatHelper} fXMLDoc.CreateElement( - SnippetNode, cHighlightSource, IntToStr(Ord(Snippet.HiliteSource)) + SnippetNode, + TCS4ImportExportDocHelper.HighlightSourceNodeName, + IntToStr(Ord(Snippet.HiliteSource)) ); + {TODO -cRefactor: Move code that writes Extra into TCS4FormatHelper} // extra info is written only if present if Snippet.Extra.HasContent then fXMLDoc.CreateElement( SnippetNode, - cExtraNode, + TCS4ImportExportDocHelper.ExtraNodeName, TSnippetExtraHelper.BuildREMLMarkup(Snippet.Extra) ); // write kind - TXMLDocHelper.WriteSnippetKind(fXMLDoc, SnippetNode, Snippet.Kind); + TCS4ImportExportDocHelper.WriteSnippetKind(fXMLDoc, SnippetNode, Snippet.Kind); // compiler results value: only write known results - TXMLDocHelper.WriteCompilerResults( + TCS4ImportExportDocHelper.WriteCompilerResults( fXMLDoc, SnippetNode, Snippet.Compatibility ); // depends and units lists + {TODO -cRefactor: Pull writing Depends node into TCS4FormatHelper} WriteReferenceList( - SnippetNode, cDependsNode, SnippetNames(Snippet.Depends) + SnippetNode, + TCS4ImportExportDocHelper.DependsNodeName, + SnippetKeys(Snippet.Depends) ); WriteReferenceList( - SnippetNode, cUnitsNode, TIStringList.Create(Snippet.Units) + SnippetNode, + TCS4ImportExportDocHelper.UnitsNodeName, + TIStringList.Create(Snippet.Units) ); end; -procedure TCodeExporter.WriteSnippets(const ParentNode: IXMLNode); +procedure TCS4SnippetExporter.WriteSnippets(const ParentNode: IXMLNode); var Node: IXMLNode; // new snippets list node Snippet: TSnippet; // refers to each exported snippet begin // Add snippets list node - Node := fXMLDoc.CreateElement(ParentNode, cSnippetsNode); + Node := fXMLDoc.CreateElement( + ParentNode, TCS4ImportExportDocHelper.SnippetsNodeName + ); // Add child node for each exported snippet for Snippet in fSnippets do WriteSnippet(Node, Snippet); end; -{ TCodeImporter } +{ TCS4SnippetImporter } -destructor TCodeImporter.Destroy; +destructor TCS4SnippetImporter.Destroy; begin fXMLDoc := nil; OleUninitialize; inherited; end; -procedure TCodeImporter.Execute(const Data: TBytes); +class procedure TCS4SnippetImporter.EnsureImportCategoryExists; +resourcestring + ImportCatDesc = 'Imported Snippets'; +var + ImportCatData: TCategoryData; +begin + if not Assigned(Database.Categories.Find(ImportCatID)) then + begin + ImportCatData.Init; + ImportCatData.Desc := ImportCatDesc; + Database.AddCategory(ImportCatID, ImportCatData); + end; +end; + +procedure TCS4SnippetImporter.Execute(const Data: TBytes); /// Reads list of units from under SnippetNode into Units list. procedure GetUnits(const SnippetNode: IXMLNode; Units: IStringList); var UnitNode: IXMLNode; // unit list node: nil if no list begin - UnitNode := fXMLDoc.FindFirstChildNode(SnippetNode, cUnitsNode); + UnitNode := fXMLDoc.FindFirstChildNode( + SnippetNode, TCS4ImportExportDocHelper.UnitsNodeName + ); Units.Clear; - TXMLDocHelper.GetPascalNameList(fXMLDoc, UnitNode, Units); + TCS4ImportExportDocHelper.GetPascalNameList(fXMLDoc, UnitNode, Units); end; /// Reads list of a snippet's required snippets from under SnippetNode into /// Depends list. + {TODO -cRefactor: Pull reading Depends node into TCS4FormatHelper ???} procedure GetDepends(const SnippetNode: IXMLNode; const Depends: ISnippetIDList); var @@ -365,14 +455,16 @@ procedure TCodeImporter.Execute(const Data: TBytes); SnippetNames: IStringList; // list of names of snippets in depends list SnippetName: string; // each snippet name in SnippetNames begin - DependsNode := fXMLDoc.FindFirstChildNode(SnippetNode, cDependsNode); + DependsNode := fXMLDoc.FindFirstChildNode( + SnippetNode, TCS4ImportExportDocHelper.DependsNodeName + ); SnippetNames := TIStringList.Create; - TXMLDocHelper.GetPascalNameList(fXMLDoc, DependsNode, SnippetNames); + TCS4ImportExportDocHelper.GetPascalNameList(fXMLDoc, DependsNode, SnippetNames); Depends.Clear; for SnippetName in SnippetNames do - // Note: in building snippet ID list we assume each snippet is user- - // defined. It may not be, but there is no way of telling from XML. - Depends.Add(TSnippetID.Create(SnippetName, True)); + // Note: in building snippet ID list we assume each snippet is from the + // default vault. It may not be, but there is no way of telling from XML. + Depends.Add(TSnippetID.Create(SnippetName, TVaultID.Default)); end; // Reads description node and converts to active text. @@ -380,7 +472,9 @@ procedure TCodeImporter.Execute(const Data: TBytes); var Desc: string; // text read from description node begin - Desc := TXMLDocHelper.GetSubTagText(fXMLDoc, SnippetNode, cDescriptionNode); + Desc := TCS4ImportExportDocHelper.GetSubTagText( + fXMLDoc, SnippetNode, TCS4ImportExportDocHelper.DescriptionNodeName + ); if Desc <> '' then begin if fVersion < 6 then @@ -417,33 +511,45 @@ procedure TCodeImporter.Execute(const Data: TBytes); begin // Read a snippet node SnippetNode := SnippetNodes[Idx]; - fSnippetInfo[Idx].Name := SnippetNode.Attributes[cSnippetNameAttr]; - fSnippetInfo[Idx].Data := - (Database as IDatabaseEdit).GetEditableSnippetInfo; - fSnippetInfo[Idx].Data.Props.Cat := TReservedCategories.ImportsCatID; + fSnippetInfo[Idx].Key := SnippetNode.Attributes[ + TCS4ImportExportDocHelper.SnippetNodeNameAttr + ]; + fSnippetInfo[Idx].Data := Database.GetEditableSnippetInfo; + fSnippetInfo[Idx].Data.Props.Cat := ImportCatID; fSnippetInfo[Idx].Data.Props.Desc := GetDescription(SnippetNode); - fSnippetInfo[Idx].Data.Props.DisplayName := TXMLDocHelper.GetSubTagText( - fXMLDoc, SnippetNode, cDisplayNameNode - ); - fSnippetInfo[Idx].Data.Props.SourceCode := TXMLDocHelper.GetSubTagText( - fXMLDoc, SnippetNode, cSourceCodeTextNode - ); - fSnippetInfo[Idx].Data.Props.HiliteSource := TXMLDocHelper.GetHiliteSource( - fXMLDoc, SnippetNode, True - ); + fSnippetInfo[Idx].Data.Props.DisplayName := + TCS4ImportExportDocHelper.GetSubTagText( + fXMLDoc, SnippetNode, TCS4ImportExportDocHelper.DisplayNameNodeName + ); + if fSnippetInfo[Idx].Data.Props.DisplayName = '' then + fSnippetInfo[Idx].Data.Props.DisplayName := fSnippetInfo[Idx].Key; + fSnippetInfo[Idx].Data.Props.SourceCode := + TCS4ImportExportDocHelper.GetSubTagText( + fXMLDoc, SnippetNode, TCS4ImportExportDocHelper.SourceCodeTextNodeName + ); + fSnippetInfo[Idx].Data.Props.HiliteSource := + TCS4ImportExportDocHelper.GetHiliteSource(fXMLDoc, SnippetNode, True); // how we read extra property depends on version of file case fVersion of 1: fSnippetInfo[Idx].Data.Props.Extra := TSnippetExtraHelper.BuildActiveText( - TXMLDocHelper.GetSubTagText(fXMLDoc, SnippetNode, cCommentsNode), - TXMLDocHelper.GetSubTagText(fXMLDoc, SnippetNode, cCreditsNode), - TXMLDocHelper.GetSubTagText(fXMLDoc, SnippetNode, cCreditsUrlNode) + TCS4ImportExportDocHelper.GetSubTagText( + fXMLDoc, SnippetNode, TCS4ImportExportDocHelper.CommentsNodeName + ), + TCS4ImportExportDocHelper.GetSubTagText( + fXMLDoc, SnippetNode, TCS4ImportExportDocHelper.CreditsNodeName + ), + TCS4ImportExportDocHelper.GetSubTagText( + fXMLDoc, SnippetNode, TCS4ImportExportDocHelper.CreditsUrlNodeName + ) ); else // later versions fSnippetInfo[Idx].Data.Props.Extra := TSnippetExtraHelper.BuildActiveText( - TXMLDocHelper.GetSubTagText(fXMLDoc, SnippetNode, cExtraNode) + TCS4ImportExportDocHelper.GetSubTagText( + fXMLDoc, SnippetNode, TCS4ImportExportDocHelper.ExtraNodeName + ) ); end; // how we read kind property depends on version of file @@ -451,18 +557,18 @@ procedure TCodeImporter.Execute(const Data: TBytes); 1, 2: // for version 1 and 2, we have StandardFormat instead of Kind: // map standard format value onto a kind - if TXMLDocHelper.GetStandardFormat(fXMLDoc, SnippetNode, False) then + if TCS4ImportExportDocHelper.GetStandardFormat(fXMLDoc, SnippetNode, False) then fSnippetInfo[Idx].Data.Props.Kind := skRoutine else fSnippetInfo[Idx].Data.Props.Kind := skFreeform; else // later versions // for later versions we have Kind value: use Freeform if missing - fSnippetInfo[Idx].Data.Props.Kind := TXMLDocHelper.GetSnippetKind( + fSnippetInfo[Idx].Data.Props.Kind := TCS4ImportExportDocHelper.GetSnippetKind( fXMLDoc, SnippetNode, skFreeForm ); end; fSnippetInfo[Idx].Data.Props.CompilerResults := - TXMLDocHelper.GetCompilerResults( + TCS4ImportExportDocHelper.GetCompilerResults( fXMLDoc, SnippetNode ); GetUnits(SnippetNode, fSnippetInfo[Idx].Data.Refs.Units); @@ -471,27 +577,33 @@ procedure TCodeImporter.Execute(const Data: TBytes); end; except on E: EDOMParseError do - raise ECodeImporter.Create(sParseError); + raise ECS4SnippetImporter.Create(sParseError); on E: ECodeSnipXML do - raise ECodeImporter.Create(E); + raise ECS4SnippetImporter.Create(E); else raise; end; end; -function TCodeImporter.GetAllSnippetNodes: IXMLSimpleNodeList; +function TCS4SnippetImporter.GetAllSnippetNodes: IXMLSimpleNodeList; var SnippetsNode: IXMLNode; // node under which all snippets are stored begin - SnippetsNode := fXMLDoc.FindNode(cExportRootNode + '\' + cSnippetsNode); - Result := fXMLDoc.FindChildNodes(SnippetsNode, cSnippetNode); + SnippetsNode := fXMLDoc.FindNode( + TCS4ImportExportDocHelper.ExportRootNodeName + + '\' + + TCS4ImportExportDocHelper.SnippetsNodeName + ); + Result := fXMLDoc.FindChildNodes( + SnippetsNode, TCS4ImportExportDocHelper.SnippetNodeName + ); end; -class procedure TCodeImporter.ImportData(out SnippetInfo: TSnippetInfoList; - const Data: TBytes); +class procedure TCS4SnippetImporter.ImportData( + out SnippetInfo: TSnippetInfoList; const Data: TBytes); var Idx: Integer; // loops through all imported snippets - Instance: TCodeImporter; + Instance: TCS4SnippetImporter; begin Instance := InternalCreate; try @@ -504,17 +616,16 @@ class procedure TCodeImporter.ImportData(out SnippetInfo: TSnippetInfoList; end; end; -constructor TCodeImporter.InternalCreate; +constructor TCS4SnippetImporter.InternalCreate; begin inherited InternalCreate; - // Set up XML document that will read data OleInitialize(nil); - fXMLDoc := TXMLDocHelper.CreateXMLDoc; - // Initialise fields that receive imported data + fXMLDoc := TCS4ImportExportDocHelper.CreateXMLDoc; SetLength(fSnippetInfo, 0); + EnsureImportCategoryExists; end; -function TCodeImporter.ValidateDoc: Integer; +function TCS4SnippetImporter.ValidateDoc: Integer; var SnippetsNode: IXMLNode; // node where snippets are recorded SnippetNodes: IXMLSimpleNodeList; // list of nodes describing snippets @@ -522,34 +633,46 @@ function TCodeImporter.ValidateDoc: Integer; // Error message sMissingNode = 'Invalid document: no <%s> node present'; begin - TXMLDocHelper.ValidateProcessingInstr(fXMLDoc); - Result := TXMLDocHelper.ValidateRootNode( + TCS4ImportExportDocHelper.ValidateProcessingInstr(fXMLDoc); + Result := TCS4ImportExportDocHelper.ValidateRootNode( fXMLDoc, - cExportRootNode, - cWatermark, - TRange.Create(cEarliestVersion, cLatestVersion) + TCS4ImportExportDocHelper.ExportRootNodeName, + TCS4ImportExportDocHelper.Watermark, + TRange.Create( + TCS4ImportExportDocHelper.EarliestVersion, TCS4ImportExportDocHelper.LatestVersion + ) ); // Must be a snippets node - SnippetsNode := fXMLDoc.FindNode(cExportRootNode + '\' + cSnippetsNode); + SnippetsNode := fXMLDoc.FindNode( + TCS4ImportExportDocHelper.ExportRootNodeName + + '\' + + TCS4ImportExportDocHelper.SnippetsNodeName + ); if not Assigned(SnippetsNode) then - raise ECodeImporter.CreateFmt(sMissingNode, [cSnippetsNode]); + raise ECS4SnippetImporter.CreateFmt( + sMissingNode, [TCS4ImportExportDocHelper.SnippetsNodeName] + ); // Must be at least one snippet node - SnippetNodes := fXMLDoc.FindChildNodes(SnippetsNode, cSnippetNode); + SnippetNodes := fXMLDoc.FindChildNodes( + SnippetsNode, TCS4ImportExportDocHelper.SnippetNodeName + ); if SnippetNodes.Count = 0 then - raise ECodeImporter.CreateFmt(sMissingNode, [cSnippetNode]); + raise ECS4SnippetImporter.CreateFmt( + sMissingNode, [TCS4ImportExportDocHelper.SnippetNodeName] + ); end; { TSnippetInfo } procedure TSnippetInfo.Assign(const Src: TSnippetInfo); begin - Name := Src.Name; + Key := Src.Key; Data.Assign(Src.Data); end; procedure TSnippetInfo.Init; begin - Name := ''; + Key := ''; Data.Init; end; diff --git a/Src/DB.IO.Manager.pas b/Src/DB.IO.Manager.pas new file mode 100644 index 000000000..99ef8177b --- /dev/null +++ b/Src/DB.IO.Manager.pas @@ -0,0 +1,937 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2008-2021, Peter Johnson (gravatar.com/delphidabbler). + * + * Manages loading and saving the entire database using the various supported + * data formats. +} + + +unit DB.IO.Manager; + + +interface + + +uses + // Project + DB.Categories, + DB.Main, + DB.Snippets, + DB.Vaults, + UBaseObjects, + UExceptions; + + +type + + /// Interface to objects that can load data into a vault within the + /// database from storage in a supported data format. + IVaultLoader = interface(IInterface) + ['{C6AF94FC-F56F-44AE-9E79-3B0CD0BB21D4}'] + /// Loads data from storage into a vault within the database. + /// + /// TSnippetList [in] Receives information + /// about each snippet in the vault. + /// TCategoryList [in] Receives information + /// about each category in the vault. + /// DBDataItemFactory [in] Object + /// used to create new categories and snippets. + procedure Load(const SnipList: TSnippetList; + const Categories: TCategoryList; + const DBDataItemFactory: IDBDataItemFactory); + end; + + /// Interface to objects that can save data from a vault within the + /// database into storage in a supported data format. + IVaultSaver = interface(IInterface) + ['{F46EE2E3-68A7-4877-9E04-192D15D29BB1}'] + /// Saves data to storage. + /// TSnippetList [in] Contains information + /// about each snippet to be saved. + /// TCategoryList [in] Contains information + /// about each category to be saved. + /// IDBDataProvider [in] Object used to + /// obtain details of the data to be stored. + procedure Save(const SnipList: TSnippetList; + const Categories: TCategoryList; const Provider: IDBDataProvider); + end; + + /// Interface to object that can save global category information, + /// regardless of any categories saved with vaults. + IGlobalCategoryLoader = interface(IInterface) + ['{0029F641-FAC4-43C8-A412-F70554BDCF28}'] + /// Loads categories data from global storage. + /// TCategoryList [in] Receives information + /// about each category loaded. + /// IDBDataItemFactory [in] Object + /// used to create new categories. + procedure Load(const Categories: TCategoryList; + const DBDataItemFactory: IDBDataItemFactory); + end; + + /// Interface to object that can load global category information, + /// regardless of any categories loaded with vaults. + IGlobalCategorySaver = interface(IInterface) + ['{D967E4FC-32FA-47F8-9BE0-4B25C7215CCA}'] + /// Saves category data to global storage. + /// TCategoryList [in] Contains information + /// about each category to be saved. + procedure Save(const Categories: TCategoryList); + end; + + /// Factory class that can create instances of objects that can be + /// used to load and save vaults and global category information into and + /// from the database. + TDatabaseIOFactory = class(TNoConstructObject) + public + /// Creates and returns an object to be used to load the given + /// vault's data in the correct format. Nil is returned if no loader object + /// is supported. + class function CreateVaultLoader(const AVault: TVault): IVaultLoader; + + /// Creates and returns an object to be used to save the given + /// vaults's data in the correct format. Nil is return if no saver object + /// is supported. + class function CreateVaultSaver(const AVault: TVault): IVaultSaver; + + /// Creates and returns an object to be used to load a list of + /// globally stored categories. + class function CreateGlobalCategoryLoader: IGlobalCategoryLoader; + + /// Creates and returns an object to be used to save a list of + /// categories to global storage. + class function CreateGlobalCategorySaver: IGlobalCategorySaver; + + end; + + /// Class of exception raised by TVaultLoader objects. + /// + EVaultLoader = class(ECodeSnip); + + +implementation + + +uses + // Delphi + SysUtils, + Generics.Collections, + IOUtils, + // Project + DB.DataFormats, + DB.IO.Vault.CS4, + DB.IO.Vault.DCSCv2, + DB.IO.Vault.Native, + DB.IO.Vault, + DB.IO.Vault.Null, + DB.IO.Categories, + DB.SnippetIDs, + UAppInfo, + UConsts, + UIStringList, + VaultBackup; + + +type + + {TODO -cRefactoring: Would a better method be to have a single TVaultLoader + class that is passed a reader object in its constructor, + rather than have sub-classes that simply create the + required reader object?} + + /// Abstract base class for objects that can load data from storage + /// into a vault within the database. + TVaultLoader = class abstract (TInterfacedObject, IVaultLoader) + strict private + fReader: IVaultStorageReader; // Object used to read data from storage + fSnipList: TSnippetList; // Receives list of snippets + fCategories: TCategoryList; // Receives list of categories + fFactory: IDBDataItemFactory; // Object creates new categories and snippets + fVault: TVault; // Vault being loaded + procedure LoadSnippets(const Cat: TCategory); + {Loads all snippets in a category. + @param Cat [in] Category to be loaded. + } + procedure LoadReferences(const Snippet: TSnippet); + {Loads all of a snippet's references. + @param Snippet [in] Snippet for which references are required. + } + procedure HandleException(const E: Exception); + {Handles exceptions generated by loader and converts ECodeSnip and + descendant exceptions into EDatabaseLoader exceptions. + @param E [in] Exception to be handled. + @except Exception always raised. + } + strict protected + function CreateReader: IVaultStorageReader; virtual; abstract; + {Creates reader object for the database. If database doesn't exist a nul + reader must be created. + @return Reader object instance. + } + function FindSnippet(const SnippetKey: string; + const SnipList: TSnippetList): TSnippet; virtual; + {Finds the snippet object with a specified key. + @param SnippetKey [in] Key of required snippet. + @param SnipList [in] List of snippets to search. + @return Reference to required snippet object or nil if snippet is not + found. + } + function IsNativeSnippet(const Snippet: TSnippet): Boolean; virtual; + {Checks if a snippet is native (belongs) to the database being read. + @param Snippet [in] Snippet to test. + @return True if snippet is native, False if not. + } + function ErrorMessageHeading: string; virtual; abstract; + {Returns heading to use in error messages. Should identify the database. + @return Required heading. + } + procedure LoadCategories; + {Loads all categories from storage. + } + procedure CreateCategory(const CatID: string; const CatData: TCategoryData); + {Creates a new category and adds it to the categories list. + @param CatID [in] ID of category. + @param CatData [in] Properties of category. + } + property Categories: TCategoryList read fCategories; + {Reference to category list} + /// The vault being loaded. + property Vault: TVault read fVault; + public + constructor Create(const AVault: TVault); + { IVaultLoader method } + procedure Load(const SnipList: TSnippetList; + const Categories: TCategoryList; + const DBDataItemFactory: IDBDataItemFactory); + {Loads data from storage and updates database object. + @param SnipList [in] Receives information about each snippet in the + database. + @param Categories [in] Receives information about each category in the + database. + @param DBDataItemFactory [in] Object used to create new categories and + snippets. + } + end; + + /// Class that loads data into the database from a vault stored in + /// DelphiDabbler Code Snippets Collection v2 data format. + TDCSCV2VaultLoader = class sealed (TVaultLoader, IVaultLoader) + strict protected + function CreateReader: IVaultStorageReader; override; + {Creates reader object. If main database doesn't exist a nul reader is + created. + @return Reader object instance. + } + function ErrorMessageHeading: string; override; + {Returns heading to use in error messages. Identifies main database. + @return Required heading. + } + end; + + /// Class that loads data into the database from a vault stored in + /// CodeSnip 4 user data format. + TCS4VaultLoader = class sealed (TVaultLoader, IVaultLoader) + strict protected + function CreateReader: IVaultStorageReader; override; + {Creates reader object. If user database doesn't exist a nul reader is + created. + @return Reader object instance. + } + function ErrorMessageHeading: string; override; + {Returns heading to use in error messages. Identifies main database. + @return Required heading. + } + end; + + /// Class that loads data into the database from a vault stored in + /// the native CodeSnip Vault data format. + TNativeVaultLoader = class sealed (TVaultLoader, IVaultLoader) + strict protected + function CreateReader: IVaultStorageReader; override; + {Creates reader object. If user database doesn't exist a nul reader is + created. + @return Reader object instance. + } + function ErrorMessageHeading: string; override; + {Returns heading to use in error messages. Identifies main database. + @return Required heading. + } + end; + + {TODO -cRefactoring: Would a better method be to have a single TVaultSaver + class that is passed a writer object in its constructor, + rather than have sub-classes that simply create the + required writer object? + Would need to make sure all .Save methods in sub-classes + are identical first. } + + /// Abstract base class for objects that can save data to storage + /// from a vault within the database. + TVaultSaver = class abstract (TInterfacedObject, + IVaultSaver + ) + strict private + var + fWriter: IVaultStorageWriter; // Object used to write to storage + fSnipList: TSnippetList; // List of snippets to be written + fCategories: TCategoryList; // List of categories to be written + fProvider: IDBDataProvider; // Object used to get data to be written + fVault: TVault; // Vault being saved + + /// Writes information about all snippets belonging to the + /// vault being saved. + procedure WriteSnippets; + + /// Writes information about categories relevant to the + /// vault. + procedure WriteCategories; + + /// Writes the vault's meta data, if supported. + procedure WriteMetaData; + + strict protected + + /// Saves vault to storage. + /// TSnippetList [in] List of all snippets + /// in the database. + /// TCategoryList [in] List of all + /// categories in the database. + /// IDBDataProvider [in] Object used to + /// obtain details of the data to be stored. + procedure DoSave(const SnipList: TSnippetList; + const Categories: TCategoryList; const Provider: IDBDataProvider + ); + + /// Creates an object that can write data to storage in the + /// required format. + /// IVaultStorageWriter. Required writer object. + function CreateWriter: IVaultStorageWriter; virtual; abstract; + + /// Vault being saved. + property Vault: TVault read fVault; + + public + /// Creates object that can save the given vault. + constructor Create(const AVault: TVault); + + /// Saves data to storage. + /// TSnippetList [in] List of all snippets + /// in the database. + /// TCategoryList [in] List of all + /// categories in the database. + /// IDBDataProvider [in] Object used to + /// obtain details of the data to be stored. + /// Method of IVaultSaver. + procedure Save(const SnipList: TSnippetList; + const Categories: TCategoryList; const Provider: IDBDataProvider); + virtual; abstract; + end; + + /// Class used to write data from a vault to storage using the + /// DelphiDabbler Code Snippets v2 data format. + TDCSCV2VaultSaver = class sealed (TVaultSaver, + IVaultSaver + ) + strict private + var + fBakFile: string; // Backup file used in case of failure + /// Backup current data. + procedure Backup; + /// Restore current data. + procedure Restore; + strict protected + /// Creates an object that can write data to storage in + /// DelphiDabbler Code Snippets v2 data format. + /// IVaultStorageWriter. Required writer object. + function CreateWriter: IVaultStorageWriter; override; + public + /// Creates object that can save the given vault. + constructor Create(const AVault: TVault); + /// Saves data to storage. + /// TSnippetList [in] List of all snippets + /// in the database. + /// TCategoryList [in] List of all + /// categories in the database. + /// IDBDataProvider [in] Object used to + /// obtain details of the data to be stored. + /// Method of IVaultSaver. + procedure Save(const SnipList: TSnippetList; + const Categories: TCategoryList; const Provider: IDBDataProvider); + override; + end; + + /// Class used to write data from a vault to storage using the + /// CodeSnip 4 user data format. + TCS4VaultSaver = class sealed (TVaultSaver, + IVaultSaver + ) + strict protected + /// Creates an object that can write data to storage in + /// CodeSnip's native v4 data format. + /// IVaultStorageWriter. Required writer object. + function CreateWriter: IVaultStorageWriter; override; + public + /// Saves data to storage. + /// TSnippetList [in] List of all snippets + /// in the database. + /// TCategoryList [in] List of all + /// categories in the database. + /// IDBDataProvider [in] Object used to + /// obtain details of the data to be stored. + /// Method of IVaultSaver. + procedure Save(const SnipList: TSnippetList; + const Categories: TCategoryList; const Provider: IDBDataProvider); + override; + end; + + /// Class that saves data from a vault within the database to + /// storage using the native CodeSnip Vault data format. + TNativeVaultSaver = class sealed (TVaultSaver, + IVaultSaver + ) + strict protected + /// Creates an object that can write data to storage in + /// CodeSnip's native v4 data format. + /// IVaultStorageWriter. Required writer object. + function CreateWriter: IVaultStorageWriter; override; + public + /// Saves data to storage. + /// TSnippetList [in] List of all snippets + /// in the database. + /// TCategoryList [in] List of all + /// categories in the database. + /// IDBDataProvider [in] Object used to + /// obtain details of the data to be stored. + /// Method of IVaultSaver. + procedure Save(const SnipList: TSnippetList; + const Categories: TCategoryList; const Provider: IDBDataProvider); + override; + end; + + /// Class used to save global category information, regardless of + /// any categories saved with vaults. + TGlobalCategoryLoader = class(TInterfacedObject, IGlobalCategoryLoader) + public + /// Loads categories data from global storage. + /// TCategoryList [in] Receives information + /// about each category loaded. + /// IDBDataItemFactory [in] Object + /// used to create new categories. + /// Method of IGlobalCategoryLoader. + procedure Load(const Categories: TCategoryList; + const DBDataItemFactory: IDBDataItemFactory); + end; + + /// Class used to save global category information, regardless of + /// any categories saved with vaults. + TGlobalCategorySaver = class(TInterfacedObject, IGlobalCategorySaver) + public + /// Saves category data to global storage. + /// TCategoryList [in] Contains information + /// about each category to be saved. + /// Method of IGlobalCategorySaver. + procedure Save(const Categories: TCategoryList); + end; + +{ TDatabaseIOFactory } + +class function TDatabaseIOFactory.CreateVaultLoader(const AVault: TVault): + IVaultLoader; +begin + case AVault.Storage.Format of + TDataFormatKind.DCSC_v2: + Result := TDCSCV2VaultLoader.Create(AVault); + TDataFormatKind.Native_v4: + Result := TCS4VaultLoader.Create(AVault); + TDataFormatKind.Native_Vault: + Result := TNativeVaultLoader.Create(AVault); + else + Result := nil; + end; +end; + +class function TDatabaseIOFactory.CreateVaultSaver(const AVault: TVault): + IVaultSaver; +begin + case AVault.Storage.Format of + TDataFormatKind.DCSC_v2: + Result := TDCSCV2VaultSaver.Create(AVault); + TDataFormatKind.Native_v4: + Result := TCS4VaultSaver.Create(AVault); + TDataFormatKind.Native_Vault: + Result := TNativeVaultSaver.Create(AVault); + else + Result := nil; + end; +end; + +class function TDatabaseIOFactory.CreateGlobalCategoryLoader: + IGlobalCategoryLoader; +begin + Result := TGlobalCategoryLoader.Create; +end; + +class function TDatabaseIOFactory.CreateGlobalCategorySaver: + IGlobalCategorySaver; +begin + Result := TGlobalCategorySaver.Create; +end; + +{ TVaultLoader } + +constructor TVaultLoader.Create(const AVault: TVault); +begin + inherited Create; + fVault := AVault; +end; + +procedure TVaultLoader.CreateCategory(const CatID: string; + const CatData: TCategoryData); + {Creates a new category and adds it to the categories list. + @param CatID [in] ID of category. + @param CatData [in] Properties of category. + } +begin + fCategories.Add(fFactory.CreateCategory(CatID, CatData)); +end; + +function TVaultLoader.FindSnippet(const SnippetKey: string; + const SnipList: TSnippetList): TSnippet; +begin + Result := SnipList.Find(SnippetKey, Vault.UID); +end; + +procedure TVaultLoader.HandleException(const E: Exception); + {Handles exceptions generated by loader and converts ECodeSnip and descendant + exceptions into EDatabaseLoader exceptions. + @param E [in] Exception to be handled. + @except Exception always raised. + } +begin + if E is ECodeSnip then + // add message header identifying database to existing message + raise EVaultLoader.Create(ErrorMessageHeading + EOL2 + E.Message) + else + raise E; +end; + +function TVaultLoader.IsNativeSnippet(const Snippet: TSnippet): Boolean; +begin + Result := Snippet.VaultID = Vault.UID; +end; + +procedure TVaultLoader.Load(const SnipList: TSnippetList; + const Categories: TCategoryList; const DBDataItemFactory: IDBDataItemFactory); + {Loads data from storage and updates database object. + @param SnipList [in] Receives information about each snippet in the + database. + @param Categories [in] Receives information about each category in the + database. + @param DBDataItemFactory [in] Object used to create new categories and + snippets. + } +var + Category: TCategory; // a category + Snippet: TSnippet; // a snippet +begin + // Create reader object that can access data storage + fReader := CreateReader; + // Record snippets and categories list in fields + // Do not clear snippet or category lists: may already contain data + fSnipList := SnipList; + fCategories := Categories; + fFactory := DBDataItemFactory; + try + // Load categories + LoadCategories; + // Load snippets in each category + for Category in fCategories do + LoadSnippets(Category); + // Build XRef, Depends and Units reference list of each snippet for this + // database + for Snippet in fSnipList do + begin + if IsNativeSnippet(Snippet) then + LoadReferences(Snippet); + end; + // Get vault's meta data + Vault.MetaData := fReader.GetMetaData; + except + on E: Exception do + HandleException(E); + end; +end; + +procedure TVaultLoader.LoadCategories; + {Loads all categories from storage + } +var + CatIDs: IStringList; // list of ids of categories + CatID: string; // name of each category + Category: TCategory; // a category object + CatData: TCategoryData; // properties of a category +begin + // Get name of all categories + CatIDs := fReader.GetAllCatIDs; + // Loop through each category by name + for CatID in CatIDs do + begin + // Check if category exists, creating it if not + Category := fCategories.Find(CatID); + if not Assigned(Category) then + begin + fReader.GetCatProps(CatID, CatData); + CreateCategory(CatID, CatData); + end; + end; +end; + +procedure TVaultLoader.LoadReferences(const Snippet: TSnippet); + {Loads all of a snippet's references. + @param Snippet [in] Snippet for which references are required. + } + + procedure LoadSnippetReferences(const RefList: TSnippetList; + const RefKeys: IStringList); + {Creates a snippet list from keys of snippets in a string list. If no + snippet with a given key is found no matching entry is added to snippet + list. + @param RefList [in] List to receive referenced snippets. + @param RefKeys [in] List of snippet keys. + } + var + RefKey: string; // referenced snippet key + Reference: TSnippet; // referenced snippet object + begin + for RefKey in RefKeys do + begin + Reference := FindSnippet(RefKey, fSnipList); + if Assigned(Reference) then + RefList.Add(Reference); + end; + end; + +begin + LoadSnippetReferences( + Snippet.Depends, fReader.GetSnippetDepends(Snippet.Key) + ); + LoadSnippetReferences( + Snippet.XRef, fReader.GetSnippetXRefs(Snippet.Key) + ); + fReader.GetSnippetUnits(Snippet.Key).CopyTo(Snippet.Units); +end; + +procedure TVaultLoader.LoadSnippets(const Cat: TCategory); + {Loads all snippets in a category. + @param Cat [in] Category to be loaded. + } +var + SnippetKeys: IStringList; // list of keys of snippets in category + SnippetProps: TSnippetData; // properties of a snippet + SnippetKey: string; // each key in key list + Snippet: TSnippet; // references a snippet object +begin + FillChar(SnippetProps, SizeOf(SnippetProps), 0); + // Get keys of all snippets in category + SnippetKeys := fReader.GetCatSnippets(Cat.ID); + // Process each snippet key in list + for SnippetKey in SnippetKeys do + begin + // Check if snippet exists in current database and add it to list if not + Snippet := fSnipList.Find(SnippetKey, Vault.UID); + if not Assigned(Snippet) then + begin + fReader.GetSnippetProps(SnippetKey, SnippetProps); + Snippet := fFactory.CreateSnippet( + SnippetKey, Vault.UID, SnippetProps + ); + fSnipList.Add(Snippet); + end; + // Add snippet to database only if it belongs to this database + if IsNativeSnippet(Snippet) then + Cat.Snippets.Add(Snippet); + end; +end; + +{ TDCSCV2VaultLoader } + +function TDCSCV2VaultLoader.CreateReader: IVaultStorageReader; + {Creates reader object. If main database doesn't exist a nul reader is + created. + @return Reader object instance. + } +begin + Result := TDCSCV2VaultStorageReader.Create(Vault.Storage.Directory); + if not Result.DatabaseExists then + Result := TNullVaultStorageReader.Create; +end; + +function TDCSCV2VaultLoader.ErrorMessageHeading: string; + {Returns heading to use in error messages. Identifies main database. + @return Required heading. + } +resourcestring + sError = 'Error loading the CodeSnip database:'; +begin + Result := sError; +end; + +{ TCS4VaultLoader } + +function TCS4VaultLoader.CreateReader: IVaultStorageReader; + {Creates reader object. If user database doesn't exist a nul reader is + created. + @return Reader object instance. + } +begin + Result := TCS4VaultStorageReader.Create(Vault.Storage.Directory); + if not Result.DatabaseExists then + Result := TNullVaultStorageReader.Create; +end; + +function TCS4VaultLoader.ErrorMessageHeading: string; + {Returns heading to use in error messages. Identifies main database. + @return Required heading. + } +resourcestring + sError = 'Error loading the user defined database:'; +begin + Result := sError; +end; + +{ TNativeVaultLoader } + +function TNativeVaultLoader.CreateReader: IVaultStorageReader; +begin + Result := TNativeVaultStorageReader.Create(Vault.Storage.Directory); + if not Result.DatabaseExists then + Result := TNullVaultStorageReader.Create; +end; + +function TNativeVaultLoader.ErrorMessageHeading: string; +resourcestring + sError = 'Error loading the vault %0:s using the %1:s data format:'; +begin + Result := Format( + sError, + [Vault.Name, TDataFormatInfo.GetName(Vault.Storage.Format)] + ); +end; + +{ TVaultSaver } + +constructor TVaultSaver.Create(const AVault: TVault); +begin + inherited Create; + fVault := AVault; +end; + +procedure TVaultSaver.DoSave(const SnipList: TSnippetList; + const Categories: TCategoryList; const Provider: IDBDataProvider); +begin + fSnipList := SnipList; + fCategories := Categories; + fProvider := Provider; + fWriter := CreateWriter; + fWriter.Initialise; + WriteCategories; + WriteSnippets; + WriteMetaData; + fWriter.Finalise; +end; + +procedure TVaultSaver.WriteCategories; +var + Cat: TCategory; // loops through each category + Props: TCategoryData; // category properties + SnipList: IStringList; // list of keys of snippets in a category +begin + for Cat in fCategories do + begin + SnipList := fProvider.GetCategorySnippets(Cat); + // only write category info when not empty + if SnipList.Count > 0 then + begin + Props := fProvider.GetCategoryProps(Cat); + fWriter.WriteCatProps(Cat.ID, Props); + fWriter.WriteCatSnippets(Cat.ID, SnipList); + end; + end; +end; + +procedure TVaultSaver.WriteMetaData; +begin + fWriter.WriteMetaData(Vault.MetaData); +end; + +procedure TVaultSaver.WriteSnippets; + + // Adds snippet keys from IDList to a string list + function IDListToStrings(const IDList: ISnippetIDList): IStringList; + var + ID: TSnippetID; // each id in snippet id list + begin + Result := TIStringList.Create; + for ID in IDList do + Result.Add(ID.Key); + end; + +var + Snippet: TSnippet; // loops through each snippet in list + Props: TSnippetData; // snippet properties + Refs: TSnippetReferences; // snippet references +begin + for Snippet in fSnipList do + begin + if Snippet.VaultID = Vault.UID then + begin + // Get and write a snippet's properties + Props := fProvider.GetSnippetProps(Snippet); + fWriter.WriteSnippetProps(Snippet.Key, Props); + // Get and write a snippet's references + Refs := fProvider.GetSnippetRefs(Snippet); + fWriter.WriteSnippetUnits(Snippet.Key, Refs.Units); + fWriter.WriteSnippetDepends(Snippet.Key, IDListToStrings(Refs.Depends)); + fWriter.WriteSnippetXRefs(Snippet.Key, IDListToStrings(Refs.XRef)); + end; + end; +end; + +{ TDCSCV2VaultSaver } + +procedure TDCSCV2VaultSaver.Backup; +var + FB: TVaultBackup; +begin + FB := TVaultBackup.Create(fBakFile, Vault); + try + FB.Backup; + finally + FB.Free; + end; +end; + +constructor TDCSCV2VaultSaver.Create(const AVault: TVault); +begin + inherited Create(AVault); + // Find a temp file name in system temp directory that doesn't yet exist + repeat + fBakFile := TPath.Combine( + TPath.GetTempPath, '~codesnip-' + TPath.GetGUIDFileName + ); + until not TFile.Exists(fBakFile); +end; + +function TDCSCV2VaultSaver.CreateWriter: IVaultStorageWriter; +begin + Result := TDCSCV2VaultStorageWriter.Create(Vault.Storage.Directory); +end; + +procedure TDCSCV2VaultSaver.Restore; +var + FB: TVaultBackup; +begin + FB := TVaultBackup.Create(fBakFile, Vault); + try + FB.Restore; + finally + FB.Free; + end; +end; + +procedure TDCSCV2VaultSaver.Save(const SnipList: TSnippetList; + const Categories: TCategoryList; const Provider: IDBDataProvider); +begin + Backup; + try + try + DoSave(SnipList, Categories, Provider); + except + Restore; + raise ExceptObject; + end; + finally + TFile.Delete(fBakFile); + end; +end; + +{ TCS4VaultSaver } + +function TCS4VaultSaver.CreateWriter: IVaultStorageWriter; +begin + Result := TCS4VaultStorageWriter.Create(Vault.Storage.Directory); +end; + +procedure TCS4VaultSaver.Save(const SnipList: TSnippetList; + const Categories: TCategoryList; const Provider: IDBDataProvider); +begin + {TODO -cVault: Backup and restore this vault per the DCSC v2 loader} + DoSave(SnipList, Categories, Provider); +end; + +{ TNativeVaultSaver } + +function TNativeVaultSaver.CreateWriter: IVaultStorageWriter; +begin + Result := TNativeVaultStorageWriter.Create(Vault.Storage.Directory); +end; + +procedure TNativeVaultSaver.Save(const SnipList: TSnippetList; + const Categories: TCategoryList; const Provider: IDBDataProvider); +begin + DoSave(SnipList, Categories, Provider); +end; + +{ TGlobalCategoryLoader } + +procedure TGlobalCategoryLoader.Load(const Categories: TCategoryList; + const DBDataItemFactory: IDBDataItemFactory); +var + Reader: TCategoryStorageReader; + CatInfo: TCategoryStorageReader.TCategoryIDAndData; + Cat: TCategory; +begin + if not TFile.Exists(TAppInfo.UserCategoriesFileName) then + Exit; + Reader := TCategoryStorageReader.Create(TAppInfo.UserCategoriesFileName); + try + for CatInfo in Reader.Read do + begin + Cat := Categories.Find(CatInfo.Key); + if not Assigned(Cat) then + begin + Categories.Add( + DBDataItemFactory.CreateCategory(CatInfo.Key, CatInfo.Value) + ) + end + else + begin + if Cat.Description <> CatInfo.Value.Desc then + Cat.Update(CatInfo.Value); + end; + end; + finally + Reader.Free; + end; +end; + +{ TGlobalCategorySaver } + +procedure TGlobalCategorySaver.Save(const Categories: TCategoryList); +var + Writer: TCategoryStorageWriter; +begin + Writer := TCategoryStorageWriter.Create(TAppInfo.UserCategoriesFileName); + try + Writer.Write(Categories); + finally + Writer.Free; + end; +end; + +end. + diff --git a/Src/DBIO.UXMLDataIO.pas b/Src/DB.IO.Vault.CS4.pas similarity index 61% rename from Src/DBIO.UXMLDataIO.pas rename to Src/DB.IO.Vault.CS4.pas index 0d1c0c0fc..f6c95d947 100644 --- a/Src/DBIO.UXMLDataIO.pas +++ b/Src/DB.IO.Vault.CS4.pas @@ -10,7 +10,7 @@ } -unit DBIO.UXMLDataIO; +unit DB.IO.Vault.CS4; interface @@ -20,21 +20,24 @@ interface // Delphi XMLIntf, // Project - DB.UCategory, DB.USnippet, DBIO.UFileIOIntf, UIStringList, UREMLDataIO, + DB.Categories, + DB.MetaData, + DB.Snippets, + DB.IO.Vault, + UIStringList, + UREMLDataIO, UXMLDocumentEx; type - { - TXMLDataIO: - Base class for classes that read and write databases stored in an XML file - and linked data files. - } - TXMLDataIO = class(TInterfacedObject) + /// Base class for classes that read and write vault data in the + /// CodeSnip 4 user data format. + TCS4VaultStorage = class(TInterfacedObject) strict protected - fDBDir: string; // Database directory - fXMLDoc: IXMLDocumentEx; // Extended XML document object + var + fDBDir: string; // Database directory + fXMLDoc: IXMLDocumentEx; // Extended XML document object function PathToXMLFile: string; {Gets fully specified path to the XML file. Path depends on which database is being accessed. @@ -56,9 +59,9 @@ TXMLDataIO = class(TInterfacedObject) @param CatID [in] Id of required category. @return Required node or nil if node doesn't exist. } - function FindSnippetNode(const SnippetName: string): IXMLNode; + function FindSnippetNode(const SnippetKey: string): IXMLNode; {Finds a specified snippet node for a snippet in the file. - @param SnippetName [in] Name of required snippet. + @param SnippetKey [in] Key of required snippet. @return Required node or nil if node doesn't exist. } public @@ -71,13 +74,10 @@ TXMLDataIO = class(TInterfacedObject) } end; - { - TXMLDataReader: - Class that can read a database from an XML file and various linked data - files. - } - TXMLDataReader = class(TXMLDataIO, - IDataReader + /// Reads a vault's data from storage in the CodeSnip 4 user data + /// format. + TCS4VaultStorageReader = class(TCS4VaultStorage, + IVaultStorageReader ) strict private fVersion: Integer; @@ -94,11 +94,12 @@ TXMLDataReader = class(TXMLDataIO, called. @except Exception always raised. } - function GetSnippetReferences(const Snippet, RefName: string): IStringList; + function GetSnippetReferences(const SnippetKey, RefName: string): + IStringList; {Get list of all specified references made by a snippet. - @param Snippet [in] Name of required snippet. + @param SnippetKey [in] Key of required snippet. @param RefName [in] Name of node containing snippet's references. - @return List of names of references. + @return List of references. } public constructor Create(const DBDir: string); @@ -123,40 +124,46 @@ TXMLDataReader = class(TXMLDataIO, values of category properties by implementor. } function GetCatSnippets(const CatID: string): IStringList; - {Get names of all snippets in a category. + {Get keys of all snippets in a category. @param CatID [in] Id of category containing snippets. - @return List of snippet names. + @return List of snippet keys. } - procedure GetSnippetProps(const Snippet: string; var Props: TSnippetData); + procedure GetSnippetProps(const SnippetKey: string; + var Props: TSnippetData); {Get properties of a snippet. - @param Snippet [in] Name of required snippet. + @param SnippetKey [in] Key of required snippet. @param Props [in/out] Empty properties passed in. Record fields set to values of snippet properties. } - function GetSnippetXRefs(const Snippet: string): IStringList; + function GetSnippetXRefs(const SnippetKey: string): IStringList; {Get list of all snippets that are cross referenced by a snippet. - @param Snippet [in] Name of snippet we need cross references for. - @return List of snippet names. + @param SnippetKey [in] Key of snippet we need cross references for. + @return List of snippet keys. } - function GetSnippetDepends(const Snippet: string): IStringList; + function GetSnippetDepends(const SnippetKey: string): IStringList; {Get list of all snippets on which a given snippet depends. - @param Snippet [in] Name of required snippet. - @return List of snippet names. + @param SnippetKey [in] Key of required snippet. + @return List of snippet keys. } - function GetSnippetUnits(const Snippet: string): IStringList; + function GetSnippetUnits(const SnippetKey: string): IStringList; {Get list of all units referenced by a snippet. - @param Snippet [in] Name of required snippet. + @param SnippetKey [in] Key of required snippet. @return List of unit names. } + + /// Gets the vault's meta data. + /// TMetaData. Null value. + /// + /// Meta data is not supported by the data format. + /// Method of IDataReader. + /// + function GetMetaData: TMetaData; end; - { - TXMLDataWriter: - Class that can write a database to an XML file and various linked data - files. - } - TXMLDataWriter = class(TXMLDataIO, - IDataWriter + /// Writes a vault's data to storage in the CodeSnip 4 user data + /// format. + TCS4VaultStorageWriter = class(TCS4VaultStorage, + IVaultStorageWriter ) strict private fFileNum: Integer; // Number of next available unused data file @@ -170,10 +177,10 @@ TXMLDataWriter = class(TXMLDataIO, @param ItemName [in] Name of each list item tag. @param Items [in] List of names in list. One ItemName node per name. } - procedure WriteReferenceList(const SnippetName, ListName: string; + procedure WriteReferenceList(const SnippetKey, ListName: string; const Items: IStringList); {Writes a snippet's reference list to XML. - @param SnippetName [in] Name of snippet whose reference list is to be + @param SnippetKey [in] Key of snippet whose reference list is to be written. @param ListName [in] Name of tag that encloses list entry. @param Items [in] List of items in reference list. @@ -198,37 +205,48 @@ TXMLDataWriter = class(TXMLDataIO, } procedure WriteCatSnippets(const CatID: string; const SnipList: IStringList); - {Write the list of snippets belonging to a category. Always called after - WriteCatProps for any given category. + {Write the list of snippets keys belonging to a category. Always called + after WriteCatProps for any given category. @param CatID [in] ID of category. - @param SnipList [in] List of names of snippets. + @param SnipList [in] List of snippet keys. } - procedure WriteSnippetProps(const SnippetName: string; + procedure WriteSnippetProps(const SnippetKey: string; const Props: TSnippetData); {Write the properties of a snippet. Always called after all categories are written and before WriteSnippetUnits, so can be used to perform any per- snippet intialisation. - @param SnippetName [in] Name of snippet. + @param SnippetKey [in] Snippet's key. @param Props [in] Properties of snippet. } - procedure WriteSnippetUnits(const SnippetName: string; + procedure WriteSnippetUnits(const SnippetKey: string; const Units: IStringList); {Write the list of units required by a snippet. - @param SnippetName [in] Name of snippet. + @param SnippetKey [in] Snippet's key. @param Units [in] List of names of required units. } - procedure WriteSnippetDepends(const SnippetName: string; + procedure WriteSnippetDepends(const SnippetKey: string; const Depends: IStringList); {Write the list of snippets on which a snippet depends. - @param SnippetName [in] Name of snippet. - @param Depends [in] List of snippet names. + @param SnippetKey [in] Snippet's key. + @param Depends [in] List of snippet keys. } - procedure WriteSnippetXRefs(const SnippetName: string; + procedure WriteSnippetXRefs(const SnippetKey: string; const XRefs: IStringList); {Write the list of snippets that a snippet cross-references. - @param SnippetName [in] Name of snippet. - @param XRefs [in] List of cross references snippets. + @param SnippetKey [in] Snippet's key. + @param XRefs [in] List of snippet keys. } + + /// Writes the vault's meta data. + /// TMetaData [in] Meta data to be written. + /// + /// + /// This data format does not support metadata, so this method does + /// nothing. + /// Method of IDataWriter. + /// + procedure WriteMetaData(const AMetaData: TMetaData); + procedure Finalise; {Finalises the database. Always called after all other methods. } @@ -240,21 +258,45 @@ implementation uses // Delphi - SysUtils, Classes, ActiveX, XMLDom, + SysUtils, + Classes, + ActiveX, + XMLDom, // Project - ActiveText.UMain, DB.USnippetKind, UConsts, UExceptions, UIOUtils, - USnippetExtraHelper, UStructs, UUtils, UXMLDocConsts, UXMLDocHelper; + ActiveText.UMain, + DB.SnippetKind, + DB.IO.Common.CS4, + UConsts, + UExceptions, + UIOUtils, + USnippetExtraHelper, + UStructs, + UUtils, + UXMLDocHelper; -const - // Database file name - cDatabaseFileName = 'database.xml'; - // File markers: attributes of root node - // watermark (never changes for all versions) - cWatermark = '531257EA-1EE3-4B0F-8E46-C6E7F7140106'; - // supported file format versions - cEarliestVersion = 1; - cLatestVersion = 6; +type + TCS4VaultFormatHelper = class(TCS4FormatHelper) + public + const + // Database file name + DatabaseFileName = 'database.xml'; + // File markers: attributes of root node + // watermark (never changes for all versions) + Watermark = '531257EA-1EE3-4B0F-8E46-C6E7F7140106'; + // supported file format versions + EarliestVersion = 1; + LatestVersion = 6; + // node & attribute names + CatIdNodeName = 'cat-id'; + UserDataRootNodeName = 'codesnip-data'; + CategoriesNodeName = 'categories'; + CategoryNodeName = 'category'; + CategoryNodeIdAttrName = 'id'; + CatSnippetsNodeName = 'cat-routines'; + SourceCodeNodeName = 'source-code'; + XRefNodeName = 'xref'; + end; { Support routines } @@ -278,13 +320,13 @@ procedure Error(const FmtStr: string; const Args: array of const); overload; raise EDataIO.CreateFmt(FmtStr, Args); end; -{ TXMLDataIO } +{ TCS4VaultStorage } resourcestring // Error message sMissingNode = 'Document has no %s node.'; -constructor TXMLDataIO.Create(const DBDir: string); +constructor TCS4VaultStorage.Create(const DBDir: string); {Class constructor. Creates object and XML document for a given database. @param DBDir [in] Directory where database is stored. } @@ -294,10 +336,10 @@ constructor TXMLDataIO.Create(const DBDir: string); // For some reason we must call OleInitialize here rather than in // initialization section OleInitialize(nil); - fXMLDoc := TXMLDocHelper.CreateXMLDoc; + fXMLDoc := TCS4VaultFormatHelper.CreateXMLDoc; end; -function TXMLDataIO.DataDir: string; +function TCS4VaultStorage.DataDir: string; {Gets name of directory storing the database being accessed. Path varies according to which database is being accessed. @return Path to directory. @@ -306,7 +348,7 @@ function TXMLDataIO.DataDir: string; Result := ExcludeTrailingPathDelimiter(fDBDir); end; -function TXMLDataIO.DataFile(const FileName: string): string; +function TCS4VaultStorage.DataFile(const FileName: string): string; {Gets full path to a file name. Path depends on which database is being accessed. @param FileName [in] File name for which path is required. @@ -316,7 +358,7 @@ function TXMLDataIO.DataFile(const FileName: string): string; Result := IncludeTrailingPathDelimiter(DataDir) + FileName; end; -destructor TXMLDataIO.Destroy; +destructor TCS4VaultStorage.Destroy; {Class destructor. Tears down object. } begin @@ -326,7 +368,7 @@ destructor TXMLDataIO.Destroy; inherited; end; -function TXMLDataIO.FindCategoryNode(const CatID: string): IXMLNode; +function TCS4VaultStorage.FindCategoryNode(const CatID: string): IXMLNode; {Finds a specified category node in the file. @param CatID [in] Id of required category. @return Required node or nil if node doesn't exist. @@ -336,18 +378,25 @@ function TXMLDataIO.FindCategoryNode(const CatID: string): IXMLNode; begin Result := nil; // Find node - CatListNode := fXMLDoc.FindNode(cUserDataRootNode + '\' + cCategoriesNode); + CatListNode := fXMLDoc.FindNode( + TCS4VaultFormatHelper.UserDataRootNodeName + + '\' + + TCS4VaultFormatHelper.CategoriesNodeName + ); if not Assigned(CatListNode) then - Error(sMissingNode, [cCategoriesNode]); + Error(sMissingNode, [TCS4VaultFormatHelper.CategoriesNodeName]); // Find required node Result := fXMLDoc.FindFirstChildNode( - CatListNode, cCategoryNode, cCategoryIdAttr, CatID + CatListNode, + TCS4VaultFormatHelper.CategoryNodeName, + TCS4VaultFormatHelper.CategoryNodeIdAttrName, + CatID ) end; -function TXMLDataIO.FindSnippetNode(const SnippetName: string): IXMLNode; +function TCS4VaultStorage.FindSnippetNode(const SnippetKey: string): IXMLNode; {Finds a specified snippet node for a snippet in the file. - @param SnippetName [in] Name of required snippet. + @param SnippetKey [in] Key of required snippet. @return Required node or nil if node doesn't exist. } var @@ -355,35 +404,42 @@ function TXMLDataIO.FindSnippetNode(const SnippetName: string): IXMLNode; begin Result := nil; // Find snippets node - SnippetListNode := fXMLDoc.FindNode(cUserDataRootNode + '\' + cSnippetsNode); + SnippetListNode := fXMLDoc.FindNode( + TCS4VaultFormatHelper.UserDataRootNodeName + + '\' + + TCS4VaultFormatHelper.SnippetsNodeName + ); if not Assigned(SnippetListNode) then - Error(sMissingNode, [cSnippetsNode]); + Error(sMissingNode, [TCS4VaultFormatHelper.SnippetsNodeName]); // Find required snippet node Result := fXMLDoc.FindFirstChildNode( - SnippetListNode, cSnippetNode, cSnippetNameAttr, SnippetName + SnippetListNode, + TCS4VaultFormatHelper.SnippetNodeName, + TCS4VaultFormatHelper.SnippetNodeNameAttr, + SnippetKey ); end; -function TXMLDataIO.PathToXMLFile: string; +function TCS4VaultStorage.PathToXMLFile: string; {Gets fully specified path to the XML file. Path depends on which database is being accessed. @return Required path. } begin - Result := DataFile(cDatabaseFileName); + Result := DataFile(TCS4VaultFormatHelper.DatabaseFileName); end; -{ TXMLDataReader } +{ TCS4VaultStorageReader } resourcestring // Error messages sNoCategoriesNode = 'No categories node in XML file'; sCatNotFound = 'Can''t find reference to category "%s" in XML file'; - sSnippetNotFound = 'Can''t find reference to snippet "%s" in XML file'; + sSnippetNotFound = 'Can''t find reference to snippet key "%s" in XML file'; sMissingSource = 'Source code file name missing for snippet "%s"'; sDBError = 'The database is corrupt and had been deleted.' + EOL2 + '%s'; -constructor TXMLDataReader.Create(const DBDir: string); +constructor TCS4VaultStorageReader.Create(const DBDir: string); {Class constructor. Sets up object and loads XML from file if database master file exists, otherwise creates a minimal empty document. @param DBDir [in] Directory where database is stored. @@ -407,16 +463,19 @@ constructor TXMLDataReader.Create(const DBDir: string); begin // Database doesn't exist: create sufficient nodes for main code to find fXMLDoc.Active := True; - TXMLDocHelper.CreateXMLProcInst(fXMLDoc); - RootNode := TXMLDocHelper.CreateRootNode( - fXMLDoc, cUserDataRootNode, cWatermark, cLatestVersion + TCS4VaultFormatHelper.CreateXMLProcInst(fXMLDoc); + RootNode := TCS4VaultFormatHelper.CreateRootNode( + fXMLDoc, + TCS4VaultFormatHelper.UserDataRootNodeName, + TCS4VaultFormatHelper.Watermark, + TCS4VaultFormatHelper.LatestVersion ); - fXMLDoc.CreateElement(RootNode, cCategoriesNode); - fXMLDoc.CreateElement(RootNode, cSnippetsNode); + fXMLDoc.CreateElement(RootNode, TCS4VaultFormatHelper.CategoriesNodeName); + fXMLDoc.CreateElement(RootNode, TCS4VaultFormatHelper.SnippetsNodeName); end; end; -function TXMLDataReader.DatabaseExists: Boolean; +function TCS4VaultStorageReader.DatabaseExists: Boolean; {Check if the database exists. This method is always called first. No other methods are called if this method returns false. @return True if database exists, False if not. @@ -425,7 +484,7 @@ function TXMLDataReader.DatabaseExists: Boolean; Result := FileExists(PathToXMLFile); end; -function TXMLDataReader.GetAllCatIDs: IStringList; +function TCS4VaultStorageReader.GetAllCatIDs: IStringList; {Get ids of all categories in database. @return List of category names. } @@ -436,18 +495,26 @@ function TXMLDataReader.GetAllCatIDs: IStringList; begin try Result := TIStringList.Create; - CatListNode := fXMLDoc.FindNode(cUserDataRootNode + '\' + cCategoriesNode); + CatListNode := fXMLDoc.FindNode( + TCS4VaultFormatHelper.UserDataRootNodeName + + '\' + + TCS4VaultFormatHelper.CategoriesNodeName + ); if not Assigned(CatListNode) then Error(sNoCategoriesNode); - CatNodes := fXMLDoc.FindChildNodes(CatListNode, cCategoryNode); + CatNodes := fXMLDoc.FindChildNodes( + CatListNode, TCS4VaultFormatHelper.CategoryNodeName + ); for CatNode in CatNodes do - Result.Add(CatNode.Attributes[cCategoryIdAttr]); + Result.Add( + CatNode.Attributes[TCS4VaultFormatHelper.CategoryNodeIdAttrName] + ); except HandleCorruptDatabase(ExceptObject); end; end; -procedure TXMLDataReader.GetCatProps(const CatID: string; +procedure TCS4VaultStorageReader.GetCatProps(const CatID: string; var Props: TCategoryData); {Get properties of a category. @param CatID [in] Id of required category. @@ -463,18 +530,19 @@ procedure TXMLDataReader.GetCatProps(const CatID: string; // Properties will not be requested for a category that doesn't exist in // this database, so this should never happen Error(sCatNotFound); - Props.Desc := TXMLDocHelper.GetSubTagText( - fXMLDoc, CatNode, cDescriptionNode + Props.Desc := TCS4VaultFormatHelper.GetSubTagText( + fXMLDoc, CatNode, TCS4VaultFormatHelper.DescriptionNodeName ); except HandleCorruptDatabase(ExceptObject); end; end; -function TXMLDataReader.GetCatSnippets(const CatID: string): IStringList; - {Get names of all snippets in a category. +function TCS4VaultStorageReader.GetCatSnippets(const CatID: string): + IStringList; + {Get keys of all snippets in a category. @param CatID [in] Id of category containing snippets. - @return List of snippet names. + @return List of snippet keys. } var CatNode: IXMLNode; // reference to required category node @@ -486,41 +554,54 @@ function TXMLDataReader.GetCatSnippets(const CatID: string): IStringList; // This is not an error since it is possible that a category exists in // another database and loader will request info from here also Exit; - TXMLDocHelper.GetPascalNameList( - fXMLDoc, fXMLDoc.FindFirstChildNode(CatNode, cCatSnippetsNode), Result + TCS4VaultFormatHelper.GetPascalNameList( + fXMLDoc, fXMLDoc.FindFirstChildNode( + CatNode, TCS4VaultFormatHelper.CatSnippetsNodeName + ), + Result ); except HandleCorruptDatabase(ExceptObject); end; end; -function TXMLDataReader.GetSnippetDepends(const Snippet: string): IStringList; +function TCS4VaultStorageReader.GetMetaData: TMetaData; +begin + // Meta data not supported by this data format + Result := TMetaData.CreateNull; +end; + +function TCS4VaultStorageReader.GetSnippetDepends(const SnippetKey: string): + IStringList; {Get list of all snippets on which a given snippet depends. - @param Snippet [in] Name of required snippet. - @return List of snippet names. + @param SnippetKey [in] Key of required snippet. + @return List of snippet keys. } begin - Result := GetSnippetReferences(Snippet, cDependsNode); + Result := GetSnippetReferences( + SnippetKey, TCS4VaultFormatHelper.DependsNodeName + ); end; -procedure TXMLDataReader.GetSnippetProps(const Snippet: string; +procedure TCS4VaultStorageReader.GetSnippetProps(const SnippetKey: string; var Props: TSnippetData); {Get properties of a snippet. - @param Snippet [in] Name of required snippet. + @param SnippetKey [in] Key of required snippet. @param Props [in/out] Empty properties passed in. Record fields set to values of snippet's properties. } var SnippetNode: IXMLNode; // node for required snippet - // --------------------------------------------------------------------------- function GetPropertyText(const PropTagName: string): string; {Gets text of a specified property. @param PropTagName [in] Tag associated with property. @return Property value from tag's text. } begin - Result := TXMLDocHelper.GetSubTagText(fXMLDoc, SnippetNode, PropTagName); + Result := TCS4VaultFormatHelper.GetSubTagText( + fXMLDoc, SnippetNode, PropTagName + ); end; function GetSourceCodePropertyText: string; @@ -530,9 +611,9 @@ procedure TXMLDataReader.GetSnippetProps(const Snippet: string; var DataFileName: string; // name of file containing source code begin - DataFileName := GetPropertyText(cSourceCodeFileNode); + DataFileName := GetPropertyText(TCS4VaultFormatHelper.SourceCodeNodeName); if DataFileName = '' then - Error(sMissingSource, [Snippet]); + Error(sMissingSource, [SnippetKey]); try // load the file: before file v5 files used default encoding, from v5 // UTF-8 with no BOM was used @@ -558,7 +639,7 @@ procedure TXMLDataReader.GetSnippetProps(const Snippet: string; @return True if standard format, False if not. } begin - Result := TXMLDocHelper.GetStandardFormat( + Result := TCS4VaultFormatHelper.GetStandardFormat( fXMLDoc, SnippetNode, False ); end; @@ -577,7 +658,9 @@ procedure TXMLDataReader.GetSnippetProps(const Snippet: string; Default := skRoutine else Default := skFreeform; - Result := TXMLDocHelper.GetSnippetKind(fXMLDoc, SnippetNode, Default); + Result := TCS4VaultFormatHelper.GetSnippetKind( + fXMLDoc, SnippetNode, Default + ); end; function GetExtraProperty: IActiveText; @@ -591,14 +674,14 @@ procedure TXMLDataReader.GetSnippetProps(const Snippet: string; // version 1: build extra data from comments, credits and credits URL // nodes Result := TSnippetExtraHelper.BuildActiveText( - GetPropertyText(cCommentsNode), - GetPropertyText(cCreditsNode), - GetPropertyText(cCreditsUrlNode) + GetPropertyText(TCS4VaultFormatHelper.CommentsNodeName), + GetPropertyText(TCS4VaultFormatHelper.CreditsNodeName), + GetPropertyText(TCS4VaultFormatHelper.CreditsUrlNodeName) ) else // version 2 & later: build extra data from REML in extra node Result := TSnippetExtraHelper.BuildActiveText( - GetPropertyText(cExtraNode) + GetPropertyText(TCS4VaultFormatHelper.ExtraNodeName) ); except // error: provide an empty property value @@ -610,7 +693,7 @@ procedure TXMLDataReader.GetSnippetProps(const Snippet: string; var Desc: string; // text read from description node begin - Desc := GetPropertyText(cDescriptionNode); + Desc := GetPropertyText(TCS4VaultFormatHelper.DescriptionNodeName); if Desc <> '' then begin if fVersion < 6 then @@ -623,25 +706,24 @@ procedure TXMLDataReader.GetSnippetProps(const Snippet: string; else Result := TActiveTextFactory.CreateActiveText; end; - // --------------------------------------------------------------------------- begin try // Find snippet node - SnippetNode := FindSnippetNode(Snippet); + SnippetNode := FindSnippetNode(SnippetKey); if not Assigned(SnippetNode) then - Error(sSnippetNotFound, [Snippet]); + Error(sSnippetNotFound, [SnippetKey]); // Snippet found: read properties - Props.Cat := GetPropertyText(cCatIdNode); - Props.DisplayName := GetPropertyText(cDisplayNameNode); + Props.Cat := GetPropertyText(TCS4VaultFormatHelper.CatIdNodeName); + Props.DisplayName := GetPropertyText(TCS4VaultFormatHelper.DisplayNameNodeName); Props.Kind := GetKindProperty; Props.Desc := GetDescriptionProperty; Props.Extra := GetExtraProperty; Props.SourceCode := GetSourceCodePropertyText; - Props.HiliteSource := TXMLDocHelper.GetHiliteSource( + Props.HiliteSource := TCS4VaultFormatHelper.GetHiliteSource( fXMLDoc, SnippetNode, True ); - Props.CompilerResults := TXMLDocHelper.GetCompilerResults( + Props.CompilerResults := TCS4VaultFormatHelper.GetCompilerResults( fXMLDoc, SnippetNode ); except @@ -649,23 +731,24 @@ procedure TXMLDataReader.GetSnippetProps(const Snippet: string; end; end; -function TXMLDataReader.GetSnippetReferences(const Snippet, +function TCS4VaultStorageReader.GetSnippetReferences(const SnippetKey, RefName: string): IStringList; {Get list of all specified references made by a snippet. - @param Snippet [in] Name of required snippet. + @param SnippetKey [in] Key of required snippet. @param RefName [in] Name of node containing snippet's references. - @return List of names of references. + @return List of references. } var SnippetNode: IXMLNode; // node for required snippet begin - try + {TODO -cRefactor: Pull reading snippet references into TCS4VaultFormatHelper ???} + try Result := TIStringList.Create; - SnippetNode := FindSnippetNode(Snippet); + SnippetNode := FindSnippetNode(SnippetKey); if not Assigned(SnippetNode) then - Error(sSnippetNotFound, [Snippet]); + Error(sSnippetNotFound, [SnippetKey]); // References are contained in a list of contained nodes - TXMLDocHelper.GetPascalNameList( + TCS4VaultFormatHelper.GetPascalNameList( fXMLDoc, fXMLDoc.FindFirstChildNode(SnippetNode, RefName), Result ); except @@ -673,25 +756,29 @@ function TXMLDataReader.GetSnippetReferences(const Snippet, end; end; -function TXMLDataReader.GetSnippetUnits(const Snippet: string): IStringList; +function TCS4VaultStorageReader.GetSnippetUnits(const SnippetKey: string): + IStringList; {Get list of all units referenced by a snippet. - @param Snippet [in] Name of required snippet. - @return List of unit names. + @param SnippetKey [in] Key of required snippet. + @return List of unit keys. } begin - Result := GetSnippetReferences(Snippet, cUnitsNode); + Result := GetSnippetReferences(SnippetKey, TCS4VaultFormatHelper.UnitsNodeName); end; -function TXMLDataReader.GetSnippetXRefs(const Snippet: string): IStringList; +function TCS4VaultStorageReader.GetSnippetXRefs(const SnippetKey: string): + IStringList; {Get list of all snippets that are cross referenced by a snippet. - @param Snippet [in] Name of snippet we need cross references for. - @return List of snippet names. + @param SnippetKey [in] Key of snippet we need cross references for. + @return List of snippet keys. } begin - Result := GetSnippetReferences(Snippet, cXRefNode); + Result := GetSnippetReferences( + SnippetKey, TCS4VaultFormatHelper.XRefNodeName + ); end; -procedure TXMLDataReader.HandleCorruptDatabase(const EObj: TObject); +procedure TCS4VaultStorageReader.HandleCorruptDatabase(const EObj: TObject); {Called when a corrupt database is encountered. Deletes all files and raises exception. @param EObj [in] Reference to exception that caused this method to be @@ -714,35 +801,47 @@ procedure TXMLDataReader.HandleCorruptDatabase(const EObj: TObject); raise EObj; end; -function TXMLDataReader.ValidateDoc: Integer; +function TCS4VaultStorageReader.ValidateDoc: Integer; {Validates XML document and gets file version. @return XML file version number. @except EDataIO raised if XML is not valid. } begin - TXMLDocHelper.ValidateProcessingInstr(fXMLDoc); - Result := TXMLDocHelper.ValidateRootNode( + TCS4VaultFormatHelper.ValidateProcessingInstr(fXMLDoc); + Result := TCS4VaultFormatHelper.ValidateRootNode( fXMLDoc, - cUserDataRootNode, - cWatermark, - TRange.Create(cEarliestVersion, cLatestVersion) + TCS4VaultFormatHelper.UserDataRootNodeName, + TCS4VaultFormatHelper.Watermark, + TRange.Create( + TCS4VaultFormatHelper.EarliestVersion, TCS4VaultFormatHelper.LatestVersion + ) ); // Both a categories and a snippets node must exist - if fXMLDoc.FindNode(cUserDataRootNode + '\' + cCategoriesNode) = nil then - Error(sMissingNode, [cCategoriesNode]); - if fXMLDoc.FindNode(cUserDataRootNode + '\' + cSnippetsNode) = nil then - Error(sMissingNode, [cSnippetsNode]); + if fXMLDoc.FindNode( + TCS4VaultFormatHelper.UserDataRootNodename + + '\' + + TCS4VaultFormatHelper.CategoriesNodeName + ) = nil then + Error(sMissingNode, [TCS4VaultFormatHelper.CategoriesNodeName]); + if fXMLDoc.FindNode( + TCS4VaultFormatHelper.UserDataRootNodeName + + '\' + + TCS4VaultFormatHelper.SnippetsNodeName + ) = nil then + Error(sMissingNode, [TCS4VaultFormatHelper.SnippetsNodeName]); end; -{ TXMLDataWriter } +{ TCS4VaultStorageWriter } -procedure TXMLDataWriter.Finalise; +procedure TCS4VaultStorageWriter.Finalise; {Finalises the database. Always called after all other methods. } var FS: TFileStream; // stream onto output file begin - fXMLDoc.DocumentElement.SetAttribute(cRootVersionAttr, cLatestVersion); + fXMLDoc.DocumentElement.SetAttribute( + TCS4VaultFormatHelper.RootVersionAttr, TCS4VaultFormatHelper.LatestVersion + ); // We use a TFileStream and TXMLDocument.SaveToStream rather than calling // TXMLDocument.SaveToFile so that any problem creating file is reported via // a known Delphi exception that can be handled. @@ -760,7 +859,7 @@ procedure TXMLDataWriter.Finalise; end; end; -procedure TXMLDataWriter.HandleException(const EObj: TObject); +procedure TCS4VaultStorageWriter.HandleException(const EObj: TObject); {Handles exceptions raised by converting expected exceptions into ECodeSnip derived exceptions. @param EObj [in] Reference to exception to be handled. @@ -772,7 +871,7 @@ procedure TXMLDataWriter.HandleException(const EObj: TObject); raise EObj; end; -procedure TXMLDataWriter.Initialise; +procedure TCS4VaultStorageWriter.Initialise; {Initialise the database. Always called before any other methods. } var @@ -795,22 +894,29 @@ procedure TXMLDataWriter.Initialise; // methods fXMLDoc.Active := True; // xml processing instruction: id file as XML - TXMLDocHelper.CreateXMLProcInst(fXMLDoc); + TCS4VaultFormatHelper.CreateXMLProcInst(fXMLDoc); // comments - TXMLDocHelper.CreateComment(fXMLDoc, sFileComment); + TCS4VaultFormatHelper.CreateComment(fXMLDoc, sFileComment); // root node - RootNode := TXMLDocHelper.CreateRootNode( - fXMLDoc, cUserDataRootNode, cWatermark, cLatestVersion + RootNode := TCS4VaultFormatHelper.CreateRootNode( + fXMLDoc, + TCS4VaultFormatHelper.UserDataRootNodeName, + TCS4VaultFormatHelper.Watermark, + TCS4VaultFormatHelper.LatestVersion ); // empty categories and snippets nodes - fCategoriesNode := fXMLDoc.CreateElement(RootNode, cCategoriesNode); - fSnippetsNode := fXMLDoc.CreateElement(RootNode, cSnippetsNode); + fCategoriesNode := fXMLDoc.CreateElement( + RootNode, TCS4VaultFormatHelper.CategoriesNodeName + ); + fSnippetsNode := fXMLDoc.CreateElement( + RootNode, TCS4VaultFormatHelper.SnippetsNodeName + ); except HandleException(ExceptObject); end; end; -procedure TXMLDataWriter.WriteCatProps(const CatID: string; +procedure TCS4VaultStorageWriter.WriteCatProps(const CatID: string; const Props: TCategoryData); {Write the properties of a category. Always called before WriteCatSnippets for a given category, so can be used to perform any per-category initialisation. @@ -822,20 +928,24 @@ procedure TXMLDataWriter.WriteCatProps(const CatID: string; begin try // Create node - CatNode := fXMLDoc.CreateElement(fCategoriesNode, cCategoryNode); - CatNode.Attributes[cCategoryIdAttr] := CatID; - fXMLDoc.CreateElement(CatNode, cDescriptionNode, Props.Desc); + CatNode := fXMLDoc.CreateElement( + fCategoriesNode, TCS4VaultFormatHelper.CategoryNodeName + ); + CatNode.Attributes[TCS4VaultFormatHelper.CategoryNodeIdAttrName] := CatID; + fXMLDoc.CreateElement( + CatNode, TCS4VaultFormatHelper.DescriptionNodeName, Props.Desc + ); except HandleException(ExceptObject); end; end; -procedure TXMLDataWriter.WriteCatSnippets(const CatID: string; +procedure TCS4VaultStorageWriter.WriteCatSnippets(const CatID: string; const SnipList: IStringList); {Write the list of snippets belonging to a category. Always called after WriteCatProps for any given category. @param CatID [in] ID of category. - @param SnipList [in] List of names of snippets. + @param SnipList [in] List of snippet keyss. } var CatNode: IXMLNode; // reference to required category node @@ -849,14 +959,27 @@ procedure TXMLDataWriter.WriteCatSnippets(const CatID: string; Assert(Assigned(CatNode), ClassName + '.WriteCatSnippets: Can''t find category node'); // Write the list - WriteNameList(CatNode, cCatSnippetsNode, cPascalNameNode, SnipList); + {TODO -cRefactor: Call TCS4VaultFormatHelper.WritePascalNameList instead? If this + is done then TCS4VaultFormatHelper.PascalNameNodeName can be made private + again.} + WriteNameList( + CatNode, + TCS4VaultFormatHelper.CatSnippetsNodeName, + TCS4VaultFormatHelper.PascalNameNodeName, + SnipList + ); except HandleException(ExceptObject); end; end; -procedure TXMLDataWriter.WriteNameList(const Parent: IXMLNode; const ListName, - ItemName: string; const Items: IStringList); +procedure TCS4VaultStorageWriter.WriteMetaData(const AMetaData: TMetaData); +begin + // Do nothing: meta data not supported. +end; + +procedure TCS4VaultStorageWriter.WriteNameList(const Parent: IXMLNode; + const ListName, ItemName: string; const Items: IStringList); {Writes a list of names to XML. @param Parent [in] Reference to node under which list is to be stored. @param ListName [in] Name of tag that encloses the list items. @@ -872,10 +995,10 @@ procedure TXMLDataWriter.WriteNameList(const Parent: IXMLNode; const ListName, fXMLDoc.CreateElement(ListNode, ItemName, Item); end; -procedure TXMLDataWriter.WriteReferenceList(const SnippetName, ListName: string; - const Items: IStringList); +procedure TCS4VaultStorageWriter.WriteReferenceList(const SnippetKey, + ListName: string; const Items: IStringList); {Writes a snippet's reference list to XML. - @param SnippetName [in] Name of snippet whose reference list is to be + @param SnippetKey [in] Key of snippet whose reference list is to be written. @param ListName [in] Name of tag that encloses list entry. @param Items [in] List of items in reference list. @@ -888,11 +1011,11 @@ procedure TXMLDataWriter.WriteReferenceList(const SnippetName, ListName: string; if Items.Count = 0 then Exit; // Find snippet node - SnippetNode := FindSnippetNode(SnippetName); + SnippetNode := FindSnippetNode(SnippetKey); Assert(Assigned(SnippetNode), ClassName + '.WriteReferenceList: Can''t find snippet node'); // Write the list - TXMLDocHelper.WritePascalNameList( + TCS4VaultFormatHelper.WritePascalNameList( fXMLDoc, SnippetNode, ListName, Items ); except @@ -900,22 +1023,23 @@ procedure TXMLDataWriter.WriteReferenceList(const SnippetName, ListName: string; end; end; -procedure TXMLDataWriter.WriteSnippetDepends(const SnippetName: string; +procedure TCS4VaultStorageWriter.WriteSnippetDepends(const SnippetKey: string; const Depends: IStringList); {Write the list of snippets on which a snippet depends. - @param SnippetName [in] Name of snippet. - @param Depends [in] List of snippet names. + @param SnippetKey [in] Snippet's key. + @param Depends [in] List of snippet keys. } begin - WriteReferenceList(SnippetName, cDependsNode, Depends); + {TODO -cRefactor: Pull writing Depends node into TCS4VaultFormatHelper} + WriteReferenceList(SnippetKey, TCS4VaultFormatHelper.DependsNodeName, Depends); end; -procedure TXMLDataWriter.WriteSnippetProps(const SnippetName: string; +procedure TCS4VaultStorageWriter.WriteSnippetProps(const SnippetKey: string; const Props: TSnippetData); {Write the properties of a snippet. Always called after all categories are written and before WriteSnippetsUnits, so can be used to perform any per- snippet intialisation. - @param SnippetName [in] Name of snippet. + @param SnippetKey [in] Snippet's key. @param Props [in] Properties of snippet. } var @@ -927,14 +1051,18 @@ procedure TXMLDataWriter.WriteSnippetProps(const SnippetName: string; begin try // Create snippet node - SnippetNode := fXMLDoc.CreateElement(fSnippetsNode, cSnippetNode); - SnippetNode.Attributes[cSnippetNameAttr] := SnippetName; + SnippetNode := fXMLDoc.CreateElement( + fSnippetsNode, TCS4VaultFormatHelper.SnippetNodeName + ); + SnippetNode.Attributes[TCS4VaultFormatHelper.SnippetNodeNameAttr] := SnippetKey; // Add properties - fXMLDoc.CreateElement(SnippetNode, cCatIdNode, Props.Cat); + fXMLDoc.CreateElement( + SnippetNode, TCS4VaultFormatHelper.CatIdNodeName, Props.Cat + ); // description node is written even if empty (which it shouldn't be) fXMLDoc.CreateElement( SnippetNode, - cDescriptionNode, + TCS4VaultFormatHelper.DescriptionNodeName, TSnippetExtraHelper.BuildREMLMarkup(Props.Desc) ); // source code is written to a UTF-8 encoded file with no BOM and filename @@ -944,23 +1072,31 @@ procedure TXMLDataWriter.WriteSnippetProps(const SnippetName: string; TFileIO.WriteAllText( DataFile(FileName), Props.SourceCode, TEncoding.UTF8, False ); - fXMLDoc.CreateElement(SnippetNode, cSourceCodeFileNode, FileName); fXMLDoc.CreateElement( - SnippetNode, cHighlightSource, IntToStr(Ord(Props.HiliteSource)) + SnippetNode, TCS4VaultFormatHelper.SourceCodeNodeName, FileName + ); + {TODO -cRefactor: Move following method call into TCS4VaultFormatHelper} + fXMLDoc.CreateElement( + SnippetNode, + TCS4VaultFormatHelper.HighlightSourceNodeName, + IntToStr(Ord(Props.HiliteSource)) + ); + fXMLDoc.CreateElement( + SnippetNode, TCS4VaultFormatHelper.DisplayNameNodeName, Props.DisplayName ); - fXMLDoc.CreateElement(SnippetNode, cDisplayNameNode, Props.DisplayName); + {TODO -cRefactor: Move code that writes Extra into TCS4VaultFormatHelper} // extra node is only written if extra property has a value if Props.Extra.HasContent then begin fXMLDoc.CreateElement( SnippetNode, - cExtraNode, + TCS4VaultFormatHelper.ExtraNodeName, TSnippetExtraHelper.BuildREMLMarkup(Props.Extra) ); end; - TXMLDocHelper.WriteSnippetKind(fXMLDoc, SnippetNode, Props.Kind); + TCS4VaultFormatHelper.WriteSnippetKind(fXMLDoc, SnippetNode, Props.Kind); // only known compiler results are written - TXMLDocHelper.WriteCompilerResults( + TCS4VaultFormatHelper.WriteCompilerResults( fXMLDoc, SnippetNode, Props.CompilerResults ); except @@ -968,24 +1104,24 @@ procedure TXMLDataWriter.WriteSnippetProps(const SnippetName: string; end; end; -procedure TXMLDataWriter.WriteSnippetUnits(const SnippetName: string; +procedure TCS4VaultStorageWriter.WriteSnippetUnits(const SnippetKey: string; const Units: IStringList); {Write the list of units required by a snippet. - @param SnippetName [in] Name of snippet. + @param SnippetKey [in] Snippet's key. @param Units [in] List of names of required units. } begin - WriteReferenceList(SnippetName, cUnitsNode, Units); + WriteReferenceList(SnippetKey, TCS4VaultFormatHelper.UnitsNodeName, Units); end; -procedure TXMLDataWriter.WriteSnippetXRefs(const SnippetName: string; +procedure TCS4VaultStorageWriter.WriteSnippetXRefs(const SnippetKey: string; const XRefs: IStringList); {Write the list of snippets that a snippet cross-references. - @param SnippetName [in] Name of snippet. + @param SnippetKey [in] Snippet's key. @param XRefs [in] List of cross references snippets. } begin - WriteReferenceList(SnippetName, cXRefNode, XRefs); + WriteReferenceList(SnippetKey, TCS4VaultFormatHelper.XRefNodeName, XRefs); end; end. diff --git a/Src/DB.IO.Vault.DCSCv2.pas b/Src/DB.IO.Vault.DCSCv2.pas new file mode 100644 index 000000000..a33e8e82f --- /dev/null +++ b/Src/DB.IO.Vault.DCSCv2.pas @@ -0,0 +1,1402 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2005-2023, Peter Johnson (gravatar.com/delphidabbler). + * + * Implements code that reads the main CodeSnip database from .ini and .dat + * files. +} + + +unit DB.IO.Vault.DCSCv2; + + +interface + + +uses + // Delphi + SysUtils, + Classes, + Types, + Generics.Collections, + IniFiles, + // Project + ActiveText.UMain, + DB.Categories, + DB.MetaData, + DB.Snippets, + DB.IO.Vault, + UIStringList, + UVersionInfo; + + +type + + /// Reads a vault's data from storage in the DelphiDabbler Code + /// Snippets Collection v2 format. + TDCSCV2VaultStorageReader = class sealed(TInterfacedObject, + IVaultStorageReader + ) + strict private + type + /// Extension of TMemIniFile that loads its data from a + /// UTF8 encoded file with BOM. Any quotes enclosing values read from the + /// ini file are stripped. + TUTF8IniFileEx = class(TMemIniFile) + public + /// Object constructor. Sets up ini file object and loads data + /// into it from a file. + /// string [in] Name of ini file. + /// + constructor Create(const AFileName: string); + /// Retrieves a string value from an ini file. + /// string [in] Section containing value. + /// + /// string [in] Identifier of value. + /// string [in] Default value used if + /// Ident has no associated value. + /// string containing the required value, with any + /// enclosing quotes removed. + /// Overrides the method in base class to strip enclosing + /// quotes. + function ReadString(const Section, Ident, Default: string): string; + override; + /// Loads ini object's data from a string array. + /// TStringDynArray [in] Array of strings + /// to be loaded. + /// Overloads inherited SetStrings method. + procedure SetStrings(const AStrings: TStringDynArray); overload; + end; + + /// + /// Class that implements a cache of ini file objects, indexed by ini + /// file name. + /// + TIniFileCache = class(TObject) + strict private + type + /// + /// Class that maps ini file names to related ini file objects. + /// + TIniFileMap = TObjectDictionary; + var + /// Maps file names to related ini file objects. + fCache: TIniFileMap; + public + /// Object constructor. Sets up empty cache. + constructor Create; + /// Object destructor. Frees cache. + destructor Destroy; override; + /// + /// Gets reference to ini file object. Creates it if it doesn't extist. + /// + /// string [in] Fully specified path to ini + /// file. + /// TCustomIniFile instance for reading ini file. + /// Caller must not free the returned TCustomIniFile instance. + /// + function GetIniFile(const PathToFile: string): TCustomIniFile; + end; + type + /// Class that maps snippet names to category ids. + TSnippetCatMap = TDictionary; + var + /// Database directory. + fDBDir: string; + /// Reference to master ini file. + fMasterIni: TCustomIniFile; + /// List of category ids in database. + fCatIDs: TStringList; + /// Map of snippet names to category ids. + fSnippetCatMap: TSnippetCatMap; + /// Cache of category ini file objects. + fIniCache: TIniFileCache; + /// Data format version number. + fVersion: TVersionNumber; + const + SupportedMajorVersion = 2; + strict private + /// + /// Returns fully specified name of database master file. + /// + function MasterFileName: string; + /// Reads data format version from file. + /// Stores result in fVersion. Detects DCSC versions 1 and + /// later. fVersion is set to null if the version can't be + /// determined. + procedure ReadVersionNumber; + /// + /// Returns ID of category associated with a snippet. + /// + /// string [in] Snippet's key. + /// string containing category ID + function SnippetToCat(const SnippetKey: string): string; + /// + /// Returns name of ini file containing details of a category. + /// + /// string [in] Id of category. + /// string containing name of category's ini file + function CatToCatIni(const CatID: string): string; + /// + /// Loads indices of all names of categories and snippets in database. + /// + /// + /// Having these indices available speeds up several of the main methods. + /// + procedure LoadIndices; + /// + /// Handles exceptions raised when a corrupt database is encountered. + /// Deletes all files and re-raises exception. + /// + /// Exception object to be handled. + procedure HandleCorruptDatabase(const EObj: TObject); + /// Returns encoding used by given meta file. + function GetFileEncoding(const FileName: string): TEncoding; + /// + /// Returns name of directory where the database is stored. + /// + function DataDir: string; + /// + /// Returns fully specified path to given file name. + /// + function DataFile(const FileName: string): string; + /// Checks if a given file exists in the vault directory. + /// + function DataFileExists(const FileName: string): Boolean; + /// Reads all lines from given file and returns them as an array. + /// + /// FileName must contain no path information. + function ReadFileLines(const FileName: string): TStringDynArray; + /// Reads all text from given file and returns it. + /// FileName must contain no path information. + function ReadFileText(const FileName: string): string; + /// + /// Gets a list from ini file of all of items of a specified kind that are + /// referenced by a snippet. + /// + /// string [in] Snippet's key. + /// string [in] Name of a key in ini file storing + /// comma separated list of references. + /// IStringList containing names of referenced items. + function GetSnippetReferences(const SnippetKey, KeyName: string): + IStringList; + strict protected + /// + /// Extracts comma delimited text fields into a string list. + /// + /// string [in] Comma delimited text. + /// IStringList containing fields. + class function CommaStrToStrings(const CommaStr: string): IStringList; + public + /// + /// Object constructor. Checks if database exists and sets up indices. + /// + /// string [in] Directory containing database. + constructor Create(const DBDir: string); + /// + /// Object destructor. Tears down object. + /// + destructor Destroy; override; + { IDataReader methods } + /// + /// Checks if the database exists. + /// + /// + /// This method is always called before any other IDataReader methods. The + /// other methods are not called if this method returns False. + /// + function DatabaseExists: Boolean; + /// + /// Gets name of all categories in the database. + /// + /// IStringList containing names. + function GetAllCatIDs: IStringList; + /// + /// Gets properties of a category. + /// + /// string [in] Id of category. + /// TCategoryData [in/out] Receives empty property + /// record and updates relevant property fields. + procedure GetCatProps(const CatID: string; var Props: TCategoryData); + /// + /// Gets keys of all snippets in a category. + /// + /// string [in] Id of category. + /// IStringList containing keys of snippets. + function GetCatSnippets(const CatID: string): IStringList; + /// + /// Gets properties of a snippet. + /// + /// string [in] Snippet's key. + /// TSnippetData [in/out] Receives empty property + /// record and updates relevant property fields. + procedure GetSnippetProps(const SnippetKey: string; + var Props: TSnippetData); + /// + /// Gets list of all snippets that are cross referenced by a specified + /// snippet. + /// + /// string [in] Snippet's key. + /// IStringList containing snippet keys. + function GetSnippetXRefs(const SnippetKey: string): IStringList; + /// + /// Gets list of all snippets on which a specified snippet depends. + /// + /// string [in] Snippet's key. + /// IStringList containing snippet keys. + function GetSnippetDepends(const SnippetKey: string): IStringList; + /// + /// Gets list of all units referenced by a snippet. + /// + /// string [in] Snippet's key. + /// IStringList containing unit names. + function GetSnippetUnits(const SnippetKey: string): IStringList; + /// Gets the vault's meta data. + /// TMetaData. The required meta data. Will be null if + /// is no meta data present. + /// Method of IDataReader. + function GetMetaData: TMetaData; + end; + + /// Writes a vault's data to storage in the DelphiDabbler Code + /// Snippets Collection v2 format. + TDCSCV2VaultStorageWriter = class sealed(TInterfacedObject, + IVaultStorageWriter + ) + strict private + type + + /// Encapsulates an INI file stored in UTF8 format. + TUTF8IniFile = class(TMemIniFile) + public + /// Saves the ini data to a file in UTF8 format. + procedure Save; + end; + + /// Implements a cache of UTF8 format ini file objects, indexed + /// by ini file name. + TUTF8IniFileCache = class(TObject) + strict private + type + /// Maps ini file names to related ini file objects. + /// + TIniFileMap = TObjectDictionary; + var + /// Maps file names to related ini file objects. + fCache: TIniFileMap; + + /// Adds an ini file to the cache and returns it. + /// Performs no checks on whether the ini file is already in + /// the cache. + /// string [in] Fully specified path + /// to ini file. + /// TUTF8IniFile instance. + function InternalAddIniFile(const APathToFile: string): TUTF8IniFile; + + public + + /// Object constructor. Sets up empty cache. + constructor Create; + + /// Object destructor. Frees cache. + destructor Destroy; override; + + /// Gets reference to ini file object. Creates it if i + /// doesn't extist. + /// string [in] Fully specified path + /// to ini file. + /// TUTF8IniFile instance. + /// Caller must not free the returned TCustomIniFile + /// instance. + function GetIniFile(const APathToFile: string): TUTF8IniFile; + + /// Creates and adds an ini file object to the cache if not + /// already present. + /// string [in] Fully specified path + /// to ini file. + procedure AddIniFile(const APathToFile: string); + + /// Enumerator for cached ini files. + function GetEnumerator: + TObjectDictionary.TPairEnumerator; + end; + + var + /// Cache of ini files. + fCache: TUTF8IniFileCache; + /// Output directory. + fOutDir: string; + /// Path to master ini file. + fMasterIniPath: string; + /// Ini file containing currently processed category. + fCurrentCatIni: TUTF8IniFile; + /// Number of next available unused data file. + fFileNumber: Integer; + + /// Handles exceptions raised by converting expected exceptions + /// into ECodeSnip derived exceptions. + /// TObject [in] Reference to exception to be + /// handled. + /// Always raise an exception. + /// Unexpected exceptions are re-raised as is. + procedure HandleException(const EObj: TObject); + + /// Returns full path to AFileName rooted at + /// fOutDir. + function MakePath(const AFileName: string): string; + + /// Returns the name of the ini file associated with + /// ACatID. + function MakeCatIniName(const ACatID: string): string; + + /// Returns the full path to the ini file associated with + /// ACatID rooted at fOutDir. + function MakeCatIniPath(const ACatID: string): string; + + /// Converts the given active text AActiveText to an + /// unformatted, single line, REML string. + function ActiveTextToREML(AActiveText: IActiveText): string; + + procedure WriteTextFile(const AFileName, AText: string); overload; + + procedure WriteTextFile(const AFileName: string; const ALines: IStringList); + overload; + + public + + /// Object constructor. + /// string [in] Directory containing the + /// output. + constructor Create(const AOutDir: string); + + /// Object destructor. + destructor Destroy; override; + + /// Initialise the output. Always called before any other methods. + /// + /// Method of IDataWriter. + procedure Initialise; + + /// Write the properties of a category. Always called before + /// WriteCatSnippets for a given category, so can be used to perform + /// any per-category initialisation. + /// string [in] ID of category. + /// TCategoryData [in] Properties of category. + /// + /// Method of IDataWriter. + procedure WriteCatProps(const CatID: string; const Props: TCategoryData); + + /// Write the list of snippet keys belonging to a category. Always + /// called after WriteCatProps for any given category. + /// string [in] ID of category. + /// IStringList [in] List of snippet keys. + /// + /// Method of IDataWriter. + procedure WriteCatSnippets(const CatID: string; + const SnipList: IStringList); + + /// Write the properties of a snippet. Always called after all + /// categories are written and before WriteSnippetUnits, so can be + /// used to perform any per-snippet intialisation. + /// string [in] Snippet's key. + /// TSnippetData [in] Properties of snippet. + /// + /// + /// NOTE: This method conforms to DelphiDabbler Code Snippets + /// Collection format v2.1.x. + /// Method of IDataWriter. + /// + procedure WriteSnippetProps(const SnippetKey: string; + const Props: TSnippetData); + + /// Write the list of units required by a snippet. + /// string [in] Snippet's key. + /// IStringList [in] List of names of required + /// units. + /// Method of IDataWriter. + procedure WriteSnippetUnits(const SnippetKey: string; + const Units: IStringList); + + /// Write the list of snippets on which a snippet depends. + /// + /// string [in] Snippet's key. + /// IStringList [in] List of snippet keys. + /// + /// Method of IDataWriter. + procedure WriteSnippetDepends(const SnippetKey: string; + const Depends: IStringList); + + /// Write the list of snippets that a snippet cross-references. + /// + /// string [in] Snippet's keys. + /// IStringList [in] List of snippet keys. + /// + /// Method of IDataWriter. + procedure WriteSnippetXRefs(const SnippetKey: string; + const XRefs: IStringList); + + /// Writes the vault's meta data. + /// TMetaData [in] Meta data to be written. + /// + /// Method of IDataWriter. + procedure WriteMetaData(const AMetaData: TMetaData); + + /// Finalises the output. Always called after all other methods. + /// + /// Method of IDataWriter. + procedure Finalise; + + end; + +implementation + + +uses + // Delphi + IOUtils, + // Project + Compilers.UGlobals, + DB.SnippetKind, + UComparers, + UConsts, + UEncodings, + UExceptions, + UIOUtils, + UREMLDataIO, + USnippetExtraHelper, + UStrUtils, + UUtils; + + +const + // Name of master file that defines database + cMasterFileName = 'categories.ini'; + + // Names of v2 meta data files + VersionFileName = 'VERSION'; + LicenseFileName = 'LICENSE'; + LicenseInfoFileName = 'LICENSE-INFO'; + ContributorsFileName = 'CONTRIBUTORS'; + AcknowledgementsFileName = 'TESTERS'; + + // Names of v1 meta data files + ContributorsFileNameV1 = 'contrib.txt'; + AcknowledgementsFileNameV1 = 'testers.txt'; + + + // Names of keys in license info file + LicenseInfoLicenseNameKey = 'LicenseName'; + LicenseInfoLicenseSPDXKey = 'LicenseSPDX'; + LicenseInfoLicenseURLKey = 'LicenseURL'; + LicenseInfoCopyrightDateKey = 'CopyrightDate'; + LicenseInfoCopyrightHolderKey = 'CopyrightHolder'; + LicenseInfoCopyrightHolderURLKey = 'CopyrightHolderURL'; + + // Names of values in categories ini file + cMasterIniName = 'Ini'; // name of category ini file + cMasterDescName = 'Desc'; // category description + // Names of values in snippet sections of various category ini files + cDependsName = 'Depends'; // dependency list for snippet + cUnitsName = 'Units'; // required unit list for snippet + cXRefName = 'SeeAlso'; // cross-reference list for snippet + cDisplayName = 'DisplayName'; // snippet's display name if any + cExtraName = 'Extra'; // extra information for snippet + cCreditsName = 'Credits'; // snippet credits + cCreditsURLName = 'Credits_URL'; // url relating to snippet credits + cCommentsName = 'Comments'; // snippet additional comments + cDescName = 'Desc'; // snippet description (plain text) + cDescExName = 'DescEx'; // snippet descriptio (REML) + cSnipFileName = 'Snip'; // name of snippet's snippet file + cStdFormatName = 'StandardFormat'; // whether snippet in std format + cKindName = 'Kind'; // kind of snippet + cTestInfoName = 'TestInfo'; // snippet's testing information + cCompilerIDNames: // snippet's compiler results for each + array[TCompilerID] of string = ( + 'Delphi2', 'Delphi3', 'Delphi4', 'Delphi5', 'Delphi6', 'Delphi7', + 'Delphi2005Win32', 'Delphi2006Win32', 'Delphi2007', 'Delphi2009Win32', + 'Delphi2010', 'DelphiXE', 'DelphiXE2', 'DelphiXE3', 'DelphiXE4', + 'DelphiXE5', 'DelphiXE6', 'DelphiXE7', 'DelphiXE8', 'Delphi10S', + 'Delphi101B', 'Delphi102T', 'Delphi103R', 'Delphi104S', 'Delphi11A', + 'Delphi12A', + 'FPC' + ); + +{ TDCSCV2VaultStorageReader } + +function TDCSCV2VaultStorageReader.CatToCatIni(const CatID: string): string; +begin + Result := DataFile(fMasterIni.ReadString(CatID, cMasterIniName, '')); +end; + +class function TDCSCV2VaultStorageReader.CommaStrToStrings( + const CommaStr: string): IStringList; +begin + Result := TIStringList.Create(CommaStr, ',', False, True); +end; + +constructor TDCSCV2VaultStorageReader.Create(const DBDir: string); +resourcestring + // Error messages + sVersionNotSpecified = 'Format version number not specified'; + sVersionNotSupported = 'Format version %s is not supported'; +begin + inherited Create; + fDBDir := DBDir; + // Create helper objects used to speed up access to ini files + if DatabaseExists then + begin + fIniCache := TIniFileCache.Create; + try + ReadVersionNumber; + if fVersion.IsNull then + raise EDataIO.Create(sVersionNotSpecified); + if fVersion.V1 <> SupportedMajorVersion then + raise EDataIO.CreateFmt(sVersionNotSupported, [string(fVersion)]); + fMasterIni := TUTF8IniFileEx.Create(MasterFileName); + fCatIDs := TStringList.Create; + fSnippetCatMap := TSnippetCatMap.Create(TTextEqualityComparer.Create); + // Load required indexes + LoadIndices; + except + HandleCorruptDatabase(ExceptObject); + end; + end; +end; + +function TDCSCV2VaultStorageReader.DatabaseExists: Boolean; +begin + Result := FileExists(MasterFileName); +end; + +function TDCSCV2VaultStorageReader.DataDir: string; +begin + Result := ExcludeTrailingPathDelimiter(fDBDir) +end; + +function TDCSCV2VaultStorageReader.DataFile(const FileName: string): string; +begin + Result := IncludeTrailingPathDelimiter(DataDir) + FileName; +end; + +function TDCSCV2VaultStorageReader.DataFileExists(const FileName: string): + Boolean; +begin + Result := TFile.Exists(DataFile(FileName), False); +end; + +destructor TDCSCV2VaultStorageReader.Destroy; +begin + fIniCache.Free; + fSnippetCatMap.Free; + fCatIDs.Free; + fMasterIni.Free; + inherited; +end; + +function TDCSCV2VaultStorageReader.GetAllCatIDs: IStringList; +begin + Result := TIStringList.Create(fCatIDs); +end; + +procedure TDCSCV2VaultStorageReader.GetCatProps(const CatID: string; + var Props: TCategoryData); +begin + try + Props.Desc := fMasterIni.ReadString(CatID, cMasterDescName, ''); + except + HandleCorruptDatabase(ExceptObject); + end; +end; + +function TDCSCV2VaultStorageReader.GetCatSnippets(const CatID: string): + IStringList; +var + CatIniFile: string; + CatIni: TCustomIniFile; // accesses .ini file associated with category + SnipList: TStringList; // list of snippets in category +begin + Result := TIStringList.Create; + try + // Snippet names are names of sections in category's .ini file + CatIniFile := CatToCatIni(CatID); + if not TFile.Exists(CatIniFile) then + // This is not an error since it is possible that a category exists in + // another vault and loader will request info from that vault too. + Exit; + CatIni := fIniCache.GetIniFile(CatToCatIni(CatID)); + SnipList := TStringList.Create; + try + CatIni.ReadSections(SnipList); + Result.Add(SnipList); + finally + SnipList.Free; + end; + except + HandleCorruptDatabase(ExceptObject); + end; +end; + +function TDCSCV2VaultStorageReader.GetFileEncoding(const FileName: string): + TEncoding; +begin + // Old v1 database meta files may be in the system default encodings, v1 and + // all v2 and later use UTF-8 with BOM. + if TFileIO.CheckBOM(DataFile(FileName), TEncoding.UTF8) then + Result := TEncoding.UTF8 + else + Result := TEncoding.Default; +end; + +function TDCSCV2VaultStorageReader.GetMetaData: TMetaData; +var + SL: TStringList; + LicenseText: string; + LicenseFileInfo: TStringDynArray; + Contributors: IStringList; +begin + + LicenseText := StrTrimRight(ReadFileText(LicenseFileName)); + LicenseFileInfo := ReadFileLines(LicenseInfoFileName); + Contributors := TIStringList.Create(ReadFileLines(ContributorsFileName)); + + Result := TMetaData.Create([ + TMetaDataCap.Version, TMetaDataCap.License, TMetaDataCap.Copyright, + TMetaDataCap.Acknowledgements + ]); + Result.Version := fVersion; // this was read in constructor + SL := TStringList.Create; + try + StrArrayToStrList(LicenseFileInfo, SL); + Result.LicenseInfo := TLicenseInfo.Create( + SL.Values[LicenseInfoLicenseNameKey], + SL.Values[LicenseInfoLicenseSPDXKey], + SL.Values[LicenseInfoLicenseURLKey], + LicenseText + ); + Result.CopyrightInfo := TCopyrightInfo.Create( + SL.Values[LicenseInfoCopyrightDateKey], + SL.Values[LicenseInfoCopyrightHolderKey], + SL.Values[LicenseInfoCopyrightHolderURLKey], + Contributors + ); + finally + SL.Free; + end; + Result.Acknowledgements := TIStringList.Create( + ReadFileLines(AcknowledgementsFileName) + ); +end; + +function TDCSCV2VaultStorageReader.GetSnippetDepends(const SnippetKey: string): + IStringList; +begin + Result := GetSnippetReferences(SnippetKey, cDependsName); +end; + +procedure TDCSCV2VaultStorageReader.GetSnippetProps(const SnippetKey: string; + var Props: TSnippetData); +var + CatIni: TCustomIniFile; // .ini file associated with snippet's category + CatID: string; // snippet's category id + + /// Reads "StandardFormat" value from ini file. + function GetStdFormatProperty: Boolean; + begin + Result := CatIni.ReadBool(SnippetKey, cStdFormatName, True); + end; + + /// Reads "Kind" value from ini file. + function GetKindProperty: TSnippetKind; + var + KindStr: string; // string value read from ini file + begin + KindStr := CatIni.ReadString(SnippetKey, cKindName, ''); + if StrSameText(KindStr, 'freeform') then + Result := skFreeform + else if StrSameText(KindStr, 'routine') then + Result := skRoutine + else if StrSameText(KindStr, 'const') then + Result := skConstant + else if StrSameText(KindStr, 'type') then + Result := skTypeDef + else if StrSameText(KindStr, 'unit') then + Result := skUnit + else if StrSameText(KindStr, 'class') then + Result := skClass + // invalid or no Kind property: kind depends on StdFormat property + else if GetStdFormatProperty then + Result := skRoutine + else + Result := skFreeform; + end; + + /// Reads "Extra" value from ini file and converts to active text. + /// + function GetExtraProperty: IActiveText; + var + Extra: string; // extra value from ini file if present + begin + try + Extra := CatIni.ReadString(SnippetKey, cExtraName, ''); + if Extra <> '' then + // There is an "extra" value: use it to set Extra property. We ignore + // any credits, credits url and comments values in this case + Result := TSnippetExtraHelper.BuildActiveText(Extra) + else + // There is no "extra" value: use any comments, credits and credits URL + // values to set Extra property + Result := TSnippetExtraHelper.BuildActiveText( + CatIni.ReadString(SnippetKey, cCommentsName, ''), + CatIni.ReadString(SnippetKey, cCreditsName, ''), + CatIni.ReadString(SnippetKey, cCreditsURLName, '') + ); + except + // There was an error: use an empty property value + Result := TActiveTextFactory.CreateActiveText; + end; + end; + + /// Reads "Snip" value from ini value and loads source code from the + /// referenced file. + function GetSourceCodeProperty: string; + var + SnipFileName: string; // name of file containing source code + begin + SnipFileName := CatIni.ReadString(SnippetKey, cSnipFileName, ''); + try + Result := TFileIO.ReadAllText( + DataFile(SnipFileName), TEncoding.UTF8, True + ); + except + // if error loading file then database is corrupt + on E: EFOpenError do + raise EDataIO.Create(E); + else + raise; + end; + end; + + /// Reads all compiler ID values from ini file and builds list of + /// compiler results. + function GetCompilerResultsProperty: TCompileResults; + var + CompID: TCompilerID; // loops thru supported compilers + CompRes: string; // character indicating compiler result + begin + for CompID := Low(TCompilerID) to High(TCompilerID) do + begin + CompRes := CatIni.ReadString(SnippetKey, cCompilerIDNames[CompID], '?'); + if CompRes = '' then + CompRes := '?'; + case CompRes[1] of + 'W', // warning result now treated as success + 'Y': Result[CompID] := crSuccess; + 'N': Result[CompID] := crError; + else Result[CompID] := crQuery; + end; + end; + end; + + /// Gets snippet description from ini file. + /// Uses REML from DescEx field if present, otherwise uses plain + /// text from Desc field if present, otherwise description is empty. + /// + function GetDescription: IActiveText; + var + REML: string; // REML code from DescEx field + PlainText: string; // plain text from Desc field + begin + REML := CatIni.ReadString(SnippetKey, cDescExName, ''); + if REML <> '' then + Result := TSnippetExtraHelper.BuildActiveText(REML) + else + begin + PlainText := CatIni.ReadString(SnippetKey, cDescName, ''); + if PlainText <> '' then + Result := TSnippetExtraHelper.PlainTextToActiveText(PlainText) + else + Result := TActiveTextFactory.CreateActiveText; + end; + end; + + /// Gets snippet's display name from ini file. + function GetDisplayNameProperty: string; + begin + Result := CatIni.ReadString(SnippetKey, cDisplayName, ''); + end; + + /// Get's snippet's test info from ini file. + function GetTestInfoProperty: TSnippetTestInfo; + var + Str: string; // string value read from ini file + begin + Str := CatIni.ReadString(SnippetKey, cTestInfoName, 'basic'); + if StrSameText(Str, 'basic') then + Result := stiBasic + else if StrSameText(Str, 'advanced') then + Result := stiAdvanced + else // Str = 'none' or any invalid value + Result := stiNone; + end; + +begin + try + // Get name of category associated with this snippet + CatID := SnippetToCat(SnippetKey); + // Get snippet properties from values listed under snippet's section in + // category's .ini file + CatIni := fIniCache.GetIniFile(CatToCatIni(CatID)); + Props.Kind := GetKindProperty; + Props.Cat := CatID; + Props.Desc := GetDescription; + Props.Extra := GetExtraProperty; + Props.DisplayName := GetDisplayNameProperty; + Props.SourceCode := GetSourceCodeProperty; + Props.CompilerResults := GetCompilerResultsProperty; + Props.TestInfo := GetTestInfoProperty; + // all snippets from main database are Pascal and use syntax highlighter: + // there is no entry in data files to switch this on or off + Props.HiliteSource := True; + except + HandleCorruptDatabase(ExceptObject); + end; +end; + +function TDCSCV2VaultStorageReader.GetSnippetReferences(const SnippetKey, + KeyName: string): IStringList; +var + CatIni: TCustomIniFile; // accesses snippet's category's .ini +begin + try + // References are contained in comma separated value in category's ini file + // under snippet's section + CatIni := fIniCache.GetIniFile(CatToCatIni(SnippetToCat(SnippetKey))); + Result := CommaStrToStrings(CatIni.ReadString(SnippetKey, KeyName, '')); + except + HandleCorruptDatabase(ExceptObject); + end; +end; + +function TDCSCV2VaultStorageReader.GetSnippetUnits(const SnippetKey: string): + IStringList; +begin + Result := GetSnippetReferences(SnippetKey, cUnitsName); +end; + +function TDCSCV2VaultStorageReader.GetSnippetXRefs(const SnippetKey: string): + IStringList; +begin + Result := GetSnippetReferences(SnippetKey, cXRefName); +end; + +procedure TDCSCV2VaultStorageReader.HandleCorruptDatabase(const EObj: TObject); +resourcestring + // Error message + sDBError = 'The database is corrupt and had been deleted.' + EOL2 + '%s'; +begin + DeleteFiles(DataDir, '*.*'); + if (EObj is EDataIO) + or (EObj is EFileStreamError) then + // we have database error: raise new exception containing old message + raise EDataIO.CreateFmt(sDBError, [(EObj as Exception).Message]) + else + // not an ECodeSnip: just re-raise + raise EObj; +end; + +procedure TDCSCV2VaultStorageReader.LoadIndices; +var + SnippetKey: string; // key of each snippet in a category + CatIdx: Integer; // loops thru all categories + CatSnippets: IStringList; // list of snippets in a single category +begin + // Read in list of category names + fMasterIni.ReadSections(fCatIDs); + // We build map of snippet names to categories by reading snippets in each + // category and referencing that category's id with the snippet name. + CatSnippets := TIStringList.Create; + for CatIdx := 0 to Pred(fCatIDs.Count) do + begin + // Get list of snippets in category ... + CatSnippets := GetCatSnippets(fCatIDs[CatIdx]); + for SnippetKey in CatSnippets do + fSnippetCatMap.Add(SnippetKey, CatIdx); + end; +end; + +function TDCSCV2VaultStorageReader.MasterFileName: string; +begin + Result := DataFile(cMasterFileName); +end; + +function TDCSCV2VaultStorageReader.ReadFileLines(const FileName: string): + TStringDynArray; +var + Encoding: TEncoding; +begin + if not DataFileExists(FileName) then + begin + SetLength(Result, 0); + Exit; + end; + Encoding := GetFileEncoding(FileName); + try + Result := TFileIO.ReadAllLines(DataFile(FileName), Encoding, True); + finally + TEncodingHelper.FreeEncoding(Encoding); + end; +end; + +function TDCSCV2VaultStorageReader.ReadFileText(const FileName: string): string; +begin + if not DataFileExists(FileName) then + Exit(''); + Result := TFileIO.ReadAllText( + DataFile(FileName), GetFileEncoding(FileName), True + ); +end; + +procedure TDCSCV2VaultStorageReader.ReadVersionNumber; +var + VersionStr: string; +begin + if DataFileExists(VersionFileName) then + begin + // Version file exists. Read and parse it. Set to null if invalid + VersionStr := StrTrim(ReadFileText(VersionFileName)); + if not TVersionNumber.TryStrToVersionNumber(VersionStr, fVersion) then + fVersion := TVersionNumber.Nul; + end + else + begin + // No version file. Check if v1 present. Set to null if v1 not detected + if DataFileExists(ContributorsFileNameV1) + and DataFileExists(AcknowledgementsFileNameV1) then + fVersion := TVersionNumber.Create(1, 0, 0, 0) + else + fVersion := TVersionNumber.Nul; + end; +end; + +function TDCSCV2VaultStorageReader.SnippetToCat(const SnippetKey: string): + string; +var + CatIdx: Integer; // index of category in category list for this snippet +resourcestring + // Error message + sMissingSnippet = 'Snippet key "%s" not found in database.'; +begin + if not fSnippetCatMap.ContainsKey(SnippetKey) then + raise EDataIO.CreateFmt(sMissingSnippet, [SnippetKey]); + CatIdx := fSnippetCatMap[SnippetKey]; + Result := fCatIDs[CatIdx]; +end; + +{ TDCSCV2VaultStorageReader.TUTF8IniFileEx } + +constructor TDCSCV2VaultStorageReader.TUTF8IniFileEx.Create( + const AFileName: string); +resourcestring + sFileNotFound = 'File "%s" does not exist.'; +begin + inherited Create(AFileName); + if not TFile.Exists(AFileName) then + raise EDataIO.CreateFmt( + sFileNotFound, [ExtractFileName(AFileName)] + ); + SetStrings(TFileIO.ReadAllLines(AFileName, TEncoding.UTF8, True)); +end; + +function TDCSCV2VaultStorageReader.TUTF8IniFileEx.ReadString(const Section, + Ident, Default: string): string; +begin + // Read string from ini + Result := inherited ReadString(Section, Ident, Default); + // Strip any leading and trailing quotes + if (Length(Result) > 1) and (Result[1] = DOUBLEQUOTE) + and (Result[Length(Result)] = DOUBLEQUOTE) then + Result := Copy(Result, 2, Length(Result) - 2); +end; + +procedure TDCSCV2VaultStorageReader.TUTF8IniFileEx.SetStrings( + const AStrings: TStringDynArray); +var + SL: TStringList; + Str: string; +begin + SL := TStringList.Create; + try + for Str in AStrings do + SL.Add(Str); + SetStrings(SL); + finally + SL.Free; + end; +end; + +{ TDCSCV2VaultStorageReader.TIniFileCache } + +constructor TDCSCV2VaultStorageReader.TIniFileCache.Create; +begin + inherited Create; + // fCache owns and frees the ini file objects + fCache := TIniFileMap.Create( + [doOwnsValues], TTextEqualityComparer.Create + ); +end; + +destructor TDCSCV2VaultStorageReader.TIniFileCache.Destroy; +begin + fCache.Free; // frees owned .Values[] objects + inherited; +end; + +function TDCSCV2VaultStorageReader.TIniFileCache.GetIniFile( + const PathToFile: string): TCustomIniFile; +begin + if not fCache.ContainsKey(PathToFile) then + fCache.Add(PathToFile, TUTF8IniFileEx.Create(PathToFile)); + Result := fCache[PathToFile]; +end; + +{ TDCSCV2VaultStorageWriter } + +function TDCSCV2VaultStorageWriter.ActiveTextToREML(AActiveText: IActiveText): + string; +begin + Result := TREMLWriter.Render(AActiveText, False); +end; + +constructor TDCSCV2VaultStorageWriter.Create(const AOutDir: string); +begin + inherited Create; + fOutDir := AOutDir; + fCache := TUTF8IniFileCache.Create; +end; + +destructor TDCSCV2VaultStorageWriter.Destroy; +begin + fCache.Free; // frees owned ini file objects + inherited; +end; + +procedure TDCSCV2VaultStorageWriter.Finalise; +var + IniInfo: TPair; +begin + try + for IniInfo in fCache do + IniInfo.Value.Save; + except + HandleException(ExceptObject); + end; +end; + +procedure TDCSCV2VaultStorageWriter.HandleException(const EObj: TObject); +begin + if (EObj is EFileStreamError) or (EObj is ECodeSnip) + or (EObj is EDirectoryNotFoundException) then + raise EDataIO.Create(EObj as Exception); + raise EObj; +end; + +procedure TDCSCV2VaultStorageWriter.Initialise; +begin + try + // Make sure database folder exists + TDirectory.CreateDirectory(fOutDir); + + // Delete current ini and data files + // (don't delete special files: CONTRIBUTORS, LICENSE, LICENSE-INFO, + // TESTERS, VERSION). + {TODO -cVault: Is it now safe to delete the special files, since we now + write these files.} + DeleteFiles(fOutDir, '*.dat'); + DeleteFiles(fOutDir, '*.ini'); + + // Initialise file count + fFileNumber := 0; + + // Record path to master meta data file. + fMasterIniPath := MakePath(cMasterFileName); + + except + HandleException(ExceptObject); + end; +end; + +function TDCSCV2VaultStorageWriter.MakeCatIniName(const ACatID: string): string; +begin + Result := ACatID + '.ini'; +end; + +function TDCSCV2VaultStorageWriter.MakeCatIniPath(const ACatID: string): string; +begin + Result := MakePath(MakeCatIniName(ACatID)); +end; + +function TDCSCV2VaultStorageWriter.MakePath(const AFileName: string): string; +begin + Result := TPath.Combine(fOutDir, AFileName); +end; + +procedure TDCSCV2VaultStorageWriter.WriteCatProps(const CatID: string; + const Props: TCategoryData); +var + Master: TUTF8IniFile; +begin + // Add entry to master ini file + Master := fCache.GetIniFile(fMasterIniPath); + Master.WriteString(CatId, cMasterDescName, Props.Desc); + Master.WriteString(CatId, cMasterIniName, MakeCatIniName(CatID)); +end; + +procedure TDCSCV2VaultStorageWriter.WriteCatSnippets(const CatID: string; + const SnipList: IStringList); +begin + // Do nothing +end; + +procedure TDCSCV2VaultStorageWriter.WriteMetaData(const AMetaData: TMetaData); +var + VersionStr: string; + KVPairs: TStringList; + LicenseInfo: IStringList; +begin + VersionStr := Format( + '%0:d.%1:d.%2:d', + [AMetaData.Version.V1, AMetaData.Version.V2, AMetaData.Version.V3] + ); + KVPairs := TStringList.Create; + try + KVPairs.Values[LicenseInfoLicenseNameKey] := AMetaData.LicenseInfo.Name; + KVPairs.Values[LicenseInfoLicenseSPDXKey] := AMetaData.LicenseInfo.SPDX; + KVPairs.Values[LicenseInfoLicenseURLKey] := AMetaData.LicenseInfo.URL; + KVPairs.Values[LicenseInfoCopyrightDateKey] := AMetaData.CopyrightInfo.Date; + KVPairs.Values[LicenseInfoCopyrightHolderKey] := + AMetaData.CopyrightInfo.Holder; + KVPairs.Values[LicenseInfoCopyrightHolderURLKey] := + AMetaData.CopyrightInfo.HolderURL; + LicenseInfo := TIStringList.Create(KVPairs); + finally + KVPairs.Free; + end; + + WriteTextFile(VersionFileName, VersionStr); + WriteTextFile(LicenseFileName, AMetaData.LicenseInfo.Text); + WriteTextFile(LicenseInfoFileName, LicenseInfo); + WriteTextFile(ContributorsFileName, AMetaData.CopyrightInfo.Contributors); + WriteTextFile(AcknowledgementsFileName, AMetaData.Acknowledgements); +end; + +procedure TDCSCV2VaultStorageWriter.WriteSnippetDepends( + const SnippetKey: string; const Depends: IStringList); +begin + fCurrentCatIni.WriteString( + SnippetKey, cDependsName, Depends.GetText(',', False) + ); +end; + +procedure TDCSCV2VaultStorageWriter.WriteSnippetProps(const SnippetKey: string; + const Props: TSnippetData); +const + Kinds: array[TSnippetKind] of string = ( + 'freeform', // skFreeform + 'routine', // skRoutine + 'const', // skConstant + 'type', // skTypeDef + 'unit', // skUnit + 'class' // skClass + ); + CompileResults: array[TCompileResult] of Char = ( + 'Y', // crSuccess + 'Y', // crWarning + 'N', // crError + 'Q' // crQuery + ); + TestInfo: array[TSnippetTestInfo] of string = ( + {TODO -cVault: New empty entries added because new entries have been added + to TSnippetTestInfo. Need to update code to support new Advanced.XXX + entries in DCSC v2.2} + 'none', // stiNone + 'basic', // stiBasic + 'advanced', // stiAdvanced + '', // stiUnitTests + '' // stiDemoCode + ); +var + SourceFileName: string; + SourceFilePath: string; + CompilerID: TCompilerID; + CompileResult: Char; +begin + + fCurrentCatIni := fCache.GetIniFile(MakeCatIniPath(Props.Cat)); + + try + // Write source code file + Inc(fFileNumber); + SourceFileName := IntToStr(fFileNumber) + '.dat'; + SourceFilePath := MakePath(SourceFileName); + TFileIO.WriteAllText( + SourceFilePath, Props.SourceCode, TEncoding.UTF8, True + ); + + // snippet kind + fCurrentCatIni.WriteString(SnippetKey, cKindName, Kinds[Props.Kind]); + + // display name, if set + if (Props.DisplayName <> '') then + {TODO -cVault: strictly, for v2 format, this name must be <=64 chars} + fCurrentCatIni.WriteString(SnippetKey, cDisplayName, Props.DisplayName); + + // description (must be set for v2) + fCurrentCatIni.WriteString( + SnippetKey, + cDescExName, + DOUBLEQUOTE + ActiveTextToREML(Props.Desc) + DOUBLEQUOTE + ); + + // extra info, if set + if Props.Extra.HasContent then + fCurrentCatIni.WriteString( + SnippetKey, + cExtraName, + DOUBLEQUOTE + ActiveTextToREML(Props.Extra) + DOUBLEQUOTE + ); + + // snippet file reference + fCurrentCatIni.WriteString(SnippetKey, cSnipFileName, SourceFileName); + + // compiler info + for CompilerID := Low(TCompilerID) to High(TCompilerID) do + begin + CompileResult := CompileResults[Props.CompilerResults[CompilerID]]; + if CompileResult <> 'Q' then + fCurrentCatIni.WriteString( + SnippetKey, cCompilerIDNames[CompilerID], CompileResult + ); + end; + + // test info: only write if not basic + {TODO -cVault: Add support for AdvancedTest .Level & .URL} + if Props.TestInfo <> stiBasic then + fCurrentCatIni.WriteString( + SnippetKey, cTestInfoName, TestInfo[Props.TestInfo] + ); + + except + + HandleException(ExceptObject); + + end; + // NOTE: + // The following deprecated keys are not written: alternatives are always + // used: + // * StandardFormat - Kind is used instead + // * Credits - Extra is used instead + // * Credits_URL - Extra is used instead + // * Comments - Extra is used instead + // * Desc - DescEx is used instead + +end; + +procedure TDCSCV2VaultStorageWriter.WriteSnippetUnits(const SnippetKey: string; + const Units: IStringList); +begin + fCurrentCatIni.WriteString( + SnippetKey, cUnitsName, Units.GetText(',', False) + ); +end; + +procedure TDCSCV2VaultStorageWriter.WriteSnippetXRefs(const SnippetKey: string; + const XRefs: IStringList); +begin + fCurrentCatIni.WriteString( + SnippetKey, cXRefName, XRefs.GetText(',', False) + ); +end; + +procedure TDCSCV2VaultStorageWriter.WriteTextFile(const AFileName, + AText: string); +begin + TFileIO.WriteAllText(MakePath(AFileName), AText, TEncoding.UTF8, True); +end; + +procedure TDCSCV2VaultStorageWriter.WriteTextFile(const AFileName: string; + const ALines: IStringList); +var + Content: string; +begin + Content := ALines.GetText(EOL, False); + if not StrIsEmpty(Content) then + Content := Content + EOL; + WriteTextFile(AFileName, Content); +end; + +{ TDCSCV2VaultStorageWriter.TUTF8IniFile } + +procedure TDCSCV2VaultStorageWriter.TUTF8IniFile.Save; +var + Data: TStringList; +begin + Data := TStringList.Create; + try + GetStrings(Data); + TFileIO.WriteAllLines(FileName, Data.ToStringArray, Encoding, True); + finally + Data.Free; + end; +end; + +{ TDCSCV2VaultStorageWriter.TUTF8IniFileCache } + +procedure TDCSCV2VaultStorageWriter.TUTF8IniFileCache.AddIniFile( + const APathToFile: string); +begin + if not fCache.ContainsKey(APathToFile) then + InternalAddIniFile(APathToFile); +end; + +constructor TDCSCV2VaultStorageWriter.TUTF8IniFileCache.Create; +begin + inherited Create; + // fCache owns and frees the ini file objects + fCache := TIniFileMap.Create( + [doOwnsValues], TTextEqualityComparer.Create + ); +end; + +destructor TDCSCV2VaultStorageWriter.TUTF8IniFileCache.Destroy; +begin + fCache.Free; // frees all owned ini file objects in .Values[] + inherited; +end; + +function TDCSCV2VaultStorageWriter.TUTF8IniFileCache.GetEnumerator: + TObjectDictionary.TPairEnumerator; +begin + Result := fCache.GetEnumerator; +end; + +function TDCSCV2VaultStorageWriter.TUTF8IniFileCache.GetIniFile( + const APathToFile: string): TUTF8IniFile; +begin + if not fCache.ContainsKey(APathToFile) then + Result := InternalAddIniFile(APathToFile) + else + Result := fCache[APathToFile]; +end; + +function TDCSCV2VaultStorageWriter.TUTF8IniFileCache.InternalAddIniFile( + const APathToFile: string): TUTF8IniFile; +begin + Result := TUTF8IniFile.Create(APathToFile, TEncoding.UTF8); + fCache.Add(APathToFile, Result); +end; + +end. + diff --git a/Src/DB.IO.Vault.Native.pas b/Src/DB.IO.Vault.Native.pas new file mode 100644 index 000000000..8ae7714b7 --- /dev/null +++ b/Src/DB.IO.Vault.Native.pas @@ -0,0 +1,1341 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2025, Peter Johnson (gravatar.com/delphidabbler). + * + * Implements classes that can read and write vaults stored in the CodeSnip + * Vault native data format. +} + + +unit DB.IO.Vault.Native; + +interface + +uses + // Delphi + XMLIntf, + // Project + Compilers.UGlobals, + DB.MetaData, + DB.Categories, + DB.SnippetKind, + DB.Snippets, + DB.IO.Vault, + UIStringList, + UVersionInfo, + UXMLDocumentEx; + +type + + /// Base class for classes that read and write vault data in the + /// CodeSnip Vault native data format. + TNativeVaultStorage = class abstract(TInterfacedObject) + strict private + var + /// Value of DataDirectory property. + fDataDirectory: string; + /// Value of XMLDoc property. + fXMLDoc: IXMLDocumentEx; + strict protected + const + /// Name of vault's XML file. + XMLFileName = 'vault.xml'; + /// Extension used for source code files. + SourceCodeFileExt = '.source'; + /// Name of vaults's license file, if any. + LicenseTextFileName = 'license.txt'; + /// Watermark included in all native data format files. + /// + Watermark = '882BAD68-8C3E-44E3-BBF4-17E55143DAF8'; + /// Version number of the earliest supported data file format. + /// + EarliestFileVersion: TVersionNumber = (V1: 1; V2: 0; V3: 0; V4: 0); + /// Version number of the current data file format. + CurrentFileVersion: TVersionNumber = (V1: 1; V2: 0; V3: 0; V4: 0); + + // XML node and attribute names + RootNodeName = 'vault'; + RootNodeWatermarkAttr = 'watermark'; + RootNodeVersionMajorAttr = 'version-major'; + RootNodeVersionMinorAttr = 'version-minor'; + CategoriesNodeName = 'categories'; + CategoryNodeName = 'category'; + CategoryNodeIdAttr = 'id'; + CategoryDescriptionNodeName = 'description'; + CategorySnippetsListNodeName = 'snippet-keys'; + CategorySnippetsListItemNodeName = 'key'; + SnippetsNodeName = 'snippets'; + SnippetNodeName = 'snippet'; + SnippetNodeKeyAttr = 'key'; + SnippetNodeCategoryAttr = 'category'; + SnippetNodeKindAttr = 'kind'; + SnippetDescriptionNodeName = 'description'; + SnippetSourceNodeName = 'source-code'; + SnippetSourceNodeFileAttr = 'file-name'; + SnippetSourceNodeLanguageAttr = 'language'; + SnippetDisplayNameNodeName = 'display-name'; + SnippetNotesNodeName = 'notes'; + SnippetCompileResultsNodeName = 'compile-results'; + SnippetCompilerNodeName = 'compiler'; + SnippetCompilerNodeIdAttr = 'id'; + SnippetCompilerNodeResultAttr = 'result'; + SnippetTestInfoNodeName = 'tests'; + SnippetTestInfoNodeLevelAttr = 'level'; + SnippetTestInfoNodeUrlAttr = 'url'; + SnippetUnitsListNodeName = 'required-units'; + SnippetUnitsListItemNodeName = 'unit'; + SnippetDependsListNodeName = 'required-snippets'; + SnippetDependsListItemNodeName = 'key'; + SnippetXRefsListNodeName = 'xrefs'; + SnippetXRefsListItemNodeName = 'key'; + LicenseNodeName = 'license'; + LicenseNodeSPDXAttr = 'spdx'; + LicenseNodeNameAttr = 'name'; + LicenseNodeURLAttr = 'url'; + LicenseNodeLicenseFileAttr = 'license-file-name'; + CopyrightNodeName = 'copyright'; + CopyrightNodeDateAttr = 'date'; + CopyrightNodeHolderAttr = 'holder'; + CopyrightNodeURLAttr = 'holder-url'; + CopyrightContributorsListNodeName = 'contributors'; + CopyrightContributorsListItemNodeName = 'name'; + AcknowledgementsListNodeName = 'acknowledgements'; + AcknowledgementsListItemNodeName = 'name'; + + /// Map of snippet kinds to the representative value used in the + /// XML file. + SnippetKindValues: array[TSnippetKind] of string = ( + 'freeform', 'routine', 'const', 'type', 'unit', 'class' + ); + + /// Map of compile result values to the representative value + /// used in the XML file. + /// crWarning is not supported and maps to the same value + /// as crSuccess. + CompileResultValues: array[TCompileResult] of Char = ('y', 'y', 'n', 'q'); + + /// Map of compiler IDs to the representative value used in the + /// XML file. + CompilerIDs: array[TCompilerID] of string = ( + 'd2', 'd3', 'd4', 'd5', 'd6', 'd7', + 'd2005', 'd2006', 'd2007', 'd2009', 'd2010', + 'dxe', 'dxe2', 'dxe3', 'dxe4', 'dxe5', 'dxe6', 'dxe7', 'dxe8', + 'd10.0', 'd10.1', 'd10.2', 'd10.3', 'd10.4', 'd11', 'd12', + 'fpc' + ); + + /// Map of test information to the representative value used in + /// the XML file. + TestInfoValues: array[TSnippetTestInfo] of string = ( + 'none', 'basic', 'advanced', 'unit-tests', 'demo-code' + ); + + strict protected + + /// Directory containing the vault. + property DataDirectory: string read fDataDirectory; + + /// XML document object. + property XMLDoc: IXMLDocumentEx read fXMLDOc; + + /// Creates and activates a minimal XML document containing a + /// processing instruction and a root node with the required attributes. + /// + /// IXMLNode. Reference to the root node. + function InitXMLDocAndRootNode: IXMLNode; + + /// Finds a specified category node. + /// string [in] ID of required category. + /// + /// IXMLNode. Found node or nil if the node was not found. + /// + function FindCategoryNode(const ACatID: string): IXMLNode; + + /// Finds a specified snippet node. + /// string [in] Key of required snippet. + /// + /// IXMLNode. Found node or nil if the node was not found. + /// + function FindSnippetNode(const ASnippetKey: string): IXMLNode; + + /// Returns fully specified path of the XML file. + function PathToXMLFile: string; + + /// Returns fully specified path of a file within the vault + /// directory. + function FilePath(const AFileName: string): string; + + public + + /// Object constructor. Creates an XML document to access the + /// vaults's XML file. + /// string [in] Full path to the + /// directory that contains the vault's data files. + constructor Create(const ADataDirectory: string); + + end; + + /// Reads a vault's data from storage in the CodeSnip Vault native + /// format. + TNativeVaultStorageReader = class sealed(TNativeVaultStorage, + IVaultStorageReader + ) + strict private + var + /// Flag that indicates if unit & depends-upon lists are + /// permitted. + fCanReadRequiredLists: Boolean; + + /// Validates an XML document loaded from storage. Returns + /// normally on success or raises exception on error. + /// EDataIO raised if there is no valid root node with + /// the expected watermark and a valid version number. + procedure ValidateDoc; + + /// Reads a list of text nodes that each have the same tag name, + /// within an enclosing node. + /// IXMLNode [in] Reference to the parent + /// node of the node that encloses the list items. + /// string [in] Name of the node that + /// encloses the list items. + /// string [in] Name of each list item + /// node. + /// IStringList [in] Text value of each list item. + /// + function GetEnclosedListItems(const AParentNode: IXMLNode; + const AListNodeName, AItemNodeName: string): IStringList; + + /// Reads a list of items that are referenced by a given snippet. + /// + /// string [in] Key of snippet making the + /// references. + /// string [in] Name of the XML node + /// that contains the list items. + /// string [in] Name of each list item + /// XML node within the list. + /// IStringList [in] List of referenced items. + function GetSnippetReferences(const ASnippetKey, AListNodeName, + AListItemName: string): IStringList; + + /// Handles exceptions raised by converting expected exceptions + /// into ECodeSnip derived exceptions. + /// TObject [in] Reference to exception object to + /// be handled. + /// Always raises an exception. Expected exceptions are + /// re-raised as EDataIO exceptions. Unexpected exceptions are + /// re-raised unchanged. + procedure HandleException(const EObj: TObject); + public + + /// Object constructor. Loads XML from file if the vault exists, + /// otherwise creates a minimal empty document. + /// string [in] Full path to the + /// directory that contains the vault's data files. + constructor Create(const ADirectory: string); + + /// Checks if the vault exists. + /// Boolean. Returns True if the vault exists or + /// False if not. + /// + /// This method is always called before any other IDataReader + /// methods. If it returns False then no other IDataReader + /// methods are called. Therefore other methods can safely assume that the + /// vault exists. + /// Method of IDataReader. + /// + function DatabaseExists: Boolean; + {TODO -cRefactor: Rename DatabaseExists to VaultExists.} + + /// Gets the unique IDs of all categories referenced in the + /// vault. + /// IStringList. List of category IDs. + /// Method of IDataReader. + function GetAllCatIDs: IStringList; + + /// Gets the properties of a given category. + /// string [in] ID of the required category. + /// + /// TCategoryData [in/out] An empty, + /// initialised, properties record is passed in and a record with the + /// properties read from the vault data is passed out. + /// Method of IDataReader. + procedure GetCatProps(const CatID: string; var Props: TCategoryData); + + /// Gets the unique keys of all snippets in a category within the + /// vault. + /// string [in] ID of the required category. + /// + /// IStringList. List of snippet keys. + /// Method of IDataReader. + function GetCatSnippets(const CatID: string): IStringList; + + /// Gets the properties of a given snippet. + /// string [in] Key of the required + /// snippet. + /// TSnippetData [in/out] An empty, + /// initialised, properties record is passed in and a record with the + /// properties read from the vault data is passed out. + /// Method of IDataReader. + procedure GetSnippetProps(const SnippetKey: string; + var Props: TSnippetData); + + /// Gets a list of the keys of all snippets within the vault that + /// are cross-referenced by a given snippet. + /// string [in] Key of snippet for which + /// cross references are required. + /// IStringList. List of keys of cross referenced snippets. + /// + /// Method of IDataReader. + function GetSnippetXRefs(const SnippetKey: string): IStringList; + + /// Gets a list of the keys of all snippets on which a given + /// snippet depends in order to compile. + /// string [in] Key of snippet for which + /// dependencies are required. + /// IStringList. List of keys of required snippets. + /// + /// Method of IDataReader. + function GetSnippetDepends(const SnippetKey: string): IStringList; + + /// Gets a list of the keys of all unit which a given snippet + /// requires in order to compile. + /// string [in] Key of snippet for which + /// units are required. + /// IStringList. List of required units. + /// + /// Method of IDataReader. + function GetSnippetUnits(const SnippetKey: string): IStringList; + + /// Gets the vault's meta data. + /// TMetaData. The required meta data. Will be null if + /// is no meta data. + /// Method of IDataReader. + function GetMetaData: TMetaData; + end; + + /// Writes a vault's data to storage in the CodeSnip Vault native + /// format. + TNativeVaultStorageWriter = class sealed(TNativeVaultStorage, + IVaultStorageWriter + ) + strict private + var + /// Reference to root node. + fRootNode: IXMLNode; + /// Reference to top-level snippets XML node. + fSnippetsNode: IXMLNode; + /// Reference to top-level categories XML node. + fCategoriesNode: IXMLNode; + /// Flag that indicates if unit & depends-upon lists can be + /// written. + fCanWriteRequiredLists: Boolean; + + /// Handles exceptions raised by converting expected exceptions + /// into ECodeSnip derived exceptions. + /// TObject [in] Reference to exception object to + /// be handled. + /// Always raises an exception. Expected exceptions are + /// re-raised as EDataIO exceptions. Unexpected exceptions are + /// re-raised unchanged. + procedure HandleException(const EObj: TObject); + + /// Writes a list of text nodes that each have the same tag name, + /// within an enclosing node. + /// IXMLNode [in] Reference to the parent node + /// of the node that encloses the list items. + /// string [in] Name of the node that + /// encloses the list items. + /// string [in] Name of each list item + /// node. + /// IStringList [in] Text value of each list + /// item. + procedure WriteEnclosedList(const AParent: IXMLNode; + const AListNodeName, AItemNodeName: string; const AItems: IStringList); + + /// Writes a reference list associated with a snippet to XML. + /// + /// string [in] Key of snippet. + /// string [in] Name of the XML node + /// that contains the list item. + /// string [in] Name of each list item + /// XML node within the list. + /// IStringList [in] List of referenced items. + /// + procedure WriteReferenceList(const ASnippetKey, AListNodeName, + AItemNodeName: string; const AItems: IStringList); + + public + /// Initialises the vault write. + /// + /// Always called before all other IDataWriter methods. + /// Method of IDataWriter. + /// + procedure Initialise; + + /// Writes the properties of a given category. + /// string [in] ID of category. + /// TCategoryData [in] Properties of the + /// category. + /// + /// Always called before WriteCatSnippets for a given + /// category, so can be used to perform any per-category initialisation. + /// + /// Method of IDataWriter. + /// + procedure WriteCatProps(const CatID: string; const Props: TCategoryData); + + /// Writes a list of keys of snippets belonging to a given + /// category. + /// string [in] ID of category. + /// IStringList [in] List of snippet keys. + /// + /// + /// Always called after WriteCatProps for a given category. + /// + /// Method of IDataWriter. + /// + procedure WriteCatSnippets(const CatID: string; + const SnipList: IStringList); + + /// Writes the property of a given snippet. + /// string [in] Snippet's key. + /// TSnippetData [in] Properties of the snippet. + /// + /// + /// Always called after all categories are written and before + /// WriteSnippetUnits, so can be used to perform any per-snippet + /// intialisation that is required. + /// Method of IDataWriter. + /// + procedure WriteSnippetProps(const SnippetKey: string; + const Props: TSnippetData); + + /// Writes a list of units required to compile a snippet. + /// + /// string [in] Snippet's key. + /// IStringList [in] List of unit names. + /// Method of IDataWriter. + procedure WriteSnippetUnits(const SnippetKey: string; + const Units: IStringList); + + /// Writes a list of keys of snippets that a snippet depends on in + /// order to compile. + /// string [in] Snippet's key. + /// IStringList [in] List of keys of required + /// snippets. + /// Method of IDataWriter. + procedure WriteSnippetDepends(const SnippetKey: string; + const Depends: IStringList); + + /// Writes a list of keys of snippets that are cross referenced + /// by a given snippet. + /// string [in] Snippet's key. + /// IStringList [in] List of keys of cross + /// referenced snippets. + /// Method of IDataWriter. + procedure WriteSnippetXRefs(const SnippetKey: string; + const XRefs: IStringList); + + /// Writes the vault's meta data. + /// TMetaData [in] Meta data to be written. + /// + /// Method of IDataWriter. + procedure WriteMetaData(const AMetaData: TMetaData); + + /// Finalises the vault write. + /// + /// Always called after all other IDataWriter methods. + /// Method of IDataWriter. + /// + procedure Finalise; + end; + +implementation + +uses + // Delphi + SysUtils, + Classes, + IOUtils, + ActiveX, + XMLDom, + // Project + ActiveText.UMain, + UExceptions, + UIOUtils, + USnippetExtraHelper, + UStrUtils, + UUtils, + UXMLDocHelper; + +resourcestring + // TNativeDataRW error message + sMissingNode = 'Document has no %s node.'; + // TNativeVaultStorageReader error messages + sParseError = 'Error parsing XML file'; + sBadDataFormat = 'Invalid native vault data format: %s'; + sNoRootNode = 'Invalid document: no root element present'; + sBadRootName = 'Invalid document: root element must be named <%s>'; + sBadWatermark = 'Invalid document: watermark is incorrect'; + sBadVersion = 'Invalid document: unsupported document version %d.%d'; + sNoCategoriesNode = 'No categories node in XML file'; + sCatNotFound = 'Can''t find reference to category "%s" in XML file'; + sMissingSource = 'Source code file name missing for snippet "%s"'; + sBadKind = 'Missing or invalid snippet kind for snippet "%s"'; + sSnippetNotFound = 'Can''t find reference to snippet key "%s" in XML file'; + sBadTestInfo = 'Invalid test information for snippet "%s"'; + sMissingLicenseText = 'License text file "%s" is missing'; + +{ TNativeVaultStorage } + +constructor TNativeVaultStorage.Create(const ADataDirectory: string); +begin + inherited Create; + fDataDirectory := ADataDirectory; + // For some reason we must call OleInitialize here rather than in + // initialization section + OleInitialize(nil); + fXMLDoc := TXMLDocHelper.CreateXMLDoc; +end; + +function TNativeVaultStorage.FilePath(const AFileName: string): string; +begin + Result := TPath.Combine(DataDirectory, AFileName); +end; + +function TNativeVaultStorage.FindCategoryNode(const ACatID: string): IXMLNode; +var + CatListNode: IXMLNode; // node that contains category nodes +begin + Result := nil; + // Find node + CatListNode := XMLDoc.FindNode(RootNodeName + '\' + CategoriesNodeName); + if not Assigned(CatListNode) then + raise EDataIO.CreateFmt(sMissingNode, [CategoriesNodeName]); + // Find required node + Result := fXMLDoc.FindFirstChildNode( + CatListNode, CategoryNodeName, CategoryNodeIdAttr, ACatID + ) +end; + +function TNativeVaultStorage.FindSnippetNode(const ASnippetKey: string): + IXMLNode; +var + SnippetListNode: IXMLNode; // list node that contains snippets nodes +begin + Result := nil; + // Find snippets node + SnippetListNode := XMLDoc.FindNode(RootNodeName + '\' + SnippetsNodeName); + if not Assigned(SnippetListNode) then + raise EDataIO.CreateFmt(sMissingNode, [SnippetsNodeName]); + // Find required snippet node + Result := XMLDoc.FindFirstChildNode( + SnippetListNode, SnippetNodeName, SnippetNodeKeyAttr, ASnippetKey + ); +end; + +function TNativeVaultStorage.InitXMLDocAndRootNode: IXMLNode; +begin + XMLDoc.Active := True; + TXMLDocHelper.CreateXMLProcInst(XMLDoc); + XMLDoc.Encoding := 'UTF-8'; + // root node + Result := XMLDoc.CreateNode(RootNodeName); + Result.SetAttribute(RootNodeWatermarkAttr, Watermark); + Result.SetAttribute(RootNodeVersionMajorAttr, CurrentFileVersion.V1); + Result.SetAttribute(RootNodeVersionMinorAttr, CurrentFileVersion.V2); + XMLDoc.ChildNodes.Add(Result); +end; + +function TNativeVaultStorage.PathToXMLFile: string; +begin + Result := FilePath(XMLFileName); +end; + +{ TNativeVaultStorageReader } + +constructor TNativeVaultStorageReader.Create(const ADirectory: string); +var + RootNode: IXMLNode; // reference to document's root node +begin + inherited Create(ADirectory); + if DatabaseExists then + begin + // Database exists: load it + XMLDoc.LoadFromFile(PathToXMLFile); + XMLDoc.Active := True; + try + ValidateDoc; + except + HandleException(ExceptObject); + end; + end + else + begin + // Database doesn't exist: create sufficient nodes for main code to find + RootNode := InitXMLDocAndRootNode; + XMLDoc.CreateElement(RootNode, CategoriesNodeName); + XMLDoc.CreateElement(RootNode, SnippetsNodeName); + end; +end; + +function TNativeVaultStorageReader.DatabaseExists: Boolean; +begin + Result := TFile.Exists(PathToXMLFile); +end; + +function TNativeVaultStorageReader.GetAllCatIDs: IStringList; +var + CatListNode: IXMLNode; // node containing list of categories + CatNodes: IXMLSimpleNodeList; // list of all category nodes of categories + CatNode: IXMLNode; // a node in CatNodes +begin + try + Result := TIStringList.Create; + CatListNode := XMLDoc.FindNode(RootNodeName + '\' + CategoriesNodeName); + if not Assigned(CatListNode) then + raise EDataIO.Create(sNoCategoriesNode); + CatNodes := XMLDoc.FindChildNodes(CatListNode, CategoryNodeName); + for CatNode in CatNodes do + Result.Add(CatNode.Attributes[CategoryNodeIdAttr]); + except + HandleException(ExceptObject); + end; +end; + +procedure TNativeVaultStorageReader.GetCatProps(const CatID: string; + var Props: TCategoryData); +var + CatNode: IXMLNode; // reference to node for required category +begin + try + CatNode := FindCategoryNode(CatID); + if not Assigned(CatNode) then + // Properties will not be requested for a category that doesn't exist in + // this database, so this should never happen + raise EDataIO.CreateFmt(sCatNotFound, [CatID]); + Props.Desc := TXMLDocHelper.GetSubTagText( + XMLDoc, CatNode, CategoryDescriptionNodeName + ); + except + HandleException(ExceptObject); + end; +end; + +function TNativeVaultStorageReader.GetCatSnippets(const CatID: string): + IStringList; +var + CatNode: IXMLNode; // reference to required category node +begin + try + CatNode := FindCategoryNode(CatID); + if not Assigned(CatNode) then + {TODO -cVault: Check the following comment and decide if this still + applies. Replace Exit with exception if necessary.} + // This is not an error since it is possible that a category exists in + // another vault and loader will request info from here also + Exit(TIStringList.Create); + Result := GetEnclosedListItems( + CatNode, CategorySnippetsListNodeName, CategorySnippetsListItemNodeName + ); + except + HandleException(ExceptObject); + end; +end; + +function TNativeVaultStorageReader.GetEnclosedListItems( + const AParentNode: IXMLNode; const AListNodeName, AItemNodeName: string): + IStringList; +var + ListNode: IXMLNode; + ItemNode: IXMLNode; + NodeList: IXMLSimpleNodeList; +begin + Assert(Assigned(AParentNode), + ClassName + '.GetEnclosedListItems: AParentNode is nil'); + Result := TIStringList.Create; + ListNode := XMLDoc.FindFirstChildNode(AParentNode, AListNodeName); + if not Assigned(ListNode) then + Exit; // it is sometimes permitted for snippet lists to be omitted + NodeList := XMLDoc.FindChildNodes(ListNode, AItemNodeName); + for ItemNode in NodeList do + if ItemNode.IsTextElement then + Result.Add(ItemNode.Text); +end; + +function TNativeVaultStorageReader.GetMetaData: TMetaData; +var + RootNode: IXMLNode; + LicenseNode: IXMLNode; + CopyrightNode: IXMLNode; + LicenseTextFileName: string; + LicenseText: string; +begin + Result := TMetaData.Create([ + TMetaDataCap.License, TMetaDataCap.Copyright, TMetaDataCap.Acknowledgements + ]); + + LicenseNode := XMLDoc.FindNode(RootNodeName + '\' + LicenseNodeName); + if Assigned(LicenseNode) then + begin + LicenseTextFileName := LicenseNode.Attributes[LicenseNodeLicenseFileAttr]; + if (LicenseTextFileName <> '') then + begin + if not TFile.Exists(FilePath(LicenseTextFileName)) then + raise EDataIO.CreateFmt(sMissingLicenseText, [LicenseTextFileName]); + LicenseText := TFileIO.ReadAllText( + FilePath(LicenseTextFileName), TEncoding.UTF8, False + ); + end + else + LicenseText := ''; + Result.LicenseInfo := TLicenseInfo.Create( + LicenseNode.Attributes[LicenseNodeNameAttr], + LicenseNode.Attributes[LicenseNodeSPDXAttr], + LicenseNode.Attributes[LicenseNodeURLAttr], + LicenseText + ); + end; + + CopyrightNode := XMLDoc.FindNode(RootNodeName + '\' + CopyrightNodeName); + if Assigned(CopyrightNode) then + begin + Result.CopyrightInfo := TCopyrightInfo.Create( + CopyrightNode.Attributes[CopyrightNodeDateAttr], + CopyrightNode.Attributes[CopyrightNodeHolderAttr], + CopyrightNode.Attributes[CopyrightNodeURLAttr], + GetEnclosedListItems( + CopyrightNode, + CopyrightContributorsListNodeName, + CopyrightContributorsListItemNodeName + ) + ); + end; + + RootNode := XMLDoc.FindNode(RootNodeName); + if not Assigned(RootNode) then + raise EDataIO.Create(sNoRootNode); + Result.Acknowledgements := GetEnclosedListItems( + RootNode, AcknowledgementsListNodeName, AcknowledgementsListItemNodeName + ); +end; + +function TNativeVaultStorageReader.GetSnippetDepends(const SnippetKey: string): + IStringList; +begin + if fCanReadRequiredLists then + Result := GetSnippetReferences( + SnippetKey, SnippetDependsListNodeName, SnippetDependsListItemNodeName + ) + else + Result := TIStringList.Create; +end; + +procedure TNativeVaultStorageReader.GetSnippetProps(const SnippetKey: string; + var Props: TSnippetData); +var + SnippetNode: IXMLNode; // node for required snippet + + // Gets text of a sepecified property that is stored in the named subtag of + // the given parent node. + function GetPropertyText(const AParentNode: IXMLNode; + const ASubTagNodeName: string): string; + begin + if not Assigned(AParentNode) then + Exit(''); + Result := TXMLDocHelper.GetSubTagText(XMLDoc, AParentNode, ASubTagNodeName); + end; + + // Returns a reference to the source code node + function SourceCodeNode: IXMLNode; + begin + Result := XMLDoc.FindFirstChildNode(SnippetNode, SnippetSourceNodeName); + end; + + // Returns source code language from source code node attribute + function GetSourceCodeLanguage: string; + begin + Result := SourceCodeNode.Attributes[SnippetSourceNodeLanguageAttr]; + end; + + // Checks if source code language is Pascal + function IsPascalSource: Boolean; + begin + Result := GetSourceCodeLanguage = 'pascal'; + end; + + // Gets source code from file referenced in source code node attribute + function GetSourceCodePropertyText: string; + var + DataFileName: string; // name of file containing source code + begin + DataFileName := SourceCodeNode.Attributes[SnippetSourceNodeFileAttr]; + if DataFileName = '' then + raise EDataIO.CreateFmt(sMissingSource, [SnippetKey]); + Result := TFileIO.ReadAllText( + FilePath(DataFileName), TEncoding.UTF8, False + ); + end; + + // Gets kind property value from snippet node attribute + function GetKindProperty: TSnippetKind; + + // Looks up AKindStr in lookup table and passes out matching TSnippetKind + // value, if found. Returns True if found & false if not + function TryLookupKind(const AKindStr: string; out AKind: TSnippetKind): + Boolean; + var + K: TSnippetKind; + begin + Result := False; + for K := Low(SnippetKindValues) to High(SnippetKindValues) do + begin + if StrSameText(SnippetKindValues[K], AKindStr) then + begin + AKind := K; + Exit(True); + end; + end; + end; + + var + Value: string; // text value of Kind node + begin + if not IsPascalSource then + // being permissive here: strictly speaking snippet kind attribute must + // have value 'freeform'. + Exit(skFreeform); + + Value := SnippetNode.Attributes[SnippetNodeKindAttr]; + if not TryLookupKind(Value, Result) then + raise EDataIO.CreateFmt(sBadKind, [SnippetKey]); + end; + + // Gets REML from the named child node of the snippet node and parses it as + // active text. + function GetActiveText(const ANodeName: string): IActiveText; + var + REML: string; + begin + REML := GetPropertyText(SnippetNode, ANodeName); + if REML <> '' then + Result := TSnippetExtraHelper.BuildActiveText(REML) + else + Result := TActiveTextFactory.CreateActiveText; + end; + + // Get compilation results from compile results node and its child nodes + function GetCompileResults: TCompileResults; + + // Looks up compiler ID string in lookup table and passes the corresponding + // compiler ID in Match if found. Returns True if found, False if not. + function TryLookupCompID(IDStr: string; out Match: TCompilerID): Boolean; + var + CompID: TCompilerID; // loops thru all compiler IDs + begin + Result := False; + for CompID := Low(TCompilerID) to High(TCompilerID) do + begin + if StrSameText(CompilerIDs[CompID], IDStr) then + begin + Match := CompID; + Exit(True); + end; + end; + end; + + var + ListNode: IXMLNode; // node that enclose compiler result nodes + ResultsNodes: IXMLSimpleNodeList; // list of compiler-result nodes + ResultNode: IXMLNode; // a compiler-result node + CompID: TCompilerID; // loops thru compiler IDs + CompResultStr: string; // compiler id string from result node + begin + // Initialise all results to unknown (query) + for CompID := Low(TCompilerID) to High(TCompilerID) do + Result[CompID] := crQuery; + + // Find enclosing node: valid if this is not present + ListNode := XMLDoc.FindFirstChildNode( + SnippetNode, SnippetCompileResultsNodeName + ); + if not Assigned(ListNode) then + Exit; + + // Get list of compiler-result nodes contained in list and process each one + ResultsNodes := XMLDoc.FindChildNodes(ListNode, SnippetCompilerNodeName); + for ResultNode in ResultsNodes do + begin + // get compile result identifier + CompResultStr := StrToLower( + ResultNode.Attributes[SnippetCompilerNodeResultAttr] + ); + if CompResultStr = '' then + CompResultStr := '?'; + // add specified result function result + if TryLookupCompID( + ResultNode.Attributes[SnippetCompilerNodeIdAttr], CompID + ) then + begin + case CompResultStr[1] of + 'y': Result[CompID] := crSuccess; + 'n': Result[CompID] := crError; + else Result[CompID] := crQuery; + end; + end; + end; + end; + + // Get test info from test node attributes + procedure SetTestInfoProperty(var Props: TSnippetData); + + function TryLookupTestLevel(const AIDStr: string; + var ALevel: TSnippetTestInfo): Boolean; + var + TestID: TSnippetTestInfo; + begin + Result := False; + for TestID := Low(TSnippetTestInfo) to High(TSnippetTestInfo) do + begin + if StrSameText(TestInfoValues[TestID], AIDStr) then + begin + ALevel := TestID; + Exit(True); + end; + end; + end; + + var + TestNode: IXMLNode; + Level: TSnippetTestInfo; + URL: string; + begin + URL := ''; + Level := stiNone; + TestNode := XMLDoc.FindFirstChildNode(SnippetNode, SnippetTestInfoNodeName); + if not Assigned(TestNode) then + Exit; + if not TryLookupTestLevel( + TestNode.Attributes[SnippetTestInfoNodeLevelAttr], Level + ) then + Exit; + URL := TestNode.Attributes[SnippetTestInfoNodeUrlAttr]; + Props.TestInfo := Level; + {TODO -cVault: When Snippet test URL is implemented, add following line} + // Props.TestURL := URL; + end; + +begin + try + // Find snippet node + SnippetNode := FindSnippetNode(SnippetKey); + if not Assigned(SnippetNode) then + raise EDataIO.CreateFmt(sSnippetNotFound, [SnippetKey]); + // Snippet found: read properties + Props.Cat := SnippetNode.Attributes[SnippetNodeCategoryAttr]; + Props.DisplayName := GetPropertyText( + SnippetNode, SnippetDisplayNameNodeName + ); + Props.Kind := GetKindProperty; + Props.Desc := GetActiveText(SnippetDescriptionNodeName); + Props.Extra := GetActiveText(SnippetNotesNodeName); + Props.SourceCode := GetSourceCodePropertyText; + {TODO -cVault: Replace Props.HiliteSource with Props.SourceCodeLanguage + field.} + Props.HiliteSource := IsPascalSource; + Props.CompilerResults := GetCompileResults; + SetTestInfoProperty(Props); + + // Record whether required units / snippets list are permitted + {TODO -cVault: Change following line to use Props.SourceLanguage once + implemented to check if language is Pascal: can't write the lists + if not.} + fCanReadRequiredLists := Props.HiliteSource; + except + HandleException(ExceptObject); + end; +end; + +function TNativeVaultStorageReader.GetSnippetReferences(const ASnippetKey, + AListNodeName, AListItemName: string): IStringList; +var + SnippetNode: IXMLNode; +begin + // Find snippet node + SnippetNode := FindSnippetNode(ASnippetKey); + if not Assigned(SnippetNode) then + raise EDataIO.CreateFmt(sSnippetNotFound, [ASnippetKey]); + Result := GetEnclosedListItems(SnippetNode, AListNodeName, AListItemName); +end; + +function TNativeVaultStorageReader.GetSnippetUnits(const SnippetKey: string): + IStringList; +begin + if fCanReadRequiredLists then + Result := GetSnippetReferences( + SnippetKey, SnippetUnitsListNodeName, SnippetUnitsListItemNodeName + ) + else + Result := TIStringList.Create; +end; + +function TNativeVaultStorageReader.GetSnippetXRefs(const SnippetKey: string): + IStringList; +begin + Result := GetSnippetReferences( + SnippetKey, SnippetXRefsListNodeName, SnippetXRefsListItemNodeName + ) +end; + +procedure TNativeVaultStorageReader.HandleException(const EObj: TObject); +begin + {TODO -cVault: Query whether database files should be deleted on error. + This is not being done while debugging} +// DeleteFiles(DataDir, '*.*'); + if EObj is EDOMParseError then + // Expected DOM parsing error + raise EDataIO.CreateFmt(sBadDataFormat, [sParseError]); + if (EObj is EDataIO) + or (EObj is EXMLDocError) + or (EObj is ECodeSnipXML) + or (EObj is EFileStreamError) + or (EObj is EFOpenError) + or (EObj is EActiveTextParserError) then + // Expected other error: Raise new exception containing old message + raise EDataIO.CreateFmt(sBadDataFormat, [(EObj as Exception).Message]) + else + // Mot an expected error: just re-raise + raise EObj; +end; + +procedure TNativeVaultStorageReader.ValidateDoc; +var + RootNode: IXMLNode; + Version: TVersionNumber; +begin + RootNode := XMLDoc.DocumentElement; + + if not Assigned(RootNode) then + raise EDataIO.Create(sNoRootNode); + + if RootNode.NodeName <> RootNodeName then + raise EDataIO.CreateFmt(sBadRootName, [RootNodeName]); + + if RootNode.Attributes[RootNodeWatermarkAttr] <> Watermark then + raise EDataIO.Create(sBadWatermark); + + Version := TVersionNumber.Nul; + Version.V1 := RootNode.Attributes[RootNodeVersionMajorAttr]; + Version.V2 := RootNode.Attributes[RootNodeVersionMinorAttr]; + if (Version < EarliestFileVersion) or (Version > CurrentFileVersion) then + raise EDataIO.CreateFmt(sBadVersion, [Version.V1, Version.V2]); +end; + +{ TNativeVaultStorageWriter } + +procedure TNativeVaultStorageWriter.Finalise; +var + FS: TFileStream; // stream onto output file +begin + // We use a TFileStream and TXMLDocument.SaveToStream rather than calling + // TXMLDocument.SaveToFile so that any problem creating file is reported via + // a known Delphi exception that can be handled. + EnsureFolders(DataDirectory); + try + FS := TFileStream.Create(PathToXMLFile, fmCreate); + try + XMLDoc.Encoding := 'UTF-8'; + XMLDoc.SaveToStream(FS); + finally + FreeAndNil(FS); + end; + except + HandleException(ExceptObject); + end; +end; + +procedure TNativeVaultStorageWriter.HandleException(const EObj: TObject); +begin + if (EObj is EFileStreamError) or (EObj is ECodeSnip) then + raise EDataIO.Create(EObj as Exception); + raise EObj; +end; + +procedure TNativeVaultStorageWriter.Initialise; +//var +// RootNode: IXMLNode; // document root node +begin + try + // Make sure database folder exists, empty of source code files + TDirectory.CreateDirectory(DataDirectory); + DeleteFiles(DataDirectory, '*' + SourceCodeFileExt); + + fRootNode := InitXMLDocAndRootNode; + + // create empty categories and snippets nodes + fCategoriesNode := XMLDoc.CreateElement(fRootNode, CategoriesNodeName); + fSnippetsNode := XMLDoc.CreateElement(fRootNode, SnippetsNodeName); + except + HandleException(ExceptObject); + end; +end; + +procedure TNativeVaultStorageWriter.WriteCatProps(const CatID: string; + const Props: TCategoryData); +var + CatNode: IXMLNode; // referenced to required category node +begin + try + // Create node + CatNode := XMLDoc.CreateElement(fCategoriesNode, CategoryNodeName); + CatNode.Attributes[CategoryNodeIdAttr] := CatID; + XMLDoc.CreateElement(CatNode, CategoryDescriptionNodeName, Props.Desc); + except + HandleException(ExceptObject); + end; +end; + +procedure TNativeVaultStorageWriter.WriteCatSnippets(const CatID: string; + const SnipList: IStringList); +var + CatNode: IXMLNode; // reference to required category node +begin + try + // Don't write list if no snippets + if SnipList.Count = 0 then + Exit; + // Find required category node + CatNode := FindCategoryNode(CatID); + Assert(Assigned(CatNode), + ClassName + '.WriteCatSnippets: Can''t find category node'); + // Write the list + WriteEnclosedList( + CatNode, + CategorySnippetsListNodeName, + CategorySnippetsListItemNodeName, + SnipList + ); + except + HandleException(ExceptObject); + end; +end; + +procedure TNativeVaultStorageWriter.WriteEnclosedList(const AParent: IXMLNode; + const AListNodeName, AItemNodeName: string; const AItems: IStringList); +var + ListNode: IXMLNode; // reference to enclosing list node + Item: string; // a name item in list +begin + ListNode := XMLDoc.CreateElement(AParent, AListNodeName); + for Item in AItems do + XMLDoc.CreateElement(ListNode, AItemNodeName, Item); +end; + +procedure TNativeVaultStorageWriter.WriteMetaData(const AMetaData: TMetaData); +var + LicenseNode: IXMLNode; + CopyrightNode: IXMLNode; +begin + // Write license info + LicenseNode := XMLDoc.CreateElement(fRootNode, LicenseNodeName); + LicenseNode.Attributes[LicenseNodeSPDXAttr] := AMetaData.LicenseInfo.SPDX; + LicenseNode.Attributes[LicenseNodeNameAttr] := AMetaData.LicenseInfo.Name; + LicenseNode.Attributes[LicenseNodeURLAttr] := AMetaData.LicenseInfo.URL; + if StrIsEmpty(AMetaData.LicenseInfo.Text) then + LicenseNode.Attributes[LicenseNodeLicenseFileAttr] := '' + else + begin + // license text file: license text is written to a UTF-8 encoded file with + // no BOM and filename is stored in XML + LicenseNode.Attributes[LicenseNodeLicenseFileAttr] := LicenseTextFileName; + TFileIO.WriteAllText( + FilePath(LicenseTextFileName), + AMetaData.LicenseInfo.Text, + TEncoding.UTF8, + False + ); + end; + + CopyrightNode := XMLDoc.CreateElement(fRootNode, CopyrightNodeName); + CopyrightNode.Attributes[CopyrightNodeDateAttr] := + AMetaData.CopyrightInfo.Date; + CopyrightNode.Attributes[CopyrightNodeHolderAttr] := + AMetaData.CopyrightInfo.Holder; + CopyrightNode.Attributes[CopyrightNodeURLAttr] + := AMetaData.CopyrightInfo.HolderURL; + if AMetaData.CopyrightInfo.Contributors.Count > 0 then + WriteEnclosedList( + CopyrightNode, + CopyrightContributorsListNodeName, + CopyrightContributorsListItemNodeName, + AMetaData.CopyrightInfo.Contributors + ); + + WriteEnclosedList( + fRootNode, + AcknowledgementsListNodeName, + AcknowledgementsListItemNodeName, + AMetaData.Acknowledgements + ); + +end; + +procedure TNativeVaultStorageWriter.WriteReferenceList(const ASnippetKey, + AListNodeName, AItemNodeName: string; const AItems: IStringList); +var + SnippetNode: IXMLNode; // reference to snippet's node +begin + try + // Don't write list if no items + if AItems.Count = 0 then + Exit; + // Find snippet node + SnippetNode := FindSnippetNode(ASnippetKey); + Assert(Assigned(SnippetNode), + ClassName + '.WriteReferenceList: Can''t find snippet node'); + // Write the list + WriteEnclosedList(SnippetNode, AListNodeName, AItemNodeName, AItems); + except + HandleException(ExceptObject); + end; +end; + +procedure TNativeVaultStorageWriter.WriteSnippetDepends( + const SnippetKey: string; const Depends: IStringList); +begin + if not fCanWriteRequiredLists then + Exit; + WriteReferenceList( + SnippetKey, + SnippetDependsListNodeName, + SnippetDependsListItemNodeName, + Depends + ); +end; + +procedure TNativeVaultStorageWriter.WriteSnippetProps(const SnippetKey: string; + const Props: TSnippetData); +var + SnippetNode: IXMLNode; // snippet's node + FileName: string; // name of file where source code stored + SourceCodeNode: IXMLNode; + CompResultsNode: IXMLNode; // node that stores all compiler results + CompResultNode: IXMLNode; // each compiler result node + CompID: TCompilerID; // loops thru all supported compilers + TestInfoNode: IXMLNode; +begin + try + // Record whether required units / snippets list are permitted + {TODO -cVault: Change following line to use Props.SourceLanguage once + implemented to check if language is Pascal: can't write the lists + if not.} + fCanWriteRequiredLists := Props.HiliteSource; + // Create snippet node + SnippetNode := XMLDoc.CreateElement(fSnippetsNode, SnippetNodeName); + SnippetNode.Attributes[SnippetNodeKeyAttr] := SnippetKey; + SnippetNode.Attributes[SnippetNodeCategoryAttr] := Props.Cat; + {TODO -cVault: change following test to test for Language = 'pascal' + instead of HiliteSource once Language prop is created} + if Props.HiliteSource then + SnippetNode.Attributes[SnippetNodeKindAttr] := + SnippetKindValues[Props.Kind] + else + SnippetNode.Attributes[SnippetNodeKindAttr] := + SnippetKindValues[skFreeform]; + + // Add property nodes + // display name + XMLDoc.CreateElement( + SnippetNode, SnippetDisplayNameNodeName, Props.DisplayName + ); + // description node: only written if Desc property has a value + if Props.Desc.HasContent then + XMLDoc.CreateElement( + SnippetNode, + SnippetDescriptionNodeName, + TSnippetExtraHelper.BuildREMLMarkup(Props.Desc) + ); + // notes node: only written if Extra property has a value + if Props.Extra.HasContent then + {TODO -cVault: rename Extra snippets property as Notes} + XMLDoc.CreateElement( + SnippetNode, + SnippetNotesNodeName, + TSnippetExtraHelper.BuildREMLMarkup(Props.Extra) + ); + // source code node + FileName := SnippetKey + SourceCodeFileExt; + SourceCodeNode := XMLDoc.CreateElement(SnippetNode, SnippetSourceNodeName); + SourceCodeNode.Attributes[SnippetSourceNodeFileAttr] := FileName; + {TODO -cVault: change snippet props to have a language field instead of + HiliteSource and use it to set the following attribute} + SourceCodeNode.Attributes[SnippetSourceNodeLanguageAttr] := + StrIf(Props.HiliteSource, 'pascal', 'text'); + // source code file: source code is written to a UTF-8 encoded file with no + // BOM and filename is stored in XML + TFileIO.WriteAllText( + FilePath(FileName), Props.SourceCode, TEncoding.UTF8, False + ); + {TODO -cVault: change following test to test for Language = 'pascal' + instead of HiliteSource once Language prop is created} + if Props.HiliteSource and (Props.Kind <> skFreeform) then + begin + // compile results list: must be omitted if snippet is not Pascal & + // even then, only known compiler results are written + CompResultsNode := XMLDoc.CreateElement( + SnippetNode, SnippetCompileResultsNodeName + ); + for CompID := Low(TCompilerID) to High(TCompilerID) do + begin + if Props.CompilerResults[CompID] <> crQuery then + begin + CompResultNode := XMLDoc.CreateElement( + CompResultsNode, SnippetCompilerNodeName + ); + CompResultNode.Attributes[SnippetCompilerNodeIdAttr] := + CompilerIDs[CompID]; + CompResultNode.Attributes[SnippetCompilerNodeResultAttr] := + CompileResultValues[Props.CompilerResults[CompID]]; + end; + end; + end; + // test info + TestInfoNode := XMLDoc.CreateElement(SnippetNode, SnippetTestInfoNodeName); + TestInfoNode.Attributes[SnippetTestInfoNodeLevelAttr] := + TestInfoValues[Props.TestInfo]; + {TODO -cVault: Change following line that always writes an empty URL once + TestURL property added to snippets.} + TestInfoNode.Attributes[SnippetTestInfoNodeUrlAttr] := ''; + except + HandleException(ExceptObject); + end; +end; + +procedure TNativeVaultStorageWriter.WriteSnippetUnits(const SnippetKey: string; + const Units: IStringList); +begin + if not fCanWriteRequiredLists then + Exit; + WriteReferenceList( + SnippetKey, + SnippetUnitsListNodeName, + SnippetUnitsListItemNodeName, + Units + ); +end; + +procedure TNativeVaultStorageWriter.WriteSnippetXRefs(const SnippetKey: string; + const XRefs: IStringList); +begin + WriteReferenceList( + SnippetKey, + SnippetXRefsListNodeName, + SnippetXRefsListItemNodeName, + XRefs + ); +end; + +end. diff --git a/Src/DBIO.UNulDataReader.pas b/Src/DB.IO.Vault.Null.pas similarity index 54% rename from Src/DBIO.UNulDataReader.pas rename to Src/DB.IO.Vault.Null.pas index ab6e8ecf2..945bab3d3 100644 --- a/Src/DBIO.UNulDataReader.pas +++ b/Src/DB.IO.Vault.Null.pas @@ -9,7 +9,7 @@ } -unit DBIO.UNulDataReader; +unit DB.IO.Vault.Null; interface @@ -17,17 +17,19 @@ interface uses // Project - DB.UCategory, DB.USnippet, DBIO.UFileIOIntf, UIStringList; + DB.MetaData, + DB.Categories, + DB.Snippets, + DB.IO.Vault, + UIStringList; type - { - TNulDataReader: - A do nothing data reader used when a database does not exist. - } - TNulDataReader = class(TInterfacedObject, - IDataReader + /// A do nothing vault data reader used when no vaults exist. + /// + TNullVaultStorageReader = class(TInterfacedObject, + IVaultStorageReader ) public { IDataReader methods } @@ -46,40 +48,46 @@ TNulDataReader = class(TInterfacedObject, @param Props [in/out] Empty properties passed in. Unchanged. } function GetCatSnippets(const CatID: string): IStringList; - {Gets names of all snippets in a category. + {Gets keys of all snippets in a category. @param CatID [in] Id of category containing snippets. - @return Empty list. + @return Empty snippet key list. } - procedure GetSnippetProps(const Snippet: string; var Props: TSnippetData); + procedure GetSnippetProps(const SnippetKey: string; + var Props: TSnippetData); {Gets properties of a snippet. These are the fields of the snippet's record in the snippets "table". - @param Snippet [in] Name of required snippet. + @param SnippetKey [in] Keys of required snippet. @param Props [in/out] Empty properties passed in. Unchanged. } - function GetSnippetXRefs(const Snippet: string): IStringList; + function GetSnippetXRefs(const SnippetKey: string): IStringList; {Gets list of all snippets that are cross referenced by a snippet. - @param Snippet [in] Name of snippet we need cross references for. - @return Empty list. + @param SnippetKey [in] Key of snippet we need cross references for. + @return Empty snippet key list. } - function GetSnippetDepends(const Snippet: string): IStringList; + function GetSnippetDepends(const SnippetKey: string): IStringList; {Gets list of all snippets on which a given snippet depends. - @param Snippet [in] Name of required snippet. - @return Empty list. + @param SnippetKey [in] Key of required snippet. + @return Empty snippet key list. } - function GetSnippetUnits(const Snippet: string): IStringList; + function GetSnippetUnits(const SnippetKey: string): IStringList; {Gets list of all units referenced by a snippet. - @param Snippet [in] Name of required snippet. - @return Empty list. + @param SnippetKey [in] Key of required snippet. + @return Empty unit name list. } + + /// Gets the vault's meta data. + /// TMetaData. Null value. + /// Method of IDataReader. + function GetMetaData: TMetaData; end; implementation -{ TNulDataReader } +{ TNullVaultStorageReader } -function TNulDataReader.DatabaseExists: Boolean; +function TNullVaultStorageReader.DatabaseExists: Boolean; {Checks if the database exists. This method is always called first. No other methods are called if this method returns false. @return Always returns True. It always can read a do-nothing database. @@ -88,7 +96,7 @@ function TNulDataReader.DatabaseExists: Boolean; Result := True; end; -function TNulDataReader.GetAllCatIDs: IStringList; +function TNullVaultStorageReader.GetAllCatIDs: IStringList; {Gets ids of all categories in database. @return Empty string list. } @@ -96,7 +104,7 @@ function TNulDataReader.GetAllCatIDs: IStringList; Result := TIStringList.Create; end; -procedure TNulDataReader.GetCatProps(const CatID: string; +procedure TNullVaultStorageReader.GetCatProps(const CatID: string; var Props: TCategoryData); {Gets properties of a category. @param CatID [in] Id of required category. @@ -106,48 +114,57 @@ procedure TNulDataReader.GetCatProps(const CatID: string; // Do nothing end; -function TNulDataReader.GetCatSnippets(const CatID: string): IStringList; - {Gets names of all snippets in a category. +function TNullVaultStorageReader.GetCatSnippets(const CatID: string): + IStringList; + {Gets keys of all snippets in a category. @param CatID [in] Id of category containing snippets. - @return Empty list. + @return Empty snippey key list. } begin Result := TIStringList.Create; end; -function TNulDataReader.GetSnippetDepends(const Snippet: string): IStringList; +function TNullVaultStorageReader.GetMetaData: TMetaData; +begin + Result := TMetaData.CreateNull; +end; + +function TNullVaultStorageReader.GetSnippetDepends(const SnippetKey: string): + IStringList; {Gets list of all snippets on which a given snippet depends. - @param Snippet [in] Name of required snippet. - @return Empty list. + @param SnippetKey [in] Key of required snippet. + @return Empty snippet key list. } begin Result := TIStringList.Create; end; -procedure TNulDataReader.GetSnippetProps(const Snippet: string; +procedure TNullVaultStorageReader.GetSnippetProps(const SnippetKey: string; var Props: TSnippetData); {Gets properties of a snippet. These are the fields of the snippet's record in the snippets "table". - @param Snippet [in] Name of required snippet. + @param SnippetKey [in] Key of required snippet. @param Props [in/out] Empty properties passed in. Unchanged. } begin // Do nothing end; -function TNulDataReader.GetSnippetUnits(const Snippet: string): IStringList; +function TNullVaultStorageReader.GetSnippetUnits(const SnippetKey: string): + IStringList; {Gets list of all units referenced by a snippet. - @param Snippet [in] Name of required snippet. - @return Empty list. + @param SnippetKey [in] Key of required snippet. + @return Empty unit name list. } begin Result := TIStringList.Create; end; -function TNulDataReader.GetSnippetXRefs(const Snippet: string): IStringList; +function TNullVaultStorageReader.GetSnippetXRefs(const SnippetKey: string): + IStringList; {Gets list of all snippets that are cross referenced by a snippet. - @param Snippet [in] Name of snippet we need cross references for. - @return Empty list. + @param SnippetKey [in] Key of snippet we need cross references for. + @return Empty snippet key list. } begin Result := TIStringList.Create; diff --git a/Src/DBIO.UFileIOIntf.pas b/Src/DB.IO.Vault.pas similarity index 60% rename from Src/DBIO.UFileIOIntf.pas rename to Src/DB.IO.Vault.pas index f9c88923e..552e0c4b6 100644 --- a/Src/DBIO.UFileIOIntf.pas +++ b/Src/DB.IO.Vault.pas @@ -11,7 +11,7 @@ } -unit DBIO.UFileIOIntf; +unit DB.IO.Vault; interface @@ -19,18 +19,17 @@ interface uses // Project - DB.UCategory, DB.USnippet, UExceptions, UIStringList; + DB.MetaData, + DB.Categories, + DB.Snippets, + UExceptions, + UIStringList; type - { - IDataReader: - Interface that defines operations that must be implemented by objects that - read the CodeSnip and/or user database. - NOTE: Any object that is to be used to read a database must implement this - interface. - } - IDataReader = interface(IInterface) + /// Interface that defines operations that must be implemented by + /// objects that read vault data from storage. + IVaultStorageReader = interface(IInterface) ['{72A8EAD4-05CE-41BF-AE0F-33495757BBFC}'] function DatabaseExists: Boolean; {Check if the database exists. This method is always called first. No @@ -38,7 +37,7 @@ interface @return True if database exists, False if not. } function GetAllCatIDs: IStringList; - {Get names of all categories in database. + {Get ids of all categories in database. @return List of category ids. } procedure GetCatProps(const CatID: string; var Props: TCategoryData); @@ -48,42 +47,43 @@ interface values of category properties by implementor. } function GetCatSnippets(const CatID: string): IStringList; - {Get names of all snippets in a category. + {Get keys of all snippets in a category. @param CatID [in] Id of category containing snippets. - @return List of snippet names. + @return List of snippet IDs. } - procedure GetSnippetProps(const Snippet: string; var Props: TSnippetData); + procedure GetSnippetProps(const SnippetKey: string; + var Props: TSnippetData); {Get properties of a snippet. These are the fields of the snippet's record in the snippets "table". - @param Snippet [in] Name of snippet. + @param SnippetKey [in] Snippet's key. @param Props [in/out] Empty properties passed in. Record fields set to values of snippet's properties by implementor. } - function GetSnippetXRefs(const Snippet: string): IStringList; + function GetSnippetXRefs(const SnippetKey: string): IStringList; {Get list of all snippets that are cross referenced by a snippet. - @param Snippet [in] Name of snippet we need cross references for. - @return List of snippet names. + @param SnippetKey [in] Keyof snippet we need cross references for. + @return List of snippet keys. } - function GetSnippetDepends(const Snippet: string): IStringList; + function GetSnippetDepends(const SnippetKey: string): IStringList; {Get list of all snippet on which a given snippet depends. - @param Snippet [in] Name of snippet. - @return List of snippet names. + @param SnippetKey [in] Snippet's key. + @return List of snippet keys. } - function GetSnippetUnits(const Snippet: string): IStringList; + function GetSnippetUnits(const SnippetKey: string): IStringList; {Get list of all units referenced by a snippet. - @param Snippet [in] Name of snippet. + @param SnippetKey [in] Snippet's key. @return List of unit names. } + + /// Gets the vault's meta data. + /// TMetaData. The required meta data. May be null if meta + /// data is not supported or not present. + function GetMetaData: TMetaData; end; - { - IDataWriter: - Interface that defines operations that must be implemented by objects that - write user database. - NOTE: Any object that is to be used to write the user database must - implement this interface. - } - IDataWriter = interface(IInterface) + /// Interface that defines operations that must be implemented by + /// objects that write vault data to storage. + IVaultStorageWriter = interface(IInterface) ['{71E892C4-6E0F-480A-9DF4-70835F83A0CA}'] procedure Initialise; {Initialise the database. Always called before any other methods. @@ -100,34 +100,41 @@ interface {Write the list of snippets belonging to a category. Always called after WriteCatProps for any given category. @param CatID [in] ID of category. - @param SnipList [in] List of names of snippets. + @param SnipList [in] List of IDs of snippets. } - procedure WriteSnippetProps(const SnippetName: string; + procedure WriteSnippetProps(const SnippetKey: string; const Props: TSnippetData); {Write the properties of a snippet. Always called after all categories are written and before WriteSnippetUnits, so can be used to perform any per- snippet intialisation. - @param SnippetName [in] Name of snippet. + @param SnippetKey [in] Snippet's key. @param Props [in] Properties of snippet. } - procedure WriteSnippetUnits(const SnippetName: string; + procedure WriteSnippetUnits(const SnippetKey: string; const Units: IStringList); {Write the list of units required by a snippet. - @param SnippetName [in] Name of snippet. + @param SnippetKey [in] Snippet's key. @param Units [in] List of names of required units. } - procedure WriteSnippetDepends(const SnippetName: string; + procedure WriteSnippetDepends(const SnippetKey: string; const Depends: IStringList); {Write the list of snippets on which a snippet depends. - @param SnippetName [in] Name of snippet. - @param Depends [in] List of snippet names. + @param SnippetKey [in] Snippet's key. + @param Depends [in] List of snippet keys. } - procedure WriteSnippetXRefs(const SnippetName: string; + procedure WriteSnippetXRefs(const SnippetKey: string; const XRefs: IStringList); {Write the list of snippets that a snippet cross-references. - @param SnippetName [in] Name of snippet. - @param XRefs [in] List of snippet names. + @param SnippetKey [in] Snippet's key. + @param XRefs [in] List of snippet keys. } + + /// Write the vault's meta data. + /// TMetaData [in] Meta data to be written. + /// + /// Data formats may support all, some or no metadata. + procedure WriteMetaData(const AMetaData: TMetaData); + procedure Finalise; {Finalises the database. Always called after all other methods. } diff --git a/Src/DB.Main.pas b/Src/DB.Main.pas new file mode 100644 index 000000000..c0a33064c --- /dev/null +++ b/Src/DB.Main.pas @@ -0,0 +1,1337 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2005-2024, Peter Johnson (gravatar.com/delphidabbler). + * + * Defines a singleton object and subsidiary classes that encapsulate the + * snippets and categories in the snippets database. +} + + +unit DB.Main; + + +interface + + +uses + // Delphi + Classes, + Generics.Collections, + // Project + ActiveText.UMain, + Compilers.UGlobals, + DB.Categories, + DB.SnippetIDs, + DB.Snippets, + DB.Vaults, + UContainers, + UIStringList, + UMultiCastEvents; + + +type + + { + TDatabaseChangeEventKind: + Enumeration that specifies the different kind of change events triggered by + the database. + } + TDatabaseChangeEventKind = ( + evChangeBegin, // a change to the database is about to take place + evChangeEnd, // a change to the database has completed + evSnippetAdded, // a snippet has been added + evBeforeSnippetDelete, // a snippet is about to be deleted + evSnippetDeleted, // a snippet has been deleted + evBeforeSnippetChange, // a snippet is about to be changed + evSnippetChanged, // a snippet's properties / references have changed + evCategoryAdded, // a category has been added + evBeforeCategoryDelete, // a category is about to be deleted + evCategoryDeleted, // a category has been deleted + evBeforeCategoryChange, // a category is about to be changed + evCategoryChanged // a category's properties have changed + ); + + /// Interface supported by objects that provide information about + /// categories and snippets. + IDBDataProvider = interface(IInterface) + ['{D2D57A0D-DB29-4012-891E-E817E0EED8C8}'] + + /// Retrieves all the properties of a category. + /// Category [in] Category for which properties + /// are requested. + /// TCategoryData. Record containing the property data. + /// + function GetCategoryProps(const Cat: TCategory): TCategoryData; + + /// Retrieves keys of all snippets that belong to a category. + /// + /// Category [in] Category for which snippet keys + /// are requested. + /// IStringList. List of snippet keys. + function GetCategorySnippets(const Cat: TCategory): IStringList; + + /// Retrieves all the properties of a snippet. + /// TSnippet [in] Snippet for which properties + /// are requested. + /// TSnippetData. Record containing the property data. + /// + function GetSnippetProps(const Snippet: TSnippet): TSnippetData; + + /// Retrieves information about all the references of a snippet. + /// + /// TSnippet [in] Snippet for which references + /// are requested. + /// TSnippetReferences. Record containing references. + /// + function GetSnippetRefs(const Snippet: TSnippet): TSnippetReferences; + end; + + { + IDatabaseChangeEventInfo: + Interface supported by objects passed to Database object's change event + handler that provides information about a change event. Some properites + are not defined for certain event types. Kind property always defined. + } + IDatabaseChangeEventInfo = interface(IInterface) + ['{80DEE62F-DC23-4EE7-A0B1-5DE46F483CE1}'] + function GetKind: TDatabaseChangeEventKind; + {Gets kind (type) of event. + @return Event kind. + } + function GetInfo: TObject; + {Gets additional information about event. + @return Object that provides required information. + } + property Kind: TDatabaseChangeEventKind read GetKind; + {Identifies kind (type) of an event. Always defined} + property Info: TObject read GetInfo; + {Provides additional information about the event. Actual type of object + depends on Kind. May be nil} + end; + + /// Interface to factory object that creates snippet and category + /// objects used by vault loader objects. + IDBDataItemFactory = interface(IInterface) + ['{C6DD85BD-E649-4A90-961C-4011D2714B3E}'] + + /// Creates a new category object. + /// string [in] ID of new category. Must be + /// unique. + /// TCategoryData [in] Record describing + /// category's properties. + /// TCategory. Instance of new category object. + function CreateCategory(const CatID: string; const Data: TCategoryData): + TCategory; + + /// Creates a new snippet object. + /// string [in] New snippet's key. Must not exist + /// in the database + /// TVaultID [in] Vault containing the + /// snippet. + /// TSnippetData [in] Record describing + /// snippet's properties. + /// Instance of new snippet with no references. + function CreateSnippet(const Key: string; const AVaultID: TVaultID; + const Props: TSnippetData): TSnippet; + + end; + + { + IDatabase: + Interface to object that encapsulates the whole database and provides access + to all snippets and all categories. + } + IDatabase = interface(IInterface) + ['{A280DEEF-0336-4264-8BD0-7CDFBB207D2E}'] + procedure Load; + {Loads data into the database from all vaults. + } + procedure Clear; + {Clears all data. + } + procedure AddChangeEventHandler(const Handler: TNotifyEventInfo); + {Adds a change event handler to list of listeners. + @param Handler [in] Event handler to be added. + } + procedure RemoveChangeEventHandler(const Handler: TNotifyEventInfo); + {Removes a change event handler from list of listeners. + @param Handler [in] Handler to remove from list. + } + function GetSnippets: TSnippetList; + {Gets list of all snippets in the database. + @return Required list. + } + function GetCategories: TCategoryList; + {Gets list of categories in the database. + @return Required list. + } + + /// Creates a new snippet key that is unique within the given + /// vault. + /// TVaultID ID of vault that the new key + /// must be unique within. + /// string containing the key. + function GetUniqueSnippetKey(const AVaultID: TVaultID): string; + + /// Provides details of all a snippet's data (properties and + /// references) that may be edited. + /// TSnippet [in] Snippet for which data is + /// required. May be nil in which case a blank record is returned. + /// TSnippetEditData. Required data. + function GetEditableSnippetInfo(const Snippet: TSnippet = nil): + TSnippetEditData; + + /// Builds an ID list of all snippets that depend on a specified + /// snippet. + /// TSnippet [in] Snippet for which dependents + /// are required. + /// ISnippetIDList. List of IDs of dependent snippets. + /// + function GetDependents(const Snippet: TSnippet): ISnippetIDList; + + /// Builds an ID list of all snippets that cross reference a + /// specified snippet. + /// TSnippet [in] Snippet for which cross + /// referers are required. + /// ISnippetIDList. List of IDs of referring snippets. + /// + function GetReferrers(const Snippet: TSnippet): ISnippetIDList; + + /// Updates a snippet's properties and references using the + /// provided data. + /// TSnippet [in] Snippet to be updated. + /// + /// TSnippetEditData [in] Record containing the + /// revised data. + /// TSnippet. Reference to the updated snippet. + /// The returned TSnippet object will be a different object + /// to ASnippet. + function UpdateSnippet(const ASnippet: TSnippet; + const AData: TSnippetEditData): TSnippet; + + /// Adds a new snippet to the database. + /// string [in] New snippet's key. + /// TVaultID [in] ID of vault that the new + /// snippet will belong to. + /// TSnippetEditData [in] Record storing the new + /// snippet's properties and references. + /// TSnippet. Reference to the new snippet. + function AddSnippet(const AKey: string; const AVaultID: TVaultID; + const AData: TSnippetEditData): TSnippet; + + /// Duplicates a snippet in the database. + /// TSnippet [in] Snippet to be duplicated. + /// + /// string [in] Key to be used for duplicated + /// snippet. + /// TVaultID [in] ID of vault the + /// duplicated snippet belongs to. + /// string [in] Display name of the + /// duplicated snippet. + /// string [in] ID of the category to which the + /// duplicated snippet will belong. + /// TSnippet. Reference to the duplicated snippet. + /// + function DuplicateSnippet(const ASnippet: TSnippet; const ANewKey: string; + const ANewVaultID: TVaultID; const ANewDisplayName: string; + const ACatID: string): TSnippet; + + /// Creates a new temporary snippet without adding it to the + /// database. + /// string [in] The new nippet's key. + /// TVaultID [in] ID of the vault to which + /// the new snippet belongs. + /// TSnippetEditData [in] Record storing the new + /// snippet's properties and references. + /// TSnippet Reference to new snippet. + /// The returned snippet must not be added to the database. + /// + function CreateTempSnippet(const AKey: string; const AVaultID: TVaultID; + const AData: TSnippetEditData): TSnippet; overload; + + /// Creates a new temporary copy of a snippet without adding it to + /// the Snippets object's snippets list. The new instance may not be added + /// to the Snippets object. + /// TSnippetList [in] Snippet to be copied. + /// + /// TSnippet [in] Reference to new copied snippet. + /// + function CreateTempSnippet(const Snippet: TSnippet): TSnippet; overload; + + /// Provides details of all a category's data that may be edited. + /// + /// TCategory [in] Category for which data is + /// required. May be nil in whih case a blank record is returned. + /// TCategoryData. Required data. + function GetEditableCategoryInfo(const Category: TCategory = nil): + TCategoryData; + + /// Adds a new category to the database. + /// string [in] ID of new category. + /// TCategoryData [in] Record storing new + /// category's properties. + /// TCategory. Reference to new category. + function AddCategory(const CatID: string; const Data: TCategoryData): + TCategory; + + /// Deletes a snippet from the database. + /// TSnippet [in] Snippet to be deleted. + /// + procedure DeleteSnippet(const Snippet: TSnippet); + + /// Updates a category's properties. + /// TCategory [in] Category to be updated. + /// + /// TCategoryData [in] Record containing revised + /// data. + /// TCategory.Reference to updated category. Will have + /// changed. + function UpdateCategory(const Category: TCategory; + const Data: TCategoryData): TCategory; + + /// Deletes a category and all its snippets from the database. + /// + /// TCategory [in] Category to be deleted. + /// + procedure DeleteCategory(const Category: TCategory); + + /// Checks if the database has been updated since the last save. + /// + /// Boolean True if database has been updated, + /// False otherwise. + function Updated: Boolean; + + /// Saves the database. + procedure Save; + + property Categories: TCategoryList read GetCategories; + {List of categories in the database} + property Snippets: TSnippetList read GetSnippets; + {List of snippets in the database} + end; + +function Database: IDatabase; + {Returns singleton instance of object that encapsulates the database. + @return Singleton object. + } + + +implementation + + +uses + // Delphi + SysUtils, + Generics.Defaults, + // Project + DB.IO.Manager, + DB.IO.Categories, + IntfCommon, + UExceptions, + UQuery, + UStrUtils, + UUniqueID; + + +var + // Private global snippets singleton object + PvtDatabase: IDatabase = nil; + + +type + + /// Class that can create category and snippet objects.. + TDBDataItemFactory = class(TInterfacedObject, IDBDataItemFactory) + public + + /// Creates a new category object. + /// string [in] ID of new category. Must be + /// unique. + /// TCategoryData [in] Record describing + /// category's properties. + /// TCategory. Instance of new category object. + function CreateCategory(const CatID: string; const Data: TCategoryData): + TCategory; + + /// Creates a new snippet object. + /// string [in] New snippet's key. Must not + /// exist in database + /// TVaultID [in] Vault containing the + /// snippet. + /// TSnippetData [in] Record describing + /// snippet's properties. + /// Instance of new snippet with no references. + function CreateSnippet(const Key: string; const AVaultID: TVaultID; + const Props: TSnippetData): TSnippet; + + end; + + /// Class that encapsulates the database. Provides access to and + /// modify all snippets and all categories via the IDatabase interface. + /// + TDatabase = class(TInterfacedObject, + IDatabase + ) + strict private + fUpdated: Boolean; // Flags if database has been updated + fCategories: TCategoryList; // List of categories + fSnippets: TSnippetList; // List of snippets + fChangeEvents: TMulticastEvents; // List of change event handlers + type + { + TEventInfo: + Class that provides information about a change event. + } + TEventInfo = class(TInterfacedObject, IDatabaseChangeEventInfo) + strict private + fKind: TDatabaseChangeEventKind; // Kind of event + fInfo: TObject; // Extra info about event + public + constructor Create(const Kind: TDatabaseChangeEventKind; + const Info: TObject = nil); + {Constructor. Creates an event information object. + @param Kind [in] Kind of event. + @param Info [in] Reference to further information about the event. + May be nil if event doesn't have additional information. + } + { IDatabaseChangeEventInfo methods } + function GetKind: TDatabaseChangeEventKind; + {Gets kind (type) of event. + @return Event kind. + } + function GetInfo: TObject; + {Gets additional information about event. + @return Object that provides required information. + } + end; + procedure TriggerEvent(const Kind: TDatabaseChangeEventKind; + const Info: TObject = nil); + {Triggers a change event. Notifies all registered listeners. + @param Kind [in] Kind of event. + @param Info [in] Reference to any further information for event. May be + nil. + } + + /// Adds a new snippet to the database. Assumes the snippet is + /// not already in the database. + /// string [in] New snippet's key. + /// TVaultID [in] ID of vault that the new + /// snippet will belong to. + /// TSnippetEditData [in] Record storing the new + /// snippet's properties and references. + /// TSnippet. Reference to the new snippet. + /// ECodeSnip raised if the snippet's category does not + /// exist. + function InternalAddSnippet(const AKey: string; const AVaultID: TVaultID; + const AData: TSnippetEditData): TSnippet; + + procedure InternalDeleteSnippet(const Snippet: TSnippet); + {Deletes a snippet from the database. + @param Snippet [in] Snippet to delete from database. + } + function InternalAddCategory(const CatID: string; + const Data: TCategoryData): TCategory; + {Adds a new category to the database. Assumes the category is not already + in the database. + @param CatID [in] ID of new category. + @param Data [in] Properties of new category. + @return Reference to new category object. + } + procedure InternalDeleteCategory(const Cat: TCategory); + {Deletes a category from the database. + @param Cat [in] Category to delete from database. + } + procedure GetDependentList(const ASnippet: TSnippet; + const List: TSnippetList); + {Builds a list of all snippets that depend on a specified snippet. + @param ASnippet [in] Snippet for which dependents are required. + @param List [in] Receives list of dependent snippets. + } + procedure GetReferrerList(const ASnippet: TSnippet; + const List: TSnippetList); + {Builds list of all snippets that cross reference a specified snippet. + @param ASnippet [in] The cross referenced snippet. + @param List [in] Receives list of cross referencing snippets. + } + public + constructor Create; + {Constructor. Sets up new empty object. + } + destructor Destroy; override; + {Destructor. Tidies up and tears down object. + } + { IDatabase methods } + function GetCategories: TCategoryList; + {Gets list of all categories in database. + @return Required list. + } + function GetSnippets: TSnippetList; + {Gets list of all snippets in database. + @return Required list. + } + + /// Load the database from all available vaults. + procedure Load; + + procedure Clear; + {Clears the object's data. + } + procedure AddChangeEventHandler(const Handler: TNotifyEventInfo); + {Adds a change event handler to list of listeners. + @param Handler [in] Event handler to be added. + } + procedure RemoveChangeEventHandler(const Handler: TNotifyEventInfo); + {Removes a change event handler from list of listeners. + @param Handler [in] Handler to remove from list. + } + + /// Creates a new snippet key that is unique within the given + /// vault. + /// TVaultID ID of vault that the new key + /// must be unique within. + /// string containing the key. + /// Method of IDatabase. + function GetUniqueSnippetKey(const AVaultID: TVaultID): string; + + function GetEditableSnippetInfo(const Snippet: TSnippet = nil): + TSnippetEditData; + {Provides details of all a snippet's data (properties and references) that + may be edited. + @param Snippet [in] Snippet for which data is required. May be nil in + which case a blank record is returned. + @return Required data. + } + function GetDependents(const Snippet: TSnippet): ISnippetIDList; + {Builds an ID list of all snippets that depend on a specified snippet. + @param Snippet [in] Snippet for which dependents are required. + @return List of IDs of dependent snippets. + } + function GetReferrers(const Snippet: TSnippet): ISnippetIDList; + {Builds an ID list of all snippets that cross reference a specified + snippet. + @param Snippet [in] Snippet which is cross referenced. + @return List of IDs of referring snippets. + } + + /// Updates a snippet's properties and references using the + /// provided data. + /// TSnippet [in] Snippet to be updated. + /// + /// TSnippetEditData [in] Record containing the + /// revised data. + /// TSnippet. Reference to the updated snippet. + /// + /// The returned TSnippet object will be a different object + /// to ASnippet. + /// Method of IDatabase. + /// + function UpdateSnippet(const ASnippet: TSnippet; + const AData: TSnippetEditData): TSnippet; + + /// Adds a new snippet to the database. + /// string [in] New snippet's key. + /// TVaultID [in] ID of vault that the new + /// snippet will belong to. + /// TSnippetEditData [in] Record storing the new + /// snippet's properties and references. + /// TSnippet. Reference to the new snippet. + /// Method of IDatabase. + function AddSnippet(const AKey: string; const AVaultID: TVaultID; + const AData: TSnippetEditData): TSnippet; + + /// Duplicates a snippet in the database. + /// TSnippet [in] Snippet to be duplicated. + /// + /// string [in] Key to be used for duplicated + /// snippet. + /// TVaultID [in] ID of the vault the + /// duplicated snippet belongs to. + /// string [in] Display name of the + /// duplicated snippet. + /// string [in] ID of the category to which the + /// duplicated snippet will belong. + /// TSnippet. Reference to the duplicated snippet. + /// + /// Method of IDatabase. + function DuplicateSnippet(const ASnippet: TSnippet; const ANewKey: string; + const ANewVaultID: TVaultID; const ANewDisplayName: string; + const ACatID: string): TSnippet; + + /// Creates a new temporary snippet without adding it to the + /// database. + /// string [in] The new nippet's key. + /// TVaultID [in] ID of the vault to which + /// the new snippet belongs. + /// TSnippetEditData [in] Record storing the new + /// snippet's properties and references. + /// TSnippet Reference to new snippet. + /// + /// The returned snippet must not be added to the database. + /// Method of IDatabase. + /// + function CreateTempSnippet(const AKey: string; const AVaultID: TVaultID; + const AData: TSnippetEditData): TSnippet; overload; + + function CreateTempSnippet(const Snippet: TSnippet): TSnippet; overload; + {Creates a new temporary copy of a snippet without adding it to the + Snippets object's snippets list. The new instance may not be added to the + Snippets object. + @param Snippet [in] Snippet to be copied. + @return Reference to new snippet. + } + procedure DeleteSnippet(const Snippet: TSnippet); + {Deletes a snippet from the database. + @param Snippet [in] Snippet to be deleted. + } + function GetEditableCategoryInfo( + const Category: TCategory = nil): TCategoryData; + {Provides details of all a category's data that may be edited. + @param Category [in] Category for which data is required. May be nil in + which case a blank record is returned. + @return Required data. + } + function AddCategory(const CatID: string; + const Data: TCategoryData): TCategory; + {Adds a new category to the database. + @param CatID [in] ID of new category. + @param Data [in] Record storing new category's properties. + @return Reference to new category. + } + function UpdateCategory(const Category: TCategory; + const Data: TCategoryData): TCategory; + {Updates a defined category's properties. + @param Category [in] Category to be updated. + @param Data [in] Record containing revised data. + @return Reference to updated category. Will have changed. + } + procedure DeleteCategory(const Category: TCategory); + {Deletes a category and all its snippets from the database. + @param Category [in] Category to be deleted. + } + function Updated: Boolean; + {Checks if the database has been updated since the last save. + @return True if database has been updated, False otherwise. + } + + /// Saves snippets from database to their respective vaults. + /// + procedure Save; + + end; + + /// Class that provides data about the categories and snippets in + /// a given vault. + TVaultDataProvider = class(TInterfacedObject, IDBDataProvider) + strict private + var + fVaultID: TVaultID; // Vault on which to operate + fSnippets: TSnippetList; // All snippets in the whole database + fCategories: TCategoryList; // All categories in the whole database + public + /// Object constructor. Sets up data provider. + /// TVaultID [in] Vault for which to provide + /// data. + /// TSnippetList [in] List of all snippets + /// in the database. + /// TCategoryList [in] List of all + /// categories in the database. + constructor Create(const AVaultID: TVaultID; const SnipList: TSnippetList; + const Categories: TCategoryList); + + /// Retrieves all the properties of a category. + /// Category [in] Category for which properties + /// are requested. + /// TCategoryData. Record containing the property data. + /// + /// Method of IDBDataProvider + function GetCategoryProps(const Cat: TCategory): TCategoryData; + + /// Retrieves keys of all snippets from the vault that belong + /// to a category. + /// Category [in] Category for which snippet keys + /// are requested. + /// IStringList. List of snippet keys. + /// Method of IDBDataProvider + function GetCategorySnippets(const Cat: TCategory): IStringList; + + /// Retrieves all the properties of a snippet. + /// TSnippet [in] Snippet for which properties + /// are requested. + /// TSnippetData. Record containing the property data. + /// + /// Method of IDBDataProvider + function GetSnippetProps(const Snippet: TSnippet): TSnippetData; + + /// Retrieves information about all the references of a snippet. + /// + /// TSnippet [in] Snippet for which references + /// are requested. + /// TSnippetReferences. Record containing references. + /// + /// Method of IDBDataProvider + function GetSnippetRefs(const Snippet: TSnippet): TSnippetReferences; + + end; + +function Database: IDatabase; + {Returns a singleton instance of the object that encapsulates the database. + @return Singleton object. + } +begin + if not Assigned(PvtDatabase) then + PvtDatabase := TDatabase.Create; + Result := PvtDatabase; +end; + +{ TDatabase } + +function TDatabase.AddCategory(const CatID: string; + const Data: TCategoryData): TCategory; + {Adds a new category to the database. + @param CatID [in] ID of new category. + @param Data [in] Record storing new category's properties. + @return Reference to new category. + } +resourcestring + // Error message + sNameExists = 'Category %s already exists in the database'; +begin + Result := nil; + TriggerEvent(evChangeBegin); + try + // Check if category with same id exists in the database: error if so + if fCategories.Find(CatID) <> nil then + raise ECodeSnip.CreateFmt(sNameExists, [CatID]); + Result := InternalAddCategory(CatID, Data); + Query.Update; + TriggerEvent(evCategoryAdded, Result); + finally + fUpdated := True; + TriggerEvent(evChangeEnd); + end; +end; + +procedure TDatabase.AddChangeEventHandler(const Handler: TNotifyEventInfo); + {Adds a change event handler to list of listeners. + @param Handler [in] Event handler to be added. + } +begin + fChangeEvents.AddHandler(Handler); +end; + +function TDatabase.AddSnippet(const AKey: string; const AVaultID: TVaultID; + const AData: TSnippetEditData): TSnippet; +resourcestring + // Error message + sKeyExists = 'Snippet with key "%s" already exists in the vault'; +begin + Result := nil; // keeps compiler happy + TriggerEvent(evChangeBegin); + try + // Check if snippet with same key exists in the database: error if so + if fSnippets.Find(AKey, AVaultID) <> nil then + raise ECodeSnip.CreateFmt(sKeyExists, [AKey]); + Result := InternalAddSnippet(AKey, AVaultID, AData); + Query.Update; + TriggerEvent(evSnippetAdded, Result); + finally + fUpdated := True; + TriggerEvent(evChangeEnd); + end; +end; + +procedure TDatabase.Clear; + {Clears the object's data. + } +begin + fCategories.Clear; + fSnippets.Clear; +end; + +constructor TDatabase.Create; + {Constructor. Sets up new empty object. + } +begin + inherited Create; + fSnippets := TSnippetList.Create(True); + fCategories := TCategoryList.Create(True); + fChangeEvents := TMultiCastEvents.Create(Self); +end; + +function TDatabase.CreateTempSnippet(const Snippet: TSnippet): TSnippet; + {Creates a new temporary copy of a snippet without adding it to the + Snippets object's snippets list. The new instance may not be added to the + Snippets object. + @param Snippet [in] Snippet to be copied. + @return Reference to new snippet. + } +var + Data: TSnippetEditData; // data describing snippet's properties and references +begin + Assert(Assigned(Snippet), ClassName + '.CreateTempSnippet: Snippet is nil'); + Data := Snippet.GetEditData; + Result := TSnippet.Create(Snippet.Key, Snippet.VaultID, Snippet.GetProps); + Result.UpdateRefs(Snippet.GetReferences, fSnippets); +end; + +function TDatabase.CreateTempSnippet(const AKey: string; + const AVaultID: TVaultID; const AData: TSnippetEditData): TSnippet; +begin + Result := TSnippet.Create(AKey, AVaultID, AData.Props); + Result.UpdateRefs(AData.Refs, fSnippets); +end; + +procedure TDatabase.DeleteCategory(const Category: TCategory); + {Deletes a category and all its snippets from the database. + @param Category [in] Category to be deleted. + } +begin + Assert(Category.CanDelete, + ClassName + '.DeleteCategory: Category can''t be deleted'); + Assert(fCategories.Contains(Category), + ClassName + '.DeleteCategory: Category is not in the database'); + TriggerEvent(evChangeBegin); + TriggerEvent(evBeforeCategoryDelete, Category); + try + InternalDeleteCategory(Category); + Query.Update; + finally + TriggerEvent(evCategoryDeleted); + TriggerEvent(evChangeEnd); + fUpdated := True; + end; +end; + +procedure TDatabase.DeleteSnippet(const Snippet: TSnippet); + {Deletes a snippet from the database. + @param Snippet [in] Snippet to be deleted. + } +var + Dependent: TSnippet; // loops thru each snippet that depends on Snippet + Dependents: TSnippetList; // list of dependent snippets + Referrer: TSnippet; // loops thru snippets that cross references Snippet + Referrers: TSnippetList; // list of referencing snippets +begin + Assert(fSnippets.Contains(Snippet), + ClassName + '.DeleteSnippet: Snippet is not in the database'); + TriggerEvent(evChangeBegin); + TriggerEvent(evBeforeSnippetDelete, Snippet); + // Get list of referencing and dependent snippets + Dependents := nil; + Referrers := nil; + try + Dependents := TSnippetList.Create; + GetDependentList(Snippet, Dependents); + Referrers := TSnippetList.Create; + GetReferrerList(Snippet, Referrers); + // Delete snippet for XRef or Depends list of referencing snippets + for Referrer in Referrers do + Referrer.XRef.Delete(Snippet); + for Dependent in Dependents do + Dependent.Depends.Delete(Snippet); + // Delete snippet itself + InternalDeleteSnippet(Snippet); + Query.Update; + finally + FreeAndNil(Referrers); + FreeAndNil(Dependents); + fUpdated := True; + TriggerEvent(evSnippetDeleted); + TriggerEvent(evChangeEnd); + end; +end; + +destructor TDatabase.Destroy; + {Destructor. Tidies up and tears down object. + } +begin + FreeAndNil(fChangeEvents); + FreeAndNil(fCategories); + FreeAndNil(fSnippets); + inherited; +end; + +function TDatabase.DuplicateSnippet(const ASnippet: TSnippet; + const ANewKey: string; const ANewVaultID: TVaultID; + const ANewDisplayName: string; const ACatID: string): TSnippet; +var + Data: TSnippetEditData; +begin + {TODO -cVault: Update edit data before calling this method and replace + and ANewDisplayName and ACatID with a single AData parameter.} + Data := ASnippet.GetEditData; + Data.Props.Cat := ACatID; + Data.Props.DisplayName := ANewDisplayName; + Result := AddSnippet(ANewKey, ANewVaultID, Data); +end; + +function TDatabase.GetCategories: TCategoryList; + {Gets list of all categories in database. + @return Required list. + } +begin + Result := fCategories; +end; + +procedure TDatabase.GetDependentList(const ASnippet: TSnippet; + const List: TSnippetList); + {Builds a list of all snippets that depend on a specified snippet. + @param ASnippet [in] Snippet for which dependents are required. + @param List [in] Receives list of dependent snippets. + } +var + Snippet: TSnippet; // references each snippet in database +begin + List.Clear; + for Snippet in fSnippets do + if not Snippet.IsEqual(ASnippet) and Snippet.Depends.Contains(ASnippet) then + List.Add(Snippet); +end; + +function TDatabase.GetDependents(const Snippet: TSnippet): ISnippetIDList; + {Builds an ID list of all snippets that depend on a specified snippet. + @param Snippet [in] Snippet for which dependents are required. + @return List of IDs of dependent snippets. + } +var + List: TSnippetList; // list of dependent snippets +begin + List := TSnippetList.Create; + try + GetDependentList(Snippet, List); + Result := List.IDs; + finally + FreeAndNil(List); + end; +end; + +function TDatabase.GetEditableCategoryInfo( + const Category: TCategory): TCategoryData; + {Provides details of all a category's data that may be edited. + @param Category [in] Category for which data is required. May be nil in + whih case a blank record is returned. + @return Required data. + } +begin + if Assigned(Category) then + Result := Category.GetEditData + else + Result.Init; +end; + +function TDatabase.GetEditableSnippetInfo(const Snippet: TSnippet): + TSnippetEditData; + {Provides details of all a snippet's data (properties and references) that may + be edited. + @param Snippet [in] Snippet for which data is required. May be nil in which + case a blank record is returned. + @return Required data. + } +begin + if Assigned(Snippet) then + Result := Snippet.GetEditData + else + Result.Init; +end; + +function TDatabase.GetReferrers(const Snippet: TSnippet): ISnippetIDList; + {Builds an ID list of all snippets that cross reference a specified + snippet. + @param Snippet [in] Snippet which is cross referenced. + @return List of IDs of referring snippets. + } +var + List: TSnippetList; // list of referring snippets +begin + List := TSnippetList.Create; + try + GetReferrerList(Snippet, List); + Result := List.IDs; + finally + FreeAndNil(List); + end; +end; + +procedure TDatabase.GetReferrerList(const ASnippet: TSnippet; + const List: TSnippetList); + {Builds list of all snippets that cross reference a specified snippet. + @param ASnippet [in] The cross referenced snippet. + @param List [in] Receives list of cross referencing snippets. + } +var + Snippet: TSnippet; // references each snippet in database +begin + List.Clear; + for Snippet in fSnippets do + if not Snippet.IsEqual(ASnippet) and Snippet.XRef.Contains(ASnippet) then + List.Add(Snippet); +end; + +function TDatabase.GetSnippets: TSnippetList; + {Gets list of all snippets in database. + @return Required list. + } +begin + Result := fSnippets; +end; + +function TDatabase.GetUniqueSnippetKey(const AVaultID: TVaultID): string; +var + SnippetsInVault: TSnippetList; + Snippet: TSnippet; +begin + // NOTE: It is probable that TUniqueID will always generate a key that is + // unique across the whole database, let alone within the vault. But it's + // safer to check and regenerate if necessary. + SnippetsInVault := TSnippetList.Create; + try + // Build list of all snippets in vault + for Snippet in fSnippets do + if Snippet.VaultID = AVaultID then + SnippetsInVault.Add(Snippet); + repeat + Result := TUniqueID.GenerateAlpha; + until SnippetsInVault.Find(Result, AVaultID) = nil; + finally + SnippetsInVault.Free; + end; +end; + +function TDatabase.InternalAddCategory(const CatID: string; + const Data: TCategoryData): TCategory; + {Adds a new category to the database. Assumes the category is not already in + the database. + @param CatID [in] ID of new category. + @param Data [in] Properties of new category. + @return Reference to new category object. + } +begin + Result := TCategory.Create(CatID, Data); + fCategories.Add(Result); +end; + +function TDatabase.InternalAddSnippet(const AKey: string; + const AVaultID: TVaultID; const AData: TSnippetEditData): TSnippet; +var + Cat: TCategory; // category object containing new snippet +resourcestring + // Error message + sCatNotFound = 'Category "%0:s" referenced by new snippet with key "%1:s" ' + + 'does not exist'; +begin + Result := TSnippet.Create(AKey, AVaultID, AData.Props); + Result.UpdateRefs(AData.Refs, fSnippets); + Cat := fCategories.Find(Result.Category); + if not Assigned(Cat) then + raise ECodeSnip.CreateFmt(sCatNotFound, [Result.Category, Result.Key]); + Cat.Snippets.Add(Result); + fSnippets.Add(Result); +end; + +procedure TDatabase.InternalDeleteCategory(const Cat: TCategory); + {Deletes a category from the database. + @param Cat [in] Category to delete from database. + } +begin + fCategories.Delete(Cat); +end; + +procedure TDatabase.InternalDeleteSnippet(const Snippet: TSnippet); + {Deletes a snippet from the database. + @param Snippet [in] Snippet to delete from database. + } +var + Cat: TCategory; // category containing snippet +begin + // Delete from category if found + Cat := fCategories.Find(Snippet.Category); + if Assigned(Cat) then + Cat.Snippets.Delete(Snippet); + // Delete from "master" list: this frees Snippet + fSnippets.Delete(Snippet); +end; + +procedure TDatabase.Load; + {Loads data from the database. + } +var + DataItemFactory: IDBDataItemFactory; + VaultLoader: IVaultLoader; + Vault: TVault; + CatLoader: IGlobalCategoryLoader; +begin + // Clear the database + Clear; + // Create factory that reader calls into to create category and snippet + // objects. This is done to keep updating of snippet and categories private + // to this unit + DataItemFactory := TDBDataItemFactory.Create; + try + // Load all vaults + for Vault in TVaults.Instance do + begin + VaultLoader := TDatabaseIOFactory.CreateVaultLoader(Vault); + if Assigned(VaultLoader) then + VaultLoader.Load(fSnippets, fCategories, DataItemFactory); + end; + // Read categories from categories file to get any empty categories not + // created by format loaders + CatLoader := TDatabaseIOFactory.CreateGlobalCategoryLoader; + CatLoader.Load(fCategories, DataItemFactory); + // Ensure that the default category is present, if it's not already loaded + if not Assigned(fCategories.Find(TCategory.DefaultID)) then + fCategories.Add(TCategory.CreateDefault); + fUpdated := False; + except + // If an exception occurs clear the database + Clear; + raise; + end; +end; + +procedure TDatabase.RemoveChangeEventHandler(const Handler: TNotifyEventInfo); + {Removes a change event handler from list of listeners. + @param Handler [in] Handler to remove from list. + } +begin + fChangeEvents.RemoveHandler(Handler); +end; + +procedure TDatabase.Save; + {Saves all snippets and categories to the database. + } +var + Provider: IDBDataProvider; + VaultSaver: IVaultSaver; + Vault: TVault; + CatSaver: IGlobalCategorySaver; +begin + // Save categories + CatSaver := TDatabaseIOFactory.CreateGlobalCategorySaver; + CatSaver.Save(fCategories); + // Save all vaults + for Vault in TVaults.Instance do + begin + Provider := TVaultDataProvider.Create( + Vault.UID, fSnippets, fCategories + ); + VaultSaver := TDatabaseIOFactory.CreateVaultSaver(Vault); + if Assigned(VaultSaver) then + VaultSaver.Save(fSnippets, fCategories, Provider); + end; + fUpdated := False; +end; + +procedure TDatabase.TriggerEvent(const Kind: TDatabaseChangeEventKind; + const Info: TObject); + {Triggers a change event. Notifies all registered listeners. + @param Kind [in] Kind of event. + @param Info [in] Reference to any further information for event. May be nil. + } +var + EvtInfo: IDatabaseChangeEventInfo; // event information object +begin + EvtInfo := TEventInfo.Create(Kind, Info); + fChangeEvents.TriggerEvents(EvtInfo); +end; + +function TDatabase.UpdateCategory(const Category: TCategory; + const Data: TCategoryData): TCategory; + {Updates a category's properties. + @param Category [in] Category to be updated. + @param Data [in] Record containing revised data. + @return Reference to updated category. Will have changed. + } +var + SnippetList: TSnippetList; + Snippet: TSnippet; + CatID: string; +begin + TriggerEvent(evChangeBegin); + TriggerEvent(evBeforeCategoryChange, Category); + try + SnippetList := TSnippetList.Create; + try + for Snippet in Category.Snippets do + SnippetList.Add(Snippet); + CatID := Category.ID; + InternalDeleteCategory(Category); + Result := InternalAddCategory(CatID, Data); + for Snippet in SnippetList do + Result.Snippets.Add(Snippet); + finally + FreeAndNil(SnippetList); + end; + Query.Update; + TriggerEvent(evCategoryChanged, Result); + finally + fUpdated := True; + TriggerEvent(evChangeEnd); + end; +end; + +function TDatabase.Updated: Boolean; + {Checks if the database has been updated since the last save. + @return True if database has been updated, False otherwise. + } +begin + Result := fUpdated; +end; + +function TDatabase.UpdateSnippet(const ASnippet: TSnippet; + const AData: TSnippetEditData): TSnippet; +var + Dependents: TSnippetList; // list of dependent snippets + Dependent: TSnippet; // each snippet that depend on ASnippet + Referrers: TSnippetList; // list of referencing snippets + Referrer: TSnippet; // each snippet that cross references ASnippet + PreservedSnippetID: TSnippetID; +begin + Referrers := nil; + Dependents := nil; + + TriggerEvent(evChangeBegin); + TriggerEvent(evBeforeSnippetChange, ASnippet); + + try + // We update by deleting old snippet and inserting new one + + // get lists of snippets that cross reference or depend on this snippet + Dependents := TSnippetList.Create; + GetDependentList(ASnippet, Dependents); + Referrers := TSnippetList.Create; + GetReferrerList(ASnippet, Referrers); + + // remove references to pre-update snippet from referring snippets + for Referrer in Referrers do + Referrer.XRef.Delete(ASnippet); + for Dependent in Dependents do + Dependent.Depends.Delete(ASnippet); + + // record snippet's key and vault ID for use in re-created updated snippet + PreservedSnippetID := ASnippet.ID; + + // delete the old, pre-update snippet + InternalDeleteSnippet(ASnippet); + // add new, post-update snippet with same key & vault ID as old snippet + Result := InternalAddSnippet( + PreservedSnippetID.Key, PreservedSnippetID.VaultID, AData + ); + + // add updated snippet to referrer lists of referring snippets + for Referrer in Referrers do + Referrer.XRef.Add(Result); + for Dependent in Dependents do + Dependent.Depends.Add(Result); + + Query.Update; + + TriggerEvent(evSnippetChanged, Result); + + finally + fUpdated := True; + Referrers.Free; + Dependents.Free; + TriggerEvent(evChangeEnd); + end; +end; + +{ TSnippets.TEventInfo } + +constructor TDatabase.TEventInfo.Create(const Kind: TDatabaseChangeEventKind; + const Info: TObject); + {Constructor. Creates an event information object. + @param Kind [in] Kind of event. + @param Info [in] Reference to further information about the event. May be + nil if event doesn't have additional information. + } +begin + inherited Create; + fKind := Kind; + fInfo := Info; +end; + +function TDatabase.TEventInfo.GetInfo: TObject; + {Gets additional information about event. + @return Object that provides required information. + } +begin + Result := fInfo; +end; + +function TDatabase.TEventInfo.GetKind: TDatabaseChangeEventKind; + {Gets kind (type) of event. + @return Event kind. + } +begin + Result := fKind; +end; + +{ TDBDataItemFactory } + +function TDBDataItemFactory.CreateCategory(const CatID: string; + const Data: TCategoryData): TCategory; +begin + Result := TCategory.Create(CatID, Data); +end; + +function TDBDataItemFactory.CreateSnippet(const Key: string; + const AVaultID: TVaultID; const Props: TSnippetData): TSnippet; +begin + Result := TSnippet.Create(Key, AVaultID, Props); +end; + +{ TVaultDataProvider } + +constructor TVaultDataProvider.Create(const AVaultID: TVaultID; + const SnipList: TSnippetList; const Categories: TCategoryList); +begin + inherited Create; + fVaultID := AVaultID; + fSnippets := SnipList; + fCategories := Categories; +end; + +function TVaultDataProvider.GetCategoryProps( + const Cat: TCategory): TCategoryData; +begin + Result.Desc := Cat.Description; +end; + +function TVaultDataProvider.GetCategorySnippets( + const Cat: TCategory): IStringList; +var + Snippet: TSnippet; // references each snippet in category +begin + Result := TIStringList.Create; + for Snippet in Cat.Snippets do + if Snippet.VaultID = fVaultID then + Result.Add(Snippet.Key); +end; + +function TVaultDataProvider.GetSnippetProps( + const Snippet: TSnippet): TSnippetData; +begin + Result := Snippet.GetProps; +end; + +function TVaultDataProvider.GetSnippetRefs( + const Snippet: TSnippet): TSnippetReferences; +begin + Result := Snippet.GetReferences; +end; + + +initialization + + +finalization + +// Free the singleton +PvtDatabase := nil; + +end. + diff --git a/Src/DB.MetaData.pas b/Src/DB.MetaData.pas new file mode 100644 index 000000000..cbd1a8ea5 --- /dev/null +++ b/Src/DB.MetaData.pas @@ -0,0 +1,369 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2025, Peter Johnson (gravatar.com/delphidabbler). + * + * Encapsulates a metadata that applies to a vault. Available metadata depends + * on that supported by a vault's chosen data format. +} + + +unit DB.MetaData; + +{$ScopedEnums ON} + +interface + +uses + // Project + UIStringList, + UVersionInfo; + +type + + /// Enumeration of the capabilities of a data format. + /// + /// - Version - supports data format version numbering. + /// - License - supports vault license information. + /// - Copyright - supports vault copyright information. + /// + /// - Acknowledgements - supports acknowledgements for the + /// vault. + /// + TMetaDataCap = ( + Version, + License, + Copyright, + Acknowledgements + ); + + /// Set of meta data capabilities applying to a data format. + /// + TMetaDataCaps = set of TMetaDataCap; + + /// Record providing information about a vault's license. + /// + TLicenseInfo = record + strict private + var + fName: string; + fSPDX: string; + fURL: string; + fText: string; + public + /// Record constructor: sets all fields of record. + /// Any or all parameters may be the empty string + constructor Create(const AName, ASPDX, AURL, AText: string); + + /// Creates and returns a null record with all fields set to the + /// empty string. + class function CreateNull: TLicenseInfo; static; + + /// Returns a deep copy of this record. + function Clone: TLicenseInfo; + + /// Checks if the record is null. + /// A null record is one where Name, SPDX, + /// URL and Text properties are all empty strings. + function IsNull: Boolean; + + /// Name of license. + property Name: string read fName; + + /// Open Source Initiative SPDX short idenitifier for licenses. + /// + /// If the license is not supported by the Open Source Initiative + /// then this property will be the empty string. + property SPDX: string read fSPDX; + + /// URL of license online. + /// Optional. + property URL: string read fURL; + + /// Full text of license. + property Text: string read fText; + + /// Returns a string containing license name followed by any URL + /// in parentheses. + /// If no URL is available then only the license name is returned. + /// + function NameWithURL: string; + end; + + /// Record providing informaton about a vault's copyright. + /// + TCopyrightInfo = record + strict private + var + fDate: string; + fHolder: string; + fHolderURL: string; + fContributors: IStringList; + function GetContributors: IStringList; + public + /// Record constructor: sets all fields of record. + /// Any or all string parameters may be the empty string. + /// AContributors may be nil if there are no contributors. + /// + constructor Create(const ADate, AHolder, AHolderURL: string; + AContributors: IStringList); + + /// Creates and returns a null record. + /// A null record has all string fields set to the empty string + /// and the Contributors property set to an empty list. + class function CreateNull: TCopyrightInfo; static; + + /// Returns a deep copy of this record. + function Clone: TCopyrightInfo; + + /// Checks if the record is null. + /// A null record is one where Date, Holder and + /// HolderURL properties are empty strings and Contributors + /// list is empty. + function IsNull: Boolean; + + /// Copyright date. + /// May be a single year or a range: e.g. 2020 or 2012-2016. + /// + property Date: string read fDate; + + /// Name of copyright holder. + property Holder: string read fHolder; + + /// URL of main copyright holder. + /// Optional. + property HolderURL: string read fHolderURL; + + /// List of names of contributors who share ownership of the + /// copyright. + property Contributors: IStringList read GetContributors; + + /// Creates and returns a string representation of all the + /// non-empty fields of the record. + function ToString: string; + end; + + /// Encapsulates meta data associated with a vault. + TMetaData = record + strict private + var + fCapabilities: TMetaDataCaps; + fVersion: TVersionNumber; + fLicenseInfo: TLicenseInfo; + fCopyrightInfo: TCopyrightInfo; + fAcknowledgements: IStringList; + function GetVersion: TVersionNumber; + function GetLicenseInfo: TLicenseInfo; + function GetCopyrightInfo: TCopyrightInfo; + function GetAcknowledgements: IStringList; + public + /// Creates a meta data record with specified capabilities. + /// + /// TMetaDataCaps [in] The required + /// capabilities. + constructor Create(const ACapabilities: TMetaDataCaps); + + /// Creates a null meta data record with specified capabilities. + /// + class function CreateNull: TMetaData; static; + + /// Returns a deep copy of this record. + function Clone: TMetaData; + + /// The meta data capabilities. + property Capabilities: TMetaDataCaps + read fCapabilities; + + /// The data format version. + property Version: TVersionNumber + read GetVersion write fVersion; + + /// Information about the vault's license. + property LicenseInfo: TLicenseInfo + read GetLicenseInfo write fLicenseInfo; + + /// Information about the vault's copyright. + property CopyrightInfo: TCopyrightInfo + read GetCopyrightInfo write fCopyrightInfo; + + /// List of acknowledgements associated with a vault. + property Acknowledgements: IStringList + read GetAcknowledgements write fAcknowledgements; + end; + +implementation + +uses + // Delphi + Character, + // Project + UStrUtils; + +function StandardiseStr(const AStr: string): string; +begin + Result := StrCompressWhiteSpace( + StrReplaceChar( + AStr, + function(Ch: Char): Boolean + begin + Result := TCharacter.IsControl(Ch); + end, + ' ' + ) + ); +end; + +{ TLicenseInfo } + +function TLicenseInfo.Clone: TLicenseInfo; +begin + Result.fName := Name; + Result.fSPDX := SPDX; + Result.fURL := URL; + Result.fText := Text; +end; + +constructor TLicenseInfo.Create(const AName, ASPDX, AURL, AText: string); +begin + fName := StandardiseStr(AName); + fSPDX := StandardiseStr(ASPDX); + fURL := StandardiseStr(AURL); + fText := StandardiseStr(AText); +end; + +class function TLicenseInfo.CreateNull: TLicenseInfo; +begin + Result := TLicenseInfo.Create('', '', '', ''); +end; + +function TLicenseInfo.IsNull: Boolean; +begin + Result := StrIsEmpty(fName) and StrIsEmpty(fSPDX) and StrIsEmpty(fURL) + and StrIsEmpty(fText); +end; + +function TLicenseInfo.NameWithURL: string; +begin + Result := fName; + if fURL <> '' then + Result := Result + ' (' + fURL + ')'; +end; + +{ TCopyrightInfo } + +function TCopyrightInfo.Clone: TCopyrightInfo; +begin + Result.fDate := Date; + Result.fHolder := Holder; + Result.fHolderURL := HolderURL; + Result.fContributors := Contributors; +end; + +constructor TCopyrightInfo.Create(const ADate, AHolder, AHolderURL: string; + AContributors: IStringList); +begin + fDate := StandardiseStr(ADate); + fHolder := StandardiseStr(AHolder); + fHolderURL := StandardiseStr(AHolderURL); + fContributors := TIStringList.Create(AContributors); +end; + +class function TCopyrightInfo.CreateNull: TCopyrightInfo; +begin + Result := TCopyrightInfo.Create('', '', '', nil); +end; + +function TCopyrightInfo.GetContributors: IStringList; +begin + Result := TIStringList.Create(fContributors); +end; + +function TCopyrightInfo.IsNull: Boolean; +begin + Result := StrIsEmpty(fDate) and StrIsEmpty(fHolder) and StrIsEmpty(fHolderURL) + and (fContributors.Count = 0); +end; + +function TCopyrightInfo.ToString: string; +resourcestring + sCopyright = 'Copyright'; +begin + Result := ''; + if Date <> '' then + Result := Result + '(C) ' + Date; + if Holder <> '' then + begin + if Result <> '' then + Result := Result + ', '; + Result := Result + Holder; + end; + if HolderURL <> '' then + begin + if Result <> '' then + Result := Result + ', '; + Result := Result + HolderURL; + end; + if Result <> '' then + Result := sCopyright + ' ' + Result; +end; + +{ TMetaData } + +function TMetaData.Clone: TMetaData; +begin + Result.fCapabilities := Capabilities; + Result.fVersion := GetVersion; + Result.fLicenseInfo := GetLicenseInfo; + Result.fCopyrightInfo := GetCopyrightInfo; + Result.fAcknowledgements := GetAcknowledgements; +end; + +constructor TMetaData.Create(const ACapabilities: TMetaDataCaps); +begin + fCapabilities := ACapabilities; + fVersion := TVersionNumber.Nul; + fLicenseInfo := TLicenseInfo.CreateNull; + fCopyrightInfo := TCopyrightInfo.CreateNull; + fAcknowledgements := TIStringList.Create; +end; + +class function TMetaData.CreateNull: TMetaData; +begin + Result := TMetaData.Create([]); +end; + +function TMetaData.GetAcknowledgements: IStringList; +begin + if TMetaDataCap.Acknowledgements in fCapabilities then + Result := TIStringList.Create(fAcknowledgements) + else + Result := TIStringList.Create; +end; + +function TMetaData.GetCopyrightInfo: TCopyrightInfo; +begin + if TMetaDataCap.Copyright in fCapabilities then + Result := fCopyrightInfo.Clone + else + Result := TCopyrightInfo.CreateNull; +end; + +function TMetaData.GetLicenseInfo: TLicenseInfo; +begin + if TMetaDataCap.License in fCapabilities then + Result := fLicenseInfo.Clone + else + Result := TLicenseInfo.CreateNull; +end; + +function TMetaData.GetVersion: TVersionNumber; +begin + if TMetaDataCap.Version in fCapabilities then + Result := fVersion + else + Result := TVersionNumber.Nul; +end; + +end. diff --git a/Src/USnippetIDs.pas b/Src/DB.SnippetIDs.pas similarity index 66% rename from Src/USnippetIDs.pas rename to Src/DB.SnippetIDs.pas index 9d775ab89..6d0af3b96 100644 --- a/Src/USnippetIDs.pas +++ b/Src/DB.SnippetIDs.pas @@ -10,7 +10,7 @@ } -unit USnippetIDs; +unit DB.SnippetIDs; interface @@ -19,30 +19,50 @@ interface uses // Delphi Generics.Collections, + Generics.Defaults, // Project - IntfCommon; + IntfCommon, + DB.Vaults; type - /// Record that uniquely identifies a code snippet. Specifies name - /// and flag indicating whether snippet is user-defined. + /// Record that uniquely identifies a code snippet. + /// Comprises the snippet's key and vault ID. TSnippetID = record strict private var - /// Value of Name property. - fName: string; - /// Value of UserDefined property. - fUserDefined: Boolean; + /// Value of Key property. + fKey: string; + /// Value of VaultID property. + fVaultID: TVaultID; + procedure SetKey(const AValue: string); + procedure SetVaultID(const AValue: TVaultID); public - /// Name of snippet. - property Name: string read fName write fName; - - /// Whether snippet is user defined. - property UserDefined: Boolean read fUserDefined write fUserDefined; + type + TComparer = class(TInterfacedObject, + IComparer, IEqualityComparer + ) + public + function Compare(const Left, Right: TSnippetID): Integer; + function Equals(const Left, Right: TSnippetID): Boolean; + reintroduce; + function GetHashCode(const Value: TSnippetID): Integer; + reintroduce; + end; + + /// Snippet's key. + property Key: string read fKey write SetKey; + + /// ID of the vault to which a snippet with this ID belongs. + /// + /// VaultID must not be null. + property VaultID: TVaultID + read fVaultID write SetVaultID; /// Creates a record with given property values. - constructor Create(const AName: string; const AUserDefined: Boolean); + /// AVaultID must not be null. + constructor Create(const AKey: string; const AVaultID: TVaultID); /// Creates copy of given snippet ID constructor Clone(const Src: TSnippetID); @@ -53,12 +73,15 @@ TSnippetID = record /// SID or +ve if this record greater than SID. function CompareTo(const SID: TSnippetID): Integer; - /// Compares two snippet names. - /// string [in] First name. - /// string [in] Second name. - /// Integer. 0 if names are same, -ve if Left is less than Right or + /// Returns the snippet ID's hash code. + function Hash: Integer; + + /// Compares two snippet keys. + /// string [in] First key. + /// string [in] Second key. + /// Integer. 0 if keys are same, -ve if Left is less than Right or /// +ve Left is greater than Right. - class function CompareNames(const Left, Right: string): Integer; static; + class function CompareKeys(const Left, Right: string): Integer; static; /// Overload of equality operator for two TSnippetIDs. class operator Equal(const SID1, SID2: TSnippetID): Boolean; @@ -148,7 +171,7 @@ implementation uses // Delphi - SysUtils, Generics.Defaults, + SysUtils, // Project UStrUtils; @@ -157,25 +180,25 @@ implementation constructor TSnippetID.Clone(const Src: TSnippetID); begin - Create(Src.Name, Src.UserDefined); + Create(Src.Key, Src.VaultID); end; -class function TSnippetID.CompareNames(const Left, Right: string): Integer; +class function TSnippetID.CompareKeys(const Left, Right: string): Integer; begin Result := StrCompareText(Left, Right); end; function TSnippetID.CompareTo(const SID: TSnippetID): Integer; begin - Result := CompareNames(Name, SID.Name); + Result := CompareKeys(Key, SID.Key); if Result = 0 then - Result := Ord(UserDefined) - Ord(SID.UserDefined); + Result := TVaultID.Compare(VaultID, SID.VaultID); end; -constructor TSnippetID.Create(const AName: string; const AUserDefined: Boolean); +constructor TSnippetID.Create(const AKey: string; const AVaultID: TVaultID); begin - fName := AName; - fUserDefined := AUserDefined; + SetKey(AKey); + SetVaultID(AVaultID); end; class operator TSnippetID.Equal(const SID1, SID2: TSnippetID): Boolean; @@ -183,11 +206,52 @@ constructor TSnippetID.Create(const AName: string; const AUserDefined: Boolean); Result := SID1.CompareTo(SID2) = 0; end; +function TSnippetID.Hash: Integer; +var + PartialHash: Integer; + KeyBytes: TBytes; +begin + // Hash is created from hash of VaultID property combined with hash of Key + // property after converting to a byte array in UTF8 format. + PartialHash := fVaultID.Hash; + KeyBytes := TEncoding.UTF8.GetBytes(fKey); + Result := BobJenkinsHash(KeyBytes[0], Length(KeyBytes), PartialHash); +end; + class operator TSnippetID.NotEqual(const SID1, SID2: TSnippetID): Boolean; begin Result := not (SID1 = SID2); end; +procedure TSnippetID.SetKey(const AValue: string); +begin + fKey := StrTrim(AValue); + Assert(fKey <> '', 'TSnippetID.SetKey: Value is whitespace or empty'); +end; + +procedure TSnippetID.SetVaultID(const AValue: TVaultID); +begin + Assert(not AValue.IsNull, 'TSnippetID.SetVaultID: Value is null'); + fVaultID := AValue.Clone; +end; + +{ TSnippetID.TComparer } + +function TSnippetID.TComparer.Compare(const Left, Right: TSnippetID): Integer; +begin + Result := Left.CompareTo(Right); +end; + +function TSnippetID.TComparer.Equals(const Left, Right: TSnippetID): Boolean; +begin + Result := Left = Right; +end; + +function TSnippetID.TComparer.GetHashCode(const Value: TSnippetID): Integer; +begin + Result := Value.Hash; +end; + { TSnippetIDList } function TSnippetIDList.Add(const SnippetID: TSnippetID): Integer; @@ -224,14 +288,7 @@ function TSnippetIDList.Count: Integer; constructor TSnippetIDList.Create; begin inherited; - fList := TList.Create( - TDelegatedComparer.Create( - function(const Left, Right: TSnippetID): Integer - begin - Result := Left.CompareTo(Right); - end - ) - ); + fList := TList.Create(TSnippetID.TComparer.Create); end; destructor TSnippetIDList.Destroy; diff --git a/Src/DB.USnippetKind.pas b/Src/DB.SnippetKind.pas similarity index 99% rename from Src/DB.USnippetKind.pas rename to Src/DB.SnippetKind.pas index 45fbed42e..a19d4ee89 100644 --- a/Src/DB.USnippetKind.pas +++ b/Src/DB.SnippetKind.pas @@ -11,7 +11,7 @@ } -unit DB.USnippetKind; +unit DB.SnippetKind; interface diff --git a/Src/DB.USnippet.pas b/Src/DB.Snippets.pas similarity index 63% rename from Src/DB.USnippet.pas rename to Src/DB.Snippets.pas index 5af498162..ba999a0d6 100644 --- a/Src/DB.USnippet.pas +++ b/Src/DB.Snippets.pas @@ -10,7 +10,7 @@ } -unit DB.USnippet; +unit DB.Snippets; interface @@ -18,10 +18,17 @@ interface uses // Delphi - Classes, Generics.Collections, Generics.Defaults, + Classes, + Generics.Collections, + Generics.Defaults, // Project - ActiveText.UMain, Compilers.UGlobals, DB.USnippetKind, UContainers, - UIStringList, USnippetIDs; + ActiveText.UMain, + Compilers.UGlobals, + DB.SnippetIDs, + DB.SnippetKind, + DB.Vaults, + UContainers, + UIStringList; type /// Enumeration providing information about the level to which a @@ -29,7 +36,9 @@ interface TSnippetTestInfo = ( stiNone, // snippet has not been tested stiBasic, // snippet has had some basic testing - stiAdvanced // snippet has had advanced (unit) testing + stiAdvanced, // snippet has had unspecified advanced testing + stiUnitTests, // snippet has unit tests + stiDemoCode // snippet has a demo program ); type @@ -100,26 +109,37 @@ TSnippetList = class; TSnippet = class(TObject) public /// Comparer for snippets by display name. - type TDisplayNameComparer = class(TComparer) - public - /// Compares snippets Left and Right. Returns -ve if Left's - /// display name sorts before Right's, 0 if the same or +ve if Left's - /// display name is greater than Right's. - function Compare(const Left, Right: TSnippet): Integer; override; - end; + type + TComparer = class(TInterfacedObject, + IComparer, IEqualityComparer + ) + public + function Compare(const Left, Right: TSnippet): Integer; + function Equals(const Left, Right: TSnippet): Boolean; + reintroduce; + function GetHashCode(const Value: TSnippet): Integer; + reintroduce; + end; + TDisplayNameComparer = class(TComparer) + public + /// Compares snippets Left and Right. Returns -ve if Left's + /// display name sorts before Right's, 0 if the same or +ve if Left's + /// display name is greater than Right's. + function Compare(const Left, Right: TSnippet): Integer; override; + end; strict private fKind: TSnippetKind; // Kind of snippet this is fCategory: string; // Name of snippet's category fDescription: IActiveText; // Description of snippet - fSourceCode: string; // Snippet's source code - fName: string; // Name of snippet + fSourceCode: string; // Snippet source code + fKey: string; // Snippet key: unique in vault fDisplayName: string; // Display name of snippet fUnits: TStringList; // List of required units fDepends: TSnippetList; // List of required snippets fXRef: TSnippetList; // List of cross-referenced snippets fExtra: IActiveText; // Further information for snippet fCompatibility: TCompileResults; // Snippet's compiler compatibility - fUserDefined: Boolean; // If this snippet is user-defined + fVaultID: TVaultID; // Snippet's vault ID fHiliteSource: Boolean; // If source is syntax highlighted fTestInfo: TSnippetTestInfo; // Level of testing of snippet function GetID: TSnippetID; @@ -130,10 +150,10 @@ type TDisplayNameComparer = class(TComparer) {Gets snippet's display name, or name if no display name is set @return Required display name. } - strict protected - procedure SetName(const Name: string); - {Sets Name property. - @param Name [in] New name. + strict private + procedure SetKey(const AKey: string); + {Sets Key property. + @param AKey [in] New key. } procedure SetProps(const Data: TSnippetData); {Sets snippet's properties. @@ -144,32 +164,82 @@ type TDisplayNameComparer = class(TComparer) @return Required field content. } public - constructor Create(const Name: string; const UserDefined: Boolean; + + /// Object constructor. Sets up snippet object with given property + /// values belonging to a specified vault. + /// string [in] Snippet's key. + /// TVaultID [in] ID of vault to which the + /// snippet belongs. Must not be null. + /// TSnippetData [in] Values of snippet + /// properties. + constructor Create(const AKey: string; const AVaultID: TVaultID; const Props: TSnippetData); - {Class contructor. Sets up snippet object with given property values. - @param Name [in] Name of snippet. - @param UserDefined [in] Indicates if this is a user defined snippet. - @param Props [in] Values of various snippet properties. - } + destructor Destroy; override; {Destructor. Tears down object. } + /// Compares this snippet with another. + /// TSnippet [in] Snippet to compare with. + /// + /// Integer. 0 if the snippets are the same, -ve if + /// this snippet is less than Snippets or +ve if this snippet is + /// greater than Snippet. + function CompareTo(const Snippet: TSnippet): Integer; + + /// Checks if this snippet is same as another snippet. Snippets + /// are considered equal if they have the same key and vault ID. + /// TSnippet [in] Snippet being compared. + /// + /// Boolean.True if snippets are equal, False if not. + /// function IsEqual(const Snippet: TSnippet): Boolean; - {Checks if this snippet is same as another snippet. Snippets are - considered equal if they have the same name and come from same database. - @param Snippet [in] Snippet being compared. - @return True if snippets are equal, False if not. - } function CanCompile: Boolean; {Checks if snippet can be compiled. @return True if compilation supported and False if not. } + + /// Returns the snippets hash code. + function Hash: Integer; + + /// Updates the snippet's properties and references. + /// TSnippetEditData [in] Snippet's new property + /// values and references. + /// TSnippetList [in] List of all snippets + /// in the database (for use in validation the new snippet references). + /// + procedure Update(const Data: TSnippetEditData; + const AllSnippets: TSnippetList); + + /// Updates the snippet's references. + /// TSnippetReferences [in] Records all the snippet's + /// references (i.e. XRef, Depends and Units). + /// TSnippetList [in] List of all snippets + /// in the database (used to ensure all references to other snippets are + /// valid). + procedure UpdateRefs(const Refs: TSnippetReferences; + const AllSnippets: TSnippetList); + + /// Get all of a snippet's editable data. + /// TSnippetEditData. The snippet's editable properties and + /// references. + function GetEditData: TSnippetEditData; + + /// Gets all of a snippet's editable properties. + /// TSnippetData. Record containing the required property + /// values. + function GetProps: TSnippetData; + + /// Gets all of a snippet's editable references. + /// TSnippetReferences. Record containing the required + /// references. + function GetReferences: TSnippetReferences; + property Kind: TSnippetKind read fKind; {Kind of snippet represented by this object} property ID: TSnippetID read GetID; {Snippet's unique ID} - property Name: string read fName; - {Name of snippet} + property Key: string read fKey; + {Snippet key} property DisplayName: string read GetDisplayName; {Displat name of snippet} property Category: string read fCategory; @@ -192,52 +262,10 @@ type TDisplayNameComparer = class(TComparer) {List of any other snippet in database on which this snippet depends} property XRef: TSnippetList read fXRef; {List of cross referenced snippets in database} - property UserDefined: Boolean read fUserDefined; - {Flag that indicates if this is a user defined snippet} - end; - - { - TSnippetEx: - Extension of TSnippet for use internally by Snippets object. - } - TSnippetEx = class(TSnippet) - public - procedure UpdateRefs(const Refs: TSnippetReferences; - const AllSnippets: TSnippetList); - {Updates a snippet's references. - @param Refs [in] Stores all snippet's references (XRef, Depends and - Units). - @param AllSnippets [in] List of all snippets in database. - } - procedure Update(const Data: TSnippetEditData; - const AllSnippets: TSnippetList); - {Updates snippet's properties and references. - @param Data [in] New property values and references. - @param AllSnippets [in] List of all snippets in database. - } - function GetEditData: TSnippetEditData; - {Gets details of all editable data of snippet. - @return Required editable properties and references. - } - function GetProps: TSnippetData; - {Gets details of snippet's properties. - @return Record containing property values. - } - function GetReferences: TSnippetReferences; - {Gets details of snippet's references. - @return Information sufficient to define references. - } + /// ID of vault to which the snippet belongs. + property VaultID: TVaultID read fVaultID; end; - { - TTempSnippet: - Special subclass of TSnippetEx that can't be added to the Snippets object. - Class does nothing, simply provides a class name for testing when a snippet - is added to a TSnippetListEx. TTempSnippet can be added to a normal snippet - list. - } - TTempSnippet = class(TSnippetEx); - { TSnippetList: Class that implements a list of TSnippet objects. @@ -249,16 +277,19 @@ TSnippetList = class(TObject) @param Idx [in] Index of required snippet in list. @return Snippet at specified index in list. } - function Find(const SnippetName: string; - const UserDefined: Boolean; out Index: Integer): Boolean; overload; - {Finds a snippet in the list that has a specified name and user defined - property. Uses a binary search. - @param SnippetName [in] Name of snippet to be found. - @param UserDefined [in] Whether required snippet is user defined or not. - @param Index [out] Index of required snippet in list. Valid only if - method returns True. - @return True if snippet found, False if not. - } + + /// Finds a snippet in the list with whose key and vault ID match. + /// + /// string [in] Snippet's key. + /// TVaultID [in] ID of vault to which the + /// snippet belongs. + /// Integer. [out] Set to the index of the + /// required snippet in the list. Valid only if the snippet was found. + /// + /// Boolean. True if snippet found, False if not. + function Find(const SnippetKey: string; const AVaultID: TVaultID; + out Index: Integer): Boolean; overload; + strict protected var fList: TSortedObjectList; // Sorted list of snippets public @@ -286,19 +317,27 @@ TSnippetList = class(TObject) @return Index where item was inserted in list @except Raised if duplicate snippet added to list. } + procedure Delete(const Snippet: TSnippet); + {Deletes a snippet from list. + @param Snippet [in] Snippet to be deleted. No action taken if snippet + not in list. + } function Find(const SnippetID: TSnippetID): TSnippet; overload; {Finds a specified snippet in list. @param SnippetID [in] ID of snippet to find. @return Reference to required snippet or nil if not found. } - function Find(const SnippetName: string; - const UserDefined: Boolean): TSnippet; overload; - {Finds a named snippet in list with a matching user defined property. - @param SnippetName [in] Name of required snippet. - @param UserDefined [in] Flag that determines if we are looking for a - user defined snippet or one from main database. - @return Reference to required snippet or nil if not found. - } + + /// Finds a snippet in the list with whose key and vault ID match. + /// + /// string [in] Snippet's key. + /// TVaultID [in] ID of vault to which the + /// snippet belongs. + /// TSnippet. Reference to the required snippet or nil if + /// not found. + function Find(const SnippetKey: string; const AVaultID: TVaultID): TSnippet; + overload; + function Contains(const Snippet: TSnippet): Boolean; {Checks whether list contains a specified snippet. @param Snippet [in] Required snippet. @@ -317,13 +356,18 @@ TSnippetList = class(TObject) {Gets an intialised snippet list enumerator. @return Required enumerator. } - function Count(const UserDefined: Boolean): Integer; overload; - {Counts number of snippets in list that are either from or not from user - defined database. - @param UserDefined [in] Flags whether to count snippets in user database - (True) or in main database (False). - @return Number of snippets in specified database. - } + + /// Returns a list the IDs of all snippets in this list. + /// ISnippetIDList. Required list of snippet IDs. + function IDs: ISnippetIDList; + + /// Counts number of snippets in list that belong to a specified + /// vault. + /// TVaultID [in] ID of required vault. + /// + /// Integer Number of snippets in the vault. + function Count(const AVaultID: TVaultID): Integer; overload; + function Count: Integer; overload; {Counts number of snippets in list. @return Number of snippets in list. @@ -332,48 +376,16 @@ TSnippetList = class(TObject) {Checks if list is empty. @return True if list is empty, False otehrwise. } - function IsEmpty(const UserDefined: Boolean): Boolean; overload; inline; - {Checks if sub-set of list from either from or not from use defined - database is empty. - @param UserDefined [in] Flags whether to check for snippets in user - database (True) or in main database (False). - @return True if required subset is empty, False if not empty. - } - property Items[Idx: Integer]: TSnippet read GetItem; default; - {List of snippets} - end; - { - TSnippetListEx: - Private extension of TSnippetList for use internally by Snippets object. - } - TSnippetListEx = class(TSnippetList) - public - function Add(const Snippet: TSnippet): Integer; override; - {Adds a snippet to list. Snippet must not be TTempSnippet class. - @param Snippet [in] Snippet to be added. - @return Index where snippet was added to list. - } - procedure Delete(const Snippet: TSnippet); - {Deletes a snippet from list. - @param Snippet [in] Snippet to be deleted. No action taken if snippet - not in list. - } - end; + /// Checks if the sub-set of snippets in the list belonging to a + /// specified vault is empty. + /// TVaultID [in] ID of vault. + /// Boolean True if the subset is empty, False otherwise. + /// + function IsEmpty(const AVaultID: TVaultID): Boolean; overload; - { - TSnippetIDListEx: - Extension of TSnippetIDList that provides an additional constructor that can - create a snippet ID list from a TSnippetList. - } - TSnippetIDListEx = class(TSnippetIDList) - public - constructor Create(const SnipList: TSnippetList); overload; - {Constructor overload that creates a snippets ID list from a - TSnippetList object. - @param SnipList [in] List of snippets objects for which ID list is - required. - } + property Items[Idx: Integer]: TSnippet read GetItem; default; + {List of snippets} end; implementation @@ -394,27 +406,27 @@ function TSnippet.CanCompile: Boolean; Result := Kind <> skFreeform; end; -constructor TSnippet.Create(const Name: string; const UserDefined: Boolean; +function TSnippet.CompareTo(const Snippet: TSnippet): Integer; +begin + Result := Self.ID.CompareTo(Snippet.ID); +end; + +constructor TSnippet.Create(const AKey: string; const AVaultID: TVaultID; const Props: TSnippetData); - {Class contructor. Sets up snippet object with given property values. - @param Name [in] Name of snippet. - @param UserDefined [in] Indicates if this is a user defined snippet. - @param Props [in] Values of various snippet properties. - } begin - Assert(ClassType <> TSnippet, - ClassName + '.Create: must only be called from descendants.'); + Assert(not AVaultID.IsNull, + ClassName + '.Create: AVaultID is null'); inherited Create; // Record simple property values - SetName(Name); + SetKey(AKey); SetProps(Props); // Create string list to store required units fUnits := TStringList.Create; // Create snippets lists for Depends and XRef properties - fDepends := TSnippetListEx.Create; - fXRef := TSnippetListEx.Create; - // The following properties added to support user defined snippets - fUserDefined := UserDefined; + fDepends := TSnippetList.Create; + fXRef := TSnippetList.Create; + // The following property added to support multiple snippet vaults + fVaultID := AVaultID.Clone; end; destructor TSnippet.Destroy; @@ -434,7 +446,7 @@ function TSnippet.GetDisplayName: string; if GetDisplayNameValue <> '' then Result := GetDisplayNameValue else - Result := fName; + Result := fKey; end; function TSnippet.GetDisplayNameValue: string; @@ -442,30 +454,55 @@ function TSnippet.GetDisplayNameValue: string; Result := fDisplayName; end; +function TSnippet.GetEditData: TSnippetEditData; +begin + Result.Props := GetProps; + Result.Refs := GetReferences; +end; + function TSnippet.GetID: TSnippetID; {Gets snippet's unique ID. @return Required ID. } begin - Result := TSnippetID.Create(fName, fUserDefined); + Result := TSnippetID.Create(fKey, fVaultID); +end; + +function TSnippet.GetProps: TSnippetData; +begin + Result.Cat := Category; + Result.Kind := Kind; + Result.Desc := Description; + Result.SourceCode := SourceCode; + Result.HiliteSource := HiliteSource; + Result.DisplayName := GetDisplayNameValue; + Result.Extra := TActiveTextFactory.CloneActiveText(Extra); + Result.CompilerResults := Compatibility; + Result.TestInfo := TestInfo; +end; + +function TSnippet.GetReferences: TSnippetReferences; +begin + Result.Units := TIStringList.Create(Units); + Result.Depends := Depends.IDs; + Result.XRef := XRef.IDs; +end; + +function TSnippet.Hash: Integer; +begin + // Snippet's hash code is the same as the snippet ID's hash code + Result := GetID.Hash; end; function TSnippet.IsEqual(const Snippet: TSnippet): Boolean; - {Checks if this snippet is same as another snippet. Snippets are considered - equal if they have the same name and come from same database. - @param Snippet [in] Snippet being compared. - @return True if snippets are equal, False if not. - } begin - Result := Snippet.ID = Self.ID; + Result := CompareTo(Snippet) = 0; end; -procedure TSnippet.SetName(const Name: string); - {Sets Name property. - @param Name [in] New name. - } +procedure TSnippet.SetKey(const AKey: string); begin - fName := Name; + fKey := StrTrim(AKey); + Assert(fKey <> '', ClassName + '.SetKey: AKey is whitespace or empty'); end; procedure TSnippet.SetProps(const Data: TSnippetData); @@ -484,82 +521,21 @@ procedure TSnippet.SetProps(const Data: TSnippetData); fTestInfo := Data.TestInfo; end; -{ TSnippet.TDisplayNameComparer } - -function TSnippet.TDisplayNameComparer.Compare(const Left, - Right: TSnippet): Integer; -begin - Result := StrCompareText(Left.DisplayName, Right.DisplayName); - if Result = 0 then - Result := Left.ID.CompareTo(Right.ID); -end; - -{ TSnippetEx } - -function TSnippetEx.GetEditData: TSnippetEditData; - {Gets details of all editable data of snippet. - @return Required editable properties and references. - } -begin - Result.Props := GetProps; - Result.Refs := GetReferences; -end; - -function TSnippetEx.GetProps: TSnippetData; - {Gets details of snippet's properties. - @return Record containing property values. - } -begin - Result.Cat := Category; - Result.Kind := Kind; - Result.Desc := Description; - Result.SourceCode := SourceCode; - Result.HiliteSource := HiliteSource; - Result.DisplayName := GetDisplayNameValue; - Result.Extra := TActiveTextFactory.CloneActiveText(Extra); - Result.CompilerResults := Compatibility; - Result.TestInfo := TestInfo; -end; - -function TSnippetEx.GetReferences: TSnippetReferences; - {Gets details of snippet's references. - @return Information sufficient to define references. - } -begin - Result.Units := TIStringList.Create(Units); - Result.Depends := TSnippetIDListEx.Create(Depends); - Result.XRef := TSnippetIDListEx.Create(XRef); -end; - -procedure TSnippetEx.Update(const Data: TSnippetEditData; +procedure TSnippet.Update(const Data: TSnippetEditData; const AllSnippets: TSnippetList); - {Updates snippet's properties and references. - @param Data [in] New property values and references. - @param AllSnippets [in] List of all snippets in database. - } begin SetProps(Data.Props); UpdateRefs(Data.Refs, AllSnippets); end; -procedure TSnippetEx.UpdateRefs(const Refs: TSnippetReferences; +procedure TSnippet.UpdateRefs(const Refs: TSnippetReferences; const AllSnippets: TSnippetList); - {Updates a snippet's references. - @param Refs [in] Stores all snippet's references (XRef, Depends and - Units). - @param AllSnippets [in] List of all snippets in database. - } - // --------------------------------------------------------------------------- + // Builds a list of snippets, SL, corresponding to the snippets IDs in IDList. + // Any snippet IDs for which there is no match snippet in the database is + // ignored. procedure BuildSnippetList(const SL: TSnippetList; const IDList: ISnippetIDList); - {Creates a snippets list from a snippets ID list. Looks up snippets in list - of all snippets in database. Any snippets in ID list that do not exist in - database are ignored. - @param SL [in] Snippets list object to be updated. - @param IDList [in] Snippets ID list that provides information used to - create snippets list. - } var ID: TSnippetID; // refers to each ID in ID list Snippet: TSnippet; // references each snippet identified by ID @@ -572,7 +548,6 @@ procedure TSnippetEx.UpdateRefs(const Refs: TSnippetReferences; SL.Add(Snippet); end; end; - // --------------------------------------------------------------------------- begin Refs.Units.CopyTo(Self.Units, True); // copy units @@ -580,6 +555,33 @@ procedure TSnippetEx.UpdateRefs(const Refs: TSnippetReferences; BuildSnippetList(Self.XRef, Refs.XRef); // build XRef list end; +{ TSnippet.TComparer } + +function TSnippet.TComparer.Compare(const Left, Right: TSnippet): Integer; +begin + Result := Left.CompareTo(Right); +end; + +function TSnippet.TComparer.Equals(const Left, Right: TSnippet): Boolean; +begin + Result := Left.IsEqual(Right); +end; + +function TSnippet.TComparer.GetHashCode(const Value: TSnippet): Integer; +begin + Result := Value.Hash; +end; + +{ TSnippet.TDisplayNameComparer } + +function TSnippet.TDisplayNameComparer.Compare(const Left, + Right: TSnippet): Integer; +begin + Result := StrCompareText(Left.DisplayName, Right.DisplayName); + if Result = 0 then + Result := Left.ID.CompareTo(Right.ID); +end; + { TSnippetList } function TSnippetList.Add(const Snippet: TSnippet): Integer; @@ -644,19 +646,13 @@ function TSnippetList.ContainsKinds(const Kinds: TSnippetKinds): Boolean; end; end; -function TSnippetList.Count(const UserDefined: Boolean): Integer; - {Counts number of snippets in list that are either from or not from user - defined database. - @param UserDefined [in] Flags whether to count snippets in user database - (True) or in main database (False). - @return Number of snippets in specified database. - } +function TSnippetList.Count(const AVaultID: TVaultID): Integer; var Snippet: TSnippet; // refers to all snippets in list begin Result := 0; for Snippet in Self do - if Snippet.UserDefined = UserDefined then + if Snippet.VaultID = AVaultID then Inc(Result); end; @@ -676,17 +672,21 @@ constructor TSnippetList.Create(const OwnsObjects: Boolean = False); begin inherited Create; fList := TSortedObjectList.Create( - TDelegatedComparer.Create( - function (const Left, Right: TSnippet): Integer - begin - Result := Left.ID.CompareTo(Right.ID); - end - ), - OwnsObjects + TSnippet.TComparer.Create, OwnsObjects ); fList.PermitDuplicates := False; end; +procedure TSnippetList.Delete(const Snippet: TSnippet); +var + Idx: Integer; // index of snippet in list. +begin + Idx := fList.IndexOf(Snippet); + if Idx = -1 then + Exit; + fList.Delete(Idx); // this frees snippet if list owns objects +end; + destructor TSnippetList.Destroy; {Destructor. Tears down object. } @@ -695,24 +695,16 @@ destructor TSnippetList.Destroy; inherited; end; -function TSnippetList.Find(const SnippetName: string; - const UserDefined: Boolean; out Index: Integer): Boolean; - {Finds a snippet in the list that has a specified name and user defined - property. Uses a binary search. - @param SnippetName [in] Name of snippet to be found. - @param UserDefined [in] Whether required snippet is user defined or not. - @param Index [out] Index of required snippet in list. Valid only if - method returns True. - @return True if snippet found, False if not. - } +function TSnippetList.Find(const SnippetKey: string; const AVaultID: TVaultID; + out Index: Integer): Boolean; var TempSnippet: TSnippet; // temp snippet used to perform search - NulData: TSnippetData; // nul data used to create snippet + NullData: TSnippetData; // nul data used to create snippet begin // We need a temporary snippet object in order to perform binary search using // object list's built in search - NulData.Init; - TempSnippet := TTempSnippet.Create(SnippetName, UserDefined, NulData); + NullData.Init; + TempSnippet := TSnippet.Create(SnippetKey, AVaultID, NullData); try Result := fList.Find(TempSnippet, Index); finally @@ -720,18 +712,12 @@ function TSnippetList.Find(const SnippetName: string; end; end; -function TSnippetList.Find(const SnippetName: string; - const UserDefined: Boolean): TSnippet; - {Finds a named snippet in list with a matching user defined property. - @param SnippetName [in] Name of required snippet. - @param UserDefined [in] Flag that determines if we are looking for a - user defined snippet or one from main database. - @return Reference to required snippet or nil if not found. - } +function TSnippetList.Find(const SnippetKey: string; const AVaultID: TVaultID): + TSnippet; var - Idx: Integer; // index of snippet name in list + Idx: Integer; // index of snippet key in list begin - if Find(SnippetName, UserDefined, Idx) then + if Find(SnippetKey, AVaultID, Idx) then Result := Items[Idx] else Result := nil; @@ -743,7 +729,7 @@ function TSnippetList.Find(const SnippetID: TSnippetID): TSnippet; @return Reference to required snippet or nil if not found. } begin - Result := Find(SnippetID.Name, SnippetID.UserDefined); + Result := Find(SnippetID.Key, SnippetID.VaultID); end; function TSnippetList.GetEnumerator: TEnumerator; @@ -771,9 +757,18 @@ function TSnippetList.IsEmpty: Boolean; Result := Count = 0; end; -function TSnippetList.IsEmpty(const UserDefined: Boolean): Boolean; +function TSnippetList.IDs: ISnippetIDList; +var + Snippet: TSnippet; begin - Result := Count(UserDefined) = 0; + Result := TSnippetIDList.Create; + for Snippet in fList do + Result.Add(Snippet.ID); +end; + +function TSnippetList.IsEmpty(const AVaultID: TVaultID): Boolean; +begin + Result := Count(AVaultID) = 0; end; function TSnippetList.IsEqual(const AList: TSnippetList): Boolean; @@ -788,7 +783,7 @@ function TSnippetList.IsEqual(const AList: TSnippetList): Boolean; Result := Assigned(AList) and (Self.Count = AList.Count); if Result then begin - // Same number of snippets: scan list checking snippet names same. We can + // Same number of snippets: scan list checking snippet keys are same. We can // rely on items being in same order since lists are sorted for Idx := 0 to Pred(Self.Count) do begin @@ -801,33 +796,6 @@ function TSnippetList.IsEqual(const AList: TSnippetList): Boolean; end; end; -{ TSnippetListEx } - -function TSnippetListEx.Add(const Snippet: TSnippet): Integer; - {Adds a snippet to list. Snippet must not be TTempSnippet class. - @param Snippet [in] Snippet to be added. - @return Index where snippet was added to list. - } -begin - Assert(not(Snippet is TTempSnippet), - ClassName + '.Add: Can''t add temporary snippets to database'); - Result := inherited Add(Snippet); -end; - -procedure TSnippetListEx.Delete(const Snippet: TSnippet); - {Deletes a snippet from list. - @param Snippet [in] Snippet to be deleted. No action taken if snippet not in - list. - } -var - Idx: Integer; // index of snippet in list. -begin - Idx := fList.IndexOf(Snippet); - if Idx = -1 then - Exit; - fList.Delete(Idx); // this frees snippet if list owns objects -end; - { TSnippetData } procedure TSnippetData.Assign(const Src: TSnippetData); @@ -907,20 +875,4 @@ procedure TSnippetEditData.Init; Refs.Init; end; -{ TSnippetIDListEx } - -constructor TSnippetIDListEx.Create(const SnipList: TSnippetList); - {Constructor overload that creates a snippets ID list from a TSnippetList - object. - @param SnipList [in] List of snippets objects for which ID list is - required. - } -var - Snippet: TSnippet; // references each snippet in list -begin - inherited Create; - for Snippet in SnipList do - Add(Snippet.ID); -end; - end. diff --git a/Src/DB.UDatabaseIO.pas b/Src/DB.UDatabaseIO.pas deleted file mode 100644 index 4fe633fbb..000000000 --- a/Src/DB.UDatabaseIO.pas +++ /dev/null @@ -1,708 +0,0 @@ -{ - * This Source Code Form is subject to the terms of the Mozilla Public License, - * v. 2.0. If a copy of the MPL was not distributed with this file, You can - * obtain one at https://mozilla.org/MPL/2.0/ - * - * Copyright (C) 2008-2021, Peter Johnson (gravatar.com/delphidabbler). - * - * Implements objects that can load data into the Database object from both the - * user and main databases. Also provides a class that can write the user - * database to storage. - * - * Uses file I/O interface implementations to read / write the physical files. -} - - -unit DB.UDatabaseIO; - - -interface - - -uses - // Project - DB.UCategory, DB.UMain, DB.USnippet, UBaseObjects, UExceptions; - - -type - - { - IDatabaseLoader: - Interface to object that can load data into the Database object from - storage. - } - IDatabaseLoader = interface(IInterface) - ['{C6AF94FC-F56F-44AE-9E79-3B0CD0BB21D4}'] - procedure Load(const SnipList: TSnippetList; - const Categories: TCategoryList; - const DBDataItemFactory: IDBDataItemFactory); - {Loads data from storage and updates database object. - @param SnipList [in] Receives information about each snippet in the - database. - @param Categories [in] Receives information about each category in the - database. - @param DBDataItemFactory [in] Object used to create new categories and - snippets. - } - end; - - { - IDatabaseWriter: - Interface to object that can write data from the user-defined component of - the Database object to storage. - } - IDatabaseWriter = interface(IInterface) - ['{F46EE2E3-68A7-4877-9E04-192D15D29BB1}'] - procedure Write(const SnipList: TSnippetList; - const Categories: TCategoryList; const Provider: IDBDataProvider); - {Writes data from Database object to storage. - @param SnipList [in] Contains information about each snippet in the - database. - @param Categories [in] Contains information about each category in the - database. - @param Privider [in] Object used to obtain details of the data to be - written to the Database object - } - end; - - { - TDatabaseIOFactory: - Factory class that can create instances of writer and loader objects for the - Database object. - } - TDatabaseIOFactory = class(TNoConstructObject) - public - class function CreateMainDBLoader: IDatabaseLoader; - {Creates an object to use to load the main database. - @return Required object instance. - } - class function CreateUserDBLoader: IDatabaseLoader; - {Creates an object to use to load the user database. - @return Required object instance. - } - class function CreateWriter: IDatabaseWriter; - {Create an object that can write user defined data from the Database - object to storage. - @return Required object instance. - } - end; - - { - EDatabaseLoader: - Class of exception raised by database loader objects. - } - EDatabaseLoader = class(ECodeSnip); - - -implementation - - -uses - // Delphi - SysUtils, - // Project - DBIO.UFileIOIntf, DBIO.UIniDataReader, DBIO.UNulDataReader, DBIO.UXMLDataIO, - UAppInfo, UConsts, UIStringList, UReservedCategories, USnippetIDs; - - -type - - { - TDatabaseLoaderClass: - Class reference to TDatabaseLoader descendants. - } - TDatabaseLoaderClass = class of TDatabaseLoader; - - { - TDatabaseLoader: - Abstract base class for objects that can load data into the Database object - from storage. - } - TDatabaseLoader = class(TInterfacedObject, IDatabaseLoader) - strict private - fReader: IDataReader; // Object used to read data from storage - fSnipList: TSnippetList; // Receives list of snippets - fCategories: TCategoryList; // Receives list of categories - fFactory: IDBDataItemFactory; // Object creates new categories and snippets - procedure LoadSnippets(const Cat: TCategory); - {Loads all snippets in a category. - @param Cat [in] Category to be loaded. - } - procedure LoadReferences(const Snippet: TSnippet); - {Loads all of a snippet's references. - @param Snippet [in] Snippet for which references are required. - } - procedure HandleException(const E: Exception); - {Handles exceptions generated by loader and converts ECodeSnip and - descendant exceptions into EDatabaseLoader exceptions. - @param E [in] Exception to be handled. - @except Exception always raised. - } - strict protected - function CreateReader: IDataReader; virtual; abstract; - {Creates reader object for the database. If database doesn't exist a nul - reader must be created. - @return Reader object instance. - } - function FindSnippet(const SnippetName: string; - const SnipList: TSnippetList): TSnippet; virtual; abstract; - {Finds the snippet object with a specified name. - @param SnippetName [in] Name of required snippet. - @param SnipList [in] List of snippets to search. - @return Reference to required snippet object or nil if snippet is not - found. - } - function IsNativeSnippet(const Snippet: TSnippet): Boolean; - virtual; abstract; - {Checks if a snippet is native (belongs) to the database being read. - @param Snippet [in] Snippet to test. - @return True if snippet is native, False if not. - } - function IsUserDatabase: Boolean; virtual; abstract; - {Checks if the database is the user database. - @return True if the database is the user database, False if not. - } - function ErrorMessageHeading: string; virtual; abstract; - {Returns heading to use in error messages. Should identify the database. - @return Required heading. - } - procedure LoadCategories; virtual; - {Loads all categories from storage. - } - procedure CreateCategory(const CatID: string; - const CatData: TCategoryData); - {Creates a new category and adds it to the categories list. - @param CatID [in] ID of category. - @param CatData [in] Properties of category. - } - property Categories: TCategoryList read fCategories; - {Reference to category list} - public - { IDatabaseLoader method } - procedure Load(const SnipList: TSnippetList; - const Categories: TCategoryList; - const DBDataItemFactory: IDBDataItemFactory); - {Loads data from storage and updates database object. - @param SnipList [in] Receives information about each snippet in the - database. - @param Categories [in] Receives information about each category in the - database. - @param DBDataItemFactory [in] Object used to create new categories and - snippets. - } - end; - - { - TMainDatabaseLoader: - Class that updates Database object with data read from main database. - } - TMainDatabaseLoader = class(TDatabaseLoader, IDatabaseLoader) - strict protected - function CreateReader: IDataReader; override; - {Creates reader object. If main database doesn't exist a nul reader is - created. - @return Reader object instance. - } - function FindSnippet(const SnippetName: string; - const SnipList: TSnippetList): TSnippet; override; - {Finds the snippet object with a specified name in the main database. - @param SnippetName [in] Name of required snippet. - @param SnipList [in] List of snippets to search. - @return Reference to required snippet object or nil if snippet is not - found. - } - function IsNativeSnippet(const Snippet: TSnippet): Boolean; override; - {Checks if a snippet is native (belongs) to the main database. - @param Snippet [in] Snippet to test. - @return True if snippet is native, False if not. - } - function IsUserDatabase: Boolean; override; - {Checks if the database is the user database. - @return False - this is not the user database. - } - function ErrorMessageHeading: string; override; - {Returns heading to use in error messages. Identifies main database. - @return Required heading. - } - end; - - { - TUserDatabaseLoader: - Class that updates Database object with data read from user database. - } - TUserDatabaseLoader = class(TDatabaseLoader, IDatabaseLoader) - strict protected - function CreateReader: IDataReader; override; - {Creates reader object. If user database doesn't exist a nul reader is - created. - @return Reader object instance. - } - function FindSnippet(const SnippetName: string; - const SnipList: TSnippetList): TSnippet; override; - {Finds the snippet object with a specified name. If snippet is not in this - (user) database the main database is searched. - @param SnippetName [in] Name of required snippet. - @param SnipList [in] List of snippets to search. - @return Reference to required snippet object or nil if snippet is not - found. - } - function IsNativeSnippet(const Snippet: TSnippet): Boolean; override; - {Checks if a snippet is native (belongs) to the user database. - @param Snippet [in] Snippet to test. - @return True if snippet is native, False if not. - } - function IsUserDatabase: Boolean; override; - {Checks if the database is the user database. - @return True - this is the user database. - } - function ErrorMessageHeading: string; override; - {Returns heading to use in error messages. Identifies main database. - @return Required heading. - } - procedure LoadCategories; override; - {Loads all categories from storage and adds user category if not present. - } - end; - - { - TDatabaseWriter: - Object used to write data from user database to storage. - } - TDatabaseWriter = class(TInterfacedObject, - IDatabaseWriter - ) - strict private - fWriter: IDataWriter; // Object used to write to storage - fSnipList: TSnippetList; // List of snippets to be written - fCategories: TCategoryList; // List of categories to be written - fProvider: IDBDataProvider; // Object used to get data to be written - function CreateWriter: IDataWriter; - {Creates object that can write data for user-defined database to storage. - @return Requied writer object. - } - procedure WriteCategories; - {Writes information about categories to storage. - } - procedure WriteSnippets; - {Writes information about all snippets to storage. - } - public - { IDatabaseWriter method } - procedure Write(const SnipList: TSnippetList; - const Categories: TCategoryList; - const Provider: IDBDataProvider); - {Writes data from Database object to storage. - @param SnipList [in] Contains information about each snippet in the - database. - @param Categories [in] Contains information about each category in the - database. - @param Provider [in] Object used to obtain details of the data to be - written from the Database object - } - end; - -{ TDatabaseIOFactory } - -class function TDatabaseIOFactory.CreateMainDBLoader: IDatabaseLoader; - {Creates an object to use to load the main database. - @return Required object instance. - } -begin - Result := TMainDatabaseLoader.Create; -end; - -class function TDatabaseIOFactory.CreateUserDBLoader: IDatabaseLoader; - {Creates an object to use to load the user database. - @return Required object instance. - } -begin - Result := TUserDatabaseLoader.Create; -end; - -class function TDatabaseIOFactory.CreateWriter: IDatabaseWriter; - {Create an object that can write user defined data from the Database object to - storage. - @return Required object instance. - } -begin - Result := TDatabaseWriter.Create; -end; - -{ TDatabaseLoader } - -procedure TDatabaseLoader.CreateCategory(const CatID: string; - const CatData: TCategoryData); - {Creates a new category and adds it to the categories list. - @param CatID [in] ID of category. - @param CatData [in] Properties of category. - } -begin - fCategories.Add(fFactory.CreateCategory(CatID, IsUserDatabase, CatData)); -end; - -procedure TDatabaseLoader.HandleException(const E: Exception); - {Handles exceptions generated by loader and converts ECodeSnip and descendant - exceptions into EDatabaseLoader exceptions. - @param E [in] Exception to be handled. - @except Exception always raised. - } -begin - if E is ECodeSnip then - // add message header identifying database to existing message - raise EDatabaseLoader.Create(ErrorMessageHeading + EOL2 + E.Message) - else - raise E; -end; - -procedure TDatabaseLoader.Load(const SnipList: TSnippetList; - const Categories: TCategoryList; const DBDataItemFactory: IDBDataItemFactory); - {Loads data from storage and updates database object. - @param SnipList [in] Receives information about each snippet in the - database. - @param Categories [in] Receives information about each category in the - database. - @param DBDataItemFactory [in] Object used to create new categories and - snippets. - } -var - Category: TCategory; // a category - Snippet: TSnippet; // a snippet -begin - // Create reader object that can access data storage - fReader := CreateReader; - // Record snippets and categories list in fields - // Do not clear snippet or category lists: may already contain data - fSnipList := SnipList; - fCategories := Categories; - fFactory := DBDataItemFactory; - try - // Load categories - LoadCategories; - // Load snippets in each category - for Category in fCategories do - LoadSnippets(Category); - // Build XRef, Depends and Units reference list of each snippet for this - // database - for Snippet in fSnipList do - begin - if IsNativeSnippet(Snippet) then - LoadReferences(Snippet); - end; - except - on E: Exception do - HandleException(E); - end; -end; - -procedure TDatabaseLoader.LoadCategories; - {Loads all categories from storage - } -var - CatIDs: IStringList; // list of ids of categories - CatID: string; // name of each category - Category: TCategory; // a category object - CatData: TCategoryData; // properties of a category -begin - // Get name of all categories - CatIDs := fReader.GetAllCatIDs; - // Loop through each category by name - for CatID in CatIDs do - begin - // Check if category exists, creating it if not - Category := fCategories.Find(CatID); - if not Assigned(Category) then - begin - fReader.GetCatProps(CatID, CatData); - CreateCategory(CatID, CatData); - end; - end; -end; - -procedure TDatabaseLoader.LoadReferences(const Snippet: TSnippet); - {Loads all of a snippet's references. - @param Snippet [in] Snippet for which references are required. - } - - // --------------------------------------------------------------------------- - procedure LoadSnippetReferences(const RefList: TSnippetList; - const RefNames: IStringList); - {Creates a snippet list from names of snippets in a string list. If no - snippet with a given name is found no matching entry is added to snippet - list. - @param RefList [in] List to receive referenced snippets. - @param RefNames [in] List of snippet names. - } - var - RefName: string; // referenced snippet name - Reference: TSnippet; // referenced snippet object - begin - for RefName in RefNames do - begin - Reference := FindSnippet(RefName, fSnipList); - if Assigned(Reference) then - RefList.Add(Reference); - end; - end; - // --------------------------------------------------------------------------- - -begin - LoadSnippetReferences( - Snippet.Depends, fReader.GetSnippetDepends(Snippet.Name) - ); - LoadSnippetReferences( - Snippet.XRef, fReader.GetSnippetXRefs(Snippet.Name) - ); - fReader.GetSnippetUnits(Snippet.Name).CopyTo(Snippet.Units); -end; - -procedure TDatabaseLoader.LoadSnippets(const Cat: TCategory); - {Loads all snippets in a category. - @param Cat [in] Category to be loaded. - } -var - SnippetNames: IStringList; // list of names of snippets in category - SnippetProps: TSnippetData; // properties of a snippet - SnippetName: string; // each name in name list - Snippet: TSnippet; // references a snippet object -begin - FillChar(SnippetProps, SizeOf(SnippetProps), 0); - // Get names of all snippets in category - SnippetNames := fReader.GetCatSnippets(Cat.ID); - // Process each snippet name in list - for SnippetName in SnippetNames do - begin - // Check if snippet exists in current database and add it to list if not - Snippet := fSnipList.Find(SnippetName, IsUserDatabase); - if not Assigned(Snippet) then - begin - fReader.GetSnippetProps(SnippetName, SnippetProps); - Snippet := fFactory.CreateSnippet( - SnippetName, IsUserDatabase, SnippetProps - ); - fSnipList.Add(Snippet); - end; - // Add snippet to database only if it belongs to this database - if IsNativeSnippet(Snippet) then - Cat.Snippets.Add(Snippet); - end; -end; - -{ TMainDatabaseLoader } - -function TMainDatabaseLoader.CreateReader: IDataReader; - {Creates reader object. If main database doesn't exist a nul reader is - created. - @return Reader object instance. - } -begin - Result := TIniDataReader.Create(TAppInfo.AppDataDir); - if not Result.DatabaseExists then - Result := TNulDataReader.Create; -end; - -function TMainDatabaseLoader.ErrorMessageHeading: string; - {Returns heading to use in error messages. Identifies main database. - @return Required heading. - } -resourcestring - sError = 'Error loading the CodeSnip database:'; -begin - Result := sError; -end; - -function TMainDatabaseLoader.FindSnippet(const SnippetName: string; - const SnipList: TSnippetList): TSnippet; - {Finds the snippet object with a specified name in the main database. - @param SnippetName [in] Name of required snippet. - @param SnipList [in] List of snippets to search. - @return Reference to required snippet object or nil if snippet is not found. - } -begin - // We only search main database - Result := SnipList.Find(SnippetName, False); -end; - -function TMainDatabaseLoader.IsNativeSnippet(const Snippet: TSnippet): Boolean; - {Checks if a snippet is native (belongs) to the main database. - @param Snippet [in] Snippet to test. - @return True if snippet is native, False if not. - } -begin - Result := not Snippet.UserDefined; -end; - -function TMainDatabaseLoader.IsUserDatabase: Boolean; - {Checks if the database is the user database. - @return False - this is not the user database. - } -begin - Result := False; -end; - -{ TUserDatabaseLoader } - -function TUserDatabaseLoader.CreateReader: IDataReader; - {Creates reader object. If user database doesn't exist a nul reader is - created. - @return Reader object instance. - } -begin - Result := TXMLDataReader.Create(TAppInfo.UserDataDir); - if not Result.DatabaseExists then - Result := TNulDataReader.Create; -end; - -function TUserDatabaseLoader.ErrorMessageHeading: string; - {Returns heading to use in error messages. Identifies main database. - @return Required heading. - } -resourcestring - sError = 'Error loading the user defined database:'; -begin - Result := sError; -end; - -function TUserDatabaseLoader.FindSnippet(const SnippetName: string; - const SnipList: TSnippetList): TSnippet; - {Finds the snippet object with a specified name. If snippet is not in this - (user) database the main database is searched. - @param SnippetName [in] Name of required snippet. - @param SnipList [in] List of snippets to search. - @return Reference to required snippet object or nil if snippet is not found. - } -begin - // Search in user database - Result := SnipList.Find(SnippetName, True); - if not Assigned(Result) then - // Not in user database: try main database - Result := SnipList.Find(SnippetName, False); -end; - -function TUserDatabaseLoader.IsNativeSnippet(const Snippet: TSnippet): Boolean; - {Checks if a snippet is native (belongs) to the user database. - @param Snippet [in] Snippet to test. - @return True if snippet is native, False if not. - } -begin - Result := Snippet.UserDefined; -end; - -function TUserDatabaseLoader.IsUserDatabase: Boolean; - {Checks if the database is the user database. - @return True - this is the user database. - } -begin - Result := True; -end; - -procedure TUserDatabaseLoader.LoadCategories; - {Loads all categories from storage and adds user and imports categories if not - present. - } -var - ResCatIdx: Integer; // loops thru all reserved categories - ResCatInfo: TReservedCategoryInfo; // info about a reserved category -begin - // Get all categories from storage - inherited; - // Add default user-defined categories if not present - for ResCatIdx := 0 to Pred(TReservedCategories.Count) do - begin - ResCatInfo := TReservedCategories.Info(ResCatIdx); - if Categories.Find(ResCatInfo.Name) = nil then - CreateCategory(ResCatInfo.Name, ResCatInfo.Data); - end; -end; - -{ TDatabaseWriter } - -function TDatabaseWriter.CreateWriter: IDataWriter; - {Creates object that can write data for user-defined items from Database to - storage. - @return Requied writer object. - } -begin - Result := TXMLDataWriter.Create(TAppInfo.UserDataDir); -end; - -procedure TDatabaseWriter.Write(const SnipList: TSnippetList; - const Categories: TCategoryList; const Provider: IDBDataProvider); - {Writes data from Database object to storage. - @param SnipList [in] Contains information about each snippet in the - database. - @param Categories [in] Contains information about each category in the - database. - @param Provider [in] Object used to obtain details of the Database data to - be written. - } -begin - fSnipList := SnipList; - fCategories := Categories; - fProvider := Provider; - fWriter := CreateWriter; - fWriter.Initialise; - WriteCategories; - WriteSnippets; - fWriter.Finalise; -end; - -procedure TDatabaseWriter.WriteCategories; - {Writes information about categories to storage. - } -var - Cat: TCategory; // loops through each category - Props: TCategoryData; // category properties - SnipList: IStringList; // list of names of snippets in a category -begin - for Cat in fCategories do - begin - Props := fProvider.GetCategoryProps(Cat); - fWriter.WriteCatProps(Cat.ID, Props); - SnipList := fProvider.GetCategorySnippets(Cat); - fWriter.WriteCatSnippets(Cat.ID, SnipList); - end; -end; - -procedure TDatabaseWriter.WriteSnippets; - {Writes information about all snippets to storage. - } - - // --------------------------------------------------------------------------- - function IDListToStrings(const IDList: ISnippetIDList): IStringList; - {Copies snippet names from a snippet ID list to a string list. - @param IDList [in] Snippet ID List to be copied. - @return String list containing names. - } - var - ID: TSnippetID; // each id in snippet id list - begin - Result := TIStringList.Create; - for ID in IDList do - Result.Add(ID.Name); - end; - // --------------------------------------------------------------------------- - -var - Snippet: TSnippet; // loops through each snippet in list - Props: TSnippetData; // snippet properties - Refs: TSnippetReferences; // snippet references -begin - for Snippet in fSnipList do - begin - // Only write user-defined snippets - if Snippet.UserDefined then - begin - // Get and write a snippet's properties - Props := fProvider.GetSnippetProps(Snippet); - fWriter.WriteSnippetProps(Snippet.Name, Props); - // Get and write a snippet's references - Refs := fProvider.GetSnippetRefs(Snippet); - fWriter.WriteSnippetUnits(Snippet.Name, Refs.Units); - fWriter.WriteSnippetDepends(Snippet.Name, IDListToStrings(Refs.Depends)); - fWriter.WriteSnippetXRefs(Snippet.Name, IDListToStrings(Refs.XRef)); - end; - end; -end; - -end. - diff --git a/Src/DB.UMain.pas b/Src/DB.UMain.pas deleted file mode 100644 index 6b61183e1..000000000 --- a/Src/DB.UMain.pas +++ /dev/null @@ -1,1239 +0,0 @@ -{ - * This Source Code Form is subject to the terms of the Mozilla Public License, - * v. 2.0. If a copy of the MPL was not distributed with this file, You can - * obtain one at https://mozilla.org/MPL/2.0/ - * - * Copyright (C) 2005-2023, Peter Johnson (gravatar.com/delphidabbler). - * - * Defines a singleton object and subsidiary classes that encapsulate the - * snippets and categories in the CodeSnip database and user defined databases. -} - - -unit DB.UMain; - - -interface - - -uses - // Delphi - Classes, Generics.Collections, - // Project - ActiveText.UMain, Compilers.UGlobals, DB.UCategory, DB.USnippet, UContainers, - UIStringList, UMultiCastEvents, USnippetIDs; - - -type - - { - TDatabaseChangeEventKind: - Enumeration that specifies the different kind of change events triggered by - the user database. - } - TDatabaseChangeEventKind = ( - evChangeBegin, // a change to the database is about to take place - evChangeEnd, // a change to the database has completed - evSnippetAdded, // a snippet has been added - evBeforeSnippetDelete, // a snippet is about to be deleted - evSnippetDeleted, // a snippet has been deleted - evBeforeSnippetChange, // a snippet is about to be changed - evSnippetChanged, // a snippet's properties / references have changed - evCategoryAdded, // a category has been added - evBeforeCategoryDelete, // a category is about to be deleted - evCategoryDeleted, // a category has been deleted - evBeforeCategoryChange, // a category is about to be changed - evCategoryChanged // a category's properties have changed - ); - - { - IDBDataProvider: - Interface supported by objects that provides data about the categories and - snippets in the database. - } - IDBDataProvider = interface(IInterface) - ['{D2D57A0D-DB29-4012-891E-E817E0EED8C8}'] - function GetCategoryProps(const Cat: TCategory): TCategoryData; - {Retrieves all the properties of a category. - @param Cat [in] Category for which data is requested. - @return Record containing property data. - } - function GetCategorySnippets(const Cat: TCategory): IStringList; - {Retrieves names of all snippets that belong to a category. - @param Cat [in] Category for which snippet names are requested. - @return Required list of snippet names. - } - function GetSnippetProps(const Snippet: TSnippet): TSnippetData; - {Retrieves all the properties of a snippet. - @param Snippet [in] Snippet for which data is requested. - @return Record containing property data. - } - function GetSnippetRefs(const Snippet: TSnippet): TSnippetReferences; - {Retrieves information about all the references of a snippet. - @param Snippet [in] Snippet for which information is requested. - @return Record containing references. - } - end; - - { - IDatabaseChangeEventInfo: - Interface supported by objects passed to Database object's change event - handler that provides information about a change event. Some properites - are not defined for certain event types. Kind property always defined. - } - IDatabaseChangeEventInfo = interface(IInterface) - ['{80DEE62F-DC23-4EE7-A0B1-5DE46F483CE1}'] - function GetKind: TDatabaseChangeEventKind; - {Gets kind (type) of event. - @return Event kind. - } - function GetInfo: TObject; - {Gets additional information about event. - @return Object that provides required information. - } - property Kind: TDatabaseChangeEventKind read GetKind; - {Identifies kind (type) of an event. Always defined} - property Info: TObject read GetInfo; - {Provides additional information about the event. Actual type of object - depends on Kind. May be nil} - end; - - { - IDataItemFactory: - Interface to factory object that creates snippet and category objects. For - use by database loader objects. - } - IDBDataItemFactory = interface(IInterface) - ['{C6DD85BD-E649-4A90-961C-4011D2714B3E}'] - function CreateCategory(const CatID: string; const UserDefined: Boolean; - const Data: TCategoryData): TCategory; - {Creates a new category object. - @param CatID [in] ID of new category. Must be unique. - @param UserDefined [in] True if category is user defined, False if not. - @param Data [in] Record describing category's properties. - @return Instance of new category object. - } - function CreateSnippet(const Name: string; const UserDefined: Boolean; - const Props: TSnippetData): TSnippet; - {Creates a new snippet object. - @param Name [in] Name of new snippet. Must not exist in database - specified by UserDefined parameter. - @param UserDefined [in] True if snippet is user defined, False if not. - @param Props [in] Record describing snippet's properties. - @return Instance of new snippet with no references. - } - end; - - { - IDatabase: - Interface to object that encapsulates the whole (main and user) databases - and provides access to all snippets and all categories. - } - IDatabase = interface(IInterface) - ['{A280DEEF-0336-4264-8BD0-7CDFBB207D2E}'] - procedure Load; - {Loads data from main and user databases. - } - procedure Clear; - {Clears all data. - } - procedure AddChangeEventHandler(const Handler: TNotifyEventInfo); - {Adds a change event handler to list of listeners. - @param Handler [in] Event handler to be added. - } - procedure RemoveChangeEventHandler(const Handler: TNotifyEventInfo); - {Removes a change event handler from list of listeners. - @param Handler [in] Handler to remove from list. - } - function GetSnippets: TSnippetList; - {Gets list of snippets in main and user databases. - @return Required list. - } - function GetCategories: TCategoryList; - {Gets list of categories in main and user databases. - @return Required list. - } - property Categories: TCategoryList read GetCategories; - {List of categories in main and user databases} - property Snippets: TSnippetList read GetSnippets; - {List of snippets in main and user databases} - end; - - { - IDatabaseEdit: - Interface to object that can be used to edit the user database. - } - IDatabaseEdit = interface(IInterface) - ['{CBF6FBB0-4C18-481F-A378-84BB09E5ECF4}'] - function GetEditableSnippetInfo(const Snippet: TSnippet = nil): - TSnippetEditData; - {Provides details of all a snippet's data (properties and references) that - may be edited. - @param Snippet [in] Snippet for which data is required. May be nil in - which case a blank record is returned. - @return Required data. - } - function GetDependents(const Snippet: TSnippet): ISnippetIDList; - {Builds an ID list of all snippets that depend on a specified snippet. - @param Snippet [in] Snippet for which dependents are required. - @return List of IDs of dependent snippets. - } - function GetReferrers(const Snippet: TSnippet): ISnippetIDList; - {Builds an ID list of all snippets that cross reference a specified - snippet. - @param Snippet [in] Snippet for which cross referers are required. - @return List of IDs of referring snippets. - } - function UpdateSnippet(const Snippet: TSnippet; - const Data: TSnippetEditData; const NewName: string = ''): TSnippet; - {Updates a user defined snippet's properties and references using provided - data. - @param Snippet [in] Snippet to be updated. Must be user-defined. - @param Data [in] Record containing revised data. - @param NewName [in] New name of snippet. Set to '' or Snippet.Name if - name is not to change. - @return Reference to updated snippet. Will have changed. - } - function AddSnippet(const SnippetName: string; - const Data: TSnippetEditData): TSnippet; - {Adds a new snippet to the user database. - @param SnippetName [in] Name of new snippet. - @param Data [in] Record storing new snippet's properties and references. - @return Reference to new snippet. - } - function DuplicateSnippet(const Snippet: TSnippet; - const UniqueName, DisplayName: string; const CatID: string): TSnippet; - function CreateTempSnippet(const SnippetName: string; - const Data: TSnippetEditData): TSnippet; overload; - {Creates a new temporary snippet without adding it to the Snippets - object's snippets list. The new instance may not be added to the - Snippets object. - @param SnippetName [in] Name of new snippet. - @param Data [in] Record storing new snippet's properties and references. - @return Reference to new snippet. - } - function CreateTempSnippet(const Snippet: TSnippet): TSnippet; overload; - {Creates a new temporary copy of a snippet without adding it to the - Snippets object's snippets list. The new instance may not be added to the - Snippets object. - @param Snippet [in] Snippet to be copied. - @return Reference to new copied snippet. - } - procedure DeleteSnippet(const Snippet: TSnippet); - {Deletes a snippet from the user database. - @param Snippet [in] Snippet to be deleted. - } - function GetEditableCategoryInfo( - const Category: TCategory = nil): TCategoryData; - {Provides details of all a category's data that may be edited. - @param Category [in] Category for which data is required. May be nil in - whih case a blank record is returned. - @return Required data. - } - function AddCategory(const CatID: string; - const Data: TCategoryData): TCategory; - {Adds a new category to the user database. - @param CatID [in] ID of new category. - @param Data [in] Record storing new category's properties. - @return Reference to new category. - } - function UpdateCategory(const Category: TCategory; - const Data: TCategoryData): TCategory; - {Updates a user defined category's properties. - @param Category [in] Category to be updated. Must be user-defined. - @param Data [in] Record containing revised data. - @return Reference to updated category. Will have changed. - } - procedure DeleteCategory(const Category: TCategory); - {Deletes a category and all its snippets from the user database. - @param Category [in] Category to be deleted. - } - function Updated: Boolean; - {Checks if user database has been updated since last save. - @return True if database has been updated, False otherwise. - } - procedure Save; - {Saves user database. - } - end; - - -function Database: IDatabase; - {Returns singleton instance of object that encapsulates main and user - databases. - @return Singleton object. - } - - -implementation - - -uses - // Delphi - SysUtils, Generics.Defaults, - // Project - DB.UDatabaseIO, IntfCommon, UExceptions, UQuery, UStrUtils; - - -var - // Private global snippets singleton object - PvtDatabase: IDatabase = nil; - - -type - - { - TDBDataItemFactory: - Class that can create category and snippet objects. - } - TDBDataItemFactory = class(TInterfacedObject, IDBDataItemFactory) - public - function CreateCategory(const CatID: string; const UserDefined: Boolean; - const Data: TCategoryData): TCategory; - {Creates a new category object. - @param CatID [in] ID of new category. Must be unique. - @param UserDefined [in] True if category is user defined, False if not. - @param Data [in] Record describing category's properties. - @return Instance of new category object. - } - function CreateSnippet(const Name: string; const UserDefined: Boolean; - const Props: TSnippetData): TSnippet; - {Creates a new snippet object. - @param Name [in] Name of new snippet. Must not exist in database - specified by UserDefined parameter. - @param UserDefined [in] True if snippet is user defined, False if not. - @param Props [in] Record describing snippet's properties. - @return Instance of new snippet with no references. - } - end; - - { - TDatabase: - Class that encapsulates the main and user databases. Provides access to all - snippets and all categories via the IDatabase interface. Also enables user - defined database to be modified via IDatabaseEdit interface. - } - TDatabase = class(TInterfacedObject, - IDatabase, - IDatabaseEdit - ) - strict private - fUpdated: Boolean; // Flags if user database has been updated - fCategories: TCategoryList; // List of categories - fSnippets: TSnippetList; // List of snippets - fChangeEvents: TMulticastEvents; // List of change event handlers - type - { - TEventInfo: - Class that provides information about a change event. - } - TEventInfo = class(TInterfacedObject, IDatabaseChangeEventInfo) - strict private - fKind: TDatabaseChangeEventKind; // Kind of event - fInfo: TObject; // Extra info about event - public - constructor Create(const Kind: TDatabaseChangeEventKind; - const Info: TObject = nil); - {Constructor. Creates an event information object. - @param Kind [in] Kind of event. - @param Info [in] Reference to further information about the event. - May be nil if event doesn't have additional information. - } - { IDatabaseChangeEventInfo methods } - function GetKind: TDatabaseChangeEventKind; - {Gets kind (type) of event. - @return Event kind. - } - function GetInfo: TObject; - {Gets additional information about event. - @return Object that provides required information. - } - end; - procedure TriggerEvent(const Kind: TDatabaseChangeEventKind; - const Info: TObject = nil); - {Triggers a change event. Notifies all registered listeners. - @param Kind [in] Kind of event. - @param Info [in] Reference to any further information for event. May be - nil. - } - function InternalAddSnippet(const SnippetName: string; - const Data: TSnippetEditData): TSnippet; - {Adds a new snippet to the user database. Assumes snippet not already in - user database. - @param SnippetName [in] Name of new snippet. - @param Data [in] Properties and references of new snippet. - @return Reference to new snippet object. - @except Exception raised if snippet's category does not exist. - } - procedure InternalDeleteSnippet(const Snippet: TSnippet); - {Deletes a snippet from the user database. - @param Snippet [in] Snippet to delete from database. - } - function InternalAddCategory(const CatID: string; - const Data: TCategoryData): TCategory; - {Adds a new category to the user database. Assumes category not already in - user database. - @param CatID [in] ID of new category. - @param Data [in] Properties of new category. - @return Reference to new category object. - } - procedure InternalDeleteCategory(const Cat: TCategory); - {Deletes a category from the user database. - @param Cat [in] Category to delete from database. - } - procedure GetDependentList(const ASnippet: TSnippet; - const List: TSnippetList); - {Builds a list of all snippets that depend on a specified snippet. - @param ASnippet [in] Snippet for which dependents are required. - @param List [in] Receives list of dependent snippets. - } - procedure GetReferrerList(const ASnippet: TSnippet; - const List: TSnippetList); - {Builds list of all snippets that cross reference a specified snippet. - @param ASnippet [in] The cross referenced snippet. - @param List [in] Receives list of cross referencing snippets. - } - public - constructor Create; - {Constructor. Sets up new empty object. - } - destructor Destroy; override; - {Destructor. Tidies up and tears down object. - } - { IDatabase methods } - function GetCategories: TCategoryList; - {Gets list of all categories in database. - @return Required list. - } - function GetSnippets: TSnippetList; - {Gets list of all snippets in database. - @return Required list. - } - procedure Load; - {Loads object's data from main and user defined databases. - } - procedure Clear; - {Clears the object's data. - } - procedure AddChangeEventHandler(const Handler: TNotifyEventInfo); - {Adds a change event handler to list of listeners. - @param Handler [in] Event handler to be added. - } - procedure RemoveChangeEventHandler(const Handler: TNotifyEventInfo); - {Removes a change event handler from list of listeners. - @param Handler [in] Handler to remove from list. - } - { IDatabaseEdit methods } - function GetEditableSnippetInfo(const Snippet: TSnippet = nil): - TSnippetEditData; - {Provides details of all a snippet's data (properties and references) that - may be edited. - @param Snippet [in] Snippet for which data is required. May be nil in - which case a blank record is returned. - @return Required data. - } - function GetDependents(const Snippet: TSnippet): ISnippetIDList; - {Builds an ID list of all snippets that depend on a specified snippet. - @param Snippet [in] Snippet for which dependents are required. - @return List of IDs of dependent snippets. - } - function GetReferrers(const Snippet: TSnippet): ISnippetIDList; - {Builds an ID list of all snippets that cross reference a specified - snippet. - @param Snippet [in] Snippet which is cross referenced. - @return List of IDs of referring snippets. - } - function UpdateSnippet(const Snippet: TSnippet; - const Data: TSnippetEditData; const NewName: string = ''): TSnippet; - {Updates a user defined snippet's properties and references using provided - data. - @param Snippet [in] Snippet to be updated. Must be user-defined. - @param Data [in] Record containing revised data. - @param NewName [in] New name of snippet. Set to '' or Snippet.Name if - name is not to change. - @return Reference to updated snippet. Will have changed. - } - function AddSnippet(const SnippetName: string; - const Data: TSnippetEditData): TSnippet; - {Adds a new snippet to the user database. - @param SnippetName [in] Name of new snippet. - @param Data [in] Record storing new snippet's properties and references. - @return Reference to new snippet. - } - function DuplicateSnippet(const Snippet: TSnippet; - const UniqueName, DisplayName: string; const CatID: string): TSnippet; - function CreateTempSnippet(const SnippetName: string; - const Data: TSnippetEditData): TSnippet; overload; - {Creates a new temporary user defined snippet without adding it to the - Snippets object's snippets list. The new instance may not be added to the - Snippets object. - @param SnippetName [in] Name of new snippet. - @param Data [in] Record storing new snippet's properties and references. - @return Reference to new snippet. - } - function CreateTempSnippet(const Snippet: TSnippet): TSnippet; overload; - {Creates a new temporary copy of a snippet without adding it to the - Snippets object's snippets list. The new instance may not be added to the - Snippets object. - @param Snippet [in] Snippet to be copied. - @return Reference to new snippet. - } - procedure DeleteSnippet(const Snippet: TSnippet); - {Deletes a snippet from the user database. - @param Snippet [in] Snippet to be deleted. - } - function GetEditableCategoryInfo( - const Category: TCategory = nil): TCategoryData; - {Provides details of all a category's data that may be edited. - @param Category [in] Category for which data is required. May be nil in - which case a blank record is returned. - @return Required data. - } - function AddCategory(const CatID: string; - const Data: TCategoryData): TCategory; - {Adds a new category to the user database. - @param CatID [in] ID of new category. - @param Data [in] Record storing new category's properties. - @return Reference to new category. - } - function UpdateCategory(const Category: TCategory; - const Data: TCategoryData): TCategory; - {Updates a user defined category's properties. - @param Category [in] Category to be updated. Must be user-defined. - @param Data [in] Record containing revised data. - @return Reference to updated category. Will have changed. - } - procedure DeleteCategory(const Category: TCategory); - {Deletes a category and all its snippets from the user database. - @param Category [in] Category to be deleted. - } - function Updated: Boolean; - {Checks if user database has been updated since last save. - @return True if database has been updated, False otherwise. - } - procedure Save; - {Saves user defined snippets and all categories to user database. - } - end; - - { - TUserDataProvider: - Class that provides data about the categories and snippets in the user- - defined database. - } - TUserDataProvider = class(TInterfacedObject, IDBDataProvider) - strict private - fSnippets: TSnippetList; // All snippets in the whole database - fCategories: TCategoryList; // All categories in the whole database - public - constructor Create(const SnipList: TSnippetList; - const Categories: TCategoryList); - {Constructor. Records list of all snippets and categories in both - databases. - @param SnipList [in] List of all snippets in whole database. - @param Categories [in] List of all categories in whole database. - } - { IDBDataProvider methods } - function GetCategoryProps(const Cat: TCategory): TCategoryData; - {Retrieves all the properties of a category. - @param Cat [in] Category for which data is requested. - @return Record containing property data. - } - function GetCategorySnippets(const Cat: TCategory): IStringList; - {Retrieves names of all user-defined snippets that belong to a category. - @param Cat [in] Category for which snippet names are requested. - @return Required list of snippet names. - } - function GetSnippetProps(const Snippet: TSnippet): TSnippetData; - {Retrieves all the properties of a snippet. - @param Snippet [in] Snippet for which data is requested. - @return Record containing property data. - } - function GetSnippetRefs(const Snippet: TSnippet): TSnippetReferences; - {Retrieves information about all the references of a snippet. - @param Snippet [in] Snippet for which information is requested. - @return Record containing references. - } - end; - -function Database: IDatabase; - {Returns singleton instance of object that encapsulates main and user - databases. - @return Singleton object. - } -begin - if not Assigned(PvtDatabase) then - PvtDatabase := TDatabase.Create; - Result := PvtDatabase; -end; - -{ TDatabase } - -function TDatabase.AddCategory(const CatID: string; - const Data: TCategoryData): TCategory; - {Adds a new category to the user database. - @param CatID [in] ID of new category. - @param Data [in] Record storing new category's properties. - @return Reference to new category. - } -resourcestring - // Error message - sNameExists = 'Category %s already exists in user database'; -begin - Result := nil; - TriggerEvent(evChangeBegin); - try - // Check if category with same id exists in user database: error if so - if fCategories.Find(CatID) <> nil then - raise ECodeSnip.CreateFmt(sNameExists, [CatID]); - Result := InternalAddCategory(CatID, Data); - Query.Update; - TriggerEvent(evCategoryAdded, Result); - finally - fUpdated := True; - TriggerEvent(evChangeEnd); - end; -end; - -procedure TDatabase.AddChangeEventHandler(const Handler: TNotifyEventInfo); - {Adds a change event handler to list of listeners. - @param Handler [in] Event handler to be added. - } -begin - fChangeEvents.AddHandler(Handler); -end; - -function TDatabase.AddSnippet(const SnippetName: string; - const Data: TSnippetEditData): TSnippet; - {Adds a new snippet to the user database. - @param SnippetName [in] Name of new snippet. - @param Data [in] Record storing new snippet's properties and references. - @return Reference to new snippet. - } -resourcestring - // Error message - sNameExists = 'Snippet "%s" already exists in user database'; -begin - Result := nil; // keeps compiler happy - TriggerEvent(evChangeBegin); - try - // Check if snippet with same name exists in user database: error if so - if fSnippets.Find(SnippetName, True) <> nil then - raise ECodeSnip.CreateFmt(sNameExists, [SnippetName]); - Result := InternalAddSnippet(SnippetName, Data); - Query.Update; - TriggerEvent(evSnippetAdded, Result); - finally - fUpdated := True; - TriggerEvent(evChangeEnd); - end; -end; - -procedure TDatabase.Clear; - {Clears the object's data. - } -begin - fCategories.Clear; - fSnippets.Clear; -end; - -constructor TDatabase.Create; - {Constructor. Sets up new empty object. - } -begin - inherited Create; - fSnippets := TSnippetListEx.Create(True); - fCategories := TCategoryListEx.Create(True); - fChangeEvents := TMultiCastEvents.Create(Self); -end; - -function TDatabase.CreateTempSnippet(const Snippet: TSnippet): TSnippet; - {Creates a new temporary copy of a snippet without adding it to the - Snippets object's snippets list. The new instance may not be added to the - Snippets object. - @param Snippet [in] Snippet to be copied. - @return Reference to new snippet. - } -var - Data: TSnippetEditData; // data describing snippet's properties and references -begin - Assert(Assigned(Snippet), ClassName + '.CreateTempSnippet: Snippet is nil'); - Assert(Snippet is TSnippetEx, - ClassName + '.CreateTempSnippet: Snippet is a TSnippetEx'); - Data := (Snippet as TSnippetEx).GetEditData; - Result := TTempSnippet.Create( - Snippet.Name, Snippet.UserDefined, (Snippet as TSnippetEx).GetProps); - (Result as TTempSnippet).UpdateRefs( - (Snippet as TSnippetEx).GetReferences, fSnippets - ); -end; - -function TDatabase.CreateTempSnippet(const SnippetName: string; - const Data: TSnippetEditData): TSnippet; - {Creates a new temporary user defined snippet without adding it to the - Snippets object's snippets list. The new instance may not be added to the - Snippets object. - @param SnippetName [in] Name of new snippet. - @param Data [in] Record storing new snippet's properties and references. - @return Reference to new snippet. - } -begin - Result := TTempSnippet.Create(SnippetName, True, Data.Props); - (Result as TTempSnippet).UpdateRefs(Data.Refs, fSnippets); -end; - -procedure TDatabase.DeleteCategory(const Category: TCategory); - {Deletes a category and all its snippets from the user database. - @param Category [in] Category to be deleted. - } -begin - Assert(Category.CanDelete, - ClassName + '.DeleteCategory: Category can''t be deleted'); - Assert(fCategories.Contains(Category), - ClassName + '.DeleteCategory: Category is not in the database'); - TriggerEvent(evChangeBegin); - TriggerEvent(evBeforeCategoryDelete, Category); - try - InternalDeleteCategory(Category); - Query.Update; - finally - TriggerEvent(evCategoryDeleted); - TriggerEvent(evChangeEnd); - fUpdated := True; - end; -end; - -procedure TDatabase.DeleteSnippet(const Snippet: TSnippet); - {Deletes a snippet from the user database. - @param Snippet [in] Snippet to be deleted. - } -var - Dependent: TSnippet; // loops thru each snippet that depends on Snippet - Dependents: TSnippetList; // list of dependent snippets - Referrer: TSnippet; // loops thru snippets that cross references Snippet - Referrers: TSnippetList; // list of referencing snippets -begin - Assert(Snippet.UserDefined, - ClassName + '.DeleteSnippet: Snippet is not user-defined'); - Assert(fSnippets.Contains(Snippet), - ClassName + '.DeleteSnippet: Snippet is not in the database'); - TriggerEvent(evChangeBegin); - TriggerEvent(evBeforeSnippetDelete, Snippet); - // Get list of referencing and dependent snippets - Dependents := nil; - Referrers := nil; - try - Dependents := TSnippetList.Create; - GetDependentList(Snippet, Dependents); - Referrers := TSnippetList.Create; - GetReferrerList(Snippet, Referrers); - // Delete snippet for XRef or Depends list of referencing snippets - for Referrer in Referrers do - (Referrer.XRef as TSnippetListEx).Delete(Snippet); - for Dependent in Dependents do - (Dependent.Depends as TSnippetListEx).Delete(Snippet); - // Delete snippet itself - InternalDeleteSnippet(Snippet); - Query.Update; - finally - FreeAndNil(Referrers); - FreeAndNil(Dependents); - fUpdated := True; - TriggerEvent(evSnippetDeleted); - TriggerEvent(evChangeEnd); - end; -end; - -destructor TDatabase.Destroy; - {Destructor. Tidies up and tears down object. - } -begin - FreeAndNil(fChangeEvents); - FreeAndNil(fCategories); - FreeAndNil(fSnippets); - inherited; -end; - -function TDatabase.DuplicateSnippet(const Snippet: TSnippet; - const UniqueName, DisplayName: string; const CatID: string): TSnippet; -var - Data: TSnippetEditData; -begin - Data := (Snippet as TSnippetEx).GetEditData; - Data.Props.Cat := CatID; - Data.Props.DisplayName := DisplayName; - Result := AddSnippet(UniqueName, Data); -end; - -function TDatabase.GetCategories: TCategoryList; - {Gets list of all categories in database. - @return Required list. - } -begin - Result := fCategories; -end; - -procedure TDatabase.GetDependentList(const ASnippet: TSnippet; - const List: TSnippetList); - {Builds a list of all snippets that depend on a specified snippet. - @param ASnippet [in] Snippet for which dependents are required. - @param List [in] Receives list of dependent snippets. - } -var - Snippet: TSnippet; // references each snippet in database -begin - List.Clear; - for Snippet in fSnippets do - if not Snippet.IsEqual(ASnippet) and Snippet.Depends.Contains(ASnippet) then - List.Add(Snippet); -end; - -function TDatabase.GetDependents(const Snippet: TSnippet): ISnippetIDList; - {Builds an ID list of all snippets that depend on a specified snippet. - @param Snippet [in] Snippet for which dependents are required. - @return List of IDs of dependent snippets. - } -var - List: TSnippetList; // list of dependent snippets -begin - List := TSnippetList.Create; - try - GetDependentList(Snippet, List); - Result := TSnippetIDListEx.Create(List); - finally - FreeAndNil(List); - end; -end; - -function TDatabase.GetEditableCategoryInfo( - const Category: TCategory): TCategoryData; - {Provides details of all a category's data that may be edited. - @param Category [in] Category for which data is required. May be nil in - whih case a blank record is returned. - @return Required data. - } -begin - Assert(not Assigned(Category) or Category.UserDefined, - ClassName + '.GetEditableCategoryInfo: Category is not user-defined'); - if Assigned(Category) then - Result := (Category as TCategoryEx).GetEditData - else - Result.Init; -end; - -function TDatabase.GetEditableSnippetInfo( - const Snippet: TSnippet): TSnippetEditData; - {Provides details of all a snippet's data (properties and references) that may - be edited. - @param Snippet [in] Snippet for which data is required. May be nil in which - case a blank record is returned. - @return Required data. - } -begin - Assert(not Assigned(Snippet) or Snippet.UserDefined, - ClassName + '.GetEditableSnippetInfo: Snippet is not user-defined'); - if Assigned(Snippet) then - Result := (Snippet as TSnippetEx).GetEditData - else - Result.Init; -end; - -function TDatabase.GetReferrers(const Snippet: TSnippet): ISnippetIDList; - {Builds an ID list of all snippets that cross reference a specified - snippet. - @param Snippet [in] Snippet which is cross referenced. - @return List of IDs of referring snippets. - } -var - List: TSnippetList; // list of referring snippets -begin - List := TSnippetList.Create; - try - GetReferrerList(Snippet, List); - Result := TSnippetIDListEx.Create(List); - finally - FreeAndNil(List); - end; -end; - -procedure TDatabase.GetReferrerList(const ASnippet: TSnippet; - const List: TSnippetList); - {Builds list of all snippets that cross reference a specified snippet. - @param ASnippet [in] The cross referenced snippet. - @param List [in] Receives list of cross referencing snippets. - } -var - Snippet: TSnippet; // references each snippet in database -begin - List.Clear; - for Snippet in fSnippets do - if not Snippet.IsEqual(ASnippet) and Snippet.XRef.Contains(ASnippet) then - List.Add(Snippet); -end; - -function TDatabase.GetSnippets: TSnippetList; - {Gets list of all snippets in database. - @return Required list. - } -begin - Result := fSnippets; -end; - -function TDatabase.InternalAddCategory(const CatID: string; - const Data: TCategoryData): TCategory; - {Adds a new category to the user database. Assumes category not already in - user database. - @param CatID [in] ID of new category. - @param Data [in] Properties of new category. - @return Reference to new category object. - } -begin - Result := TCategoryEx.Create(CatID, True, Data); - fCategories.Add(Result); -end; - -function TDatabase.InternalAddSnippet(const SnippetName: string; - const Data: TSnippetEditData): TSnippet; - {Adds a new snippet to the user database. Assumes snippet not already in user - database. - @param SnippetName [in] Name of new snippet. - @param Data [in] Properties and references of new snippet. - @return Reference to new snippet object. - @except Exception raised if snippet's category does not exist. - } -var - Cat: TCategory; // category object containing new snippet -resourcestring - // Error message - sCatNotFound = 'Category "%0:s" referenced by new snippet named "%1:s" does ' - + 'not exist'; -begin - Result := TSnippetEx.Create(SnippetName, True, Data.Props); - (Result as TSnippetEx).UpdateRefs(Data.Refs, fSnippets); - Cat := fCategories.Find(Result.Category); - if not Assigned(Cat) then - raise ECodeSnip.CreateFmt(sCatNotFound, [Result.Category, Result.Name]); - Cat.Snippets.Add(Result); - fSnippets.Add(Result); -end; - -procedure TDatabase.InternalDeleteCategory(const Cat: TCategory); - {Deletes a category from the user database. - @param Cat [in] Category to delete from database. - } -begin - (fCategories as TCategoryListEx).Delete(Cat); -end; - -procedure TDatabase.InternalDeleteSnippet(const Snippet: TSnippet); - {Deletes a snippet from the user database. - @param Snippet [in] Snippet to delete from database. - } -var - Cat: TCategory; // category containing snippet -begin - // Delete from category if found - Cat := fCategories.Find(Snippet.Category); - if Assigned(Cat) then - (Cat.Snippets as TSnippetListEx).Delete(Snippet); - // Delete from "master" list: this frees Snippet - (fSnippets as TSnippetListEx).Delete(Snippet); -end; - -procedure TDatabase.Load; - {Loads object's data from main and user defined databases. - } -var - Factory: IDBDataItemFactory; // object reader uses to create snippets objects -begin - Clear; - // Create factory that reader calls into to create category and snippet - // objects. This is done to keep updating of snippet and categories private - // to this unit - Factory := TDBDataItemFactory.Create; - try - // Load main database: MUST do this first since user database can - // reference objects in main database - TDatabaseIOFactory.CreateMainDBLoader.Load(fSnippets, fCategories, Factory); - // Load any user database - TDatabaseIOFactory.CreateUserDBLoader.Load(fSnippets, fCategories, Factory); - fUpdated := False; - except - // If an exception occurs clear the database - Clear; - raise; - end; -end; - -procedure TDatabase.RemoveChangeEventHandler(const Handler: TNotifyEventInfo); - {Removes a change event handler from list of listeners. - @param Handler [in] Handler to remove from list. - } -begin - fChangeEvents.RemoveHandler(Handler); -end; - -procedure TDatabase.Save; - {Saves user defined snippets and all categories to user database. - } -var - Provider: IDBDataProvider; // object that supplies info to writer -begin - // Create object that can provide required information about user database - Provider := TUserDataProvider.Create(fSnippets, fCategories); - // Use a writer object to write out the database - TDatabaseIOFactory.CreateWriter.Write(fSnippets, fCategories, Provider); - fUpdated := False; -end; - -procedure TDatabase.TriggerEvent(const Kind: TDatabaseChangeEventKind; - const Info: TObject); - {Triggers a change event. Notifies all registered listeners. - @param Kind [in] Kind of event. - @param Info [in] Reference to any further information for event. May be nil. - } -var - EvtInfo: IDatabaseChangeEventInfo; // event information object -begin - EvtInfo := TEventInfo.Create(Kind, Info); - fChangeEvents.TriggerEvents(EvtInfo); -end; - -function TDatabase.UpdateCategory(const Category: TCategory; - const Data: TCategoryData): TCategory; - {Updates a user defined category's properties. - @param Category [in] Category to be updated. Must be user-defined. - @param Data [in] Record containing revised data. - @return Reference to updated category. Will have changed. - } -var - SnippetList: TSnippetList; - Snippet: TSnippet; - CatID: string; -begin - TriggerEvent(evChangeBegin); - TriggerEvent(evBeforeCategoryChange, Category); - try - SnippetList := TSnippetList.Create; - try - for Snippet in Category.Snippets do - SnippetList.Add(Snippet); - CatID := Category.ID; - InternalDeleteCategory(Category); - Result := InternalAddCategory(CatID, Data); - for Snippet in SnippetList do - Result.Snippets.Add(Snippet); - finally - FreeAndNil(SnippetList); - end; - Query.Update; - TriggerEvent(evCategoryChanged, Result); - finally - fUpdated := True; - TriggerEvent(evChangeEnd); - end; -end; - -function TDatabase.Updated: Boolean; - {Checks if user database has been updated since last save. - @return True if database has been updated, False otherwise. - } -begin - Result := fUpdated; -end; - -function TDatabase.UpdateSnippet(const Snippet: TSnippet; - const Data: TSnippetEditData; const NewName: string): TSnippet; - {Updates a user defined snippet's properties and references using provided - data. - @param Snippet [in] Snippet to be updated. Must be user-defined. - @param Data [in] Record containing revised data. - @param NewName [in] New name of snippet. Set to '' or Snippet.Name if name - is not to change. - @return Reference to updated snippet. Will have changed. - } -var - SnippetName: string; // name of snippet - Dependent: TSnippet; // loops thru each snippetthat depends on Snippet - Dependents: TSnippetList; // list of dependent snippets - Referrer: TSnippet; // loops thru snippets that cross references Snippet - Referrers: TSnippetList; // list of referencing snippets -resourcestring - // Error message - sCantRename = 'Can''t rename snippet named %0:s to %1:s: Snippet with name ' - + '%1:s already exists in user database'; -begin - Result := Snippet; // keeps compiler happy - Assert(Snippet.UserDefined, - ClassName + '.UpdateSnippet: Snippet is not user-defined'); - Referrers := nil; - Dependents := nil; - TriggerEvent(evChangeBegin); - TriggerEvent(evBeforeSnippetChange, Snippet); - try - // Calculate new name - if NewName <> '' then - SnippetName := NewName - else - SnippetName := Snippet.Name; - // If name has changed then new name musn't exist in user database - if not StrSameText(SnippetName, Snippet.Name) then - if fSnippets.Find(SnippetName, True) <> nil then - raise ECodeSnip.CreateFmt(sCantRename, [Snippet.Name, SnippetName]); - // We update by deleting old snippet and inserting new one - // get lists of snippets that cross reference or depend on this snippet - Dependents := TSnippetList.Create; - GetDependentList(Snippet, Dependents); - Referrers := TSnippetList.Create; - GetReferrerList(Snippet, Referrers); - // remove invalid references from referring snippets - for Referrer in Referrers do - (Referrer.XRef as TSnippetListEx).Delete(Snippet); - for Dependent in Dependents do - (Dependent.Depends as TSnippetListEx).Delete(Snippet); - // delete the snippet - InternalDeleteSnippet(Snippet); - // add new snippet - Result := InternalAddSnippet(SnippetName, Data); - // add new snippet to referrer list of referring snippets - for Referrer in Referrers do - Referrer.XRef.Add(Result); - for Dependent in Dependents do - Dependent.Depends.Add(Result); - Query.Update; - TriggerEvent(evSnippetChanged, Result); - finally - fUpdated := True; - Referrers.Free; - Dependents.Free; - TriggerEvent(evChangeEnd); - end; -end; - -{ TSnippets.TEventInfo } - -constructor TDatabase.TEventInfo.Create(const Kind: TDatabaseChangeEventKind; - const Info: TObject); - {Constructor. Creates an event information object. - @param Kind [in] Kind of event. - @param Info [in] Reference to further information about the event. May be - nil if event doesn't have additional information. - } -begin - inherited Create; - fKind := Kind; - fInfo := Info; -end; - -function TDatabase.TEventInfo.GetInfo: TObject; - {Gets additional information about event. - @return Object that provides required information. - } -begin - Result := fInfo; -end; - -function TDatabase.TEventInfo.GetKind: TDatabaseChangeEventKind; - {Gets kind (type) of event. - @return Event kind. - } -begin - Result := fKind; -end; - -{ TDBDataItemFactory } - -function TDBDataItemFactory.CreateCategory(const CatID: string; - const UserDefined: Boolean; const Data: TCategoryData): TCategory; - {Creates a new category object. - @param CatID [in] ID of new category. Must be unique. - @param UserDefined [in] True if category is user defined, False if not. - @param Data [in] Record describing category's properties. - @return Instance of new category object. - } -begin - Result := TCategoryEx.Create(CatID, UserDefined, Data); -end; - -function TDBDataItemFactory.CreateSnippet(const Name: string; - const UserDefined: Boolean; const Props: TSnippetData): TSnippet; - {Creates a new snippet object. - @param Name [in] Name of new snippet. Must not exist in database specified - by UserDefined parameter. - @param UserDefined [in] True if snippet is user defined, False if not. - @param Props [in] Record describing snippet's properties. - @return Instance of new snippet with no references. - } -begin - Result := TSnippetEx.Create(Name, UserDefined, Props); -end; - -{ TUserDataProvider } - -constructor TUserDataProvider.Create(const SnipList: TSnippetList; - const Categories: TCategoryList); - {Constructor. Records list of all snippets and categories in both databases. - @param SnipList [in] List of all snippets in whole database. - @param Categories [in] List of all categories in whole database. - } -begin - inherited Create; - fSnippets := SnipList; - fCategories := Categories; -end; - -function TUserDataProvider.GetCategoryProps( - const Cat: TCategory): TCategoryData; - {Retrieves all the properties of a category. - @param Cat [in] Category for which data is requested. - @return Record containing property data. - } -begin - Result.Desc := Cat.Description; -end; - -function TUserDataProvider.GetCategorySnippets( - const Cat: TCategory): IStringList; - {Retrieves names of all user-defined snippets that belong to a category. - @param Cat [in] Category for which snippet names are requested. - @return Required list of snippet names. - } -var - Snippet: TSnippet; // references each snippet in category -begin - Result := TIStringList.Create; - for Snippet in Cat.Snippets do - if Snippet.UserDefined then - Result.Add(Snippet.Name); -end; - -function TUserDataProvider.GetSnippetProps( - const Snippet: TSnippet): TSnippetData; - {Retrieves all the properties of a snippet. - @param Snippet [in] Snippet for which data is requested. - @return Record containing property data. - } -begin - Result := (Snippet as TSnippetEx).GetProps; -end; - -function TUserDataProvider.GetSnippetRefs( - const Snippet: TSnippet): TSnippetReferences; - {Retrieves information about all the references of a snippet. - @param Snippet [in] Snippet for which information is requested. - @return Record containing references. - } -begin - Result := (Snippet as TSnippetEx).GetReferences; -end; - -initialization - - -finalization - -// Free the singleton -PvtDatabase := nil; - -end. - diff --git a/Src/DB.UMetaData.pas b/Src/DB.UMetaData.pas deleted file mode 100644 index 1c26520f3..000000000 --- a/Src/DB.UMetaData.pas +++ /dev/null @@ -1,961 +0,0 @@ -{ - * This Source Code Form is subject to the terms of the Mozilla Public License, - * v. 2.0. If a copy of the MPL was not distributed with this file, You can - * obtain one at https://mozilla.org/MPL/2.0/ - * - * Copyright (C) 2020-2021, Peter Johnson (gravatar.com/delphidabbler). - * - * Provides meta data for the current main database and for any database - * updates. -} - - -unit DB.UMetaData; - -{ - Notes About Database Versions And Meta Files. - ============================================= - - Versions - -------- - - v1 of the Code Snippets Database was not considered to have a version number - until the arrival of v2. Therefore v1 did not have any means of identifying - its version number. Although the database format changed slightly over time - there is not enough historical information to identify different minor - releases, so all are considered to be v1.0.0.0 - - Database v2 has a VERSION file that specifies the version number as a dotted - quad, of the form v2.0.0.0. - - Note that semantic versioning is now being used so any database with major - version 2 will be backwards compatible with earlier v2 minor release. - - If a breaking change is introduced the major version will be bumped to v3 and - so on. - - Meta Files - ---------- - - Database v1 had only two meta files: - + contrib.txt - lists of contributors to the database, one per line - + testers.txt - lists of database testers, one per line - If those two files are present the database is assumed to be v1 - - Database v2 has the following meta files: - + VERSION - version number (v2.x.x.x) - + CONTRIBUTORS - lists of contributors to the database, one per line - + TESTERS - lists of database testers, one per line - + LICENSE - full text of the license that applies to the snippets - + LICENSE-INFO - furter information about the license - - For database v1 the license text, license information are hard-wired in the - absence of meta files. As noted above the version number is deduced. - - File encoding - ------------- - - All meta files are plain text. - - Early v1 database meta files were encoded in the system default encoding. - Later v1 databases encoded meta files in UTF-8. To distinguish between UTF-8 - and default encoded files the UTF-8 files use the UTF-8 preamble (BOM). - - v2 database meta files are all encoded in UTF-8 with preamble (BOM). - - Future major versions - --------------------- - - Future major database releases MUST include backwards compatibility with - earlier versions of CodeSnip in as much as those versions must be able to - easily detect and reject the format. - - To achieve this new major releases MUST include a VERSION file encoded in - UTF-8 with BOM. Existing code can detect and will reject any unsupported - version. - - CodeSnip support - ---------------- - - CodeSnip versions earlier than v4.16 are only ever delivered v1 database files - via their built in web update code. There is no way for these versions to - access v2 databases. - - CodeSnip from v4.16 get their main snippets database from files downloaded - manually. All such databases are v2. CodeSnip v4.16 also supports v1 format - because such a database may be resident on the user's computer at install - time. -} - - -interface - - -uses - // VCL - Classes, - // Project - UExceptions, - UIStringList, - UVersionInfo; - - -type - - /// Record providing information about the main database license. - /// - TDBLicenseInfo = record - strict private - fName: string; - fSPDX: string; - fURL: string; - fText: string; - public - /// Record constructor: sets all fields of record. - constructor Create(const AName, ASPDX, AURL, AText: string); - /// Name of license. - property Name: string read fName; - /// Open Source Initiative SPDX short idenitifier for licenses. - /// - /// If the license is not supported by the Open Source Initiative - /// then this property will be the empty string. - property SPDX: string read fSPDX; - /// URL of license online. - /// Optional. - property URL: string read fURL; - /// Full text of license. - property Text: string read fText; - /// Returns a string containing license name followed by any URL - /// in parentheses. - /// If no URL is available then only the license name is returned. - /// - function NameWithURL: string; - end; - - /// Record providing informaton about the main database copyright. - /// - TDBCopyrightInfo = record - strict private - fDate: string; - fHolder: string; - fHolderURL: string; - public - /// Record constructor: sets all fields of record. - constructor Create(const ADate, AHolder, AHolderURL: string); - /// Copyright date. - /// May be a single year or a range: e.g. 2020 or 2012-2016. - /// - property Date: string read fDate; - /// Name of copyright holder. - property Holder: string read fHolder; - /// URL of main copyright holder. - /// Optional. - property HolderURL: string read fHolderURL; - end; - - /// Interface supported by classes providing database meta data. - /// - IDBMetaData = interface(IInterface) - /// Returns database version number. - /// A null version number is returned if the meta data does not - /// come from a recognised database. - function GetVersion: TVersionNumber; - /// Returns database license information. - /// Return value is meaningless if the meta data does not come - /// from a supported database. - function GetLicenseInfo: TDBLicenseInfo; - /// Returns database copyright informatiom. - /// Return value is meaningless if the meta data does not come - /// from a supported database. - function GetCopyrightInfo: TDBCopyrightInfo; - /// Returns list of contributors to database. - /// Return value is meaningless if the meta data does not come - /// from a supported database. - function GetContributors: IStringList; - /// Returns list of testers of database. - /// Return value is meaningless if the meta data does not come - /// from a supported database. - function GetTesters: IStringList; - /// Checks if meta data is recognised as belonging to a valid - /// database, whether supported or not. - function IsRecognised: Boolean; - /// Checks if meta data is recognised as belonging to a supported - /// database version. - function IsSupportedVersion: Boolean; - /// Checks if meta data is corrupt. - /// Should only be called if meta data belongs to a supported - /// database. An exception should be raised if called on unsupported - /// versions. - function IsCorrupt: Boolean; - /// Refreshes the meta information by re-reading from database - /// meta files. - procedure Refresh; - end; - - /// Factory that creates instances of objects that provide - /// information about the main database and database updates. - TMainDBMetaDataFactory = record - public - /// Returns instance of class that provides meta data for the - /// main database. - class function MainDBMetaDataInstance: IDBMetaData; static; - /// Returns instance of class that provides meta data for the - /// database update stored in the given folder. - class function UpdateMetaDataInstance(const UpdateDir: string): - IDBMetaData; static; - end; - - /// Class of exception raised by meta data classes. - EDBMetaData = class(ECodeSnip); - - -implementation - - -uses - // Project - SysUtils, - IOUtils, - Types, - // VCL - UAppInfo, - UEncodings, - UIOUtils, - UResourceUtils, - UStructs, - UStrUtils; - - -const - DBValidVersions: TRange = (Min: 1; Max: 2); - -type - - /// Provides names of meta data files supported by various database - /// versions. - TDBMetaFileNames = record - public - const - ContributorsV1 = 'contrib.txt'; - TestersV1 = 'testers.txt'; - VersionV2AndLater = 'VERSION'; - LicenseV2 = 'LICENSE'; - LicenseInfoV2 = 'LICENSE-INFO'; - ContributorsV2 = 'CONTRIBUTORS'; - TestersV2 = 'TESTERS'; - end; - - /// Abstract base class for classes that access or emulate database - /// meta data files. - TDBMetaFiles = class abstract(TObject) - strict private - var - /// Directory of database for which meta data files are being - /// accessed. - fDBDir: string; - /// Returns encoding used by given meta file. - function GetFileEncoding(const FileName: TFileName): TEncoding; - strict protected - /// Makes a fully specified path to a given database file. - /// - /// FileName must contain no path information. - function MakePath(const FileName: string): string; - /// Checks if a given file exists in database directory. - function DBFileExists(const FileName: string): Boolean; - /// Reads all lines from given file and returns them as an array. - /// - /// FileName must contain no path information. - function ReadFileLines(const FileName: TFileName): TStringDynArray; - /// Reads all text from given file and returns it. - /// FileName must contain no path information. - function ReadFileText(const FileName: TFileName): string; - public - /// Constructs object that accesses meta data database files in - /// given directory. - constructor Create(const DBDir: string); - /// Returns text of the version file, or surrogate value. - /// - function Version: string; virtual; abstract; - /// Returns content license text file or surrogate value. - /// - function LicenseText: string; virtual; abstract; - /// Returns lines of license information file or surrogate value. - /// - function LicenseInfo: TStringDynArray; virtual; abstract; - /// Returns lines of contributors file or surrogate value. - /// - function Contributors: TStringDynArray; virtual; abstract; - /// Returns lines of testers file or surrogate value. - function Testers: TStringDynArray; virtual; abstract; - /// Checks if all the expected meta files are present. Returns - /// True if so or False if not. - /// ENotSupportedException must be raised if called on an - /// unsupported database version. - function AreAllFilesPresent: Boolean; virtual; abstract; - end; - - /// Class that accesses content of version 1 main database meta data - /// files. - /// Not all meta files are present in version main databases so - /// invariant placeholder content is provided to substitute for missing - /// files. - TV1DBMetaFiles = class sealed(TDBMetaFiles) - strict private - const - cContributorsFile = TDBMetaFileNames.ContributorsV1; - cTestersFile = TDBMetaFileNames.TestersV1; - public - /// Returns an surrogate, invariant value of 1 for the version - /// number. - /// No version file exists for this database version. The value - /// returned is deduced using documentation from the current code snippets - /// database project. - function Version: string; override; - /// Returns an surrogate, invariant value for the license text. - /// - /// No license text file exists for this database version. The - /// value returned is based on documentation of the database. - function LicenseText: string; override; - /// Returns an surrogate, invariant value for the lines of license - /// information. - function LicenseInfo: TStringDynArray; override; - /// Returns the lines of the contributors file. - function Contributors: TStringDynArray; override; - /// Returns the lines of the testers file. - function Testers: TStringDynArray; override; - /// Checks if all the expected meta files are present. Returns - /// True if so or False if not. - function AreAllFilesPresent: Boolean; override; - end; - - /// Class that accesses content of supported version 2 main database - /// meta files. - TV2DBMetaFiles = class sealed(TDBMetaFiles) - strict private - const - cVersionFile = TDBMetaFileNames.VersionV2AndLater; - cLicenseFile = TDBMetaFileNames.LicenseV2; - cLicenseInfoFile = TDBMetaFileNames.LicenseInfoV2; - cContributorsFile = TDBMetaFileNames.ContributorsV2; - cTestersFile = TDBMetaFileNames.TestersV2; - public - /// Returns the contents of the version file. - function Version: string; override; - /// Returns the contents of the license text file. - function LicenseText: string; override; - /// Returns the lines of the license info file. - function LicenseInfo: TStringDynArray; override; - /// Returns the lines of the contributors file. - function Contributors: TStringDynArray; override; - /// Returns the lines of the testers file. - function Testers: TStringDynArray; override; - /// Checks if all the expected meta files are present. Returns - /// True if so or False if not. - function AreAllFilesPresent: Boolean; override; - end; - - /// Class that represents later versions of database meta file - /// formats. - /// These formats have a valid version file but the version is not - /// supported and nothing is known about any other meta data files. - TLaterDBMetaFiles = class sealed(TDBMetaFiles) - strict private - const - cVersionFile = TDBMetaFileNames.VersionV2AndLater; - public - /// Returns the contents of the version file. - function Version: string; override; - /// Returns the empty string. - /// The file format is unknown, so the license text file cannot be - /// read and there is no information to deduce the value. - function LicenseText: string; override; - /// Returns an empty string array. - /// The file format is unknown, so the license information file - /// cannot be read and there is no information to deduce the value. - /// - function LicenseInfo: TStringDynArray; override; - /// Returns an empty string array. - /// The file format is unknown, so the contributors file cannot be - /// read and there is no information to deduce the value. - function Contributors: TStringDynArray; override; - /// Returns an empty string array. - /// The file format is unknown, so the testers file cannot be read - /// and there is no information to deduce the value. - function Testers: TStringDynArray; override; - /// Checks if all the expected meta files are present only if - /// the meta files come from a supported database format. - /// ENotSupportedException always raised since there is no way - /// of knowing what files should be present in an unsupported database - /// format. - function AreAllFilesPresent: Boolean; override; - end; - - /// Class that is present to represent unknown database meta file - /// formats. Also used when database is not present. - /// Accesses no files and returns null results for all methods - /// except IsVersionSupported. - TUnknownOrMissingMetaFiles = class sealed(TDBMetaFiles) - public - /// Returns the empty string. - /// The file format is unknown, so the version file cannot be read - /// and there is no information to deduce the value. - function Version: string; override; - /// Returns the empty string. - /// The file format is unknown, so the license text file cannot be - /// read and there is no information to deduce the value. - function LicenseText: string; override; - /// Returns an empty string array. - /// The file format is unknown, so the license information file - /// cannot be read and there is no information to deduce the value. - /// - function LicenseInfo: TStringDynArray; override; - /// Returns an empty string array. - /// The file format is unknown, so the contributors file cannot be - /// read and there is no information to deduce the value. - function Contributors: TStringDynArray; override; - /// Returns an empty string array. - /// The file format is unknown, so the testers file cannot be read - /// and there is no information to deduce the value. - function Testers: TStringDynArray; override; - /// Checks if all the expected meta files are present only if - /// the meta files come from a supported database format. - /// ENotSupportedException always raised since there is no way - /// of knowing what files should be present in an unrecognised database - /// format. - function AreAllFilesPresent: Boolean; override; - end; - - /// Factory to create the correct instance of database meta file - /// classes that can read the version of a database in a given folder. - /// - TDBMetaFilesFactory = record - public - class function GetInstance(const DBDir: string): TDBMetaFiles; - static; - end; - - /// Abstract base class for classes that provide main database meta - /// data. - TAbstractMainDBMetaData = class abstract(TInterfacedObject) - strict private - var - fMetaFiles: TDBMetaFiles; - fIsVersionLoaded: Boolean; - fVersion: TVersionNumber; - fIsLicenseAndCopyrightInfoLoaded: Boolean; - fLicenseInfo: TDBLicenseInfo; - fCopyrightInfo: TDBCopyrightInfo; - fContributors: IStringList; - fTesters: IStringList; - - procedure LoadLicenseAndCopyrightInfo; - - strict protected - function GetDBDir: string; virtual; abstract; - public - constructor Create; - procedure AfterConstruction; override; - destructor Destroy; override; - /// Returns database version number. - /// - /// A null version number is returned if the meta data does not come - /// from a recognised database. - /// Method of IDBMetaData. - /// - function GetVersion: TVersionNumber; - /// Returns database license information. - /// - /// Return value is meaningless if the meta data does not come - /// from a supported database. - /// Method of IDBMetaData. - /// - function GetLicenseInfo: TDBLicenseInfo; - /// Returns database copyright informatiom. - /// - /// Return value is meaningless if the meta data does not come - /// from a supported database. - /// Method of IDBMetaData. - /// - function GetCopyrightInfo: TDBCopyrightInfo; - /// Returns list of contributors to database. - /// - /// Return value is meaningless if the meta data does not come - /// from a supported database. - /// Method of IDBMetaData. - /// - function GetContributors: IStringList; - /// Returns list of testers of database. - /// - /// Return value is meaningless if the meta data does not come - /// from a supported database. - /// Method of IDBMetaData. - /// - function GetTesters: IStringList; - /// Checks if meta data is recognised as belonging to a valid - /// database, whether supported or not. - /// Method of IDBMetaData. - function IsRecognised: Boolean; - /// Checks if meta data is recognised as belonging to a supported - /// database version. - /// Method of IDBMetaData. - function IsSupportedVersion: Boolean; - /// Checks if meta data is corrupt. - /// - /// Should only be called if meta data belongs to a supported - /// database. - /// Method of IDBMetaData. - /// - /// ENotSupportedException raised if called on an unsupported - /// database. - function IsCorrupt: Boolean; - /// Refreshes the meta information by re-reading from database - /// meta files. - /// Method of IDBMetaData. - procedure Refresh; - end; - - /// Class that provides meta data for the main database. - TMainDBMetaData = class sealed(TAbstractMainDBMetaData, IDBMetaData) - strict protected - function GetDBDir: string; override; - end; - - /// Class that provides meta data for update database directories. - /// - TUpdateDBMetaData = class sealed(TAbstractMainDBMetaData, IDBMetaData) - strict private - var - fUpdateDir: string; - strict protected - function GetDBDir: string; override; - public - constructor Create(const UpdateDir: string); - end; - -{ TMainDBMetaDataFactory } - -class function TMainDBMetaDataFactory.MainDBMetaDataInstance: - IDBMetaData; -begin - Result := TMainDBMetaData.Create; -end; - -class function TMainDBMetaDataFactory.UpdateMetaDataInstance( - const UpdateDir: string): IDBMetaData; -begin - Result := TUpdateDBMetaData.Create(UpdateDir); -end; - -{ TAbstractMainDBMetaData } - -procedure TAbstractMainDBMetaData.AfterConstruction; -begin - inherited; - Refresh; -end; - -constructor TAbstractMainDBMetaData.Create; -begin - inherited; -// Refresh; -end; - -destructor TAbstractMainDBMetaData.Destroy; -begin - fMetaFiles.Free; - inherited; -end; - -function TAbstractMainDBMetaData.GetContributors: IStringList; -begin - if not Assigned(fContributors) then - fContributors := TIStringList.Create(fMetaFiles.Contributors); - Result := fContributors; -end; - -function TAbstractMainDBMetaData.GetCopyrightInfo: TDBCopyrightInfo; -begin - if not fIsLicenseAndCopyrightInfoLoaded then - LoadLicenseAndCopyrightInfo; - Result := fCopyrightInfo; -end; - -function TAbstractMainDBMetaData.GetLicenseInfo: TDBLicenseInfo; -begin - if not fIsLicenseAndCopyrightInfoLoaded then - LoadLicenseAndCopyrightInfo; - Result := fLicenseInfo; -end; - -function TAbstractMainDBMetaData.GetTesters: IStringList; -begin - if not Assigned(fTesters) then - fTesters := TIStringList.Create(fMetaFiles.Testers); - Result := fTesters; -end; - -function TAbstractMainDBMetaData.GetVersion: TVersionNumber; -begin - if not fIsVersionLoaded then - begin - if not TVersionNumber.TryStrToVersionNumber( - StrTrim(fMetaFiles.Version), fVersion - ) then - fVersion := TVersionNumber.Nul; - end; - fIsVersionLoaded := True; - Result := fVersion; -end; - -function TAbstractMainDBMetaData.IsCorrupt: Boolean; -resourcestring - sNotSupportedError = 'Can''t call IDBMetaData.IsCorrupt for an unsupported ' - + 'database version'; -begin - if not IsSupportedVersion then - raise ENotSupportedException.Create(sNotSupportedError); - Result := not fMetaFiles.AreAllFilesPresent; -end; - -function TAbstractMainDBMetaData.IsRecognised: Boolean; -begin - Result := not GetVersion.IsNull; -end; - -function TAbstractMainDBMetaData.IsSupportedVersion: Boolean; -var - ThisVersion: TVersionNumber; -begin - ThisVersion := GetVersion; - Result := DBValidVersions.Contains(ThisVersion.V1); -end; - -procedure TAbstractMainDBMetaData.LoadLicenseAndCopyrightInfo; -var - SL: TStringList; -begin - if fIsLicenseAndCopyrightInfoLoaded then - Exit; - SL := TStringList.Create; - try - StrArrayToStrList(fMetaFiles.LicenseInfo, SL); - fLicenseInfo := TDBLicenseInfo.Create( - SL.Values['LicenseName'], - SL.Values['LicenseSPDX'], - SL.Values['LicenseURL'], - fMetaFiles.LicenseText - ); - fCopyrightInfo := TDBCopyrightInfo.Create( - SL.Values['CopyrightDate'], - SL.Values['CopyrightHolder'], - SL.Values['CopyrightHolderURL'] - ); - finally - SL.Free; - end; - fIsLicenseAndCopyrightInfoLoaded := True; -end; - -procedure TAbstractMainDBMetaData.Refresh; -begin - FreeAndNil(fMetaFiles); - fMetaFiles := TDBMetaFilesFactory.GetInstance(GetDBDir); - fIsVersionLoaded := False; - fIsLicenseAndCopyrightInfoLoaded := False; - fContributors := nil; - fTesters := nil; -end; - -{ TMainDBMetaData } - -function TMainDBMetaData.GetDBDir: string; -begin - Result := TAppInfo.AppDataDir; -end; - -{ TUpdateDBMetaData } - -constructor TUpdateDBMetaData.Create(const UpdateDir: string); -begin - inherited Create; - fUpdateDir := ExcludeTrailingPathDelimiter(UpdateDir); -end; - -function TUpdateDBMetaData.GetDBDir: string; -begin - Result := fUpdateDir; -end; - -{ TDBMetaFiles } - -constructor TDBMetaFiles.Create(const DBDir: string); -begin - inherited Create; - fDBDir := DBDir; -end; - -function TDBMetaFiles.DBFileExists(const FileName: string): Boolean; -begin - Result := TFile.Exists(MakePath(FileName), False); -end; - -function TDBMetaFiles.GetFileEncoding(const FileName: TFileName): TEncoding; -begin - // Old v1 database meta files may be in the system default encodings, v1 and - // all v2 and later use UTF-8 with BOM. - if TFileIO.CheckBOM(MakePath(FileName), TEncoding.UTF8) then - Result := TEncoding.UTF8 - else - Result := TEncoding.Default; -end; - -function TDBMetaFiles.MakePath(const FileName: string): string; -begin - Assert(not StrContainsStr(PathDelim, FileName), - ClassName + '.MakePath: FileName must be a base file name.'); - Result := IncludeTrailingPathDelimiter(fDBDir) + FileName; -end; - -function TDBMetaFiles.ReadFileLines(const FileName: TFileName): TStringDynArray; -var - Encoding: TEncoding; -begin - if not DBFileExists(FileName) then - begin - SetLength(Result, 0); - Exit; - end; - Encoding := GetFileEncoding(FileName); - try - Result := TFileIO.ReadAllLines(MakePath(FileName), Encoding, True); - finally - TEncodingHelper.FreeEncoding(Encoding); - end; -end; - -function TDBMetaFiles.ReadFileText(const FileName: TFileName): string; -begin - if not DBFileExists(FileName) then - Exit(''); - Result := TFileIO.ReadAllText( - MakePath(FileName), GetFileEncoding(FileName), True - ); -end; - -{ TV1DBMetaFiles } - -function TV1DBMetaFiles.AreAllFilesPresent: Boolean; -begin - Result := DBFileExists(cContributorsFile) and DBFileExists(cTestersFile); -end; - -function TV1DBMetaFiles.Contributors: TStringDynArray; -begin - Result := ReadFileLines(cContributorsFile) -end; - -function TV1DBMetaFiles.LicenseInfo: TStringDynArray; -begin - Result := TStringDynArray.Create( - 'LicenseName=MIT License', - 'LicenseSPDX=MIT', - 'LicenseURL=https://opensource.org/licenses/MIT', - 'CopyrightDate=2005-2016', - 'CopyrightHolder=Peter Johnson & Contributors', - 'CopyrightHolderURL=https://gravatar.com/delphidabbler' - ); -end; - -function TV1DBMetaFiles.LicenseText: string; -begin - Result := LoadResourceAsString(HInstance, 'CSDBLICENSE', RT_RCDATA, etUTF8); -end; - -function TV1DBMetaFiles.Testers: TStringDynArray; -begin - Result := ReadFileLines(cTestersFile); -end; - -function TV1DBMetaFiles.Version: string; -begin - Result := '1'; -end; - -{ TV2DBMetaFiles } - -function TV2DBMetaFiles.AreAllFilesPresent: Boolean; -begin - Result := DBFileExists(cVersionFile) - and DBFileExists(cLicenseFile) - and DBFileExists(cLicenseInfoFile) - and DBFileExists(cContributorsFile) - and DBFileExists(cTestersFile); -end; - -function TV2DBMetaFiles.Contributors: TStringDynArray; -begin - Result := ReadFileLines(cContributorsFile); -end; - -function TV2DBMetaFiles.LicenseInfo: TStringDynArray; -begin - Result := ReadFileLines(cLicenseInfoFile); -end; - -function TV2DBMetaFiles.LicenseText: string; -begin - Result := StrTrimRight(ReadFileText(cLicenseFile)); -end; - -function TV2DBMetaFiles.Testers: TStringDynArray; -begin - Result := ReadFileLines(cTestersFile); -end; - -function TV2DBMetaFiles.Version: string; -begin - Result := StrTrim(ReadFileText(cVersionFile)); -end; - -{ TLaterDBMetaFiles } - -function TLaterDBMetaFiles.AreAllFilesPresent: Boolean; -resourcestring - sNotSupportedError = 'Calling %s.AreAllFilesPresent is not supported for an ' - + 'unsupported database format'; -begin - raise ENotSupportedException.CreateFmt(sNotSupportedError, [ClassName]); -end; - -function TLaterDBMetaFiles.Contributors: TStringDynArray; -begin - SetLength(Result, 0); -end; - -function TLaterDBMetaFiles.LicenseInfo: TStringDynArray; -begin - SetLength(Result, 0); -end; - -function TLaterDBMetaFiles.LicenseText: string; -begin - Result := ''; -end; - -function TLaterDBMetaFiles.Testers: TStringDynArray; -begin - SetLength(Result, 0); -end; - -function TLaterDBMetaFiles.Version: string; -begin - Result := StrTrim(ReadFileText(cVersionFile)); -end; - -{ TUnknownOrMissingMetaFiles } - -function TUnknownOrMissingMetaFiles.AreAllFilesPresent: Boolean; -resourcestring - sNotSupportedError = 'Calling %s.AreAllFilesPresent is not supported for an ' - + 'unrecognised database format or missing database'; -begin - raise ENotSupportedException.CreateFmt(sNotSupportedError, [ClassName]); -end; - -function TUnknownOrMissingMetaFiles.Contributors: TStringDynArray; -begin - SetLength(Result, 0); -end; - -function TUnknownOrMissingMetaFiles.LicenseInfo: TStringDynArray; -begin - SetLength(Result, 0); -end; - -function TUnknownOrMissingMetaFiles.LicenseText: string; -begin - Result := ''; -end; - -function TUnknownOrMissingMetaFiles.Testers: TStringDynArray; -begin - SetLength(Result, 0); -end; - -function TUnknownOrMissingMetaFiles.Version: string; -begin - Result := ''; -end; - -{ TDBMetaFilesFactory } - -class function TDBMetaFilesFactory.GetInstance(const DBDir: string): - TDBMetaFiles; -var - VersionFile: string; - VersionStr: string; - Version: TVersionNumber; - DBPath: string; -begin - if not TDirectory.Exists(ExcludeTrailingPathDelimiter(DBDir)) then - // Database is not installed - Exit(TUnknownOrMissingMetaFiles.Create(DBDir)); - - DBPath := IncludeTrailingPathDelimiter(DBDir); - - // Check if VERSION file exists: - // Yes: - // either: version is invalid - database format unknown - // or: version is 2.x.x.x - database format v2 recognised - // or: version is >2 - database format recognised but not supported - // No: - // either: expected v1 meta files exist - database format v1 recognised - // or: no v1 meta files - database format unknown - VersionFile := DBPath + TDBMetaFileNames.VersionV2AndLater; - if TFile.Exists(VersionFile, False) then - begin - VersionStr := TFileIO.ReadAllText(VersionFile, TEncoding.UTF8, True); - if not TVersionNumber.TryStrToVersionNumber(VersionStr, Version) then - Result := TUnknownOrMissingMetaFiles.Create(DBDir) - else if Version.V1 = 2 then - Result := TV2DBMetaFiles.Create(DBDir) - else - Result := TLaterDBMetaFiles.Create(DBDir); - end - else - begin - if TFile.Exists(DBPath + TDBMetaFileNames.ContributorsV1, False) - and TFile.Exists(DBPath + TDBMetaFileNames.TestersV1, False) then - Result := TV1DBMetaFiles.Create(DBDir) - else - Result := TUnknownOrMissingMetaFiles.Create(DBDir); - end; -end; - -{ TDBLicenseInfo } - -constructor TDBLicenseInfo.Create(const AName, ASPDX, AURL, AText: string); -begin - fName := AName; - fSPDX := ASPDX; - fURL := AURL; - fText := AText; -end; - -function TDBLicenseInfo.NameWithURL: string; -begin - Result := fName; - if fURL <> '' then - Result := Result + ' (' + fURL + ')'; -end; - -{ TDBCopyrightInfo } - -constructor TDBCopyrightInfo.Create(const ADate, AHolder, AHolderURL: string); -begin - fDate := ADate; - fHolder := AHolder; - fHolderURL := AHolderURL; -end; - -end. diff --git a/Src/DB.Vaults.pas b/Src/DB.Vaults.pas new file mode 100644 index 000000000..7c58dd145 --- /dev/null +++ b/Src/DB.Vaults.pas @@ -0,0 +1,576 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2024, Peter Johnson (gravatar.com/delphidabbler). + * + * Implements support for multiple snippet vaults. +} + + +unit DB.Vaults; + +{$ScopedEnums ON} + +interface + +uses + SysUtils, + Generics.Collections, + Generics.Defaults, + + DB.DataFormats, + DB.MetaData, + UEncodings, + UExceptions, + USettings, + USingleton; + +type + + TVaultID = record + strict private + var + fID: TBytes; + public + type + TComparer = class(TInterfacedObject, + IComparer, IEqualityComparer + ) + public + function Compare(const Left, Right: TVaultID): Integer; + function Equals(const Left, Right: TVaultID): Boolean; reintroduce; + function GetHashCode(const Value: TVaultID): Integer; reintroduce; + end; + constructor Create(const ABytes: TBytes); overload; + constructor Create(const AStr: string); overload; + constructor Create(const AGUID: TGUID); overload; + class function CreateFromHexString(const AHexStr: string): TVaultID; + static; + class function CreateNull: TVaultID; static; + class function Default: TVaultID; static; + function Clone: TVaultID; + function ToArray: TBytes; + function ToHexString: string; + function IsNull: Boolean; + function Hash: Integer; + class function Compare(Left, Right: TVaultID): Integer; static; + class operator Equal(Left, Right: TVaultID): Boolean; + class operator NotEqual(Left, Right: TVaultID): Boolean; + end; + + EVaultID = class(ECodeSnip); + + TVault = class + strict private + var + fUID: TVaultID; + fName: string; + fStorage: TDataStorageDetails; + fMetaData: TMetaData; + procedure SetMetaData(const AValue: TMetaData); + public + type + TComparer = class(TInterfacedObject, + IComparer, IEqualityComparer + ) + public + function Compare(const Left, Right: TVault): Integer; + function Equals(const Left, Right: TVault): Boolean; reintroduce; + function GetHashCode(const Value: TVault): Integer; reintroduce; + end; + /// Creates a vault object. + /// TVaultID [in] Unique ID of the vault. Must + /// not be null. + /// string [in] Name of vault. Should be unique. + /// Must not be empty or only whitespace. + constructor Create(const AUID: TVaultID; const AName: string; + const AStorage: TDataStorageDetails); + /// Vault identifier. Must be unique. + property UID: TVaultID read fUID; + /// Vault name. Must be unique. + property Name: string read fName; + /// Vault storage information. + property Storage: TDataStorageDetails read fStorage; + /// Meta data associated with the vault. + /// Meta data is read from and written to the associated storage. + /// + property MetaData: TMetaData read fMetaData write SetMetaData; + /// Checks if this object's fields are valid. + function IsValid: Boolean; + /// Checks if this object is the default vault. + function IsDefault: Boolean; + end; + + TVaults = class sealed(TSingleton) + strict private + var + fItems: TList; + function GetItem(const Idx: Integer): TVault; + procedure DoUpdate(const Idx: Integer; const AVault: TVault); + class function GetInstance: TVaults; static; + strict protected + procedure Initialize; override; + procedure Finalize; override; + public + class property Instance: TVaults read GetInstance; + function GetEnumerator: TEnumerator; + function IndexOfID(const AUID: TVaultID): Integer; + function ContainsID(const AUID: TVaultID): Boolean; + function ContainsName(const AName: string): Boolean; + function GetVault(const AUID: TVaultID): TVault; + function Default: TVault; + procedure Add(const AVault: TVault); + procedure Update(const AVault: TVault); + procedure AddOrUpdate(const AVault: TVault); + procedure Delete(const AUID: TVaultID); + procedure Clear; + procedure Save; + function ToArray: TArray; + function GetAllIDs: TArray; + function Count: Integer; + property Items[const Idx: Integer]: TVault read GetItem; default; + end; + + TVaultsPersist = record + strict private + const + CountKey = 'Count'; + UIDKey = 'UID'; + NameKey = 'Name'; + StorageFormatKey = 'Storage.Format'; + StorageDirectoryKey = 'Storage.Directory'; + class procedure SaveVault(const AOrdinal: Cardinal; const AVault: TVault); + static; + class procedure LoadVault(const AOrdinal: Cardinal; const AVaults: TVaults); + static; + public + class procedure Save(const AVaults: TVaults); static; + class procedure Load(const AVaults: TVaults); static; + end; + +implementation + +uses + // Delphi + RTLConsts, + IOUtils, + Math, + // Project + UAppInfo, + UStrUtils, + UUtils; + +resourcestring + SBadHexString = 'Invalid Hex String.'; + +{ TVault } + +constructor TVault.Create(const AUID: TVaultID; const AName: string; + const AStorage: TDataStorageDetails); +var + TrimmedName: string; +begin + TrimmedName := StrTrim(AName); + Assert(not AUID.IsNull, 'TVault.Create: AUID is null'); + Assert(TrimmedName <> '', + 'TVault.Create: AName is empty or only whitespace'); + {TODO -cRefactor: move following into IsValid method of TDataDetails} + Assert(AStorage.Format <> TDataFormatKind.Error, + 'TVault.Create: ADataDetails.Kind = TDataFormatKind.Error'); + fUID := AUID.Clone; + fName := TrimmedName; + fStorage := AStorage; +end; + +function TVault.IsDefault: Boolean; +begin + Result := UID = TVaultID.Default; +end; + +function TVault.IsValid: Boolean; +begin + {TODO: Constructor enforces all these requirements, so #TVault.IsValid + may not be needed.} + Result := not fUID.IsNull + and (fName <> '') + and (fStorage.Format <> TDataFormatKind.Error); +end; + +procedure TVault.SetMetaData(const AValue: TMetaData); +begin + fMetaData := AValue.Clone; +end; + +{ TVaults } + +procedure TVaults.Add(const AVault: TVault); +begin + if not ContainsID(AVault.UID) then + fItems.Add(AVault); +end; + +procedure TVaults.AddOrUpdate(const AVault: TVault); +var + Idx: Integer; +begin + Idx := IndexOfID(AVault.UID); + if Idx < 0 then + fItems.Add(AVault) + else + DoUpdate(Idx, AVault); +end; + +procedure TVaults.Clear; +var + Idx: Integer; +begin + for Idx := Pred(fItems.Count) downto 0 do + DoUpdate(Idx, nil); // frees and nils item with given index + fItems.Clear; +end; + +function TVaults.ContainsID(const AUID: TVaultID): + Boolean; +begin + Result := IndexOfID(AUID) >= 0; +end; + +function TVaults.ContainsName(const AName: string): Boolean; +var + Vault: TVault; +begin + Result := False; + for Vault in fItems do + if StrSameText(AName, Vault.Name) then + Exit(True); +end; + +function TVaults.Count: Integer; +begin + Result := fItems.Count; +end; + +function TVaults.Default: TVault; +begin + Result := GetVault(TVaultID.Default); +end; + +procedure TVaults.Delete(const AUID: TVaultID); +resourcestring + sCantDelete = 'Cannot delete the default vault'; +var + Idx: Integer; +begin + if TVaultID.Default = AUID then + raise EArgumentException.Create(sCantDelete); + Idx := IndexOfID(AUID); + if Idx >= 0 then + begin + DoUpdate(Idx, nil); // frees and nils item with given index + fItems.Delete(Idx); + end; +end; + +procedure TVaults.DoUpdate(const Idx: Integer; const AVault: TVault); +var + OldEntry: TVault; +begin + OldEntry := fItems[Idx]; + fItems[Idx] := AVault; + OldEntry.Free; +end; + +procedure TVaults.Finalize; +begin + Save; + Clear; + fItems.Free; +end; + +function TVaults.GetAllIDs: TArray; +var + Idx: Integer; +begin + SetLength(Result, fItems.Count); + for Idx := 0 to Pred(fItems.Count) do + Result[Idx] := fItems[Idx].UID; +end; + +function TVaults.GetVault(const AUID: TVaultID): TVault; +var + Idx: Integer; +begin + Idx := IndexOfID(AUID); + if Idx < 0 then + raise EArgumentException.CreateRes(@SGenericItemNotFound); + Result := fItems[Idx]; +end; + +function TVaults.GetEnumerator: TEnumerator; +begin + Result := fItems.GetEnumerator; +end; + +class function TVaults.GetInstance: TVaults; +begin + Result := TVaults.Create; +end; + +function TVaults.GetItem(const Idx: Integer): TVault; +begin + Result := fItems[Idx]; +end; + +function TVaults.IndexOfID(const AUID: TVaultID): Integer; +var + Idx: Integer; +begin + Result := -1; + for Idx := 0 to Pred(fItems.Count) do + if AUID = fItems[Idx].UID then + Exit(Idx); +end; + +procedure TVaults.Initialize; +begin + fItems := TList.Create; + TVaultsPersist.Load(Self); + // Ensure there is always at least the default vault present + if not ContainsID(TVaultID.Default) then + Add( + TVault.Create( + TVaultID.Default, + 'Default', + TDataStorageDetails.Create( + TDataFormatInfo.DefaultFormat, + TAppInfo.UserDefaultVaultDir + ) + ) + ); +end; + +procedure TVaults.Save; +begin + TVaultsPersist.Save(Self); +end; + +function TVaults.ToArray: TArray; +begin + Result := fItems.ToArray; +end; + +procedure TVaults.Update(const AVault: TVault); +var + Idx: Integer; +begin + Idx := IndexOfID(AVault.UID); + if Idx >= 0 then + DoUpdate(Idx, AVault); +end; + +{ TVaultID } + +constructor TVaultID.Create(const ABytes: TBytes); +begin + fID := System.Copy(ABytes); +end; + +constructor TVaultID.Create(const AStr: string); +begin + fID := TEncoding.UTF8.GetBytes(AStr); +end; + +function TVaultID.Clone: TVaultID; +begin + Result := TVaultID.Create(fID); +end; + +class function TVaultID.Compare(Left, Right: TVaultID): Integer; +var + CompareLength: Integer; + Idx: Integer; +begin + CompareLength := Min(Length(Left.fID), Length(Right.fID)); + Result := 0; + for Idx := 0 to Pred(CompareLength) do + begin + Result := Left.fID[Idx] - Right.fID[Idx]; + if Result <> 0 then + Exit; + end; + if Length(Left.fID) < Length(Right.fID) then + Exit(-1) + else if Length(Left.fID) > Length(Right.fID) then + Exit(1); +end; + +constructor TVaultID.Create(const AGUID: TGUID); +begin + fID := System.Copy(GUIDToBytes(AGUID)); +end; + +class function TVaultID.CreateFromHexString( + const AHexStr: string): TVaultID; +var + ConvertedBytes: TBytes; +begin + if not TryHexStringToBytes(AHexStr, ConvertedBytes) then + raise EVaultID.Create(SBadHexString); + Result := TVaultID.Create(ConvertedBytes); +end; + +class function TVaultID.CreateNull: TVaultID; +var + NullID: TBytes; +begin + SetLength(NullID, 0); + Result := TVaultID.Create(NullID); +end; + +class function TVaultID.Default: TVaultID; +begin + // Default vault is an empty GUID = 16 zero bytes + Result := TVaultID.Create(TGUID.Empty); +end; + +class operator TVaultID.Equal(Left, Right: TVaultID): + Boolean; +begin + Result := IsEqualBytes(Left.fID, Right.fID); +end; + +function TVaultID.Hash: Integer; +begin + Result := BobJenkinsHash(fID[0], Length(fID), 0); +end; + +function TVaultID.IsNull: Boolean; +begin + Result := Length(fID) = 0; +end; + +class operator TVaultID.NotEqual(Left, Right: TVaultID): + Boolean; +begin + Result := not IsEqualBytes(Left.fID, Right.fID); +end; + +function TVaultID.ToArray: TBytes; +begin + Result := System.Copy(fID); +end; + +function TVaultID.ToHexString: string; +begin + Result := BytesToHexString(fID); +end; + +{ TVaultID.TComparer } + +function TVaultID.TComparer.Compare(const Left, + Right: TVaultID): Integer; +begin + Result := TVaultID.Compare(Left, Right); +end; + +function TVaultID.TComparer.Equals(const Left, + Right: TVaultID): Boolean; +begin + Result := Left = Right; +end; + +function TVaultID.TComparer.GetHashCode( + const Value: TVaultID): Integer; +begin + Result := Value.Hash; +end; + +{ TVaultsPersist } + +class procedure TVaultsPersist.Load(const AVaults: TVaults); +var + ConfigSection: ISettingsSection; + Count: Integer; + Idx: Integer; +begin + ConfigSection := Settings.ReadSection(ssVaults); + Count := ConfigSection.GetInteger(CountKey, 0); + for Idx := 0 to Pred(Count) do + LoadVault(Idx, AVaults); +end; + +class procedure TVaultsPersist.LoadVault(const AOrdinal: Cardinal; + const AVaults: TVaults); +var + ConfigSection: ISettingsSection; + UID: TVaultID; + Name: string; + Vault: TVault; + StorageDetails: TDataStorageDetails; +begin + ConfigSection := Settings.ReadSection(ssVault, IntToStr(AOrdinal)); + UID := TVaultID.Create(ConfigSection.GetBytes(UIDKey)); + if AVaults.ContainsID(UID) then + // Don't load a duplicate vault + Exit; + Name := ConfigSection.GetString(NameKey, ''); + + StorageDetails := TDataStorageDetails.Create( + TDataFormatKind( + ConfigSection.GetInteger(StorageFormatKey, Ord(TDataFormatKind.Error)) + ), + ConfigSection.GetString(StorageDirectoryKey, '') + ); + Vault := TVault.Create(UID, Name, StorageDetails); + AVaults.Add(Vault); +end; + +class procedure TVaultsPersist.Save(const AVaults: TVaults); +var + ConfigSection: ISettingsSection; + Idx: Integer; +begin + // Save number of vaults + ConfigSection := Settings.EmptySection(ssVaults); + ConfigSection.SetInteger(CountKey, AVaults.Count); + ConfigSection.Save; + // Save each vault's properties in its own section + for Idx := 0 to Pred(AVaults.Count) do + SaveVault(Idx, AVaults[Idx]); +end; + +class procedure TVaultsPersist.SaveVault(const AOrdinal: Cardinal; + const AVault: TVault); +var + ConfigSection: ISettingsSection; +begin + // Save info about vault format in its own section + ConfigSection := Settings.EmptySection(ssVault, IntToStr(AOrdinal)); + ConfigSection.SetBytes(UIDKey, AVault.UID.ToArray); + ConfigSection.SetString(NameKey, AVault.Name); + ConfigSection.SetInteger(StorageFormatKey, Ord(AVault.Storage.Format)); + ConfigSection.SetString(StorageDirectoryKey, AVault.Storage.Directory); + ConfigSection.Save; +end; + +{ TVault.TComparer } + +function TVault.TComparer.Compare(const Left, Right: TVault): Integer; +begin + Result := TVaultID.Compare(Left.UID, Right.UID); +end; + +function TVault.TComparer.Equals(const Left, Right: TVault): Boolean; +begin + Result := Left.UID = Right.UID; +end; + +function TVault.TComparer.GetHashCode(const Value: TVault): Integer; +begin + Result := Value.UID.Hash; +end; + +end. + diff --git a/Src/DBIO.UIniDataReader.pas b/Src/DBIO.UIniDataReader.pas deleted file mode 100644 index 90b0c9657..000000000 --- a/Src/DBIO.UIniDataReader.pas +++ /dev/null @@ -1,618 +0,0 @@ -{ - * This Source Code Form is subject to the terms of the Mozilla Public License, - * v. 2.0. If a copy of the MPL was not distributed with this file, You can - * obtain one at https://mozilla.org/MPL/2.0/ - * - * Copyright (C) 2005-2023, Peter Johnson (gravatar.com/delphidabbler). - * - * Implements code that reads the main CodeSnip database from .ini and .dat - * files. -} - - -unit DBIO.UIniDataReader; - - -interface - - -uses - // Delphi - Classes, Generics.Collections, IniFiles, - // Project - DB.UCategory, DB.USnippet, DBIO.UFileIOIntf, UIStringList, UMainDBFileReader; - - -type - - /// - /// Reads main CodeSnip database data from .ini and .dat files. - /// - TIniDataReader = class sealed(TInterfacedObject, IDataReader) - strict private - type - /// - /// Class that implements a cache of ini file objects, indexed by ini - /// file name. - /// - TIniFileCache = class(TObject) - strict private - type - /// - /// Class that maps ini file names to related ini file objects. - /// - TIniFileMap = TObjectDictionary; - var - /// Maps file names to related ini file objects. - fCache: TIniFileMap; - /// Loads database files using correct encoding. - fFileReader: TMainDBFileReader; - public - /// Object constructor. Sets up empty cache. - constructor Create(const FileReader: TMainDBFileReader); - /// Object destructor. Frees cache. - destructor Destroy; override; - /// - /// Gets reference to ini file object. Creates it if it doesn't extist. - /// - /// string [in] Fully specified path to ini - /// file. - /// TCustomIniFile instance for reading ini file. - /// Caller must not free the returned TCustomIniFile instance. - /// - function GetIniFile(const PathToFile: string): TCustomIniFile; - end; - type - /// Class that maps snippet names to category ids. - TSnippetCatMap = TDictionary; - var - /// Database directory. - fDBDir: string; - /// Reference to master ini file. - fMasterIni: TCustomIniFile; - /// List of category ids in database. - fCatIDs: TStringList; - /// Map of snippet names to category ids. - fSnippetCatMap: TSnippetCatMap; - /// Cache of category ini file objects. - fIniCache: TIniFileCache; - /// Reads DB files using correct encoding. - fFileReader: TMainDBFileReader; - /// - /// Returns fully specified name of database master file. - /// - function MasterFileName: string; - /// - /// Returns ID of category associated with a snippet. - /// - /// string [in] Name of snippet. - /// string containing category ID - function SnippetToCat(const Snippet: string): string; - /// - /// Returns name of ini file containing details of a category. - /// - /// string [in] Id of category. - /// string containing bame of category's ini file - function CatToCatIni(const CatID: string): string; - /// - /// Loads indices of all names of categories and snippets in database. - /// - /// - /// Having these indices available speeds up several of the main methods. - /// - procedure LoadIndices; - /// - /// Handles exceptions raised when a corrupt database is encountered. - /// Deletes all files and re-raises exception. - /// - /// Exception object to be handled. - procedure HandleCorruptDatabase(const EObj: TObject); - /// - /// Returns name of directory where the database is stored. - /// - function DataDir: string; - /// - /// Returns fully specified path to given file name. - /// - function DataFile(const FileName: string): string; - /// - /// Gets a list from ini file of all of items of a specified kind that are - /// referenced by a snippet. - /// - /// string [in] Name of snippet. - /// string [in] Name of a key in ini file storing - /// comma separated list of references. - /// IStringList containing names of referenced items. - function GetSnippetReferences(const Snippet, RefName: string): IStringList; - strict protected - /// - /// Extracts comma delimited text fields into a string list. - /// - /// string [in] Comma delimited text. - /// IStringList containing fields. - class function CommaStrToStrings(const CommaStr: string): IStringList; - public - /// - /// Object constructor. Checks if database exists and sets up indices. - /// - /// string [in] Directory containing database. - constructor Create(const DBDir: string); - /// - /// Object destructor. Tears down object. - /// - destructor Destroy; override; - { IDataReader methods } - /// - /// Checks if the database exists. - /// - /// - /// This method is always called before any other IDataReader methods. The - /// other methods are not called if this method returns False. - /// - function DatabaseExists: Boolean; - /// - /// Gets name of all categories in the database. - /// - /// IStringList containing names. - function GetAllCatIDs: IStringList; - /// - /// Gets properties of a category. - /// - /// string [in] Id of category. - /// TCategoryData [in/out] Receives empty property - /// record and updates relevant property fields. - procedure GetCatProps(const CatID: string; var Props: TCategoryData); - /// - /// Gets names of all snippets in a category. - /// - /// string [in] Id of category. - /// IStringList containing names of snippets. - function GetCatSnippets(const CatID: string): IStringList; - /// - /// Gets properties of a snippet. - /// - /// string [in] Name of snippet. - /// TSnippetData [in/out] Receives empty property - /// record and updates relevant property fields. - procedure GetSnippetProps(const Snippet: string; var Props: TSnippetData); - /// - /// Gets list of all snippets that are cross referenced by a specified - /// snippet. - /// - /// string [in] Name of snippet. - /// IStringList containing snippet names. - function GetSnippetXRefs(const Snippet: string): IStringList; - /// - /// Gets list of all snippets on which a specified snippet depends. - /// - /// string [in] Name of snippet. - /// IStringList containing snippet names. - function GetSnippetDepends(const Snippet: string): IStringList; - /// - /// Gets list of all units referenced by a snippet. - /// - /// string [in] Name of snippet. - /// IStringList containing unit names. - function GetSnippetUnits(const Snippet: string): IStringList; - end; - - -implementation - - -uses - // Delphi - SysUtils, - // Project - ActiveText.UMain, Compilers.UGlobals, DB.USnippetKind, UComparers, UConsts, - UIniDataLoader, USnippetExtraHelper, UStrUtils, UUtils; - - -const - // Name of master file that defines database - cMasterFileName = 'categories.ini'; - // Names of values in categories ini file - cMasterIniName = 'Ini'; // name of category ini file - cMasterDescName = 'Desc'; // category description - // Names of values in snippet sections of various category ini files - cDependsName = 'Depends'; // dependency list for snippet - cUnitsName = 'Units'; // required unit list for snippet - cXRefName = 'SeeAlso'; // cross-reference list for snippet - cDisplayName = 'DisplayName'; // snippet's display name if any - cExtraName = 'Extra'; // extra information for snippet - cCreditsName = 'Credits'; // snippet credits - cCreditsURLName = 'Credits_URL'; // url relating to snippet credits - cCommentsName = 'Comments'; // snippet additional comments - cDescName = 'Desc'; // snippet description (plain text) - cDescExName = 'DescEx'; // snippet descriptio (REML) - cSnipFileName = 'Snip'; // name of snippet's snippet file - cStdFormatName = 'StandardFormat'; // whether snippet in std format - cKindName = 'Kind'; // kind of snippet - cTestInfoName = 'TestInfo'; // snippet's testing information - cCompilerIDNames: // snippet's compiler results for each - array[TCompilerID] of string = ( - 'Delphi2', 'Delphi3', 'Delphi4', 'Delphi5', 'Delphi6', 'Delphi7', - 'Delphi2005Win32', 'Delphi2006Win32', 'Delphi2007', 'Delphi2009Win32', - 'Delphi2010', 'DelphiXE', 'DelphiXE2', 'DelphiXE3', 'DelphiXE4', - 'DelphiXE5', 'DelphiXE6', 'DelphiXE7', 'DelphiXE8', 'Delphi10S', - 'Delphi101B', 'Delphi102T', 'Delphi103R', 'Delphi104S', 'Delphi11A', - 'Delphi12A', - 'FPC' - ); - -{ TIniDataReader } - -function TIniDataReader.CatToCatIni(const CatID: string): string; -begin - Result := DataFile(fMasterIni.ReadString(CatID, cMasterIniName, '')); -end; - -class function TIniDataReader.CommaStrToStrings( - const CommaStr: string): IStringList; -begin - Result := TIStringList.Create(CommaStr, ',', False, True); -end; - -constructor TIniDataReader.Create(const DBDir: string); -begin - inherited Create; - fDBDir := DBDir; - // Create helper objects used to speed up access to ini files - if DatabaseExists then - begin - fFileReader := TMainDBFileReader.Create(MasterFileName); - fIniCache := TIniFileCache.Create(fFileReader); - try - fMasterIni := TDatabaseIniFile.Create(fFileReader, MasterFileName); - fCatIDs := TStringList.Create; - fSnippetCatMap := TSnippetCatMap.Create(TTextEqualityComparer.Create); - // Load required indexes - LoadIndices; - except - HandleCorruptDatabase(ExceptObject); - end; - end; -end; - -function TIniDataReader.DatabaseExists: Boolean; -begin - Result := FileExists(MasterFileName); -end; - -function TIniDataReader.DataDir: string; -begin - Result := ExcludeTrailingPathDelimiter(fDBDir) -end; - -function TIniDataReader.DataFile(const FileName: string): string; -begin - Result := IncludeTrailingPathDelimiter(DataDir) + FileName; -end; - -destructor TIniDataReader.Destroy; -begin - fFileReader.Free; - fIniCache.Free; - fSnippetCatMap.Free; - fCatIDs.Free; - fMasterIni.Free; - inherited; -end; - -function TIniDataReader.GetAllCatIDs: IStringList; -begin - Result := TIStringList.Create(fCatIDs); -end; - -procedure TIniDataReader.GetCatProps(const CatID: string; - var Props: TCategoryData); -begin - try - Props.Desc := fMasterIni.ReadString(CatID, cMasterDescName, ''); - except - HandleCorruptDatabase(ExceptObject); - end; -end; - -function TIniDataReader.GetCatSnippets(const CatID: string): IStringList; -var - CatIni: TCustomIniFile; // accesses .ini file associated with category - SnipList: TStringList; // list of snippets in category -begin - try - // Snippet names are names of sections in category's .ini file - CatIni := fIniCache.GetIniFile(CatToCatIni(CatID)); - SnipList := TStringList.Create; - try - CatIni.ReadSections(SnipList); - Result := TIStringList.Create(SnipList); - finally - SnipList.Free; - end; - except - HandleCorruptDatabase(ExceptObject); - end; -end; - -function TIniDataReader.GetSnippetDepends(const Snippet: string): IStringList; -begin - Result := GetSnippetReferences(Snippet, cDependsName); -end; - -procedure TIniDataReader.GetSnippetProps(const Snippet: string; - var Props: TSnippetData); -var - CatIni: TCustomIniFile; // .ini file associated with snippet's category - CatID: string; // snippet's category id - - // --------------------------------------------------------------------------- - /// Reads "StandardFormat" value from ini file. - function GetStdFormatProperty: Boolean; - begin - Result := CatIni.ReadBool(Snippet, cStdFormatName, True); - end; - - /// Reads "Kind" value from ini file. - function GetKindProperty: TSnippetKind; - var - KindStr: string; // string value read from ini file - begin - KindStr := CatIni.ReadString(Snippet, cKindName, ''); - if StrSameText(KindStr, 'freeform') then - Result := skFreeform - else if StrSameText(KindStr, 'routine') then - Result := skRoutine - else if StrSameText(KindStr, 'const') then - Result := skConstant - else if StrSameText(KindStr, 'type') then - Result := skTypeDef - else if StrSameText(KindStr, 'unit') then - Result := skUnit - else if StrSameText(KindStr, 'class') then - Result := skClass - // invalid or no Kind property: kind depends on StdFormat property - else if GetStdFormatProperty then - Result := skRoutine - else - Result := skFreeform; - end; - - /// Reads "Extra" value from ini file and converts to active text. - /// - function GetExtraProperty: IActiveText; - var - Extra: string; // extra value from ini file if present - begin - try - Extra := CatIni.ReadString(Snippet, cExtraName, ''); - if Extra <> '' then - // There is an "extra" value: use it to set Extra property. We ignore - // any credits, credits url and comments values in this case - Result := TSnippetExtraHelper.BuildActiveText(Extra) - else - // There is no "extra" value: use any comments, credits and credits URL - // values to set Extra property - Result := TSnippetExtraHelper.BuildActiveText( - CatIni.ReadString(Snippet, cCommentsName, ''), - CatIni.ReadString(Snippet, cCreditsName, ''), - CatIni.ReadString(Snippet, cCreditsURLName, '') - ); - except - // There was an error: use an empty property value - Result := TActiveTextFactory.CreateActiveText; - end; - end; - - /// Reads "Snip" value from ini value and loads source code from the - /// referenced file. - function GetSourceCodeProperty: string; - var - SnipFileName: string; // name of file containing source code - begin - SnipFileName := CatIni.ReadString(Snippet, cSnipFileName, ''); - try - Result := fFileReader.ReadAllText(DataFile(SnipFileName)); - except - // if error loading file then database is corrupt - on E: EFOpenError do - raise EDataIO.Create(E); - else - raise; - end; - end; - - /// Reads all compiler ID values from ini file and builds list of - /// compiler results. - function GetCompilerResultsProperty: TCompileResults; - var - CompID: TCompilerID; // loops thru supported compilers - CompRes: string; // character indicating compiler result - begin - for CompID := Low(TCompilerID) to High(TCompilerID) do - begin - CompRes := CatIni.ReadString(Snippet, cCompilerIDNames[CompID], '?'); - if CompRes = '' then - CompRes := '?'; - case CompRes[1] of - 'W', // warning result now treated as success - 'Y': Result[CompID] := crSuccess; - 'N': Result[CompID] := crError; - else Result[CompID] := crQuery; - end; - end; - end; - - /// Gets snippet description from ini file. - /// Uses REML from DescEx field if present, otherwise uses plain - /// text from Desc field if present, otherwise description is empty. - /// - function GetDescription: IActiveText; - var - REML: string; // REML code from DescEx field - PlainText: string; // plain text from Desc field - begin - REML := CatIni.ReadString(Snippet, cDescExName, ''); - if REML <> '' then - Result := TSnippetExtraHelper.BuildActiveText(REML) - else - begin - PlainText := CatIni.ReadString(Snippet, cDescName, ''); - if PlainText <> '' then - Result := TSnippetExtraHelper.PlainTextToActiveText(PlainText) - else - Result := TActiveTextFactory.CreateActiveText; - end; - end; - - /// Gets snippet's display name from ini file. - function GetDisplayNameProperty: string; - begin - Result := CatIni.ReadString(Snippet, cDisplayName, ''); - end; - - /// Get's snippet's test info from ini file. - function GetTestInfoProperty: TSnippetTestInfo; - var - Str: string; // string value read from ini file - begin - Str := CatIni.ReadString(Snippet, cTestInfoName, 'basic'); - if StrSameText(Str, 'basic') then - Result := stiBasic - else if StrSameText(Str, 'advanced') then - Result := stiAdvanced - else // Str = 'none' or any invalid value - Result := stiNone; - end; - // --------------------------------------------------------------------------- - -begin - try - // Get name of category associated with this snippet - CatID := SnippetToCat(Snippet); - // Get snippet properties from values listed under snippet's section in - // category's .ini file - CatIni := fIniCache.GetIniFile(CatToCatIni(CatID)); - Props.Kind := GetKindProperty; - Props.Cat := CatID; - Props.Desc := GetDescription; - Props.Extra := GetExtraProperty; - Props.DisplayName := GetDisplayNameProperty; - Props.SourceCode := GetSourceCodeProperty; - Props.CompilerResults := GetCompilerResultsProperty; - Props.TestInfo := GetTestInfoProperty; - // all snippets from main database are Pascal and use syntax highlighter: - // there is no entry in data files to switch this on or off - Props.HiliteSource := True; - except - HandleCorruptDatabase(ExceptObject); - end; -end; - -function TIniDataReader.GetSnippetReferences(const Snippet, - RefName: string): IStringList; -var - CatIni: TCustomIniFile; // accesses snippet's category's .ini -begin - try - // References are contained in comma separated value in category's ini file - // under snippet's section - CatIni := fIniCache.GetIniFile(CatToCatIni(SnippetToCat(Snippet))); - Result := CommaStrToStrings(CatIni.ReadString(Snippet, RefName, '')); - except - HandleCorruptDatabase(ExceptObject); - end; -end; - -function TIniDataReader.GetSnippetUnits(const Snippet: string): IStringList; -begin - Result := GetSnippetReferences(Snippet, cUnitsName); -end; - -function TIniDataReader.GetSnippetXRefs(const Snippet: string): IStringList; -begin - Result := GetSnippetReferences(Snippet, cXRefName); -end; - -procedure TIniDataReader.HandleCorruptDatabase(const EObj: TObject); -resourcestring - // Error message - sDBError = 'The database is corrupt and had been deleted.' + EOL2 + '%s'; -begin - DeleteFiles(DataDir, '*.*'); - if (EObj is EDataIO) - or (EObj is EFileStreamError) - or (EObj is EDatabaseIniFile) then - // we have database error: raise new exception containing old message - raise EDataIO.CreateFmt(sDBError, [(EObj as Exception).Message]) - else - // not an ECodeSnip: just re-raise - raise EObj; -end; - -procedure TIniDataReader.LoadIndices; -var - SnippetName: string; // each snippet name in a category - CatIdx: Integer; // loops thru all categories - CatSnippets: IStringList; // list of snippets in a single category -begin - // Read in list of category names - fMasterIni.ReadSections(fCatIDs); - // We build map of snippet names to categories by reading snippets in each - // category and referencing that category's id with the snippet name. - CatSnippets := TIStringList.Create; - for CatIdx := 0 to Pred(fCatIDs.Count) do - begin - // Get list of snippets in category ... - CatSnippets := GetCatSnippets(fCatIDs[CatIdx]); - for SnippetName in CatSnippets do - fSnippetCatMap.Add(SnippetName, CatIdx); - end; -end; - -function TIniDataReader.MasterFileName: string; -begin - Result := DataFile(cMasterFileName); -end; - -function TIniDataReader.SnippetToCat(const Snippet: string): string; -var - CatIdx: Integer; // index of category in category list for this snippet -resourcestring - // Error message - sMissingSnippet = 'Snippet "%s" not found in database.'; -begin - if not fSnippetCatMap.ContainsKey(Snippet) then - raise EDataIO.CreateFmt(sMissingSnippet, [Snippet]); - CatIdx := fSnippetCatMap[Snippet]; - Result := fCatIDs[CatIdx]; -end; - -{ TIniDataReader.TIniFileCache } - -constructor TIniDataReader.TIniFileCache.Create( - const FileReader: TMainDBFileReader); -begin - inherited Create; - fFileReader := FileReader; - // fCache owns and frees the ini file objects - fCache := TIniFileMap.Create( - [doOwnsValues], TTextEqualityComparer.Create - ); -end; - -destructor TIniDataReader.TIniFileCache.Destroy; -begin - fCache.Free; // frees owned .Values[] objects - inherited; -end; - -function TIniDataReader.TIniFileCache.GetIniFile( - const PathToFile: string): TCustomIniFile; -begin - if not fCache.ContainsKey(PathToFile) then - fCache.Add(PathToFile, TDatabaseIniFile.Create(fFileReader, PathToFile)); - Result := fCache[PathToFile]; -end; - -end. - diff --git a/Src/ExternalObj.ridl b/Src/ExternalObj.ridl index fcf28f613..5c1572b87 100644 --- a/Src/ExternalObj.ridl +++ b/Src/ExternalObj.ridl @@ -3,7 +3,7 @@ * v. 2.0. If a copy of the MPL was not distributed with this file, You can * obtain one at https://mozilla.org/MPL/2.0/ * - * Copyright (C) 2006-2021, Peter Johnson (gravatar.com/delphidabbler). + * Copyright (C) 2006-2024, Peter Johnson (gravatar.com/delphidabbler). * * Source for type library that defines the interface to extensions to the * browser control DOM's "external object". @@ -12,46 +12,41 @@ [ uuid(DA95AEFB-3FB5-4A9E-9F9D-A53DD05CA7D4), - version(14.0), + version(15.0), helpstring("CodeSnip DOM External Object Extender Type Library"), custom(DE77BA64-517C-11D1-A2DA-0000F8773CE9, 117441012), custom(DE77BA63-517C-11D1-A2DA-0000F8773CE9, 1219706147) - ] + library ExternalObj { importlib("stdole2.tlb"); /* - * V14 interface of extension to browser DOM's "external" object. + * V15 interface of extension to browser DOM's "external" object. */ - interface IWBExternal14; + interface IWBExternal15; [ uuid(BA971829-ED4D-4092-BCAE-4B5DB1A2D74A), - version(14.0), + version(15.0), helpstring("DOM external object extender"), dual, oleautomation ] - interface IWBExternal14: IDispatch + interface IWBExternal15: IDispatch { - /* - * Update database from internet. - */ - [id(0x00000065)] - HRESULT _stdcall UpdateDbase(void); /* - * Display named snippet. - * @param SnippetName [in] Name of snippet to display. - * @param UserDefined [in] Whether snippet is user defined. + * Display snippet identified by key and vault ID. + * @param Key [in] Snippet's key. + * @param VaultIDAsHex [in] Hex representation of snippet's vault ID. */ - [id(0x00000066)] - HRESULT _stdcall DisplaySnippet([in] BSTR SnippetName, - [in] VARIANT_BOOL UserDefined, [in] VARIANT_BOOL NewTab); + [id(0x00000080)] + HRESULT _stdcall DisplaySnippet([in] BSTR Key, + [in] BSTR VaultIDAsHex, [in] VARIANT_BOOL NewTab); /* * Displays configure compilers dialog box. @@ -60,11 +55,12 @@ library ExternalObj HRESULT _stdcall ConfigCompilers(void); /* - * Edits the named snippet. - * @param SnippetName [in] Name of snippet to edit. Must be user defined. + * Edits the snippet identified by its key. + * @param Key [in] Key of snippet to edit. Must be user defined. + * @param VaultIDAsHex [in] Hex representation of snippet's vault ID. */ [id(0x0000006C)] - HRESULT _stdcall EditSnippet([in] BSTR SnippetName); + HRESULT _stdcall EditSnippet([in] BSTR Key, [in] BSTR VaultIDAsHex); /* * Display identified category. @@ -73,12 +69,6 @@ library ExternalObj [id(0x0000006E)] HRESULT _stdcall DisplayCategory([in] BSTR CatID, [in] VARIANT_BOOL NewTab); - /* - * Open Snippets Editor ready to create a new snippet. - */ - [id(0x0000006F)] - HRESULT _stdcall NewSnippet(void); - /* * Show news items from CodeSnip news feed. */ diff --git a/Src/Favourites.UFavourites.pas b/Src/Favourites.UFavourites.pas index 0a5154621..b8c35cee5 100644 --- a/Src/Favourites.UFavourites.pas +++ b/Src/Favourites.UFavourites.pas @@ -19,7 +19,8 @@ interface // Delphi Generics.Collections, // Project - UMultiCastEvents, USnippetIDs; + DB.SnippetIDs, + UMultiCastEvents; type diff --git a/Src/Favourites.UManager.pas b/Src/Favourites.UManager.pas index da119c289..e81c2a360 100644 --- a/Src/Favourites.UManager.pas +++ b/Src/Favourites.UManager.pas @@ -18,7 +18,10 @@ interface uses // Delphi - Favourites.UFavourites, USnippetIDs, IntfNotifier, UView; + DB.SnippetIDs, + Favourites.UFavourites, + IntfNotifier, + UView; type @@ -78,7 +81,10 @@ implementation // Delphi SysUtils, // Project - DB.UMain, DB.USnippet, Favourites.UPersist, FmFavouritesDlg; + DB.Main, + DB.Snippets, + Favourites.UPersist, + FmFavouritesDlg; { TFavouritesManager } diff --git a/Src/Favourites.UPersist.pas b/Src/Favourites.UPersist.pas index 9f73ab49d..97ca36d98 100644 --- a/Src/Favourites.UPersist.pas +++ b/Src/Favourites.UPersist.pas @@ -17,8 +17,11 @@ interface uses + // Delphi + SysUtils, // Project - Favourites.UFavourites, UExceptions; + Favourites.UFavourites, + UExceptions; type @@ -33,10 +36,10 @@ TFavouritesPersist = record const /// Watermark that is present one the first line of a valid /// favourites file. - Watermark = #$25BA + ' CodeSnip Favourites v1 ' + #$25C4; - strict private - /// Returns fully specified name of the favourites file. - class function FavouritesFileName: string; static; + Watermark = #$25BA + ' CodeSnip Favourites v2 ' + #$25C4; + /// Returns date format settings to be used when writing and + /// reading the Favourites file. + class function DateFormatSettings: TFormatSettings; static; public /// Saves all favourites from given favourites list to file. /// @@ -52,97 +55,107 @@ implementation uses // Delphi - SysUtils, IOUtils, Classes, + IOUtils, + Classes, /// Project - DB.UMain, UAppInfo, UConsts, UIOUtils, UIStringList, USnippetIDs, UStrUtils; + DB.Main, + DB.SnippetIDs, + DB.Vaults, + UAppInfo, + UConsts, + UIOUtils, + UIStringList, + UStrUtils, + UTabSeparatedFileIO; { TFavouritesPersist } -class function TFavouritesPersist.FavouritesFileName: string; +class function TFavouritesPersist.DateFormatSettings: TFormatSettings; begin - Result := IncludeTrailingPathDelimiter(TAppInfo.UserAppDir) - + 'Favourites'; + // We use YYYY-MM-DD HH:MM:SS date format in Favourites file + Result := TFormatSettings.Create; + Result.DateSeparator := '-'; + Result.TimeSeparator := ':'; + Result.ShortDateFormat := 'yyyy/mm/dd'; + Result.ShortTimeFormat := 'hh:nn:ss'; end; class procedure TFavouritesPersist.Load(Favourites: TFavourites); var - Lines: IStringList; - Line: string; - Fields: IStringList; - SnippetName: string; - UserDef: Boolean; - LastAccess: TDateTime; + TSVReader: TTabSeparatedReader; resourcestring - sBadFormat = 'Invalid favourites file format'; + sBadFormat = 'Invalid favourites file format (v2)'; begin - if not TFile.Exists(FavouritesFileName, False) then + if not TFile.Exists(TAppInfo.UserFavouritesFileName, False) then Exit; + try - Lines := TIStringList.Create( - TFileIO.ReadAllLines(FavouritesFileName, TEncoding.UTF8, True) + TSVReader := TTabSeparatedReader.Create( + TAppInfo.UserFavouritesFileName, Watermark ); + try + TSVReader.Read( + procedure (AFields: TArray) + var + Key: string; + VaultID: TVaultID; + LastAccess: TDateTime; + begin + if Length(AFields) <> 3 then + raise EFavouritesPersist.Create(sBadFormat); + Key := StrTrim(AFields[0]); + VaultID := TVaultID.CreateFromHexString(StrTrim(AFields[1])); + LastAccess := StrToDateTime(StrTrim(AFields[2]), DateFormatSettings); + if Database.Snippets.Find(Key, VaultID) <> nil then + Favourites.Add(TSnippetID.Create(Key, VaultID), LastAccess); + end + ); + finally + TSVReader.Free; + end; + except - on E: EStreamError do + on E: EConvertError do raise EFavouritesPersist.Create(E); - on E: EIOUtils do + on E: ETabSeparatedReader do raise EFavouritesPersist.Create(E); else raise; end; - Line := Lines[0]; - if Line <> Watermark then - raise EFavouritesPersist.Create(sBadFormat); - Lines.Delete(0); - for Line in Lines do - begin - if StrTrim(Line) = '' then - Continue; - Fields := TIStringList.Create(Line, TAB, False, True); - if Fields.Count <> 3 then - raise EFavouritesPersist.Create(sBadFormat); - SnippetName := Fields[0]; - UserDef := True; // accept any text as true excpet "false" - if StrSameText(Fields[1], 'false') then - UserDef := False; - if not TryStrToDateTime(Fields[2], LastAccess) then - raise EFavouritesPersist.Create(sBadFormat); - // only add to favourites if snippet in database - if Database.Snippets.Find(SnippetName, UserDef) <> nil then - Favourites.Add(TSnippetID.Create(SnippetName, UserDef), LastAccess); - end; end; class procedure TFavouritesPersist.Save(Favourites: TFavourites); var - SB: TStringBuilder; Fav: TFavourite; + TSVWriter: TTabSeparatedFileWriter; begin - SB := TStringBuilder.Create; + TDirectory.CreateDirectory( + TPath.GetDirectoryName(TAppInfo.UserFavouritesFileName) + ); try - SB.AppendLine(Watermark); - for Fav in Favourites do - begin - SB.Append(Fav.SnippetID.Name); - SB.Append(TAB); - SB.Append(BoolToStr(Fav.SnippetID.UserDefined, True)); - SB.Append(TAB); - SB.Append(DateTimeToStr(Fav.LastAccessed)); - SB.AppendLine; - end; - TDirectory.CreateDirectory(TPath.GetDirectoryName(FavouritesFileName)); + TSVWriter := TTabSeparatedFileWriter.Create( + TAppInfo.UserFavouritesFileName, Watermark + ); try - TFileIO.WriteAllText( - FavouritesFileName, SB.ToString, TEncoding.UTF8, True - ); - except - on E: EStreamError do - raise EFavouritesPersist.Create(E); - else - raise; + for Fav in Favourites do + begin + TSVWriter.WriteLine( + [ + Fav.SnippetID.Key, + Fav.SnippetID.VaultID.ToHexString, + DateTimeToStr(Fav.LastAccessed, DateFormatSettings) + ] + ); + end; + finally + TSVWriter.Free; end; - finally - SB.Free; + except + on E: EStreamError do + raise EFavouritesPersist.Create(E); + else + raise; end; end; diff --git a/Src/FmAboutDlg.dfm b/Src/FmAboutDlg.dfm index cfc0062f7..ea3d25d6b 100644 --- a/Src/FmAboutDlg.dfm +++ b/Src/FmAboutDlg.dfm @@ -27,12 +27,16 @@ inherited AboutDlg: TAboutDlg Top = 47 Width = 409 Height = 218 - ActivePage = tsPaths + ActivePage = tsVaults Align = alTop TabOrder = 0 OnMouseDown = pcDetailMouseDown object tsProgram: TTabSheet Caption = 'About The Program' + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 inline frmProgram: THTMLTpltDlgFrame Left = 0 Top = 0 @@ -63,60 +67,89 @@ inherited AboutDlg: TAboutDlg end end end - object tsDatabase: TTabSheet - Caption = 'About The Database' + object tsVaults: TTabSheet + Caption = 'About Vaults' ImageIndex = 1 - inline frmDatabase: THTMLTpltDlgFrame - Left = 0 + DesignSize = ( + 401 + 190) + object lblVaults: TLabel + Left = 3 + Top = 3 + Width = 60 + Height = 13 + Caption = '&Select vault:' + FocusControl = cbVaults + end + object cbVaults: TComboBox + Left = 112 Top = 0 - Width = 401 - Height = 190 - Align = alClient + Width = 286 + Height = 21 + Style = csDropDownList + Anchors = [akLeft, akTop, akRight] TabOrder = 0 - TabStop = True - ExplicitWidth = 401 - ExplicitHeight = 190 - inherited pnlBrowser: TPanel - Width = 401 - Height = 190 - ExplicitWidth = 401 - ExplicitHeight = 190 - inherited wbBrowser: TWebBrowser - Width = 401 - Height = 190 - ExplicitWidth = 345 - ExplicitHeight = 133 - ControlData = { - 4C00000072290000A31300000000000000000000000000000000000000000000 - 000000004C000000000000000000000001000000E0D057007335CF11AE690800 - 2B2E126208000000000000004C0000000114020000000000C000000000000046 - 8000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000100000000000000000000000000000000000000} - end - end + OnChange = cbVaultsChange + end + object tvVaultInfo: TTreeView + Left = 0 + Top = 27 + Width = 401 + Height = 163 + Anchors = [akLeft, akTop, akRight, akBottom] + BorderStyle = bsNone + Indent = 19 + ParentColor = True + ReadOnly = True + ShowRoot = False + TabOrder = 1 end end object tsPaths: TTabSheet Caption = 'Paths && Files' ImageIndex = 2 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 + DesignSize = ( + 401 + 190) object btnViewAppConfig: TButton Left = 3 - Top = 144 + Top = 3 Width = 170 Height = 25 Caption = 'View Application Config File...' - TabOrder = 1 + TabOrder = 0 OnClick = btnViewAppConfigClick end object btnViewUserConfig: TButton - Left = 192 - Top = 144 + Left = 228 + Top = 3 Width = 170 Height = 25 + Anchors = [akTop, akRight] Caption = 'View Per-User Config File...' - TabOrder = 0 + TabOrder = 1 OnClick = btnViewUserConfigClick end + object sbPaths: TScrollBox + Left = 3 + Top = 34 + Width = 395 + Height = 153 + BevelInner = bvLowered + BevelOuter = bvRaised + BevelKind = bkFlat + BorderStyle = bsNone + Padding.Left = 3 + Padding.Top = 3 + Padding.Right = 3 + Padding.Bottom = 3 + TabOrder = 2 + TabStop = True + end end end object pnlTitle: TPanel diff --git a/Src/FmAboutDlg.pas b/Src/FmAboutDlg.pas index a26397685..f6012eb91 100644 --- a/Src/FmAboutDlg.pas +++ b/Src/FmAboutDlg.pas @@ -24,14 +24,17 @@ interface ExtCtrls, Classes, Messages, + Generics.Collections, // Project Browser.UHTMLEvents, - DB.UMetaData, + DB.MetaData, + DB.Vaults, FmGenericViewDlg, FrBrowserBase, FrHTMLDlg, FrHTMLTpltDlg, UCSSBuilder, + UI.Adapters.VaultList, UIStringList; @@ -75,28 +78,31 @@ TPathInfoBox = class(TCustomGroupBox) property Path: string read GetPath write SetPath; end; - /// Implements program' about dialogue box. - /// Displays information about the program, the main database and + /// Implements program's about dialogue box. + /// Displays information about the program, the vautls in use and /// the program's user and application folders and config files. Also /// provides access to the program's easter egg. TAboutDlg = class(TGenericViewDlg) bvlSeparator: TBevel; - frmDatabase: THTMLTpltDlgFrame; frmProgram: THTMLTpltDlgFrame; pcDetail: TPageControl; - tsDatabase: TTabSheet; + tsVaults: TTabSheet; tsProgram: TTabSheet; pnlTitle: TPanel; frmTitle: THTMLTpltDlgFrame; tsPaths: TTabSheet; btnViewAppConfig: TButton; btnViewUserConfig: TButton; + cbVaults: TComboBox; + lblVaults: TLabel; + tvVaultInfo: TTreeView; + sbPaths: TScrollBox; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); - /// Handles event triggered when user clicks on one of page - /// control tabs. Ensures page control has focus. - /// Without this fix, page control does not always get focus when - /// a tab is clicked. + /// Handles event triggered when user clicks on one of the page + /// control tabs. Ensures the page control has focus. + /// Without this fix, the page control does not always get focus # + /// when a tab is clicked. procedure pcDetailMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); /// Handles button click event to display application config file. @@ -105,16 +111,18 @@ TAboutDlg = class(TGenericViewDlg) /// Handles button click event to display per-user config file. /// procedure btnViewUserConfigClick(Sender: TObject); + /// Handles the change event triggered when the user selects a + /// vault in the vaults combo box. Updates the display of information about + /// the selected vault. + procedure cbVaultsChange(Sender: TObject); strict private var - /// Control that displays main database folder. - fMainDBPathGp: TPathInfoBox; - /// Control that displays user database folder. - fUserDBPathGp: TPathInfoBox; - /// Control that displays program install path. - fInstallPathGp: TPathInfoBox; - /// Provides access to main database meta data. - fMetaData: IDBMetaData; + /// List of dynamically created path information group boxes. + /// + fPathInfoBoxes: TList; + /// Provides a sorted list of vault names for display in the + /// vault combo box. + fVaultList: TVaultListAdapter; /// Handles title frame's OnHTMLEvent event. Checks for mouse /// events relating to display of the easter egg and acts accordingly. /// @@ -123,12 +131,10 @@ TAboutDlg = class(TGenericViewDlg) /// information about the event. procedure HTMLEventHandler(Sender: TObject; const EventInfo: THTMLEventInfo); - /// Builds HTML used to display list of contributors or an error - /// message if the list is empty. - /// IStringList [in] List of contributors to - /// display. - /// string. Required HTML. - function ContribListHTML(ContribList: IStringList): string; + /// Displays any meta data associated with a vault. + /// TVault [in] Vault for which meta data + /// is to be displayed. + procedure DisplayVaultInfo(AVault: TVault); /// Displays content of a config file in a dialogue box or an /// error message if the file does not exist. /// string [in] Name of config file to display. @@ -151,17 +157,16 @@ TAboutDlg = class(TGenericViewDlg) /// TCSSBuilder [in] Object used to update CSS. /// procedure UpdateTitleCSS(Sender: TObject; const CSSBuilder: TCSSBuilder); - /// Updates CSS used for HTML displayed in detail frames. - /// + /// Updates CSS used for HTML displayed in About The Program + /// tab frame. /// TObject [in] Not used. /// TCSSBuilder [in] Object used to update CSS. /// - /// Details frames form the body of the About Box on the Program - /// and Database tabs. - procedure UpdateDetailCSS(Sender: TObject; const CSSBuilder: TCSSBuilder); + procedure UpdateProgramTabCSS(Sender: TObject; + const CSSBuilder: TCSSBuilder); public /// Displays dialog box. - /// TComponent [in] Component that owns this dialogus + /// TComponent [in] Component that owns this dialogue /// box. class procedure Execute(AOwner: TComponent); end; @@ -179,25 +184,22 @@ implementation ShellAPI, IOUtils, // Project - DB.UMain, + DB.DataFormats, FmEasterEgg, FmPreviewDlg, UAppInfo, - UColours, UConsts, UCSSUtils, UCtrlArranger, UEncodings, UFontHelper, UGraphicUtils, - UHTMLUtils, UHTMLTemplate, UIOUtils, UMessageBox, UResourceUtils, UStrUtils, - UThemesEx, - UVersionInfo; + UThemesEx; {$R *.dfm} @@ -218,29 +220,44 @@ function ExploreFolder(const Folder: string): Boolean; procedure TAboutDlg.ArrangeForm; var - PathTabHeight: Integer; + PathInfoBox: TPathInfoBox; + NextPathInfoBoxTop: Integer; begin - fMainDBPathGp.Top := TCtrlArranger.BottomOf(fInstallPathGp, 8); - fUserDBPathGp.Top := TCtrlArranger.BottomOf(fMainDBPathGp, 8); - TCtrlArranger.AlignTops( - [btnViewAppConfig, btnViewUserConfig], - TCtrlArranger.BottomOf(fUserDBPathGp, 8) - ); - PathTabHeight := TCtrlArranger.BottomOf( - [btnViewUserConfig, btnViewAppConfig] - ); - TCtrlArranger.AlignLefts([fUserDBPathGp, btnViewAppConfig]); - TCtrlArranger.AlignRights([fUserDBPathGp, btnViewUserConfig]); + // Vaults tab + TCtrlArranger.AlignVCentres(8, [lblVaults, cbVaults]); + TCtrlArranger.MoveToRightOf(lblVaults, cbVaults, 12); + TCtrlArranger.MoveBelow([lblVaults, cbVaults], tvVaultInfo, 8); + + // Paths tab + TCtrlArranger.AlignTops([btnViewAppConfig, btnViewUserConfig], 8); + TCtrlArranger.MoveBelow([btnViewAppConfig, btnViewUserConfig], sbPaths, 8); + // stack path group boxes vertically + NextPathInfoBoxTop := 8; + for PathInfoBox in fPathInfoBoxes do + begin + PathInfoBox.Top := NextPathInfoBoxTop; + Inc(NextPathInfoBoxTop, PathInfoBox.Height + 8); + end; + // align ctrl left & right sides + TCtrlArranger.AlignLefts([sbPaths, btnViewAppConfig]); + TCtrlArranger.AlignRights([sbPaths, btnViewUserConfig]); + // Set height of title frame and page control pnlTitle.Height := frmTitle.DocHeight; - pcDetail.ClientHeight := - pcDetail.Height - tsProgram.ClientHeight + - Max( - PathTabHeight, - Max(frmProgram.DocHeight, frmDatabase.DocHeight) - ) + 8; + pcDetail.ClientHeight := pcDetail.Height - tsProgram.ClientHeight + + frmProgram.DocHeight + 8; pnlBody.ClientHeight := pnlTitle.Height + bvlSeparator.Height + pcDetail.Height; + + // Set path scroll box height + sbPaths.ClientHeight := tsPaths.ClientHeight - sbPaths.Top - 28; + + // Set path controls' widths: must do this after all path box tops are set + // and after scroll box height is set so any vertical scroll bar will have + // been created. + for PathInfoBox in fPathInfoBoxes do + PathInfoBox.Width := sbPaths.ClientWidth - 2 * PathInfoBox.Left; + inherited; end; @@ -258,70 +275,181 @@ procedure TAboutDlg.btnViewUserConfigClick(Sender: TObject); ViewConfigFile(TAppInfo.UserConfigFileName, sTitle); end; +procedure TAboutDlg.cbVaultsChange(Sender: TObject); +begin + DisplayVaultInfo(fVaultList.Vault(cbVaults.ItemIndex)); +end; + procedure TAboutDlg.ConfigForm; // Creates and initialises a custom path information control with given // caption, path and tab order. function CreatePathInfoBox(const Caption, Path: string; const TabOrder: Integer): TPathInfoBox; + const + MarginWidth = 8; begin - Result := TPathInfoBox.CreateParented(tsPaths.Handle); - Result.Parent := tsPaths; - Result.SetBounds(8, 8, tsPaths.ClientWidth - 16, 0); + Result := TPathInfoBox.CreateParented(sbPaths.Handle); + Result.Parent := sbPaths; + Result.SetBounds(MarginWidth, MarginWidth, sbPaths.ClientWidth - 2 * MarginWidth, 0); Result.Caption := Caption; Result.Path := Path; Result.TabOrder := TabOrder; end; +var + Vault: TVault; + TabIdx: Integer; resourcestring // Captions for custom controls sInstallPathGpCaption = 'Install Directory'; - sMainDBPathGpCaption = 'Main Database Directory'; - sUserDBPathGpCaption = 'User Database Directory'; + sVaultPathGpCaption = '%s Vault Directory'; begin inherited; - // Create meta data object for main database - fMetaData := TMainDBMetaDataFactory.MainDBMetaDataInstance; // Creates required custom controls - fInstallPathGp := CreatePathInfoBox( - sInstallPathGpCaption, TAppInfo.AppExeDir, 0 - ); - fMainDBPathGp := CreatePathInfoBox( - sMainDBPathGpCaption, TAppInfo.AppDataDir, 1 + TabIdx := 0; + fPathInfoBoxes.Add( + CreatePathInfoBox(sInstallPathGpCaption, TAppInfo.AppExeDir, 1) ); - fUserDBPathGp := CreatePathInfoBox( - sUserDBPathGpCaption, TAppInfo.UserDataDir, 2 - ); - btnViewAppConfig.TabOrder := fUserDBPathGp.TabOrder + 1; - btnViewUserConfig.TabOrder := btnViewAppConfig.TabOrder + 1; + for Vault in TVaults.Instance do + begin + Inc(TabIdx); + fPathInfoBoxes.Add( + CreatePathInfoBox( + Format(sVaultPathGpCaption, [Vault.Name]), + Vault.Storage.Directory, + TabIdx + ) + ); + end; + // Load vaults into combo box & select default vault + fVaultList.ToStrings(cbVaults.Items); + cbVaults.ItemIndex := fVaultList.IndexOfUID(TVaultID.Default); + DisplayVaultInfo(fVaultList.Vault(cbVaults.ItemIndex)); + // Set vaults treeview and paths scrollbox background colours + tvVaultInfo.Color := ThemeServicesEx.GetTabBodyColour; + sbPaths.Color := ThemeServicesEx.GetTabBodyColour; // Load content into HTML frames InitHTMLFrames; end; -function TAboutDlg.ContribListHTML(ContribList: IStringList): - string; -resourcestring - // Error string used when contributor file not available - sNoContributors = 'No contributors list available. Database may be corrupt'; +procedure TAboutDlg.DisplayVaultInfo(AVault: TVault); var - Contributor: string; // name of a contributor - DivAttrs: IHTMLAttributes; // attributes of div tag -begin - Result := ''; - if ContribList.Count > 0 then + HasEntries: Boolean; + + function AddChild(const AParentNode: TTreeNode; const AData: string): + TTreeNode; begin - for Contributor in ContribList do - Result := Result - + TXHTML.CompoundTag('div', TXHTML.Entities(Contributor)) - + EOL; - end - else + Result := tvVaultInfo.Items.AddChild(AParentNode, AData); + HasEntries := True; + end; + + procedure AddChildren(const AParentNode: TTreeNode; const AData: IStringList); + var + DataItem: string; begin - // List couldn't be found: display warning message - DivAttrs := THTMLAttributes.Create('class', 'warning'); - Result := TXHTML.CompoundTag( - 'div', DivAttrs, TXHTML.Entities(sNoContributors) - ); + for DataItem in AData do + AddChild(AParentNode, DataItem); + end; + +var + MetaData: TMetaData; + Capabilities: TMetaDataCaps; + HeadingNode: TTreeNode; + SubheadingNode: TTreeNode; +resourcestring + sVersionHeading = 'Version'; + sLicenseHeading = 'License'; + sCopyrightHeading = 'Copyright'; + sContributorsHeading = 'Contributors'; + sAcknowledgementsHeading = 'Acknowledgements'; + sNoMetaData = 'No information available for this vault.'; + sNotAvailable = 'Not specified'; + sNone = 'None'; +begin + tvVaultInfo.Items.BeginUpdate; + try + tvVaultInfo.Items.Clear; + HasEntries := False; + MetaData := AVault.MetaData; + Capabilities := MetaData.Capabilities; + + if Capabilities <> [] then + begin + + if TMetaDataCap.Version in Capabilities then + begin + HeadingNode := AddChild(nil, sVersionHeading); + if not MetaData.Version.IsNull then + AddChild(HeadingNode, MetaData.Version) + else + AddChild(HeadingNode, sNotAvailable); + end; + + if (TMetaDataCap.License in Capabilities) then + begin + HeadingNode := AddChild(nil, sLicenseHeading); + if not MetaData.LicenseInfo.IsNull then + begin + if not StrIsEmpty(MetaData.LicenseInfo.Name) + and not StrIsEmpty(MetaData.LicenseInfo.SPDX) then + AddChild( + HeadingNode, + StrIf( + MetaData.LicenseInfo.Name <> '', + MetaData.LicenseInfo.Name, + MetaData.LicenseInfo.SPDX + ) + ); + if not StrIsEmpty(MetaData.LicenseInfo.URL) then + AddChild(HeadingNode, MetaData.LicenseInfo.URL); + end + else + AddChild(HeadingNode, sNone); + end; + + if TMetaDataCap.Copyright in Capabilities then + begin + HeadingNode := AddChild(nil, sCopyrightHeading); + if not MetaData.CopyrightInfo.IsNull then + begin + if not StrIsEmpty(MetaData.CopyrightInfo.Date) then + AddChild(HeadingNode, MetaData.CopyrightInfo.Date); + if not StrIsEmpty(MetaData.CopyrightInfo.Holder) then + AddChild(HeadingNode, MetaData.CopyrightInfo.Holder); + if not StrIsEmpty(MetaData.CopyrightInfo.HolderURL) then + AddChild(HeadingNode, MetaData.CopyrightInfo.HolderURL); + if MetaData.CopyrightInfo.Contributors.Count > 0 then + begin + SubheadingNode := AddChild(HeadingNode, sContributorsHeading); + AddChildren(SubheadingNode, MetaData.CopyrightInfo.Contributors); + end; + end + else + AddChild(HeadingNode, sNone); + end; + + if TMetaDataCap.Acknowledgements in Capabilities then + begin + HeadingNode := AddChild(nil, sAcknowledgementsHeading); + if MetaData.Acknowledgements.Count > 0 then + AddChildren(HeadingNode, MetaData.Acknowledgements) + else + AddChild(HeadingNode, sNone); + end; + end + + else + AddChild(nil, sNoMetaData); + + if HasEntries then + begin + tvVaultInfo.FullExpand; + tvVaultInfo.Items[0].MakeVisible; + end; + + finally + tvVaultInfo.Items.EndUpdate; end; end; @@ -340,17 +468,17 @@ class procedure TAboutDlg.Execute(AOwner: TComponent); procedure TAboutDlg.FormCreate(Sender: TObject); begin inherited; + fVaultList := TVaultListAdapter.Create; + fPathInfoBoxes := TList.Create; frmTitle.OnBuildCSS := UpdateTitleCSS; - frmProgram.OnBuildCSS := UpdateDetailCSS; - frmDatabase.OnBuildCSS := UpdateDetailCSS; + frmProgram.OnBuildCSS := UpdateProgramTabCSS; end; procedure TAboutDlg.FormDestroy(Sender: TObject); begin inherited; - fInstallPathGp.Free; - fMainDBPathGp.Free; - fUserDBPathGp.Free; + fPathInfoBoxes.Free; + fVaultList.Free; end; procedure TAboutDlg.HTMLEventHandler(Sender: TObject; @@ -415,101 +543,8 @@ procedure TAboutDlg.InitHTMLFrames; ); end; - // Initialises and loads HTML into database frame. - procedure InitDatabaseFrame; - begin - // Ensure browser loads page so we can process it - pcDetail.ActivePage := tsDatabase; - - frmDatabase.Initialise( - 'dlg-about-database-tplt.html', - procedure(Tplt: THTMLTemplate) - var - IsDBAvalable: Boolean; - IsMetaDataAvailable: Boolean; - IsLicenseInfoAvailable: Boolean; - - function DBVersion: string; - var - Ver: TVersionNumber; - begin - Ver := fMetaData.GetVersion; - if Ver.V1 = 1 then - Result := '1' - else - Result := Ver; - end; - - begin - // Resolve conditionally displayed block placeholders - IsDBAvalable := Database.Snippets.Count(False) > 0; - IsMetaDataAvailable := fMetaData.IsSupportedVersion - and not fMetaData.IsCorrupt; - IsLicenseInfoAvailable := IsMetaDataAvailable - and (fMetaData.GetLicenseInfo.Name <> '') - and (fMetaData.GetCopyrightInfo.Date <> '') - and (fMetaData.GetCopyrightInfo.Holder <> ''); - Tplt.ResolvePlaceholderHTML( - 'DBAvailable', TCSS.BlockDisplayProp(IsDBAvalable) - ); - Tplt.ResolvePlaceholderHTML( - 'DBNotAvailable', TCSS.BlockDisplayProp(not IsDBAvalable) - ); - Tplt.ResolvePlaceholderHTML( - 'MetaDataAvailable', TCSS.BlockDisplayProp(IsMetaDataAvailable) - ); - Tplt.ResolvePlaceholderHTML( - 'MetaDataNotAvailable', TCSS.BlockDisplayProp(not IsMetaDataAvailable) - ); - Tplt.ResolvePlaceholderHTML( - 'LicenseInfoAvailable', TCSS.BlockDisplayProp(IsLicenseInfoAvailable) - ); - Tplt.ResolvePlaceholderHTML( - 'LicenseInfoAvailableInline', - TCSS.InlineDisplayProp(IsLicenseInfoAvailable) - ); - Tplt.ResolvePlaceholderHTML( - 'LicenseInfoNotAvailable', - TCSS.BlockDisplayProp(not IsLicenseInfoAvailable) - ); - - // Resolve content placeholders - Tplt.ResolvePlaceholderText( - 'CopyrightYear', fMetaData.GetCopyrightInfo.Date - ); - Tplt.ResolvePlaceholderText( - 'CopyrightHolders', fMetaData.GetCopyrightInfo.Holder - ); - Tplt.ResolvePlaceholderHTML( - 'DBLicense', - StrIf( - fMetaData.GetLicenseInfo.URL <> '', - TXHTML.CompoundTag( - 'a', - THTMLAttributes.Create([ - THTMLAttribute.Create('href', fMetaData.GetLicenseInfo.URL), - THTMLAttribute.Create('class', 'external-link') - ]), - TXHTML.Entities(fMetaData.GetLicenseInfo.Name) - ), - TXHTML.Entities(fMetaData.GetLicenseInfo.Name) - ) - ); - Tplt.ResolvePlaceholderHTML( - 'ContribList', ContribListHTML(fMetaData.GetContributors) - ); - Tplt.ResolvePlaceholderHTML( - 'TesterList', ContribListHTML(fMetaData.GetTesters) - ); - Tplt.ResolvePlaceholderText('Version', DBVersion); - end - ); - end; - // --------------------------------------------------------------------------- - begin InitTitleFrame; - InitDatabaseFrame; InitProgramFrame; end; @@ -520,7 +555,7 @@ procedure TAboutDlg.pcDetailMouseDown(Sender: TObject; Button: TMouseButton; pcDetail.SetFocus; end; -procedure TAboutDlg.UpdateDetailCSS(Sender: TObject; +procedure TAboutDlg.UpdateProgramTabCSS(Sender: TObject; const CSSBuilder: TCSSBuilder); var ContentFont: TFont; // font used for content @@ -541,18 +576,12 @@ procedure TAboutDlg.UpdateDetailCSS(Sender: TObject; end; // Put border round scroll box CSSBuilder.AddSelector('.scrollbox') - .AddProperty(UCSSUtils.TCSS.BorderProp(cssAll, 1, cbsSolid, clBorder)); - // Set colours and font style of contributors and testers headings - CSSBuilder.AddSelector('.contrib-head, .tester-head') - .AddProperty(TCSS.BackgroundColorProp(clBtnFace)) - .AddProperty(TCSS.ColorProp(clBtnText)) - .AddProperty(TCSS.FontWeightProp(cfwBold)); + .AddProperty(UCSSUtils.TCSS.BorderProp(cssAll, 1, cbsSolid, clBtnShadow)); end; procedure TAboutDlg.UpdateTitleCSS(Sender: TObject; const CSSBuilder: TCSSBuilder); begin - // Set body colour, and put border round it CSSBuilder.Selectors['body'] .AddProperty(TCSS.BackgroundColorProp(clWindow)) .AddProperty(TCSS.PaddingProp(4)); diff --git a/Src/FmAddCategoryDlg.dfm b/Src/FmAddCategoryDlg.dfm index 110836fca..0c6f9b995 100644 --- a/Src/FmAddCategoryDlg.dfm +++ b/Src/FmAddCategoryDlg.dfm @@ -12,10 +12,6 @@ inherited AddCategoryDlg: TAddCategoryDlg Height = 240 TabOrder = 0 TabStop = True - inherited lblError: TLabel - Width = 108 - ExplicitWidth = 108 - end end end inherited btnOK: TButton diff --git a/Src/FmAddCategoryDlg.pas b/Src/FmAddCategoryDlg.pas index 27ebb3258..61dfdf96d 100644 --- a/Src/FmAddCategoryDlg.pas +++ b/Src/FmAddCategoryDlg.pas @@ -68,7 +68,9 @@ implementation uses // Project - DB.UCategory, DB.UMain, UUniqueID; + DB.Categories, + DB.Main, + UUniqueID; {$R *.dfm} @@ -82,11 +84,11 @@ procedure TAddCategoryDlg.AddCategory(const Desc: string); var Data: TCategoryData; // category properties begin - Data := (Database as IDatabaseEdit).GetEditableCategoryInfo; + Data := Database.GetEditableCategoryInfo; Data.Desc := Desc; // add category with a unique id string as name (name must be unique and is // for internal use only) - (Database as IDatabaseEdit).AddCategory(TUniqueID.Generate, Data); + Database.AddCategory(TUniqueID.Generate, Data); end; procedure TAddCategoryDlg.ArrangeForm; diff --git a/Src/FmCodeExportDlg.dfm b/Src/FmCodeExportDlg.dfm index 1bcdbcc40..bbdce1666 100644 --- a/Src/FmCodeExportDlg.dfm +++ b/Src/FmCodeExportDlg.dfm @@ -10,7 +10,7 @@ inherited CodeExportDlg: TCodeExportDlg object lblSnippets: TLabel Left = 0 Top = 0 - Width = 146 + Width = 151 Height = 13 Caption = 'Select &snippets to be exported:' FocusControl = frmSnippets @@ -18,7 +18,7 @@ inherited CodeExportDlg: TCodeExportDlg object lblFile: TLabel Left = 0 Top = 232 - Width = 200 + Width = 208 Height = 13 Caption = 'Save to &file: (click button to browse for file)' FocusControl = edFile diff --git a/Src/FmCodeExportDlg.pas b/Src/FmCodeExportDlg.pas index 39cfdae8e..a8415d786 100644 --- a/Src/FmCodeExportDlg.pas +++ b/Src/FmCodeExportDlg.pas @@ -18,10 +18,19 @@ interface uses // Delphi - Classes, StdCtrls, Controls, Forms, ExtCtrls, + Classes, + StdCtrls, + Controls, + Forms, + ExtCtrls, // Project - DB.USnippet, FmGenericOKDlg, FrCheckedTV, FrSelectUserSnippets, - FrSelectSnippets, FrSelectSnippetsBase, UBaseObjects; + DB.Snippets, + FmGenericOKDlg, + FrCheckedTV, + FrSelectUserSnippets, + FrSelectSnippets, + FrSelectSnippetsBase, + UBaseObjects; type @@ -34,17 +43,20 @@ interface TCodeExportDlg = class(TGenericOKDlg, INoPublicConstruct) btnBrowse: TButton; edFile: TEdit; + {TODO -cRefactor: Change type of frmSnippets to TSelectSnippetsFrame - + TSelectSnippetsFrame and TSelectUserSnippetsFrame are now + functionally identical.} frmSnippets: TSelectUserSnippetsFrame; lblFile: TLabel; lblSnippets: TLabel; procedure btnBrowseClick(Sender: TObject); procedure btnOKClick(Sender: TObject); strict private + /// Selects a snippet in the snippets check list. + /// TSnippet [in] Snippet to be selected. + /// If nil then no snippet is selected. procedure SelectSnippet(const Snippet: TSnippet); - {Selects a snippet in the snippets check list. - @param Snippet [in] Snippet to be selected. If nil, or not user-defined, - no snippet is selected. - } + procedure WriteOutputFile; {Writes export file. } @@ -55,13 +67,14 @@ TCodeExportDlg = class(TGenericOKDlg, INoPublicConstruct) controls that depend on UI font. } public + /// Displays export dialog box and writes export file containing + /// user's selected snippets. + /// TComponent [in] Reference to control that + /// owns the dialogue box. + /// TSnippet [in] Reference to a snippet to + /// pre-select in the snippets check list box. If nil then no + /// snippet is pre-selected. class procedure Execute(const AOwner: TComponent; const Snippet: TSnippet); - {Displays export dialog box and writes export file if user OKs entries. - @param AOwner [in] Reference to control that owns the dialog box. - @param Snippet [in] Reference to a snippet to pre-select in snippets - check list box. If nil or not user-defined then no snippet is pre- - selected. - } end; @@ -72,8 +85,17 @@ implementation // Delphi SysUtils, Dialogs, // Project - UCodeImportExport, UCtrlArranger, UEncodings, UExceptions, UIOUtils, - UMessageBox, UOpenDialogHelper, USaveDialogEx, UStrUtils, UUtils; + DB.Vaults, + DB.IO.ImportExport.CS4, + UCtrlArranger, + UEncodings, + UExceptions, + UIOUtils, + UMessageBox, + UOpenDialogHelper, + USaveDialogEx, + UStrUtils, + UUtils; {$R *.dfm} @@ -184,11 +206,12 @@ procedure TCodeExportDlg.ConfigForm; class procedure TCodeExportDlg.Execute(const AOwner: TComponent; const Snippet: TSnippet); - {Displays export dialog box and writes export file if user OKs entries. - @param AOwner [in] Reference to control that owns the dialog box. - @param Snippet [in] Reference to a snippet to pre-select in snippets check - list box. If nil or not user-defined then no snippet is pre-selected. - } + {TODO -cVault: Add parameter to receive snippet selection per current search + display only those snippets (maybe filtering out unwanted snippets by + handling an event triggered by the snippet list frame. As now, select + only the snippet specified by the Snippet parameter.} + {TODO -cVault: Add check box to use to causes all snippets depended upon by + each exported snippet to also be exported.} var Dlg: TCodeExportDlg; begin @@ -202,20 +225,17 @@ class procedure TCodeExportDlg.Execute(const AOwner: TComponent; end; procedure TCodeExportDlg.SelectSnippet(const Snippet: TSnippet); - {Selects a snippet in the snippets check list. - @param Snippet [in] Snippet to be selected. If nil, or not user-defined, no - snippet is selected. - } var List: TSnippetList; // list containing only the provided snippet begin - if not Assigned(Snippet) or not Snippet.UserDefined then - // Snippet is nil or not user-defined: select nothing + if not Assigned(Snippet) then + // Snippet is nil: select nothing frmSnippets.SelectedSnippets := nil else begin - // Snippet is user-defined. We make a snippet list containing only this - // snippet because frmSnippets requires a list of snippets to select. + // Snippet is not nil: we make a snippet list containing only this snippet. + // A list is required because frmSnippets requires a list of snippets to + // select. List := TSnippetList.Create; try List.Add(Snippet); @@ -232,7 +252,7 @@ procedure TCodeExportDlg.WriteOutputFile; var OutData: TEncodedData; // receives export file content begin - OutData := TCodeExporter.ExportSnippets(frmSnippets.SelectedSnippets); + OutData := TCS4SnippetExporter.ExportSnippets(frmSnippets.SelectedSnippets); TFileIO.WriteAllBytes(StrTrim(edFile.Text), OutData.Data); end; diff --git a/Src/FmCodeImportDlg.dfm b/Src/FmCodeImportDlg.dfm index f3cc01a43..ff4408c08 100644 --- a/Src/FmCodeImportDlg.dfm +++ b/Src/FmCodeImportDlg.dfm @@ -9,7 +9,7 @@ inherited CodeImportDlg: TCodeImportDlg ExplicitHeight = 321 inherited pcWizard: TPageControl Height = 288 - ActivePage = tsInfo + ActivePage = tsFinish ExplicitHeight = 288 object tsInfo: TTabSheet Caption = 'tsInfo' @@ -21,8 +21,8 @@ inherited CodeImportDlg: TCodeImportDlg Height = 227 AutoSize = False Caption = - 'This wizard helps you import snippets from a file into your user' + - ' database.'#13#10#13#10'Click the Next button below to begin.' + 'This wizard helps you import snippets from a file into a vault.'#13 + + #10#13#10'Click the Next button below to begin.' WordWrap = True end end @@ -67,6 +67,31 @@ inherited CodeImportDlg: TCodeImportDlg TabOrder = 1 end end + object tsVault: TTabSheet + Caption = 'tsVault' + ImageIndex = 4 + TabVisible = False + DesignSize = ( + 369 + 278) + object lblVaults: TLabel + Left = 0 + Top = 8 + Width = 234 + Height = 13 + Caption = 'Choose a &vault to receive the imported snippets:' + FocusControl = cbVaults + end + object cbVaults: TComboBox + Left = 0 + Top = 38 + Width = 369 + Height = 21 + Style = csDropDownList + Anchors = [akLeft, akTop, akRight] + TabOrder = 0 + end + end object tsUpdate: TTabSheet Caption = 'tsUpdate' ImageIndex = 3 @@ -79,14 +104,6 @@ inherited CodeImportDlg: TCodeImportDlg Caption = 'Imported &snippets:' FocusControl = lvImports end - object lblSelectedSnippet: TLabel - Left = 0 - Top = 217 - Width = 83 - Height = 13 - Caption = 'S&elected snippet:' - FocusControl = edRename - end object lblModifyInstructions: TLabel Left = 0 Top = 8 @@ -94,9 +111,10 @@ inherited CodeImportDlg: TCodeImportDlg Height = 40 AutoSize = False Caption = - 'The functions to be imported are listed below. Select, deselect ' + - 'and rename as required then click the "Update" button to update ' + - 'the database. Use "Cancel" to abandon the import.' + 'The functions to be imported are listed below. Clear the check b' + + 'oxes next to any snippets you don'#39't want to import then click th' + + 'e "Update" button to update the database. Use "Cancel" to abando' + + 'n the import.' WordWrap = True end object lvImports: TListView @@ -107,12 +125,8 @@ inherited CodeImportDlg: TCodeImportDlg Checkboxes = True Columns = < item - Caption = 'Snippet Name' - Width = 140 - end - item - Caption = 'Import Using Name' - Width = 140 + Caption = 'Snippet' + Width = 280 end item Caption = 'Action' @@ -126,24 +140,8 @@ inherited CodeImportDlg: TCodeImportDlg SortType = stText TabOrder = 0 ViewStyle = vsReport - OnSelectItem = lvImportsSelectItem OnItemChecked = lvImportsItemChecked end - object btnRename: TButton - Left = 161 - Top = 236 - Width = 75 - Height = 25 - Action = actRename - TabOrder = 1 - end - object edRename: TEdit - Left = 0 - Top = 238 - Width = 155 - Height = 21 - TabOrder = 2 - end end object tsFinish: TTabSheet Caption = 'tsFinish' @@ -156,8 +154,8 @@ inherited CodeImportDlg: TCodeImportDlg Height = 33 AutoSize = False Caption = - 'The database has now been updated. The following snippets were i' + - 'mported:' + 'The chosen vault has now been updated. The following snippets we' + + 're imported:' WordWrap = True end object sbFinish: TScrollBox @@ -174,11 +172,6 @@ inherited CodeImportDlg: TCodeImportDlg object alMain: TActionList Left = 448 Top = 208 - object actRename: TAction - Caption = '&Rename...' - OnExecute = actRenameExecute - OnUpdate = actRenameUpdate - end object actBrowse: TAction Caption = '...' Hint = 'Browse for import file' diff --git a/Src/FmCodeImportDlg.pas b/Src/FmCodeImportDlg.pas index 86f0fbef2..83ad8443c 100644 --- a/Src/FmCodeImportDlg.pas +++ b/Src/FmCodeImportDlg.pas @@ -25,9 +25,11 @@ interface ExtCtrls, Forms, // Project + DB.Vaults, FmWizardDlg, UBaseObjects, - UCodeImportMgr; + UCodeImportMgr, + UI.Adapters.VaultList; type /// @@ -47,50 +49,44 @@ TCodeImportDlg = class(TWizardDlg, INoPublicConstruct) lvImports: TListView; lblImportList: TLabel; lblLoadFile: TLabel; - btnRename: TButton; - edRename: TEdit; - lblSelectedSnippet: TLabel; alMain: TActionList; - actRename: TAction; actBrowse: TAction; lblModifyInstructions: TLabel; lblFinish: TLabel; sbFinish: TScrollBox; + tsVault: TTabSheet; + lblVaults: TLabel; + cbVaults: TComboBox; /// Handles clicks on list view check boxes. procedure lvImportsItemChecked(Sender: TObject; Item: TListItem); - /// Handles selection changes events in list view. - procedure lvImportsSelectItem(Sender: TObject; Item: TListItem; - Selected: Boolean); - /// Updates enabled state of rename action and associated - /// controls. - procedure actRenameUpdate(Sender: TObject); - /// Handles event that requests renaming of a snippet. - procedure actRenameExecute(Sender: TObject); /// Handles request to display open file dialog box to get import /// file name. procedure actBrowseExecute(Sender: TObject); + /// Frees field objects and objects stored in list view items' + /// Data properties. + procedure FormDestroy(Sender: TObject); + /// Creates field objects. + procedure FormCreate(Sender: TObject); strict private const // Indices of wizard pages - cIntroPage = 0; - cFilePage = 1; - cUpdatePage = 2; - cFinishPage = 3; + cIntroPage = 0; + cFilePage = 1; + cVaultPage = 2; + cUpdatePage = 3; + cFinishPage = 4; // Index of subitems in list view - cLVActionIdx = 1; - cLVImportName = 0; + cLVActionIdx = 0; var /// Reference to import manager object used to perform import /// operations. fImportMgr: TCodeImportMgr; + /// Object that populates cbVaults with an alphabetical + /// list of vault names and manages interaction with it. + fVaultList: TVaultListAdapter; /// Validates entries on wizard pages indetified by the page /// index. procedure ValidatePage(const PageIdx: Integer); - /// Checks validity of a given snippet name that is to be used - /// to replace the name in a given list item. Passes any error message - /// back via parameter list. - function ValidateSnippetName(const Name: string; const Item: TListItem; - out ErrMsg: string): Boolean; /// Reads input file from disk. procedure ReadImportFile; /// Retrieves import file name from edit control where it is @@ -106,12 +102,6 @@ TCodeImportDlg = class(TWizardDlg, INoPublicConstruct) /// Counts snippets that will be / have been added to database. /// Excludes any snippets skipped by user. function CountImportSnippets: Integer; - /// Retrieves the name that will be used to add an imported - /// snippet to the database from the given list item. - function GetImportAsNameFromLV(const Item: TListItem): string; - /// Updates given list item with new imported snippet name. - /// - procedure SetImportNameInLV(const Item: TListItem; const Value: string); /// Updates given list item with description of current import /// action for the associated snippet. procedure SetActionInLV(const Item: TListItem; const Value: string); @@ -126,11 +116,17 @@ TCodeImportDlg = class(TWizardDlg, INoPublicConstruct) procedure UpdateDatabase; /// Displays names of imported snippets on finish page. procedure PresentResults; + /// Gets the ID of the vault into which all snippets are to be + /// imported. + function GetVaultID: TVaultID; strict protected /// Protected constructor that sets up object to use given import /// manager object. constructor InternalCreate(AOwner: TComponent; const ImportMgr: TCodeImportMgr); reintroduce; + /// Initialises form fields and controls. + /// Overridden method called from ancestor class. + procedure InitForm; override; /// Aligns and arranges controls in each tab sheet and sizes /// dialog box to accomodate controls. /// Overridden method called from ancestor class. @@ -168,6 +164,7 @@ implementation SysUtils, Dialogs, // Project + UBox, UCtrlArranger, UExceptions, UMessageBox, @@ -187,7 +184,7 @@ procedure TCodeImportDlg.actBrowseExecute(Sender: TObject); resourcestring sFilter = 'CodeSnip export files (*.csexp)|*.csexp|' // file filter + 'All files (*.*)|*.*'; - sTitle = 'Import File'; // dialog box title + sTitle = 'Import File'; // dialogue box title begin OpenDlg := TOpenDialogEx.Create(nil); try @@ -208,23 +205,6 @@ procedure TCodeImportDlg.actBrowseExecute(Sender: TObject); end; end; -procedure TCodeImportDlg.actRenameExecute(Sender: TObject); -var - ErrMsg: string; // any error message returned from snippets validator -begin - if not ValidateSnippetName(edRename.Text, lvImports.Selected, ErrMsg) then - raise EDataEntry.Create(ErrMsg, edRename); - SetImportNameInLV(lvImports.Selected, edRename.Text); - lvImports.Selected.MakeVisible(False); - UpdateImportData(lvImports.Selected); -end; - -procedure TCodeImportDlg.actRenameUpdate(Sender: TObject); -begin - actRename.Enabled := Assigned(lvImports.Selected); - edRename.Enabled := Assigned(lvImports.Selected); -end; - procedure TCodeImportDlg.ArrangeForm; begin TCtrlArranger.SetLabelHeights(Self); @@ -240,13 +220,13 @@ procedure TCodeImportDlg.ArrangeForm; ); lblLoadFile.Top := TCtrlArranger.BottomOf([edFile, btnBrowse], 12); + // tsVault + cbVaults.Top := TCtrlArranger.BottomOf(lblVaults, 6); + cbVaults.Width := tsVault.Width; + // tsUpdate lblImportList.Top := TCtrlArranger.BottomOf(lblModifyInstructions, 8); lvImports.Top := TCtrlArranger.BottomOf(lblImportList, 6); - lblSelectedSnippet.Top := TCtrlArranger.BottomOf(lvImports, 8); - TCtrlArranger.AlignVCentres( - TCtrlArranger.BottomOf(lblSelectedSnippet, 6), [edRename, btnRename] - ); // tsFinish sbFinish.Top := TCtrlArranger.BottomOf(lblFinish, 6); @@ -307,16 +287,33 @@ class function TCodeImportDlg.Execute(AOwner: TComponent; end; end; +procedure TCodeImportDlg.FormCreate(Sender: TObject); +begin + inherited; + fVaultList := TVaultListAdapter.Create; +end; + +procedure TCodeImportDlg.FormDestroy(Sender: TObject); +var + Idx: Integer; +begin + inherited; + fVaultList.Free; + // Free the TBox<> objects stored in list item data pointer + for Idx := Pred(lvImports.Items.Count) downto 0 do + TObject(lvImports.Items[Idx].Data).Free; +end; + function TCodeImportDlg.GetFileNameFromEditCtrl: string; begin Result := StrTrim(edFile.Text); end; -function TCodeImportDlg.GetImportAsNameFromLV(const Item: TListItem): string; +function TCodeImportDlg.GetVaultID: TVaultID; begin - if Item.SubItems.Count <= cLVImportName then - Exit(''); - Result := Item.SubItems[cLVImportName]; + Assert(cbVaults.ItemIndex >= 0, + ClassName + '.GetVaultID: no vault selected'); + Result := fVaultList.Vault(cbVaults.ItemIndex).UID; end; function TCodeImportDlg.HeadingText(const PageIdx: Integer): string; @@ -324,20 +321,33 @@ function TCodeImportDlg.HeadingText(const PageIdx: Integer): string; // Page headings sIntroPageheading = 'Import snippets from a file'; sFilePage = 'Choose import file'; + sVaultPage = 'Choose a vault'; sUpdatePage = 'Edit import and update database'; sFinishPage = 'Import complete'; begin case PageIdx of - cIntroPage: Result := sIntroPageheading; - cFilePage: Result := sFilePage; - cUpdatePage: Result := sUpdatePage; - cFinishPage: Result := sFinishPage; + cIntroPage: Result := sIntroPageheading; + cFilePage: Result := sFilePage; + cVaultPage: Result := sVaultPage; + cUpdatePage: Result := sUpdatePage; + cFinishPage: Result := sFinishPage; end; end; +procedure TCodeImportDlg.InitForm; +begin + fVaultList.ToStrings(cbVaults.Items); + Assert(cbVaults.Items.Count > 0, ClassName + '.InitForm: no vaults'); + Assert(TVaults.Instance.ContainsID(TVaultID.Default), + ClassName + '.InitForm: default vault not found'); + cbVaults.ItemIndex := fVaultList.IndexOfUID(TVaultID.Default); + Assert(cbVaults.ItemIndex >= 0, + ClassName + '.InitForm: default vault name not in cbVaults'); + inherited; +end; + procedure TCodeImportDlg.InitImportInfo; - // --------------------------------------------------------------------------- /// Creates a new list view items containing given information. procedure AddListItem(const Info: TImportInfo); var @@ -345,13 +355,11 @@ procedure TCodeImportDlg.InitImportInfo; begin LI := lvImports.Items.Add; LI.SubItems.Add(''); - LI.SubItems.Add(''); - LI.Caption := Info.OrigName; - SetImportNameInLV(LI, Info.ImportAsName); + LI.Caption := Info.DisplayName; LI.Checked := not Info.Skip; + LI.Data := TBox.Create(Info); UpdateActionDisplay(LI); end; - // --------------------------------------------------------------------------- var InfoItem: TImportInfo; // import info item describing an imported snippet @@ -375,6 +383,7 @@ constructor TCodeImportDlg.InternalCreate(AOwner: TComponent; begin inherited InternalCreate(AOwner); fImportMgr := ImportMgr; + fImportMgr.RequestVaultCallback := GetVaultID; end; procedure TCodeImportDlg.lvImportsItemChecked(Sender: TObject; Item: TListItem); @@ -383,13 +392,6 @@ procedure TCodeImportDlg.lvImportsItemChecked(Sender: TObject; Item: TListItem); UpdateImportData(Item); end; -procedure TCodeImportDlg.lvImportsSelectItem(Sender: TObject; Item: TListItem; - Selected: Boolean); -begin - if Assigned(Item) then - edRename.Text := GetImportAsNameFromLV(Item); -end; - procedure TCodeImportDlg.MoveForward(const PageIdx: Integer; var CanMove: Boolean); begin @@ -415,7 +417,6 @@ procedure TCodeImportDlg.MoveForward(const PageIdx: Integer; procedure TCodeImportDlg.PresentResults; - // --------------------------------------------------------------------------- /// Creates a label containing name of an imported snippet and adds it to /// scroll box with top at given position. procedure AddLabel(var Top: Integer; const SnippetName: string); @@ -431,7 +432,6 @@ procedure TCodeImportDlg.PresentResults; Lbl.Caption := Bullet + ' ' + SnippetName; Top := TCtrlArranger.BottomOf(Lbl, 2); end; - // --------------------------------------------------------------------------- var DataItem: TImportInfo; // description of each snippet from import file @@ -442,7 +442,7 @@ procedure TCodeImportDlg.PresentResults; begin if DataItem.Skip then Continue; - AddLabel(LblTop, DataItem.ImportAsName); + AddLabel(LblTop, DataItem.DisplayName); end; end; @@ -459,14 +459,6 @@ procedure TCodeImportDlg.SetActionInLV(const Item: TListItem; Item.SubItems[cLVActionIdx] := Value; end; -procedure TCodeImportDlg.SetImportNameInLV(const Item: TListItem; - const Value: string); -begin - if Item.SubItems.Count <= cLVImportName then - Exit; - Item.SubItems[cLVImportName] := Value; -end; - procedure TCodeImportDlg.UpdateActionDisplay(const Item: TListItem); resourcestring // description of actions @@ -507,21 +499,13 @@ procedure TCodeImportDlg.UpdateDatabase; end; procedure TCodeImportDlg.UpdateImportData(const Item: TListItem); -var - DataItem: TImportInfo; // description of each snippet from import file - Idx: Integer; // index of selected snippet name in import info list begin if not Assigned(Item) then Exit; - Idx := fImportMgr.ImportInfo.IndexOfName(Item.Caption); - if Idx = -1 then - raise EBug.Create( - ClassName + '.UpdateImportData: Can''t find import data item.' - ); - DataItem := TImportInfo.Create( - Item.Caption, GetImportAsNameFromLV(Item), not Item.Checked + fImportMgr.ImportInfo.SetSkip( + TBox(Item.Data).Value.OrigKey, + not Item.Checked ); - fImportMgr.ImportInfo.Items[Idx] := DataItem; end; procedure TCodeImportDlg.ValidatePage(const PageIdx: Integer); @@ -550,29 +534,4 @@ procedure TCodeImportDlg.ValidatePage(const PageIdx: Integer); end; end; -function TCodeImportDlg.ValidateSnippetName(const Name: string; - const Item: TListItem; out ErrMsg: string): Boolean; -resourcestring - // Error message - sDuplicateName = '"%s" duplicates a name in the import list.'; -var - LI: TListItem; // each list item in list view -begin - // Checks snippet name for being well formed and not already in user database - Result := TSnippetValidator.ValidateName(Name, True, ErrMsg); - if not Result then - Exit; - // Checks name not already used for other imported snippets - for LI in lvImports.Items do - begin - if LI = Item then - Continue; // this is item we're about to change: ignore its name - if StrSameText(Name, GetImportAsNameFromLV(LI)) then - begin - ErrMsg := Format(sDuplicateName, [Name]); - Exit(False); - end; - end; -end; - end. diff --git a/Src/FmCompErrorDlg.pas b/Src/FmCompErrorDlg.pas index 56744cc6a..d5cfbc919 100644 --- a/Src/FmCompErrorDlg.pas +++ b/Src/FmCompErrorDlg.pas @@ -17,11 +17,24 @@ interface uses // Delphi - Forms, StdCtrls, Controls, ExtCtrls, Classes, Tabs, ActnList, ImgList, + Forms, + StdCtrls, + Controls, + ExtCtrls, + Classes, + Tabs, + ActnList, + ImgList, Generics.Collections, // Project - Compilers.UGlobals, DB.USnippet, FmGenericViewDlg, FrBrowserBase, FrHTMLDlg, - FrHTMLTpltDlg, UBaseObjects, USnippetIDs; + Compilers.UGlobals, + DB.SnippetIDs, + DB.Snippets, + FmGenericViewDlg, + FrBrowserBase, + FrHTMLDlg, + FrHTMLTpltDlg, + UBaseObjects; type @@ -130,7 +143,11 @@ implementation // Delphi Graphics, // Project - DB.UMain, UConsts, UExceptions, UHTMLUtils, UHTMLTemplate; + DB.Main, + UConsts, + UExceptions, + UHTMLUtils, + UHTMLTemplate; {$R *.dfm} diff --git a/Src/FmDeleteCategoryDlg.dfm b/Src/FmDeleteCategoryDlg.dfm index 48c13e494..de0504e9c 100644 --- a/Src/FmDeleteCategoryDlg.dfm +++ b/Src/FmDeleteCategoryDlg.dfm @@ -1,15 +1,10 @@ inherited DeleteCategoryDlg: TDeleteCategoryDlg Caption = 'Delete Category' + ExplicitWidth = 320 + ExplicitHeight = 375 PixelsPerInch = 96 TextHeight = 13 inherited pnlBody: TPanel - object lblErrorMsg: TLabel - Left = 0 - Top = 144 - Width = 156 - Height = 13 - Caption = 'Non-empty category: can'#39't delete' - end inline frmCategories: TCategoryListFrame Left = 0 Top = 0 @@ -18,10 +13,6 @@ inherited DeleteCategoryDlg: TDeleteCategoryDlg TabOrder = 0 TabStop = True ExplicitHeight = 138 - inherited lblCategories: TLabel - Width = 60 - ExplicitWidth = 60 - end inherited lbCategories: TListBox Height = 108 ExplicitHeight = 108 diff --git a/Src/FmDeleteCategoryDlg.pas b/Src/FmDeleteCategoryDlg.pas index 3f6a65b0f..6770f3814 100644 --- a/Src/FmDeleteCategoryDlg.pas +++ b/Src/FmDeleteCategoryDlg.pas @@ -5,8 +5,7 @@ * * Copyright (C) 2009-2023, Peter Johnson (gravatar.com/delphidabbler). * - * Implements a dialogue box that permits user to select and delete a user - * defined category. + * Implements a dialogue box that permits user to select and delete a category. } @@ -18,19 +17,24 @@ interface uses // Delphi - Forms, StdCtrls, Controls, ExtCtrls, Classes, + Forms, + StdCtrls, + Controls, + ExtCtrls, + Classes, // Project - DB.UCategory, FmCategoryEditDlg, FrCategoryList, UBaseObjects; + DB.Categories, + FmCategoryEditDlg, + FrCategoryList, + UBaseObjects; type - { - TDeleteCategoryDlg: - Dialog box that permits user to select and delete a user-defined category. - } + + /// Dialogue box that permits the user to select and delete a + /// category. TDeleteCategoryDlg = class(TCategoryEditDlg, INoPublicConstruct) frmCategories: TCategoryListFrame; - lblErrorMsg: TLabel; procedure btnOKClick(Sender: TObject); strict private fCategories: TCategoryList; // List of categories that can be deleted @@ -39,14 +43,12 @@ TDeleteCategoryDlg = class(TCategoryEditDlg, INoPublicConstruct) according to changes. @param Sender [in] Not used. } - procedure UpdateErrorLabelState; - {Shows or hides error state label depending of whether selected category - can be deleted. - } + + /// Deletes a category from the database. + /// TCategory [in] Category to be deleted. + /// The category must be empty. procedure DeleteCategory(const Cat: TCategory); - {Deletes category and all its snippets from database. - @param Cat [in] Category to be deleted. - } + strict protected procedure ConfigForm; override; {Configures form. Populates controls and supplies event handler to frame. @@ -74,7 +76,10 @@ implementation uses // Project - DB.UMain, UColours, UCtrlArranger, UFontHelper; + DB.Main, + UColours, + UCtrlArranger, + UFontHelper; {$R *.dfm} @@ -86,8 +91,6 @@ procedure TDeleteCategoryDlg.ArrangeForm; } begin frmCategories.ArrangeFrame; - TCtrlArranger.SetLabelHeight(lblErrorMsg); - lblErrorMsg.Top := TCtrlArranger.BottomOf(frmCategories, 8); inherited; end; @@ -117,17 +120,12 @@ procedure TDeleteCategoryDlg.ConfigForm; frmCategories.OnChange := SelectionChangeHandler; frmCategories.Prompt := sPrompt; frmCategories.SetCategories(fCategories); - TFontHelper.SetDefaultFont(lblErrorMsg.Font); - lblErrorMsg.Font.Color := clWarningText; - lblErrorMsg.Visible := False; end; procedure TDeleteCategoryDlg.DeleteCategory(const Cat: TCategory); - {Deletes category and all its snippets from database. - @param Cat [in] Category to be deleted. - } begin - (Database as IDatabaseEdit).DeleteCategory(Cat); + Assert(Cat.CanDelete, ClassName + '.DeleteCategory: Cat can''t be deleted'); + Database.DeleteCategory(Cat); end; class function TDeleteCategoryDlg.Execute(AOwner: TComponent; @@ -156,18 +154,6 @@ procedure TDeleteCategoryDlg.SelectionChangeHandler(Sender: TObject); } begin UpdateOKBtn; - UpdateErrorLabelState; -end; - -procedure TDeleteCategoryDlg.UpdateErrorLabelState; - {Shows or hides error state label depending of whether selected category can - be deleted. - } -begin - if not frmCategories.IsValidEntry then - lblErrorMsg.Visible := False - else - lblErrorMsg.Visible := not frmCategories.SelectedCategory.CanDelete; end; procedure TDeleteCategoryDlg.UpdateOKBtn; @@ -176,6 +162,7 @@ procedure TDeleteCategoryDlg.UpdateOKBtn; } begin btnOK.Enabled := frmCategories.IsValidEntry + // following check is potentially redundant, but leaving in for safety and frmCategories.SelectedCategory.CanDelete; end; diff --git a/Src/FmDeleteUserDBDlg.pas b/Src/FmDeleteUserDBDlg.pas deleted file mode 100644 index d51be0681..000000000 --- a/Src/FmDeleteUserDBDlg.pas +++ /dev/null @@ -1,111 +0,0 @@ -{ - * This Source Code Form is subject to the terms of the Mozilla Public License, - * v. 2.0. If a copy of the MPL was not distributed with this file, You can - * obtain one at https://mozilla.org/MPL/2.0/ - * - * Copyright (C) 2022-2023, Peter Johnson (gravatar.com/delphidabbler). - * - * Implements a dialogue box that asks user to confirm deletion of user-defined - * snippets database. -} - - -unit FmDeleteUserDBDlg; - -interface - -uses - // Delphi - Forms, StdCtrls, Controls, ExtCtrls, Classes, - // Project - FmGenericOKDlg, - FrBrowserBase, FrHTMLDlg, FrFixedHTMLDlg, - UBaseObjects; - -type - TDeleteUserDBDlg = class(TGenericOKDlg, INoPublicConstruct) - edConfirm: TEdit; - frmWarning: TFixedHTMLDlgFrame; - procedure btnOKClick(Sender: TObject); - strict private - const - cConfirmText = 'DELETE MY SNIPPETS'; - var - fPermissionGranted: Boolean; - strict protected - /// Protected constructor that sets up form. - constructor InternalCreate(AOwner: TComponent); override; - procedure ConfigForm; override; - procedure ArrangeForm; override; - function IsValidPassword: Boolean; - public - class function Execute(AOwner: TComponent): Boolean; - end; - -implementation - -uses - // Delphi - SysUtils, - // Project - UCtrlArranger, UMessageBox; - -{$R *.dfm} - -procedure TDeleteUserDBDlg.ArrangeForm; -begin - frmWarning.Height := frmWarning.DocHeight; - edConfirm.Left := 0; - TCtrlArranger.MoveBelow(frmWarning, edConfirm, 12); - TCtrlArranger.AlignHCentresTo([frmWarning], [edConfirm]); - pnlBody.ClientHeight := TCtrlArranger.TotalControlHeight(pnlBody) + 8; - inherited; -end; - -procedure TDeleteUserDBDlg.btnOKClick(Sender: TObject); -resourcestring - sBadPassword = 'Invalid confirmation text entered'; -begin - inherited; - fPermissionGranted := IsValidPassword; - if not fPermissionGranted then - begin - TMessageBox.Error(Self, sBadPassword); - edConfirm.Text := ''; - ModalResult := mrNone; - end; -end; - -procedure TDeleteUserDBDlg.ConfigForm; -begin - inherited; -// frmWarning.OnBuildCSS := BuildCSS; - frmWarning.Initialise('dlg-dbdelete.html'); -end; - -class function TDeleteUserDBDlg.Execute(AOwner: TComponent): Boolean; -var - Dlg: TDeleteUserDBDlg; -begin - Dlg := InternalCreate(AOwner); - try - Dlg.ShowModal; - Result := Dlg.fPermissionGranted; - finally - Dlg.Free; - end; -end; - -constructor TDeleteUserDBDlg.InternalCreate(AOwner: TComponent); -begin - Assert(Supports(Self, INoPublicConstruct), ClassName + '.InternalCreate: ' - + 'Form''s protected constructor can''t be called'); - inherited InternalCreate(AOwner); -end; - -function TDeleteUserDBDlg.IsValidPassword: Boolean; -begin - Result := edConfirm.Text = cConfirmText; -end; - -end. diff --git a/Src/FmDependenciesDlg.pas b/Src/FmDependenciesDlg.pas index e1705a01e..c71d34724 100644 --- a/Src/FmDependenciesDlg.pas +++ b/Src/FmDependenciesDlg.pas @@ -18,9 +18,20 @@ interface uses // Delphi - ComCtrls, StdCtrls, Controls, ExtCtrls, Classes, Windows, ActnList, + ComCtrls, + StdCtrls, + Controls, + ExtCtrls, + Classes, + Windows, + ActnList, // Project - DB.USnippet, FmGenericViewDlg, UBaseObjects, USearch, USnippetIDs, + DB.SnippetIDs, + DB.Snippets, + DB.Vaults, + FmGenericViewDlg, + UBaseObjects, + USearch, USnippetsTVDraw; @@ -65,12 +76,16 @@ TTVDraw = class(TSnippetsTVDraw) strict private fRootID: TSnippetID; // ID of snippet whose dependency nodes displayed strict protected - function IsUserDefinedNode(const Node: TTreeNode): Boolean; + + /// Gets the vault ID, if any, associated with a tree node. + /// + /// TTreeNode [in] Node to be checked. + /// + /// TVaultID. Associated vault ID. If Node has + /// no associated vault then a null vault ID is returned. + function GetVaultID(const Node: TTreeNode): TVaultID; override; - {Checks if a node represents a user defined snippets object. - @param Node [in] Node to be checked. - @return True if node represents user defined object, False if not. - } + function IsErrorNode(const Node: TTreeNode): Boolean; override; {Checks if a node represents an error condition. @@ -158,9 +173,15 @@ implementation uses // Delphi - SysUtils, Graphics, + SysUtils, + Graphics, // Project - DB.UMain, DB.USnippetKind, UBox, UColours, UCtrlArranger, UFontHelper, + DB.Main, + DB.SnippetKind, + UBox, + UColours, + UCtrlArranger, + UFontHelper, UPreferences; {$R *.dfm} @@ -387,8 +408,8 @@ function TDependenciesDlg.GetDisplayName: string; begin if fDisplayName <> '' then Exit(fDisplayName); - if fSnippetID.Name <> '' then - Exit(fSnippetID.Name); + if fSnippetID.Key <> '' then + Exit(fSnippetID.Key); Result := sUntitled; end; @@ -398,16 +419,18 @@ procedure TDependenciesDlg.lbDependentsDrawItem(Control: TWinControl; LB: TListBox; Canvas: TCanvas; - function IsUserDefinedItem: Boolean; + function ExtractVaultItem: TVaultID; begin - Result := (LB.Items.Objects[Index] as TBox).Value; + Result := (LB.Items.Objects[Index] as TBox).Value; end; begin LB := Control as TListBox; Canvas := LB.Canvas; if not (odSelected in State) then - Canvas.Font.Color := Preferences.DBHeadingColours[IsUserDefinedItem]; + Canvas.Font.Color := Preferences.GetSnippetHeadingColour( + ExtractVaultItem + ); Canvas.TextRect( Rect, Rect.Left + 2, @@ -437,14 +460,14 @@ procedure TDependenciesDlg.PopulateRequiredByList; // must only try to get dependents for snippet if it is in database if (tiRequiredBy in fTabs) and Assigned(ThisSnippet) then begin - Dependents := (Database as IDatabaseEdit).GetDependents(ThisSnippet); + Dependents := Database.GetDependents(ThisSnippet); for SnippetID in Dependents do begin ASnippet := Database.Snippets.Find(SnippetID); Assert(Assigned(ASnippet), ClassName + '.PopulateRequiredByList: Snippet id not found'); lbDependents.Items.AddObject( - ASnippet.DisplayName, TBox.Create(ASnippet.UserDefined) + ASnippet.DisplayName, TBox.Create(ASnippet.VaultID) ); end; end; @@ -494,6 +517,14 @@ constructor TDependenciesDlg.TTVDraw.Create( fRootID := RootID; end; +function TDependenciesDlg.TTVDraw.GetVaultID(const Node: TTreeNode): TVaultID; +begin + if not Assigned(Node.Data) then + Result := TVaultID.CreateNull + else + Result := TSnippet(Node.Data).VaultID; +end; + function TDependenciesDlg.TTVDraw.IsErrorNode( const Node: TTreeNode): Boolean; {Checks if a node represents an error condition. @@ -504,18 +535,5 @@ function TDependenciesDlg.TTVDraw.IsErrorNode( Result := Assigned(Node.Data) and (TSnippet(Node.Data).ID = fRootID); end; -function TDependenciesDlg.TTVDraw.IsUserDefinedNode( - const Node: TTreeNode): Boolean; - {Checks if a node represents a user defined snippets object. - @param Node [in] Node to be checked. - @return True if node represents user defined object, False if not. - } -begin - if not Assigned(Node.Data) then - Result := True - else - Result := TSnippet(Node.Data).UserDefined; -end; - end. diff --git a/Src/FmDuplicateSnippetDlg.dfm b/Src/FmDuplicateSnippetDlg.dfm index 567120d7e..08dce8e37 100644 --- a/Src/FmDuplicateSnippetDlg.dfm +++ b/Src/FmDuplicateSnippetDlg.dfm @@ -1,7 +1,7 @@ inherited DuplicateSnippetDlg: TDuplicateSnippetDlg Caption = 'DuplicateSnippetDlg' ExplicitWidth = 474 - ExplicitHeight = 356 + ExplicitHeight = 375 PixelsPerInch = 96 TextHeight = 13 inherited pnlBody: TPanel @@ -9,17 +9,9 @@ inherited DuplicateSnippetDlg: TDuplicateSnippetDlg Height = 185 ExplicitWidth = 222 ExplicitHeight = 185 - object lblUniqueName: TLabel - Left = 0 - Top = 0 - Width = 173 - Height = 13 - Caption = '&Unique name for duplicated snippet:' - FocusControl = edUniqueName - end object lblCategory: TLabel Left = 0 - Top = 104 + Top = 58 Width = 49 Height = 13 Caption = '&Category:' @@ -27,48 +19,54 @@ inherited DuplicateSnippetDlg: TDuplicateSnippetDlg end object lblDisplayName: TLabel Left = 0 - Top = 48 - Width = 67 + Top = 2 + Width = 36 Height = 13 - Caption = '&Display name:' + Caption = '&Snippet' FocusControl = edDisplayName end - object edUniqueName: TEdit + object lblVaults: TLabel Left = 0 - Top = 19 - Width = 222 - Height = 21 - Anchors = [akLeft, akTop, akRight] - TabOrder = 0 - ExplicitWidth = 200 + Top = 116 + Width = 28 + Height = 13 + Caption = '&Vault:' + FocusControl = cbVaults end object cbCategory: TComboBox Left = 0 - Top = 123 + Top = 77 Width = 222 Height = 21 Style = csDropDownList Anchors = [akLeft, akTop, akRight] - TabOrder = 2 + TabOrder = 1 end object edDisplayName: TEdit Left = 0 - Top = 67 + Top = 21 Width = 222 Height = 21 Anchors = [akLeft, akTop, akRight] - TabOrder = 1 - ExplicitWidth = 200 + TabOrder = 0 end object chkEdit: TCheckBox Left = 0 - Top = 160 + Top = 162 Width = 222 Height = 17 Anchors = [akLeft, akTop, akRight] Caption = '&Edit in Snippets Editor' + TabOrder = 2 + end + object cbVaults: TComboBox + Left = 0 + Top = 135 + Width = 222 + Height = 21 + Style = csDropDownList + Anchors = [akLeft, akTop, akRight] TabOrder = 3 - ExplicitWidth = 200 end end inherited btnHelp: TButton diff --git a/Src/FmDuplicateSnippetDlg.pas b/Src/FmDuplicateSnippetDlg.pas index 4c207e683..d0b063dc8 100644 --- a/Src/FmDuplicateSnippetDlg.pas +++ b/Src/FmDuplicateSnippetDlg.pas @@ -5,7 +5,7 @@ * * Copyright (C) 2012-2023, Peter Johnson (gravatar.com/delphidabbler). * - * Implements a dialogue box which can create a duplicate copy of asnippet. + * Implements a dialogue box which can create a duplicate copy of a snippet. } @@ -17,9 +17,18 @@ interface uses // Delphi - SysUtils, Controls, StdCtrls, ExtCtrls, Classes, + SysUtils, + Controls, + StdCtrls, + ExtCtrls, + Classes, // Project - DB.USnippet, FmGenericOKDlg, UBaseObjects, UCategoryListAdapter, + DB.Snippets, + DB.Vaults, + FmGenericOKDlg, + UBaseObjects, + UI.Adapters.CategoryList, + UI.Adapters.VaultList, UIStringList; @@ -28,10 +37,10 @@ TDuplicateSnippetDlg = class(TGenericOKDlg, INoPublicConstruct) cbCategory: TComboBox; chkEdit: TCheckBox; edDisplayName: TEdit; - edUniqueName: TEdit; lblCategory: TLabel; lblDisplayName: TLabel; - lblUniqueName: TLabel; + lblVaults: TLabel; + cbVaults: TComboBox; procedure btnOKClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); @@ -51,9 +60,13 @@ TPersistentOptions = class(TObject) var fSnippet: TSnippet; fCatList: TCategoryListAdapter; + fVaultList: TVaultListAdapter; fOptions: TPersistentOptions; - function DisallowedNames: IStringList; - function UniqueSnippetName(const BaseName: string): string; + fSnippetKey: string; + /// Returns the ID of the vault selected in the vaults drop down + /// list, or the null vault ID if no vault is selected. + function SelectedVaultID: TVaultID; + function SelectedCategoryID: string; procedure ValidateData; procedure HandleException(const E: Exception); procedure UpdateDatabase; @@ -77,11 +90,23 @@ implementation // Delphi Math, // Project - DB.UCategory, DB.UMain, UCtrlArranger, UExceptions, UMessageBox, USettings, - USnippetValidator, UStructs, UStrUtils, UUserDBMgr; + DB.Categories, + DB.Main, + DB.SnippetIDs, + UCtrlArranger, + UExceptions, + UMessageBox, + USettings, + USnippetValidator, + UStructs, + UStrUtils, + UUserDBMgr; {$R *.dfm} +{TODO -cTidy: Re-order methods alphabetically} +{TODO -cRefactor: Add method to get display name from ctrl and strip whitespace} + { TDuplicateSnippetDlg } procedure TDuplicateSnippetDlg.ArrangeForm; @@ -90,19 +115,21 @@ procedure TDuplicateSnippetDlg.ArrangeForm; TCtrlArranger.AlignLefts( [ - lblUniqueName, lblDisplayName, lblCategory, edUniqueName, edDisplayName, - cbCategory, chkEdit + lblDisplayName, edDisplayName, + lblCategory, cbCategory, + lblVaults, cbVaults, + chkEdit ], 0 ); - lblUniqueName.Top := 0; - TCtrlArranger.MoveBelow(lblUniqueName, edUniqueName, 4); - TCtrlArranger.MoveBelow(edUniqueName, lblDisplayName, 8); + lblDisplayName.Top := 0; TCtrlArranger.MoveBelow(lblDisplayName, edDisplayName, 4); TCtrlArranger.MoveBelow(edDisplayName, lblCategory, 8); TCtrlArranger.MoveBelow(lblCategory, cbCategory, 4); - TCtrlArranger.MoveBelow(cbCategory, chkEdit, 20); + TCtrlArranger.MoveBelow(cbCategory, lblVaults, 8); + TCtrlArranger.MoveBelow(lblVaults, cbVaults, 4); + TCtrlArranger.MoveBelow(cbVaults, chkEdit, 20); pnlBody.ClientWidth := Max( TCtrlArranger.TotalControlWidth(pnlBody) + 8, @@ -117,6 +144,7 @@ procedure TDuplicateSnippetDlg.btnOKClick(Sender: TObject); begin try ValidateData; + fSnippetKey := Database.GetUniqueSnippetKey(SelectedVaultID); UpdateDatabase; except on E: Exception do @@ -124,23 +152,12 @@ procedure TDuplicateSnippetDlg.btnOKClick(Sender: TObject); end; end; -function TDuplicateSnippetDlg.DisallowedNames: IStringList; -var - Snippet: TSnippet; -begin - Result := TIStringList.Create; - Result.CaseSensitive := False; - for Snippet in Database.Snippets do - if Snippet.UserDefined then - Result.Add(Snippet.Name); -end; - class function TDuplicateSnippetDlg.Execute(const AOwner: TComponent; const ASnippet: TSnippet): Boolean; var Dlg: TDuplicateSnippetDlg; resourcestring - sCaption = 'Duplicate %s'; // dialog box caption + sCaption = 'Duplicate "%s"'; // dialogue box caption begin Assert(Assigned(ASnippet), ClassName + '.Execute: ASnippet is nil'); Dlg := InternalCreate(AOwner); @@ -176,81 +193,81 @@ procedure TDuplicateSnippetDlg.HandleException(const E: Exception); procedure TDuplicateSnippetDlg.InitForm; var SnippetCat: TCategory; + SnippetVault: TVault; begin inherited; - edUniqueName.Text := UniqueSnippetName(fSnippet.Name); - edDisplayName.Text := StrIf( - StrSameStr(fSnippet.Name, fSnippet.DisplayName), '', fSnippet.DisplayName - ); + edDisplayName.Text := fSnippet.DisplayName; + fCatList.ToStrings(cbCategory.Items); + fVaultList.ToStrings(cbVaults.Items); + Assert(cbCategory.Items.Count > 0, ClassName + '.InitForm: no categories'); + Assert(cbVaults.Items.Count > 0, ClassName + '.InitForm: no vaults'); + SnippetCat := Database.Categories.Find(fSnippet.Category); - if Assigned(SnippetCat) then - cbCategory.ItemIndex := cbCategory.Items.IndexOf(SnippetCat.Description) - else - cbCategory.ItemIndex := -1; + Assert(Assigned(SnippetCat), ClassName + '.InitForm: invalid category'); + cbCategory.ItemIndex := cbCategory.Items.IndexOf(SnippetCat.Description); + + SnippetVault := TVaults.Instance.GetVault(fSnippet.VaultID); + cbVaults.ItemIndex := cbVaults.Items.IndexOf(SnippetVault.Name); + chkEdit.Checked := fOptions.EditSnippetOnClose; end; -function TDuplicateSnippetDlg.UniqueSnippetName(const BaseName: string): string; -var - ExistingNames: IStringList; - Postfix: Cardinal; +function TDuplicateSnippetDlg.SelectedCategoryID: string; +begin + Assert(cbCategory.ItemIndex >= 0, + ClassName + '.SelectedCategoryID: no category selected'); + Result := fCatList.CatID(cbCategory.ItemIndex); +end; + +function TDuplicateSnippetDlg.SelectedVaultID: TVaultID; begin - ExistingNames := DisallowedNames; - if not ExistingNames.Contains(BaseName) then - Exit(BaseName); - // BaseName exists: find number to append to it to make name unique - Postfix := 1; - repeat - Inc(PostFix); - Result := BaseName + IntToStr(PostFix); - until not ExistingNames.Contains(Result); + Assert(cbVaults.ItemIndex >= 0, + ClassName + '.SelectedVaultID: no vault selected'); + Result := fVaultList.Vault(cbVaults.ItemIndex).UID; end; procedure TDuplicateSnippetDlg.UpdateDatabase; -var - UniqueName: string; - DisplayName: string; begin - UniqueName := StrTrim(edUniqueName.Text); - DisplayName := StrTrim(edDisplayName.Text); - (Database as IDatabaseEdit).DuplicateSnippet( + Database.DuplicateSnippet( fSnippet, - UniqueName, - StrIf(StrSameStr(UniqueName, DisplayName), '', DisplayName), - fCatList.CatID(cbCategory.ItemIndex) + fSnippetKey, + SelectedVaultID, + StrTrim(edDisplayName.Text), + SelectedCategoryID ); end; procedure TDuplicateSnippetDlg.ValidateData; -var - ErrMsg: string; - ErrSel: TSelection; resourcestring sNoCategory = 'You must choose a category'; + sNoVault = 'You must choose a vault'; + sNoDisplayName = 'You must provide a display name'; begin - if not TSnippetValidator.ValidateName( - StrTrim(edUniqueName.Text), True, ErrMsg, ErrSel - ) then - raise EDataEntry.Create(ErrMsg, edUniqueName, ErrSel); + if StrTrim(edDisplayName.Text) = '' then + raise EDataEntry.Create(sNoDisplayName, edDisplayName); if cbCategory.ItemIndex = -1 then raise EDataEntry.Create(sNoCategory, cbCategory); + if cbVaults.ItemIndex = -1 then + raise EDataEntry.Create(sNoVault, cbVaults); end; procedure TDuplicateSnippetDlg.FormCreate(Sender: TObject); begin inherited; fCatList := TCategoryListAdapter.Create(Database.Categories); + fVaultList := TVaultListAdapter.Create; fOptions := TPersistentOptions.Create; end; procedure TDuplicateSnippetDlg.FormDestroy(Sender: TObject); begin if (ModalResult = mrOK) and chkEdit.Checked then - TUserDBMgr.EditSnippet(StrTrim(edUniqueName.Text)); + TUserDBMgr.EditSnippet(TSnippetID.Create(fSnippetKey, SelectedVaultID)); fOptions.EditSnippetOnClose := chkEdit.Checked; inherited; fOptions.Free; + fVaultList.Free; fCatList.Free; end; diff --git a/Src/FmFavouritesDlg.pas b/Src/FmFavouritesDlg.pas index 7213d1852..6016cf26b 100644 --- a/Src/FmFavouritesDlg.pas +++ b/Src/FmFavouritesDlg.pas @@ -23,7 +23,10 @@ interface // 3rd party LVEx, // Project - FmGenericNonModalDlg, Favourites.UFavourites, IntfNotifier, USnippetIDs, + DB.SnippetIDs, + FmGenericNonModalDlg, + Favourites.UFavourites, + IntfNotifier, UWindowSettings; @@ -271,10 +274,20 @@ implementation uses // Delphi - SysUtils, DateUtils, Windows, Graphics, + SysUtils, + DateUtils, + Windows, + Graphics, // Project - DB.UMain, DB.USnippet, UCtrlArranger, UMessageBox, UPreferences, USettings, - UStructs, UStrUtils; + DB.Main, + DB.Snippets, + DB.Vaults, + UCtrlArranger, + UMessageBox, + UPreferences, + USettings, + UStructs, + UStrUtils; {$R *.dfm} @@ -343,9 +356,7 @@ procedure TFavouritesDlg.actDisplayExecute(Sender: TObject); LI := fLVFavs.Selected as TFavouriteListItem; SelectedSnippet := LI.Favourite.SnippetID; fNotifier.DisplaySnippet( - SelectedSnippet.Name, - SelectedSnippet.UserDefined, - chkNewTab.Checked + SelectedSnippet.Key, SelectedSnippet.VaultID, chkNewTab.Checked ); fFavourites.Touch(SelectedSnippet); fLVFavs.Selected := FindListItem(SelectedSnippet); @@ -366,7 +377,7 @@ procedure TFavouritesDlg.AddLVItem(const Favourite: TFavourite); if Assigned(Snippet) then LI.Caption := Snippet.DisplayName else - LI.Caption := Favourite.SnippetID.Name; + LI.Caption := Favourite.SnippetID.Key; if IsToday(Favourite.LastAccessed) then LI.SubItems.Add(TimeToStr(Favourite.LastAccessed)) else @@ -579,10 +590,12 @@ class function TFavouritesDlg.IsDisplayed: Boolean; procedure TFavouritesDlg.LVCustomDrawItem(Sender: TCustomListView; Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean); var - UserDefined: Boolean; + VaultID: TVaultID; begin - UserDefined := (Item as TFavouriteListItem).Favourite.SnippetID.UserDefined; - fLVFavs.Canvas.Font.Color := Preferences.DBHeadingColours[UserDefined]; + VaultID := (Item as TFavouriteListItem).Favourite.SnippetID.VaultID; + fLVFavs.Canvas.Font.Color := Preferences.GetSnippetHeadingColour( + VaultID + ); end; procedure TFavouritesDlg.LVCustomDrawSubItem(Sender: TCustomListView; diff --git a/Src/FmFindXRefsDlg.pas b/Src/FmFindXRefsDlg.pas index 0d301ef98..a09373192 100644 --- a/Src/FmFindXRefsDlg.pas +++ b/Src/FmFindXRefsDlg.pas @@ -20,9 +20,15 @@ interface uses // Delphi - StdCtrls, Controls, ExtCtrls, Classes, + StdCtrls, + Controls, + ExtCtrls, + Classes, // Project - DB.USnippet, FmGenericOKDlg, UBaseObjects, USearch; + DB.Snippets, + FmGenericOKDlg, + UBaseObjects, + USearch; type @@ -127,9 +133,15 @@ implementation uses // Delphi - SysUtils, Graphics, + SysUtils, + Graphics, // Project - UColours, UCtrlArranger, UPreferences, UQuery, USettings; + DB.Vaults, + UColours, + UCtrlArranger, + UPreferences, + UQuery, + USettings; {$R *.dfm} @@ -229,7 +241,7 @@ procedure TFindXRefsDlg.ConfigForm; // Set label font styles and colours lblSnippetName.Font.Style := [fsBold]; lblSnippetName.Font.Color := - Preferences.DBHeadingColours[fSnippet.UserDefined]; + Preferences.GetSnippetHeadingColour(fSnippet.VaultID); // Display selected snippet name in appropriate controls lblSnippetName.Caption := fSnippet.DisplayName; chkIncludeSnippet.Caption := Format( diff --git a/Src/FmMain.dfm b/Src/FmMain.dfm index 5b2eab657..7bff16ed5 100644 --- a/Src/FmMain.dfm +++ b/Src/FmMain.dfm @@ -613,29 +613,25 @@ inherited MainForm: TMainForm OnExecute = actPrintExecute OnUpdate = actPrintUpdate end - object actBackupDatabase: TAction + object actBackupVault: TAction Category = 'Database' - Caption = 'Backup User Database...' - Hint = 'Backup user database|Backup the user-defined snippet database' + Caption = 'Backup Vault...' + Hint = 'Backup a vault|Backup a vault'#39's data files' ImageIndex = 33 - OnExecute = actBackupDatabaseExecute - OnUpdate = ActNonEmptyUserDBUpdate + OnExecute = actBackupVaultExecute + OnUpdate = ActNonEmptyDBUpdate end - object actRestoreDatabase: TAction + object actRestoreVault: TAction Category = 'Database' - Caption = 'Restore User Database...' - Hint = - 'Restore user database|Restore the user-defined snippet database ' + - 'from a backup' + Caption = 'Restore Vault...' + Hint = 'Restore a vault|Restore a vaults'#39's data files from a backup' ImageIndex = 32 - OnExecute = actRestoreDatabaseExecute + OnExecute = actRestoreVaultExecute end object actSaveDatabase: TAction Category = 'Database' - Caption = 'Save User Database' - Hint = - 'Save user database|Save all changes to the user-defined snippet ' + - 'database' + Caption = 'Save Database' + Hint = 'Save database|Save all vaults to the database' ImageIndex = 25 ShortCut = 16467 OnExecute = actSaveDatabaseExecute @@ -843,14 +839,12 @@ inherited MainForm: TMainForm OnExecute = actAddFavouriteExecute OnUpdate = actAddFavouriteUpdate end - object actMoveUserDatabase: TAction + object actMoveVault: TAction Category = 'Database' - Caption = 'Move User Database...' - Hint = - 'Move user database|Move the user-defined snippet database to a n' + - 'ew directory' - OnExecute = actMoveUserDatabaseExecute - OnUpdate = ActNonEmptyUserDBUpdate + Caption = 'Move Vault Data Files...' + Hint = 'Move a vault|Move a vault'#39's data files to a new directory' + OnExecute = actMoveVaultExecute + OnUpdate = ActNonEmptyDBUpdate end object actSWAGImport: TAction Category = 'Snippets' @@ -868,14 +862,14 @@ inherited MainForm: TMainForm ' CodeSnip news, in the default web browser' ImageIndex = 6 end - object actDeleteUserDatabase: TAction + object actDeleteVault: TAction Category = 'Database' - Caption = 'Delete User Database...' + Caption = 'Delete All Snippets From Vault' Hint = - 'Delete User Database|Deletes the user'#39's snippets database - USE ' + - 'WITH CAUTION' - OnExecute = actDeleteUserDatabaseExecute - OnUpdate = ActNonEmptyUserDBUpdate + 'Delete All Snippets From A Vault|Deletes all the snippets from a' + + ' chosen vault - USE WITH CAUTION' + OnExecute = actDeleteVaultExecute + OnUpdate = ActNonEmptyDBUpdate end object actSaveInfo: TAction Category = 'File' @@ -1099,11 +1093,11 @@ inherited MainForm: TMainForm object miSpacer11: TMenuItem Caption = '-' end - object miBackupDatabase: TMenuItem - Action = actBackupDatabase + object miBackupVault: TMenuItem + Action = actBackupVault end - object miRestoreDatabase: TMenuItem - Action = actRestoreDatabase + object miRestoreVault: TMenuItem + Action = actRestoreVault end object miSpacer13: TMenuItem Caption = '-' @@ -1114,14 +1108,14 @@ inherited MainForm: TMainForm object miSpacer20: TMenuItem Caption = '-' end - object miMoveUserDatabase: TMenuItem - Action = actMoveUserDatabase + object miMoveVault: TMenuItem + Action = actMoveVault end object miSpacer21: TMenuItem Caption = '-' end - object miDeleteUserDatabase: TMenuItem - Action = actDeleteUserDatabase + object miDeleteVault: TMenuItem + Action = actDeleteVault end end object miCompile: TMenuItem diff --git a/Src/FmMain.pas b/Src/FmMain.pas index 6fc09ef54..d4ecf88c0 100644 --- a/Src/FmMain.pas +++ b/Src/FmMain.pas @@ -55,7 +55,7 @@ TMainForm = class(THelpAwareForm) actAddCategory: TAction; actAddFavourite: TAction; actAddSnippet: TAction; - actBackupDatabase: TAction; + actBackupVault: TAction; actBlog: TBrowseURL; actBugReport: TAction; actCloseAllDetailsTabs: TAction; @@ -70,7 +70,7 @@ TMainForm = class(THelpAwareForm) actCopySource: TAction; actDeleteCategory: TAction; actDeleteSnippet: TAction; - actDeleteUserDatabase: TAction; + actDeleteVault: TAction; actDuplicateSnippet: TAction; actEditSnippet: TAction; actExit: TFileExit; @@ -92,14 +92,14 @@ TMainForm = class(THelpAwareForm) actImportCode: TAction; actLicense: TAction; actLoadSelection: TAction; - actMoveUserDatabase: TAction; + actMoveVault: TAction; actNextTab: TAction; actNewDetailsTab: TAction; actPreferences: TAction; actPreviousTab: TAction; actPrint: TAction; actRenameCategory: TAction; - actRestoreDatabase: TAction; + actRestoreVault: TAction; actSaveDatabase: TAction; actSaveSelection: TAction; actSaveSnippet: TAction; @@ -126,7 +126,7 @@ TMainForm = class(THelpAwareForm) miAddCategory: TMenuItem; miAddFavourite: TMenuItem; miAddSnippet: TMenuItem; - miBackupDatabase: TMenuItem; + miBackupVault: TMenuItem; miBlog: TMenuItem; miCategories: TMenuItem; miCloseAllDetailsTabs: TMenuItem; @@ -141,7 +141,7 @@ TMainForm = class(THelpAwareForm) miDatabase: TMenuItem; miDeleteCategory: TMenuItem; miDeleteSnippet: TMenuItem; - miDeleteUserDatabase: TMenuItem; + miDeleteVault: TMenuItem; miDuplicateSnippet: TMenuItem; miEdit: TMenuItem; miEditSnippet: TMenuItem; @@ -166,13 +166,13 @@ TMainForm = class(THelpAwareForm) miImportCode: TMenuItem; miLicense: TMenuItem; miLoadSelection: TMenuItem; - miMoveUserDatabase: TMenuItem; + miMoveVault: TMenuItem; miNewDetailsTab: TMenuItem; miPreferences: TMenuItem; miPrint: TMenuItem; miRenameCategory: TMenuItem; miReportBug: TMenuItem; - miRestoreDatabase: TMenuItem; + miRestoreVault: TMenuItem; miSaveDatabase: TMenuItem; miSaveSelection: TMenuItem; miSaveSnippet: TMenuItem; @@ -256,7 +256,7 @@ TMainForm = class(THelpAwareForm) /// database. procedure actAddSnippetExecute(Sender: TObject); /// Makes a backup of the user database. - procedure actBackupDatabaseExecute(Sender: TObject); + procedure actBackupVaultExecute(Sender: TObject); /// Displays Bug Report dialogue box. procedure actBugReportExecute(Sender: TObject); /// Closes all open tabs in details pane. @@ -301,7 +301,7 @@ TMainForm = class(THelpAwareForm) procedure actDeleteSnippetExecute(Sender: TObject); /// Requests permission then attempts to delete the user defined /// snippets database. - procedure actDeleteUserDatabaseExecute(Sender: TObject); + procedure actDeleteVaultExecute(Sender: TObject); /// Displays a dialogue box that can be used to duplicate the /// selected snippet. procedure actDuplicateSnippetExecute(Sender: TObject); @@ -361,7 +361,7 @@ TMainForm = class(THelpAwareForm) /// Displays a dialogue box that can be used to move the user /// database to a user defined directory. /// This action must be hidden in the portable edition. - procedure actMoveUserDatabaseExecute(Sender: TObject); + procedure actMoveVaultExecute(Sender: TObject); /// Creates a new empty tab in details pane. procedure actNewDetailsTabExecute(Sender: TObject); /// Displays next tab in either overview or details pane depending @@ -397,7 +397,7 @@ TMainForm = class(THelpAwareForm) procedure actRenameCategoryUpdate(Sender: TObject); /// Displays a dialogue box from which a backup file can be /// selected and used to restore the user defined database. - procedure actRestoreDatabaseExecute(Sender: TObject); + procedure actRestoreVaultExecute(Sender: TObject); /// Save any changes in the user defined database to disk. /// procedure actSaveDatabaseExecute(Sender: TObject); @@ -502,7 +502,6 @@ TMainForm = class(THelpAwareForm) /// position is permitted and blocks the move if not. procedure splitVertCanResize(Sender: TObject; var NewSize: Integer; var Accept: Boolean); - procedure ActNonEmptyUserDBUpdate(Sender: TObject); procedure actSaveInfoUpdate(Sender: TObject); procedure actSaveInfoExecute(Sender: TObject); strict private @@ -532,10 +531,10 @@ TMainForm = class(THelpAwareForm) /// Displays view item from history list given by TViewItemAction /// instance referenced by Sender. procedure ActViewHistoryItemExecute(Sender: TObject); - /// Opens a named user defined snippet in Snippets Editor for - /// editing. The snippet name is provided by the TEditSnippetAction - /// instance referenced by Sender. - procedure ActEditSnippetByNameExecute(Sender: TObject); + /// Opens snippet in Snippets Editor for editing. The snippet ID + /// is provided by the TEditSnippetAction instance referenced by Sender. + /// + procedure ActEditSnippetByIDExecute(Sender: TObject); /// Selects a tab in the details pane where the tab is provided by /// the TDetailTabAction instance referenced by Sender. procedure ActSelectDetailTabExecute(Sender: TObject); @@ -585,18 +584,48 @@ implementation uses // Delphi - Windows, Graphics, + Windows, + Graphics, // Project ClassHelpers.UControls, ClassHelpers.UGraphics, - DB.UCategory, DB.UMain, DB.USnippet, FmSplash, FmTrappedBugReportDlg, - FmWaitDlg, IntfFrameMgrs, UActionFactory, UAppInfo, - UCodeShareMgr, UCommandBars, UConsts, UCopyInfoMgr, - UCopySourceMgr, UDatabaseLoader, UDatabaseLoaderUI, UDetailTabAction, - UEditSnippetAction, UExceptions, UHelpMgr, UHistoryMenus, UKeysHelper, - UMessageBox, UNotifier, UNulDropTarget, UPrintMgr, UQuery, USaveInfoMgr, - USaveSnippetMgr, USaveUnitMgr, USelectionIOMgr, UUrl, UUserDBMgr, UView, - UViewItemAction, UWBExternal; + DB.Categories, + DB.Main, + DB.Snippets, + DB.Vaults, + FmSplash, + FmTrappedBugReportDlg, + FmWaitDlg, + IntfFrameMgrs, + UActionFactory, + UAppInfo, + UCodeShareMgr, + UCommandBars, + UConsts, + UCopyInfoMgr, + UCopySourceMgr, + UDatabaseLoader, + UDatabaseLoaderUI, + UDetailTabAction, + UEditSnippetAction, + UExceptions, + UHelpMgr, + UHistoryMenus, + UKeysHelper, + UMessageBox, + UNotifier, + UNulDropTarget, + UPrintMgr, + UQuery, + USaveInfoMgr, + USaveSnippetMgr, + USaveUnitMgr, + USelectionIOMgr, + UUrl, + UUserDBMgr, + UView, + UViewItemAction, + UWBExternal; {$R *.dfm} @@ -631,9 +660,9 @@ procedure TMainForm.actAddSnippetExecute(Sender: TObject); TUserDBMgr.AddSnippet; end; -procedure TMainForm.actBackupDatabaseExecute(Sender: TObject); +procedure TMainForm.actBackupVaultExecute(Sender: TObject); begin - if (Database as IDatabaseEdit).Updated then + if Database.Updated then TUserDBMgr.Save(Self); TUserDBMgr.BackupDatabase(Self); fStatusBarMgr.Update; @@ -734,9 +763,9 @@ procedure TMainForm.actDeleteSnippetExecute(Sender: TObject); // display update is handled by snippets change event handler end; -procedure TMainForm.actDeleteUserDatabaseExecute(Sender: TObject); +procedure TMainForm.actDeleteVaultExecute(Sender: TObject); begin - if (Database as IDatabaseEdit).Updated then + if Database.Updated then TUserDBMgr.Save(Self); if TUserDBMgr.DeleteDatabase then begin @@ -762,18 +791,19 @@ procedure TMainForm.ActEditDeleteSnippetUpdate(Sender: TObject); TUserDBMgr.CanEdit(fMainDisplayMgr.CurrentView); end; -procedure TMainForm.ActEditSnippetByNameExecute(Sender: TObject); +procedure TMainForm.ActEditSnippetByIDExecute(Sender: TObject); begin - TUserDBMgr.EditSnippet((Sender as TEditSnippetAction).SnippetName); + TUserDBMgr.EditSnippet((Sender as TEditSnippetAction).ID); end; procedure TMainForm.actEditSnippetExecute(Sender: TObject); +var + Snippet: TSnippet; begin Assert(TUserDBMgr.CanEdit(fMainDisplayMgr.CurrentView), ClassName + '.actEditSnippetExecute: Can''t edit current view item'); - fNotifier.EditSnippet( - (fMainDisplayMgr.CurrentView as ISnippetView).Snippet.Name - ); + Snippet := (fMainDisplayMgr.CurrentView as ISnippetView).Snippet; + fNotifier.EditSnippet(Snippet.Key, Snippet.VaultID); // display of updated snippet is handled by snippets change event handler end; @@ -920,9 +950,9 @@ procedure TMainForm.actLoadSelectionExecute(Sender: TObject); DoSearchFilter(Search); end; -procedure TMainForm.actMoveUserDatabaseExecute(Sender: TObject); +procedure TMainForm.actMoveVaultExecute(Sender: TObject); begin - if (Database as IDatabaseEdit).Updated then + if Database.Updated then TUserDBMgr.Save(Self); TUserDBMgr.MoveDatabase; end; @@ -942,11 +972,6 @@ procedure TMainForm.ActNonEmptyDBUpdate(Sender: TObject); (Sender as TAction).Enabled := not Database.Snippets.IsEmpty; end; -procedure TMainForm.ActNonEmptyUserDBUpdate(Sender: TObject); -begin - (Sender as TAction).Enabled := not Database.Snippets.IsEmpty(True); -end; - procedure TMainForm.ActOverviewTabExecute(Sender: TObject); begin // Action's Tag property specifies index of tab being selected @@ -1003,7 +1028,7 @@ procedure TMainForm.actRenameCategoryUpdate(Sender: TObject); (Sender as TAction).Enabled := TUserDBMgr.CanRenameACategory; end; -procedure TMainForm.actRestoreDatabaseExecute(Sender: TObject); +procedure TMainForm.actRestoreVaultExecute(Sender: TObject); begin if TUserDBMgr.RestoreDatabase(Self) then begin @@ -1149,7 +1174,7 @@ procedure TMainForm.actUpdateDbaseExecute(Sender: TObject); if fDialogMgr.ExecDBUpdateDlg then begin // Database was updated: check if user database needs saving - if (Database as IDatabaseEdit).Updated + if Database.Updated and TMessageBox.Confirm(Self, sConfirmSave) then TUserDBMgr.Save(Self); // Reload the databases @@ -1316,14 +1341,11 @@ procedure TMainForm.FormCreate(Sender: TObject); end; procedure TMainForm.FormDestroy(Sender: TObject); -var - EditableDB: IDatabaseEdit; begin inherited; // Save any changes to user database - EditableDB := Database as IDatabaseEdit; - if EditableDB.Updated then - EditableDB.Save; + if Database.Updated then + Database.Save; // Unhook snippets event handler Database.RemoveChangeEventHandler(DBChangeHandler); @@ -1407,7 +1429,6 @@ procedure TMainForm.InitForm; // note that actions created on fly are automatically freed fNotifier := TNotifier.Create; ActionSetter := fNotifier as ISetActions; - ActionSetter.SetUpdateDbaseAction(actUpdateDbase); ActionSetter.SetDisplaySnippetAction( TActionFactory.CreateSnippetAction(Self) ); @@ -1425,11 +1446,8 @@ procedure TMainForm.InitForm; TActionFactory.CreateDetailTabAction(Self, ActSelectDetailTabExecute) ); ActionSetter.SetEditSnippetAction( - TActionFactory.CreateEditSnippetAction( - Self, ActEditSnippetByNameExecute - ) + TActionFactory.CreateEditSnippetAction(Self, ActEditSnippetByIDExecute) ); - ActionSetter.SetNewSnippetAction(actAddSnippet); ActionSetter.SetNewsAction(actBlog); ActionSetter.SetAboutBoxAction(actAbout); diff --git a/Src/FmRenameCategoryDlg.dfm b/Src/FmRenameCategoryDlg.dfm index f0e9bbe65..4ba71bbd2 100644 --- a/Src/FmRenameCategoryDlg.dfm +++ b/Src/FmRenameCategoryDlg.dfm @@ -1,5 +1,7 @@ inherited RenameCategoryDlg: TRenameCategoryDlg Caption = 'Rename Category' + ExplicitWidth = 320 + ExplicitHeight = 240 PixelsPerInch = 96 TextHeight = 13 inherited pnlBody: TPanel @@ -10,10 +12,6 @@ inherited RenameCategoryDlg: TRenameCategoryDlg Height = 240 TabOrder = 0 TabStop = True - inherited lblCategories: TLabel - Width = 60 - ExplicitWidth = 60 - end end inline frmDescription: TCategoryDescEditFrame Left = 0 @@ -23,10 +21,6 @@ inherited RenameCategoryDlg: TRenameCategoryDlg TabOrder = 1 TabStop = True ExplicitTop = 120 - inherited lblError: TLabel - Width = 108 - ExplicitWidth = 108 - end end end inherited btnOK: TButton diff --git a/Src/FmRenameCategoryDlg.pas b/Src/FmRenameCategoryDlg.pas index 039d6905a..6dac08204 100644 --- a/Src/FmRenameCategoryDlg.pas +++ b/Src/FmRenameCategoryDlg.pas @@ -18,9 +18,16 @@ interface uses // Delphi - Forms, StdCtrls, Controls, ExtCtrls, Classes, + Forms, + StdCtrls, + Controls, + ExtCtrls, + Classes, // Project - DB.UCategory, FmCategoryEditDlg, FrCategoryList, FrCategoryDescEdit, + DB.Categories, + FmCategoryEditDlg, + FrCategoryList, + FrCategoryDescEdit, UBaseObjects; @@ -92,7 +99,9 @@ implementation // Delphi Windows {for inlining}, // Project - DB.UMain, UCtrlArranger, UStrUtils; + DB.Main, + UCtrlArranger, + UStrUtils; {$R *.dfm} @@ -203,9 +212,9 @@ procedure TRenameCategoryDlg.RenameCategory(const Category: TCategory; var EditData: TCategoryData; // category properties begin - EditData := (Database as IDatabaseEdit).GetEditableCategoryInfo(Category); + EditData := Database.GetEditableCategoryInfo(Category); EditData.Desc := NewDesc; - (Database as IDatabaseEdit).UpdateCategory(Category, EditData); + Database.UpdateCategory(Category, EditData); end; procedure TRenameCategoryDlg.UpdateOKBtn; diff --git a/Src/FmSWAGImportDlg.dfm b/Src/FmSWAGImportDlg.dfm index e93311a78..112c2f536 100644 --- a/Src/FmSWAGImportDlg.dfm +++ b/Src/FmSWAGImportDlg.dfm @@ -19,7 +19,7 @@ inherited SWAGImportDlg: TSWAGImportDlg inherited pcWizard: TPageControl Width = 671 Height = 456 - ActivePage = tsFinish + ActivePage = tsUpdate ExplicitWidth = 671 ExplicitHeight = 456 object tsIntro: TTabSheet @@ -184,7 +184,7 @@ inherited SWAGImportDlg: TSWAGImportDlg Caption = 'tsUpdate' ImageIndex = 2 TabVisible = False - object lblUpdateDesc: TLabel + object lblUpdateDesc1: TLabel Left = 0 Top = 3 Width = 649 @@ -192,26 +192,39 @@ inherited SWAGImportDlg: TSWAGImportDlg AutoSize = False Caption = 'You have chosen to import the following SWAG packets as CodeSnip' + - ' snippets. They will be imported with the given Display Names an' + - 'd Packet IDs. You can change these if you wish using the Snippet' + - 's Editor. To make changes go back to the previous page. When you' + - ' are ready to import the packets click "Import". This step can'#39't' + - ' be undone.' + ' snippets with the given Display Names. You can change these nam' + + 'es later, if you wish, using the Snippets Editor. To modify your' + + ' selection go back to the previous page.' WordWrap = True end + object lblUpdateDesc2: TLabel + Left = 0 + Top = 41 + Width = 649 + Height = 36 + AutoSize = False + Caption = + 'When you are ready to import the packets select the vault into w' + + 'hich you want to import them then click "Import". This step can'#39 + + 't be undone.' + WordWrap = True + end + object lblVaults: TLabel + Left = 0 + Top = 83 + Width = 60 + Height = 13 + Caption = 'Select &vault:' + end object lvImports: TListView Left = 0 - Top = 51 + Top = 107 Width = 660 - Height = 317 + Height = 288 Columns = < item Caption = 'Packet Title '#8594' Snippet Display Name' - Width = 400 - end - item - Caption = 'Snippet Name from SWAG ID' - Width = 200 + Width = 600 end> ColumnClick = False GridLines = True @@ -219,9 +232,17 @@ inherited SWAGImportDlg: TSWAGImportDlg ReadOnly = True RowSelect = True SortType = stText - TabOrder = 0 + TabOrder = 1 ViewStyle = vsReport end + object cbVaults: TComboBox + Left = 86 + Top = 80 + Width = 289 + Height = 21 + Style = csDropDownList + TabOrder = 0 + end end object tsFinish: TTabSheet Caption = 'tsFinish' @@ -262,8 +283,8 @@ inherited SWAGImportDlg: TSWAGImportDlg end end object alWizard: TActionList - Left = 336 - Top = 256 + Left = 224 + Top = 248 object actDisplayCategory: TAction Caption = 'S&how Packets In Category' OnExecute = actDisplayCategoryExecute diff --git a/Src/FmSWAGImportDlg.pas b/Src/FmSWAGImportDlg.pas index ffe252edc..5a8964c6b 100644 --- a/Src/FmSWAGImportDlg.pas +++ b/Src/FmSWAGImportDlg.pas @@ -7,7 +7,7 @@ * * Implements a wizard dialogue box that lets the user select and import * packets from the DelphiDabbler implementation of the SWAG Pascal archive as - * new user-defined CodeSnip snippets. + * new CodeSnip snippets. } @@ -24,9 +24,11 @@ interface StdCtrls, Forms, ExtCtrls, + ActnList, Classes, Generics.Collections, // Project + DB.Vaults, FmWizardDlg, FrBrowserBase, FrFixedHTMLDlg, @@ -37,13 +39,14 @@ interface UCSSBuilder, SWAG.UCommon, SWAG.UImporter, - SWAG.UReader, ActnList; + SWAG.UReader, + UI.Adapters.VaultList; type /// Class that implements a wizard dialogue box that lets the user /// select and import packets from the DelphiDabbler implementation of the - /// SWAG Pascal archive as new user-defined CodeSnip snippets. + /// SWAG Pascal archive as new snippets. TSWAGImportDlg = class(TWizardDlg, INoPublicConstruct) tsIntro: TTabSheet; tsCategories: TTabSheet; @@ -54,7 +57,7 @@ TSWAGImportDlg = class(TWizardDlg, INoPublicConstruct) clbSelectPackets: TCheckListBox; tsUpdate: TTabSheet; lvImports: TListView; - lblUpdateDesc: TLabel; + lblUpdateDesc1: TLabel; tsFinish: TTabSheet; frmOutro: THTMLTpltDlgFrame; btnDisplayCategory: TButton; @@ -71,6 +74,9 @@ TSWAGImportDlg = class(TWizardDlg, INoPublicConstruct) frmIntro: THTMLTpltDlgFrame; lblVersionNumber: TLabel; lblFolderPageInfo1: TLabel; + lblUpdateDesc2: TLabel; + lblVaults: TLabel; + cbVaults: TComboBox; /// Handles clicks on the check boxes next to packets in the /// packet selection list box by selecting and deselecting packets for /// inclusion in the import. @@ -104,6 +110,8 @@ TSWAGImportDlg = class(TWizardDlg, INoPublicConstruct) procedure actDisplayPacketExecute(Sender: TObject); /// Updates enabled state of display packet category. procedure actDisplayPacketUpdate(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); strict private const /// Index of introductory page in wizard. @@ -131,15 +139,22 @@ TSWAGImportDlg = class(TWizardDlg, INoPublicConstruct) /// List of packets selected for import, sorted by ID. /// fSelectedPackets: TSortedList; - /// Object that imports selected SWAG packets into CodeSnip's - /// user database. + /// Object that imports selected SWAG packets into a specified + /// vault. fImporter: TSWAGImporter; /// ID of currently selected category. /// Set to zero if no category is selected. fCurrentCatID: Cardinal; + /// Object that populates cbVaults with an alphabetical + /// list of vault names and manages interaction with it. + fVaultList: TVaultListAdapter; /// Retrieves import directory name from edit control where it is /// entered. function GetDirNameFromEditCtrl: string; + /// Retrieves vault specified by user that applies to imported + /// snippets. + /// TVaultID. The required vault ID. + function SelectedVaultID: TVaultID; /// Validates entries on the wizard page identified by the given /// page index. procedure ValidatePage(const PageIdx: Integer); @@ -183,8 +198,8 @@ TSWAGImportDlg = class(TWizardDlg, INoPublicConstruct) /// Gets the complete information for each packet selected for /// import and stores in the given list. procedure GetImportPackets(const PacketList: TList); - /// Performs the import of the selected packets as into CodeSnip's - /// user database as new user-defined snippets. + /// Performs the import of the selected packets into a specified + /// vault. /// Displays a wait dialogue box while the import is proceeding. /// procedure UpdateDatabase; @@ -350,11 +365,19 @@ procedure TSWAGImportDlg.ArrangeForm; TCtrlArranger.AlignHCentresTo([clbSelectPackets], [btnDisplayPacket]); // tsUpdate - lblUpdateDesc.Width := tsUpdate.ClientWidth; - lblUpdateDesc.Top := 3; + TCtrlArranger.AlignLefts( + [lblUpdateDesc1, lblUpdateDesc2, lblVaults, lvImports], 0 + ); + lblUpdateDesc1.Width := tsUpdate.ClientWidth; + lblUpdateDesc2.Width := tsUpdate.ClientWidth; lvImports.Width := tsUpdate.ClientWidth; - TCtrlArranger.AlignLefts([lblUpdateDesc, lvImports], 0); - TCtrlArranger.MoveBelow(lblUpdateDesc, lvImports, 12); + lblUpdateDesc1.Top := 3; + TCtrlArranger.MoveBelow(lblUpdateDesc1, lblUpdateDesc2, 4); + TCtrlArranger.AlignVCentres( + TCtrlArranger.BottomOf(lblUpdateDesc2, 8), [lblVaults, cbVaults] + ); + TCtrlArranger.MoveToRightOf(lblVaults, cbVaults, 4); + TCtrlArranger.MoveBelow([lblVaults, cbVaults], lvImports, 12); // tsFinish frmOutro.Height := frmOutro.DocHeight; @@ -503,6 +526,16 @@ procedure TSWAGImportDlg.ConfigForm; ); end ); + + // Set up vaults list + fVaultList.ToStrings(cbVaults.Items); + Assert(cbVaults.Items.Count > 0, + ClassName + '.ConfigForm: no vaults'); + Assert(TVaults.Instance.ContainsID(TVaultID.Default), + ClassName + '.ConfigForm: default vault not found'); + cbVaults.ItemIndex := fVaultList.IndexOfUID(TVaultID.Default); + Assert(cbVaults.ItemIndex >= 0, + ClassName + '.ConfigForm: default vault not in cbVaults'); end; destructor TSWAGImportDlg.Destroy; @@ -579,6 +612,18 @@ class function TSWAGImportDlg.Execute(const AOwner: TComponent): Boolean; end; end; +procedure TSWAGImportDlg.FormCreate(Sender: TObject); +begin + inherited; + fVaultList := TVaultListAdapter.Create; +end; + +procedure TSWAGImportDlg.FormDestroy(Sender: TObject); +begin + fVaultList.Free; + inherited; +end; + function TSWAGImportDlg.GetDirNameFromEditCtrl: string; begin Result := StrTrim(edPath.Text); @@ -771,7 +816,6 @@ procedure TSWAGImportDlg.PopulateImportsLV; begin LI := lvImports.Items.Add; LI.Caption := Packet.Title; - LI.SubItems.Add(TSWAGImporter.MakeValidSnippetName(Packet.ID)); end; finally lvImports.Items.EndUpdate; @@ -823,6 +867,13 @@ procedure TSWAGImportDlg.PreviewSelectedPacket; ); end; +function TSWAGImportDlg.SelectedVaultID: TVaultID; +begin + Assert(cbVaults.ItemIndex >= 0, + ClassName + '.SelectedVaultID: no vault selected'); + Result := fVaultList.Vault(cbVaults.ItemIndex).UID; +end; + procedure TSWAGImportDlg.UpdateButtons(const PageIdx: Integer); resourcestring // button caption for update page @@ -856,6 +907,7 @@ procedure TSWAGImportDlg.UpdateDatabase; procedure begin fImporter.Import( + SelectedVaultID, procedure (const Packet: TSWAGPacket) begin Application.ProcessMessages; diff --git a/Src/FmSelectionSearchDlg.dfm b/Src/FmSelectionSearchDlg.dfm index 17136ec70..687078e14 100644 --- a/Src/FmSelectionSearchDlg.dfm +++ b/Src/FmSelectionSearchDlg.dfm @@ -5,15 +5,15 @@ inherited SelectionSearchDlg: TSelectionSearchDlg PixelsPerInch = 96 TextHeight = 13 inherited pnlBody: TPanel - Width = 371 + Width = 379 Height = 293 - ExplicitWidth = 371 + ExplicitWidth = 379 ExplicitHeight = 293 object lblOverwriteSearch: TLabel AlignWithMargins = True Left = 0 Top = 280 - Width = 371 + Width = 379 Height = 13 Margins.Left = 0 Margins.Top = 8 @@ -45,7 +45,7 @@ inherited SelectionSearchDlg: TSelectionSearchDlg object btnSelectAll: TButton Left = 287 Top = 1 - Width = 83 + Width = 91 Height = 25 Caption = '&Select All' TabOrder = 1 @@ -54,50 +54,57 @@ inherited SelectionSearchDlg: TSelectionSearchDlg object btnClearAll: TButton Left = 287 Top = 32 - Width = 83 + Width = 91 Height = 25 Caption = '&Clear All' TabOrder = 2 OnClick = btnClearAllClick end - object btnUserDB: TButton - Left = 287 - Top = 63 - Width = 83 - Height = 25 - Caption = '&User Defined' - TabOrder = 3 - OnClick = btnUserDBClick - end - object btnMainDB: TButton - Left = 287 - Top = 94 - Width = 83 - Height = 25 - Caption = '&Main' - TabOrder = 4 - OnClick = btnMainDBClick - end object btnExpandAll: TButton Left = 287 Top = 174 - Width = 82 + Width = 91 Height = 25 Caption = 'E&xpand All' - TabOrder = 5 + TabOrder = 4 OnClick = btnExpandAllClick end object btnCollapseAll: TButton Left = 287 Top = 205 - Width = 82 + Width = 91 Height = 25 Caption = 'C&ollapse All' - TabOrder = 6 + TabOrder = 5 OnClick = btnCollapseAllClick end + object btnVaults: TBitBtn + Left = 287 + Top = 63 + Width = 91 + Height = 25 + Caption = '&Vault' + DoubleBuffered = True + Glyph.Data = { + F6000000424DF600000000000000760000002800000010000000100000000100 + 0400000000008000000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00FFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00FFF + FFFFFFFFFF0000FFFFFFFFFFF000000FFFFFFFFF00000000FFFFFFF000000000 + 0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF} + Layout = blGlyphRight + ParentDoubleBuffered = False + TabOrder = 3 + OnClick = btnVaultsClick + end end inherited btnOK: TButton OnClick = btnOKClick end + object mnuVaults: TPopupMenu + Left = 72 + Top = 72 + end end diff --git a/Src/FmSelectionSearchDlg.pas b/Src/FmSelectionSearchDlg.pas index a1dcf49bc..5278670c0 100644 --- a/Src/FmSelectionSearchDlg.pas +++ b/Src/FmSelectionSearchDlg.pas @@ -18,10 +18,22 @@ interface uses // Delphi - Forms, StdCtrls, Controls, ExtCtrls, Classes, + Forms, + StdCtrls, + Controls, + ExtCtrls, + Classes, + Buttons, + Menus, // Project - DB.USnippet, FmGenericOKDlg, FrCheckedTV, FrSelectSnippets, - FrSelectSnippetsBase, UBaseObjects, USearch; + DB.Snippets, + DB.Vaults, + FmGenericOKDlg, + FrCheckedTV, + FrSelectSnippets, + FrSelectSnippetsBase, + UBaseObjects, + USearch; type @@ -34,18 +46,17 @@ interface } TSelectionSearchDlg = class(TGenericOKDlg, INoPublicConstruct) btnClearAll: TButton; - btnMainDB: TButton; btnSelectAll: TButton; - btnUserDB: TButton; frmSelect: TSelectSnippetsFrame; btnExpandAll: TButton; btnCollapseAll: TButton; lblOverwriteSearch: TLabel; + btnVaults: TBitBtn; + mnuVaults: TPopupMenu; procedure btnClearAllClick(Sender: TObject); - procedure btnMainDBClick(Sender: TObject); procedure btnOKClick(Sender: TObject); procedure btnSelectAllClick(Sender: TObject); - procedure btnUserDBClick(Sender: TObject); + procedure btnVaultsClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure btnExpandAllClick(Sender: TObject); procedure btnCollapseAllClick(Sender: TObject); @@ -61,17 +72,27 @@ TSelectionSearchDlg = class(TGenericOKDlg, INoPublicConstruct) no snippet selected. @param Sender [in] Not used. } - procedure SelectDB(const UserDefined: Boolean); - {Selects all snippets from either main or user defined database. - @param UserDefined [in] Flag true if user-defined snippets are to be - selected, False if main database snippets are to be selected. - } + + /// Selects all snippets from the given vault. + /// TVaultID ID of the required vault. + /// + procedure SelectDB(const AVaultID: TVaultID); + + /// Populates vault pop-up menu with menu items. + procedure PopulateVaultsMenu; + + /// Handles clicks on vault menu items. Selects snippets belonging + /// to the selected vault. + procedure VaultMenuClick(Sender: TObject); + strict protected + procedure ConfigForm; override; + + /// Initialises form. Populates vaults menu and collapses + /// treeview. procedure InitForm; override; - {Initialises form. Disables User Defined button if there are no user - defined snippets in database. - } + procedure AfterShowForm; override; {Restores default cursor after form shown. } @@ -95,13 +116,38 @@ implementation uses // Delphi SysUtils, + Types, // Project - DB.UMain, UCtrlArranger, UQuery; + DB.Main, + UCtrlArranger, + UQuery; {$R *.dfm} +type + /// Custom menu item with additional property to store a compiler + /// version. + TVaultMenuItem = class(TMenuItem) + strict private + var + /// Value of Vault property + fVault: TVault; + public + /// Constructs a menu item with all required properties and event + /// handlers. + /// TComponent [in] Menu item's owner. + /// TVault [in] Vault whose name is + /// displayed in menu item. + /// TNotifyEvent [in] Reference to an event + /// handler for menu item's OnClick event. + constructor Create(AOwner: TComponent; const AVault: TVault; + const AClickHandler: TNotifyEvent); reintroduce; + /// Vault whose name is displayed in the menu item. + property Vault: TVault read fVault write fVault; + end; + { TSelectionSearchDlg } procedure TSelectionSearchDlg.AfterShowForm; @@ -127,17 +173,19 @@ procedure TSelectionSearchDlg.btnCollapseAllClick(Sender: TObject); frmSelect.CollapseTree; end; -procedure TSelectionSearchDlg.btnExpandAllClick(Sender: TObject); +procedure TSelectionSearchDlg.btnVaultsClick(Sender: TObject); +var + PopupPos: TPoint; // place where menu pops up begin - frmSelect.ExpandTree; + PopupPos := ClientToScreen( + Point(btnVaults.Left, btnVaults.Top + btnVaults.Height) + ); + mnuVaults.Popup(PopupPos.X, PopupPos.Y); end; -procedure TSelectionSearchDlg.btnMainDBClick(Sender: TObject); - {Main button click handler. Selects all snippets in main database. - @param Sender [in] Not used. - } +procedure TSelectionSearchDlg.btnExpandAllClick(Sender: TObject); begin - SelectDB(False); + frmSelect.ExpandTree; end; procedure TSelectionSearchDlg.btnOKClick(Sender: TObject); @@ -166,15 +214,6 @@ procedure TSelectionSearchDlg.btnSelectAllClick(Sender: TObject); frmSelect.SelectedSnippets := Database.Snippets; end; -procedure TSelectionSearchDlg.btnUserDBClick(Sender: TObject); - {User Defined button click handler. Selects all user defined snippets in - database. - @param Sender [in] Not used. - } -begin - SelectDB(True); -end; - procedure TSelectionSearchDlg.ConfigForm; begin inherited; @@ -219,20 +258,30 @@ procedure TSelectionSearchDlg.FormCreate(Sender: TObject); end; procedure TSelectionSearchDlg.InitForm; - {Initialises form. Disables User Defined button if there are no user defined - snippets in database. - } begin inherited; frmSelect.CollapseTree; - btnUserDB.Enabled := Database.Snippets.Count(True) > 0; + PopulateVaultsMenu; end; -procedure TSelectionSearchDlg.SelectDB(const UserDefined: Boolean); - {Selects all snippets from either main or user defined database. - @param UserDefined [in] Flag true if user-defined snippets are to be - selected, False if main database snippets are to be selected. - } +procedure TSelectionSearchDlg.PopulateVaultsMenu; + + /// Adds a menu item for given vault to the pop-up menu. + procedure AddMenuItem(const AVault: TVault); + begin + mnuVaults.Items.Add( + TVaultMenuItem.Create(mnuVaults, AVault, VaultMenuClick) + ); + end; + +var + Vault: TVault; +begin + for Vault in TVaults.Instance do + AddMenuItem(Vault); +end; + +procedure TSelectionSearchDlg.SelectDB(const AVaultID: TVaultID); var Snippet: TSnippet; // references each snippet in database SnippetList: TSnippetList; // list of selected snippets @@ -240,7 +289,7 @@ procedure TSelectionSearchDlg.SelectDB(const UserDefined: Boolean); SnippetList := TSnippetList.Create; try for Snippet in Database.Snippets do - if Snippet.UserDefined = UserDefined then + if Snippet.VaultID = AVaultID then SnippetList.Add(Snippet); frmSelect.SelectedSnippets := SnippetList; finally @@ -266,5 +315,21 @@ procedure TSelectionSearchDlg.SetSelectedSnippets(const Value: TSnippetList); frmSelect.SelectedSnippets := Value; end; +procedure TSelectionSearchDlg.VaultMenuClick(Sender: TObject); +begin + SelectDB((Sender as TVaultMenuItem).Vault.UID); +end; + +{ TVaultMenuItem } + +constructor TVaultMenuItem.Create(AOwner: TComponent; const AVault: TVault; + const AClickHandler: TNotifyEvent); +begin + inherited Create(AOwner); + Caption := AVault.Name; + Vault := AVault; + OnClick := AClickHandler; +end; + end. diff --git a/Src/FmSnippetsEditorDlg.dfm b/Src/FmSnippetsEditorDlg.dfm index 365274c63..951761e11 100644 --- a/Src/FmSnippetsEditorDlg.dfm +++ b/Src/FmSnippetsEditorDlg.dfm @@ -19,7 +19,7 @@ inherited SnippetsEditorDlg: TSnippetsEditorDlg Top = 0 Width = 662 Height = 504 - ActivePage = tsCompileResults + ActivePage = tsCode Align = alClient TabOrder = 0 OnChange = pcMainChange @@ -42,14 +42,6 @@ inherited SnippetsEditorDlg: TSnippetsEditorDlg Caption = '&Source code:' FocusControl = edSourceCode end - object lblName: TLabel - Left = 3 - Top = 11 - Width = 31 - Height = 13 - Caption = '&Name:' - FocusControl = edName - end object lblCategories: TLabel Left = 0 Top = 183 @@ -98,6 +90,21 @@ inherited SnippetsEditorDlg: TSnippetsEditorDlg Caption = 'Displa&y Name:' FocusControl = edDisplayName end + object lblVaults: TLabel + Left = 3 + Top = 10 + Width = 28 + Height = 13 + Caption = '&Vault:' + FocusControl = cbVaults + end + object lblVaultInfo: TLabel + Left = 411 + Top = 10 + Width = 54 + Height = 13 + Caption = 'lblVaultInfo' + end object edSourceCode: TMemo Left = 4 Top = 224 @@ -113,14 +120,6 @@ inherited SnippetsEditorDlg: TSnippetsEditorDlg ScrollBars = ssBoth TabOrder = 6 end - object edName: TEdit - Left = 93 - Top = 7 - Width = 209 - Height = 21 - PopupMenu = mnuEditCtrls - TabOrder = 0 - end object cbCategories: TComboBox Left = 93 Top = 179 @@ -154,12 +153,14 @@ inherited SnippetsEditorDlg: TSnippetsEditorDlg inherited edText: TMemo Width = 462 Height = 55 + TabOrder = 1 ExplicitWidth = 462 ExplicitHeight = 55 end inherited tcEditMode: TTabControl Top = 55 Width = 462 + TabOrder = 0 ExplicitTop = 55 ExplicitWidth = 462 end @@ -189,10 +190,22 @@ inherited SnippetsEditorDlg: TSnippetsEditorDlg Caption = 'Synta&x highlight this snippet as Pascal code' TabOrder = 7 end + object cbVaults: TComboBox + Left = 93 + Top = 7 + Width = 298 + Height = 21 + Style = csDropDownList + TabOrder = 0 + end end object tsReferences: TTabSheet Caption = 'References' ImageIndex = 1 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 object lblXRefs: TLabel Left = 3 Top = 3 @@ -322,6 +335,10 @@ inherited SnippetsEditorDlg: TSnippetsEditorDlg object tsCompileResults: TTabSheet Caption = 'Compile Results' ImageIndex = 3 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 object lblCompilers: TLabel Left = 3 Top = 3 diff --git a/Src/FmSnippetsEditorDlg.pas b/Src/FmSnippetsEditorDlg.pas index 45e9bc7d7..c02a384ef 100644 --- a/Src/FmSnippetsEditorDlg.pas +++ b/Src/FmSnippetsEditorDlg.pas @@ -5,8 +5,7 @@ * * Copyright (C) 2008-2023, Peter Johnson (gravatar.com/delphidabbler). * - * Implements a dialogue box that enables the user to create or edit user - * defined snippets. + * Implements a dialogue box that enables the user to create or edit snippets. } @@ -18,22 +17,47 @@ interface uses // Delphi - SysUtils, Classes, ActnList, Buttons, StdCtrls, Forms, Controls, CheckLst, - ComCtrls, ExtCtrls, StdActns, Menus, ImgList, + SysUtils, + Classes, + ActnList, + Buttons, + StdCtrls, + Forms, + Controls, + CheckLst, + ComCtrls, + ExtCtrls, + StdActns, + Menus, + ImgList, // Project - ActiveText.UMain, Compilers.UGlobals, DB.USnippet, FmGenericOKDlg, - FrBrowserBase, FrFixedHTMLDlg, FrHTMLDlg, UBaseObjects, UCategoryListAdapter, - UCompileMgr, UCompileResultsLBMgr, UCSSBuilder, UMemoCaretPosDisplayMgr, - UMemoHelper, USnipKindListAdapter, USnippetsChkListMgr, UUnitsChkListMgr, - FmSnippetsEditorDlg.FrActiveTextEditor; + ActiveText.UMain, + Compilers.UGlobals, + DB.Snippets, + DB.Vaults, + FmGenericOKDlg, + FrBrowserBase, + FrFixedHTMLDlg, + FrHTMLDlg, + UBaseObjects, + UCompileMgr, + UCompileResultsLBMgr, + UCSSBuilder, + UMemoCaretPosDisplayMgr, + UMemoHelper, + USnippetsChkListMgr, + UUnitsChkListMgr, + FmSnippetsEditorDlg.FrActiveTextEditor, + UI.Adapters.CategoryList, + UI.Adapters.SnippetKindList, + UI.Adapters.VaultList; type { TSnippetsEditorDlg: - Dialog box class that enables the user to create or edit a user defined - snippet. + Dialog box class that enables the user to create or edit a snippet. } TSnippetsEditorDlg = class(TGenericOKDlg, INoPublicConstruct) alMain: TActionList; @@ -61,7 +85,6 @@ TSnippetsEditorDlg = class(TGenericOKDlg, INoPublicConstruct) clbDepends: TCheckListBox; clbUnits: TCheckListBox; clbXRefs: TCheckListBox; - edName: TEdit; edSourceCode: TMemo; edUnit: TEdit; lbCompilers: TListBox; @@ -73,7 +96,6 @@ TSnippetsEditorDlg = class(TGenericOKDlg, INoPublicConstruct) lblDescription: TLabel; lblExtra: TLabel; lblExtraCaretPos: TLabel; - lblName: TLabel; lblKind: TLabel; lblSourceCaretPos: TLabel; lblSourceCode: TLabel; @@ -118,6 +140,9 @@ TSnippetsEditorDlg = class(TGenericOKDlg, INoPublicConstruct) actClearUnits: TAction; miClearUnits: TMenuItem; miSpacer3: TMenuItem; + lblVaults: TLabel; + cbVaults: TComboBox; + lblVaultInfo: TLabel; procedure actAddUnitExecute(Sender: TObject); procedure actAddUnitUpdate(Sender: TObject); procedure actCompileExecute(Sender: TObject); @@ -158,9 +183,9 @@ TSnippetsEditorDlg = class(TGenericOKDlg, INoPublicConstruct) strict private fSnippet: TSnippet; // Snippet being edited: nil for new snippet fCatList: TCategoryListAdapter; // Accesses sorted list of categories + fVaultList: TVaultListAdapter; // Accesses sorted list of vaults fSnipKindList: TSnipKindListAdapter; // Accesses sorted list of snippet kinds - fOrigName: string; // Original name of snippet ('' for new) fEditData: TSnippetEditData; // Record storing a snippet's editable data fCompileMgr: TCompileMgr; // Manages compilation and results display fDependsCLBMgr: @@ -173,6 +198,24 @@ TSnippetsEditorDlg = class(TGenericOKDlg, INoPublicConstruct) fSourceMemoHelper: TMemoHelper; // Helper for working with source code memo fMemoCaretPosDisplayMgr: TMemoCaretPosDisplayMgr; // Manages display of memo caret positions + + /// Returns the ID of the vault that applies to a new or existing + /// snippet. + /// TVaultID. The required vault ID. + /// For a new snippet the return value is the vault to be applied + /// to the snippet. For an existing snippet this is the value to which the + /// snippet already belongs. + function SelectedVaultID: TVaultID; + + /// Returns a snippet key that is unique with the current + /// snippet vault. + /// string. The required key. + /// For a new snippet this key will change depending each time the + /// method is called, and will always be unique within the selected + /// vault. For an existing snippet the key is always that of the snippet + /// and never changes across method calls. + function UniqueSnippetKey: string; + procedure PopulateControls; {Populates controls with dynamic data. } @@ -254,10 +297,27 @@ implementation // Delphi Windows {for inlining}, Graphics, // Project - DB.UMain, DB.USnippetKind, FmDependenciesDlg, IntfCommon, UColours, UConsts, - UCSSUtils, UCtrlArranger, UExceptions, UFontHelper, UIStringList, - UReservedCategories, USnippetExtraHelper, USnippetValidator, UMessageBox, - USnippetIDs, UStructs, UStrUtils, UTestUnitDlgMgr, UThemesEx, UUtils; + DB.Categories, + DB.Main, + DB.SnippetIDs, + DB.SnippetKind, + FmDependenciesDlg, + IntfCommon, + UColours, + UConsts, + UCSSUtils, + UCtrlArranger, + UExceptions, + UFontHelper, + UIStringList, + USnippetExtraHelper, + USnippetValidator, + UMessageBox, + UStructs, + UStrUtils, + UTestUnitDlgMgr, + UThemesEx, + UUtils; {$R *.dfm} @@ -424,7 +484,7 @@ procedure TSnippetsEditorDlg.actViewDependenciesExecute(Sender: TObject); fDependsCLBMgr.GetCheckedSnippets(DependsList); TDependenciesDlg.Execute( Self, - TSnippetID.Create(StrTrim(edName.Text), True), + TSnippetID.Create(UniqueSnippetKey, SelectedVaultID), StrTrim(edDisplayName.Text), DependsList, [tiDependsUpon], @@ -552,42 +612,63 @@ procedure TSnippetsEditorDlg.ArrangeForm; begin // tsCode edSourceCode.Width := tsCode.ClientWidth - 8; + // Column 1 TCtrlArranger.AlignLefts( [ - lblName, lblDisplayName, lblDescription, lblKind, lblCategories, + lblVaults, lblDisplayName, lblDescription, lblKind, lblCategories, lblSourceCode, edSourceCode ], 3 ); + // Column 2 + TCtrlArranger.AlignLefts( + [ + cbVaults, lblVaultInfo, edDisplayName, frmDescription, cbKind, + cbCategories + ], + TCtrlArranger.RightOf( + [lblVaults, lblDisplayName, lblDescription, lblKind, lblCategories], + 12 + ) + ); + // Right hand sides TCtrlArranger.AlignRights( [edSourceCode, lblSourceCaretPos, btnViewDescription] ); frmDescription.Width := btnViewDescription.Left - frmDescription.Left - 8; - TCtrlArranger.AlignVCentres(3, [lblName, edName]); + // Row 1 + TCtrlArranger.AlignVCentres(3, [lblVaults, cbVaults, lblVaultInfo]); + // Row 2 TCtrlArranger.AlignVCentres( - TCtrlArranger.BottomOf([lblName, edName], 8), + TCtrlArranger.BottomOf([lblVaults, cbVaults], 8), [lblDisplayName, edDisplayName] ); + // Row 3 TCtrlArranger.AlignTops( [lblDescription, frmDescription, btnViewDescription], TCtrlArranger.BottomOf([lblDisplayName, edDisplayName], 8) ); + // Row 4 TCtrlArranger.AlignVCentres( TCtrlArranger.BottomOf( [lblDescription, frmDescription, btnViewDescription], 8 ), [lblKind, cbKind, lblSnippetKindHelp] ); + // Row 5 TCtrlArranger.AlignVCentres( TCtrlArranger.BottomOf([lblKind, cbKind, lblSnippetKindHelp], 8), [lblCategories, cbCategories] ); + // Row 6 TCtrlArranger.MoveToRightOf(cbKind, lblSnippetKindHelp, 12); TCtrlArranger.AlignTops( [lblSourceCode, lblSourceCaretPos], TCtrlArranger.BottomOf([lblCategories, cbCategories], 8) ); + // Row 7 TCtrlArranger.MoveBelow([lblSourceCode, lblSourceCaretPos], edSourceCode, 4); + // Row 8 TCtrlArranger.MoveBelow(edSourceCode, chkUseHiliter, 8); // tsReferences @@ -621,26 +702,17 @@ procedure TSnippetsEditorDlg.btnOKClick(Sender: TObject); snippet if all is well. @param Sender [in] Not used. } -var - SnippetName: string; // name of snippet being edited / added begin inherited; try // Validate and record entered data ValidateData; fEditData.Assign(UpdateData); - SnippetName := StrTrim(edName.Text); // Add or update snippet if Assigned(fSnippet) then - fSnippet := (Database as IDatabaseEdit).UpdateSnippet( - fSnippet, fEditData, SnippetName - ) + Database.UpdateSnippet(fSnippet, fEditData) else - begin - fSnippet := (Database as IDatabaseEdit).AddSnippet( - SnippetName, fEditData - ) - end; + Database.AddSnippet(UniqueSnippetKey, SelectedVaultID, fEditData); except on E: Exception do HandleException(E); @@ -683,8 +755,8 @@ function TSnippetsEditorDlg.CreateTempSnippet: TSnippet; ValidateData; // Create snippet object from entered data EditData.Assign(UpdateData); - Result := (Database as IDatabaseEdit).CreateTempSnippet( - StrTrim(edName.Text), EditData + Result := Database.CreateTempSnippet( + UniqueSnippetKey, SelectedVaultID, EditData ); end; @@ -717,6 +789,7 @@ class function TSnippetsEditorDlg.EditSnippet(AOwner: TComponent; resourcestring sCaption = 'Edit Snippet'; // dialogue box caption begin + Assert(Assigned(Snippet), ClassName + '.EditSnippet: Snippet is nil'); Instance := InternalCreate(AOwner); try Instance.Caption := sCaption; @@ -756,6 +829,7 @@ procedure TSnippetsEditorDlg.FormCreate(Sender: TObject); begin inherited; fCatList := TCategoryListAdapter.Create(Database.Categories); + fVaultList := TVaultListAdapter.Create; fSnipKindList := TSnipKindListAdapter.Create; fCompileMgr := TCompileMgr.Create(Self); // auto-freed fMemoCaretPosDisplayMgr := TMemoCaretPosDisplayMgr.Create; @@ -780,6 +854,7 @@ procedure TSnippetsEditorDlg.FormDestroy(Sender: TObject); FreeAndNil(fXRefsCLBMgr); FreeAndNil(fDependsCLBMgr); FreeAndNil(fSnipKindList); + FreeAndNil(fVaultList); FreeAndNil(fCatList); fMemoCaretPosDisplayMgr.Free; end; @@ -821,12 +896,12 @@ procedure TSnippetsEditorDlg.InitControls; chkUseHiliter.Checked := fSnippet.HiliteSource; frmDescription.DefaultEditMode := emAuto; frmDescription.ActiveText := fSnippet.Description; - edName.Text := fSnippet.Name; - if fSnippet.Name <> fSnippet.DisplayName then - edDisplayName.Text := fSnippet.DisplayName - else - edDisplayName.Text := ''; + edDisplayName.Text := fSnippet.DisplayName; cbCategories.ItemIndex := fCatList.IndexOf(fSnippet.Category); + cbVaults.ItemIndex := fVaultList.IndexOfUID(fSnippet.VaultID); + cbVaults.Visible := False; // can't change existing snippet vault + lblVaultInfo.Caption := cbVaults.Text; + lblVaultInfo.Visible := True; frmExtra.DefaultEditMode := emAuto; frmExtra.ActiveText := fSnippet.Extra; cbKind.ItemIndex := fSnipKindList.IndexOf(fSnippet.Kind); @@ -844,11 +919,15 @@ procedure TSnippetsEditorDlg.InitControls; chkUseHiliter.Checked := True; frmDescription.DefaultEditMode := emPlainText; frmDescription.Clear; - edName.Clear; edDisplayName.Clear; - cbCategories.ItemIndex := fCatList.IndexOf(TReservedCategories.UserCatID); + cbCategories.ItemIndex := fCatList.IndexOf(TCategory.DefaultID); if cbCategories.ItemIndex = -1 then cbCategories.ItemIndex := 0; + cbVaults.ItemIndex := fVaultList.IndexOfUID(TVaultID.Default); + Assert(cbVaults.ItemIndex >= 0, + ClassName + '.InitControls: No default vault in cbVaults'); + cbVaults.Visible := True; // can select vault of new snippet + lblVaultInfo.Visible := False; cbKind.ItemIndex := fSnipKindList.IndexOf(skFreeform); frmExtra.DefaultEditMode := emPlainText; frmExtra.Clear; @@ -872,12 +951,7 @@ procedure TSnippetsEditorDlg.InitForm; inherited; // Get data associated with snippet, or blank / default data if adding a new // snippet - fEditData := (Database as IDatabaseEdit).GetEditableSnippetInfo(fSnippet); - // Record snippet's original name, if any - if Assigned(fSnippet) then - fOrigName := fSnippet.Name - else - fOrigName := ''; + fEditData := Database.GetEditableSnippetInfo(fSnippet); // Populate controls with dynamic data PopulateControls; // Initialise controls to default values @@ -931,6 +1005,19 @@ procedure TSnippetsEditorDlg.PopulateControls; fSnipKindList.ToStrings(cbKind.Items); // Display all available categories in drop down list fCatList.ToStrings(cbCategories.Items); + // Display all available vaults in drop down list + fVaultList.ToStrings(cbVaults.Items); +end; + +function TSnippetsEditorDlg.SelectedVaultID: TVaultID; +begin + // If editing existing snippet ID then the vault cannot be edited + if Assigned(fSnippet) then + // Editing existing snippet: can't change vault + Result := fSnippet.VaultID + else + // Editing new snippet: chosing vault is permitted + Result := fVaultList.Vault(cbVaults.ItemIndex).UID; end; procedure TSnippetsEditorDlg.SetAllCompilerResults( @@ -942,16 +1029,21 @@ procedure TSnippetsEditorDlg.SetAllCompilerResults( fCompilersLBMgr.SetCompileResults(CompRes); end; +function TSnippetsEditorDlg.UniqueSnippetKey: string; +begin + if Assigned(fSnippet) then + Result := fSnippet.Key + else + Result := Database.GetUniqueSnippetKey(SelectedVaultID); +end; + function TSnippetsEditorDlg.UpdateData: TSnippetEditData; {Updates snippet's data from user entries. Assumes data has been validated. @return Record containing snippet's data. } begin Result.Init; - if StrTrim(edName.Text) <> StrTrim(edDisplayName.Text) then - Result.Props.DisplayName := StrTrim(edDisplayName.Text) - else - Result.Props.DisplayName := ''; + Result.Props.DisplayName := StrTrim(edDisplayName.Text); Result.Props.Cat := fCatList.CatID(cbCategories.ItemIndex); Result.Props.Kind := fSnipKindList.SnippetKind(cbKind.ItemIndex); (Result.Props.Desc as IAssignable).Assign(frmDescription.ActiveText); @@ -978,17 +1070,20 @@ procedure TSnippetsEditorDlg.UpdateReferences; fDependsCLBMgr.Clear; fXRefsCLBMgr.Save; fXRefsCLBMgr.Clear; - EditSnippetID := TSnippetID.Create(fOrigName, True); + + EditSnippetID := TSnippetID.Create(UniqueSnippetKey, SelectedVaultID); EditSnippetKind := fSnipKindList.SnippetKind(cbKind.ItemIndex); + + {TODO -cVault: We do following kind of filtering of Database.Snippets so + often it would be useful to have a Filter or Select method of + TSnippetList that can be passed a predicate to do this and return a + filtered snippet list. + } for Snippet in Database.Snippets do begin - // We ignore snippet being edited and main database snippets if there is - // a user-defined one with same name - if (Snippet.ID <> EditSnippetID) and - ( - Snippet.UserDefined or - not Assigned(Database.Snippets.Find(Snippet.Name, True)) - ) then + if Snippet.VaultID <> SelectedVaultID then + Continue; + if Snippet.ID <> EditSnippetID then begin // Decide if snippet can be added to depends list: must be correct kind if Snippet.Kind in @@ -998,6 +1093,7 @@ procedure TSnippetsEditorDlg.UpdateReferences; fXRefsCLBMgr.AddSnippet(Snippet); end; end; + // Restore checks to any saved checked item that still exist in new list fDependsCLBMgr.Restore; fXRefsCLBMgr.Restore; @@ -1017,13 +1113,10 @@ procedure TSnippetsEditorDlg.ValidateData; ErrorMessage: string; // receives validation error messages ErrorSelection: TSelection; // receives selection containing errors begin - if not TSnippetValidator.ValidateName( - edName.Text, - not StrSameText(StrTrim(edName.Text), fOrigName), - ErrorMessage, - ErrorSelection + if not TSnippetValidator.ValidateDisplayName( + edDisplayName.Text, ErrorMessage ) then - raise EDataEntry.Create(ErrorMessage, edName, ErrorSelection); + raise EDataEntry.Create(ErrorMessage, edDisplayName); frmDescription.Validate; if not TSnippetValidator.ValidateSourceCode( edSourceCode.Text, ErrorMessage, ErrorSelection @@ -1031,7 +1124,7 @@ procedure TSnippetsEditorDlg.ValidateData; raise EDataEntry.Create(ErrorMessage, edSourceCode, ErrorSelection); frmExtra.Validate; if not TSnippetValidator.ValidateDependsList( - StrTrim(edName.Text), UpdateData, ErrorMessage + UniqueSnippetKey, SelectedVaultID, UpdateData, ErrorMessage ) then raise EDataEntry.Create( // selection not applicable to list boxes StrMakeSentence(ErrorMessage) + EOL2 + sDependencyPrompt, clbDepends diff --git a/Src/FmTestCompileDlg.dfm b/Src/FmTestCompileDlg.dfm index f6e44ee4a..54610b754 100644 --- a/Src/FmTestCompileDlg.dfm +++ b/Src/FmTestCompileDlg.dfm @@ -10,7 +10,7 @@ inherited TestCompileDlg: TTestCompileDlg object lblSnippetName: TLabel Left = 96 Top = 8 - Width = 89 + Width = 88 Height = 13 Caption = 'lblSnippetName' Font.Charset = DEFAULT_CHARSET @@ -23,7 +23,7 @@ inherited TestCompileDlg: TTestCompileDlg object lblSnippetNameDesc: TLabel Left = 0 Top = 8 - Width = 53 + Width = 55 Height = 13 Caption = 'Results for ' end diff --git a/Src/FmTestCompileDlg.pas b/Src/FmTestCompileDlg.pas index 5066e2bff..cb66b4778 100644 --- a/Src/FmTestCompileDlg.pas +++ b/Src/FmTestCompileDlg.pas @@ -15,10 +15,21 @@ interface uses - Classes, ActnList, StdCtrls, Forms, Controls, ExtCtrls, Messages, + // Delphi + Classes, + ActnList, + StdCtrls, + Forms, + Controls, + ExtCtrls, + Messages, Generics.Collections, - - Compilers.UGlobals, DB.USnippet, FmGenericViewDlg, UBaseObjects, UCompileMgr, + // Project + Compilers.UGlobals, + DB.Snippets, + FmGenericViewDlg, + UBaseObjects, + UCompileMgr, ULEDImageList; type @@ -155,9 +166,16 @@ implementation uses // Delphi - Math, Windows, Graphics, Types {for inlining}, + Math, + Windows, + Graphics, + Types {for inlining}, // Project - UColours, UCtrlArranger, UFontHelper, UPreferences; + DB.Vaults, + UColours, + UCtrlArranger, + UFontHelper, + UPreferences; {$R *.dfm} @@ -282,7 +300,7 @@ procedure TTestCompileDlg.ConfigForm; // Set required label fonts and captions TFontHelper.SetDefaultBaseFont(lblSnippetName.Font); lblSnippetName.Font.Color := - Preferences.DBHeadingColours[fSnippet.UserDefined]; + Preferences.GetSnippetHeadingColour(fSnippet.VaultID); lblSnippetName.Caption := fSnippet.DisplayName; end; diff --git a/Src/FmUserDataPathDlg.dfm b/Src/FmUserDataPathDlg.dfm deleted file mode 100644 index 014df9466..000000000 --- a/Src/FmUserDataPathDlg.dfm +++ /dev/null @@ -1,206 +0,0 @@ -inherited UserDataPathDlg: TUserDataPathDlg - Caption = 'Move User Database' - ExplicitWidth = 474 - ExplicitHeight = 375 - PixelsPerInch = 96 - TextHeight = 13 - inherited pnlBody: TPanel - Top = 9 - Height = 329 - ExplicitTop = 9 - ExplicitHeight = 329 - object lblInstructions: TLabel - Left = 0 - Top = 0 - Width = 377 - Height = 25 - AutoSize = False - Caption = - 'Use this dialogue box to move the user database to a new directo' + - 'ry or to restore the directory to its default location. Choose t' + - 'he appropriate option below.' - WordWrap = True - end - object lblWarning: TLabel - Left = 0 - Top = 32 - Width = 377 - Height = 20 - AutoSize = False - Caption = - 'You are strongly advised to make a backup of the database before' + - ' continuing.' - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [fsBold] - ParentFont = False - WordWrap = True - end - object gbMove: TGroupBox - Left = 0 - Top = 59 - Width = 377 - Height = 140 - Caption = 'Move database to new directory' - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [fsBold] - ParentFont = False - TabOrder = 0 - object lblPath: TLabel - Left = 8 - Top = 20 - Width = 240 - Height = 13 - Caption = 'Enter the full path to the new database &directory:' - FocusControl = edPath - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - ParentFont = False - end - object lblExplainMove: TLabel - Left = 8 - Top = 66 - Width = 361 - Height = 34 - AutoSize = False - Caption = - 'The directory must be empty and must not be a sub-directory of t' + - 'he current database directory. If the directory does not exist a' + - ' new one will be created.' - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - ParentFont = False - WordWrap = True - end - object edPath: TEdit - Left = 8 - Top = 39 - Width = 325 - Height = 21 - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - ParentFont = False - TabOrder = 0 - end - object btnBrowse: TButton - Left = 341 - Top = 39 - Width = 27 - Height = 21 - Action = actBrowse - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - ParentFont = False - TabOrder = 1 - end - object btnMove: TButton - Left = 112 - Top = 86 - Width = 153 - Height = 41 - Action = actMove - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - ParentFont = False - TabOrder = 2 - end - end - object gbRestore: TGroupBox - Left = 0 - Top = 208 - Width = 377 - Height = 112 - Caption = 'Restore database to default directory' - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [fsBold] - ParentFont = False - TabOrder = 1 - object lblExplainDefaultPath: TLabel - Left = 8 - Top = 20 - Width = 361 - Height = 34 - AutoSize = False - Caption = - 'Use this button to restore the database to its default directory' + - '. This option is only available if the database has been moved.' - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - ParentFont = False - WordWrap = True - end - object btnDefaultPath: TButton - Left = 112 - Top = 61 - Width = 153 - Height = 41 - Action = actDefaultPath - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'Tahoma' - Font.Style = [] - ParentFont = False - TabOrder = 0 - end - end - inline frmProgress: TProgressFrame - Left = 57 - Top = 0 - Width = 320 - Height = 82 - ParentBackground = False - TabOrder = 2 - Visible = False - ExplicitLeft = 57 - ExplicitHeight = 82 - inherited pnlBody: TPanel - Height = 82 - end - end - end - object alDlg: TActionList - Left = 152 - Top = 304 - object actBrowse: TAction - Caption = '...' - OnExecute = actBrowseExecute - end - object actDefaultPath: TAction - Caption = '&Restore Default Path' - OnExecute = actDefaultPathExecute - OnUpdate = actDefaultPathUpdate - end - object actMove: TAction - Caption = '&Move' - OnExecute = actMoveExecute - OnUpdate = actMoveUpdate - end - end -end diff --git a/Src/FrCategoryDescEdit.pas b/Src/FrCategoryDescEdit.pas index b5dd958ea..ed292b441 100644 --- a/Src/FrCategoryDescEdit.pas +++ b/Src/FrCategoryDescEdit.pas @@ -117,7 +117,12 @@ implementation // Delphi Windows {for inlining}, // Project - DB.UCategory, DB.UMain, UColours, UCtrlArranger, UFontHelper, UStrUtils; + DB.Categories, + DB.Main, + UColours, + UCtrlArranger, + UFontHelper, + UStrUtils; {$R *.dfm} diff --git a/Src/FrCategoryList.pas b/Src/FrCategoryList.pas index b1b225c97..9711362e2 100644 --- a/Src/FrCategoryList.pas +++ b/Src/FrCategoryList.pas @@ -18,9 +18,13 @@ interface uses // Delphi - Forms, Controls, StdCtrls, Classes, + Forms, + Controls, + StdCtrls, + Classes, // Project - DB.UCategory, UCategoryListAdapter; + DB.Categories, + UI.Adapters.CategoryList; type @@ -89,7 +93,8 @@ implementation // Delphi SysUtils, // Project - DB.UMain, UCtrlArranger; + DB.Main, + UCtrlArranger; {$R *.dfm} diff --git a/Src/FrDetailView.pas b/Src/FrDetailView.pas index 8aa41a592..c4b69631a 100644 --- a/Src/FrDetailView.pas +++ b/Src/FrDetailView.pas @@ -17,7 +17,7 @@ interface uses // Delphi - OleCtrls, SHDocVw, Classes, Controls, ExtCtrls, Windows, ActiveX, + OleCtrls, SHDocVw, Classes, Controls, ExtCtrls, Windows, ActiveX, Graphics, // Project FrBrowserBase, IntfFrameMgrs, UCommandBars, UCSSBuilder, UDetailPageLoader, USearch, UView, UWBPopupMenus; @@ -44,6 +44,14 @@ TDetailViewFrame = class {sealed}(TBrowserBaseFrame, /// Generates and loads HTML representing a view into browser /// control. fPageLoader: TDetailPageLoader; + /// Records colour to be defined when defining CSS classes to + /// display page heading. + fHeadingColour: TColor; + /// Calculates colour of page heading, according to the type of + /// view being displayed. + /// IView [in] View for which heading colour is + /// required. + function GetHeadingColour(AView: IView): TColor; /// Handles web browser UI manager's OnMenuPopup event. Pops up /// relevant menu if appropriate. /// TObject [in] Not used. @@ -107,11 +115,24 @@ implementation uses // Delphi - SysUtils, Graphics, Menus, Math, + SysUtils, + Menus, + Math, // Project - ActiveText.UHTMLRenderer, Browser.UHighlighter, Hiliter.UAttrs, Hiliter.UCSS, - Hiliter.UGlobals, UColours, UCSSUtils, UFontHelper, UPreferences, UQuery, - USystemInfo, UUtils, UWBCommandBars; + ActiveText.UHTMLRenderer, + Browser.UHighlighter, + DB.Vaults, + Hiliter.UAttrs, + Hiliter.UCSS, + Hiliter.UGlobals, + UColours, + UCSSUtils, + UFontHelper, + UPreferences, + UQuery, + USystemInfo, + UUtils, + UWBCommandBars; {$R *.dfm} @@ -225,11 +246,9 @@ procedure TDetailViewFrame.BuildCSS(const CSSBuilder: TCSSBuilder); CSSBuilder.AddSelector('.optionbox') .AddProperty(TCSS.BorderProp(cssAll, 1, cbsSolid, clBorder)); - // Heading colours for user & main databases - CSSBuilder.AddSelector('.userdb') - .AddProperty(TCSS.ColorProp(Preferences.DBHeadingColours[True])); - CSSBuilder.AddSelector('.maindb') - .AddProperty(TCSS.ColorProp(Preferences.DBHeadingColours[False])); + // Heading colour + CSSBuilder.AddSelector('.heading') + .AddProperty(TCSS.ColorProp(fHeadingColour)); // Sets CSS for style of New Tab text CSSFont.Assign(ContentFont); @@ -354,6 +373,8 @@ procedure TDetailViewFrame.Display(View: IView); var Filter: ITextSearchFilter; // text search filter containing criteria begin + fHeadingColour := GetHeadingColour(View); + // Load view's HTML into browser control fPageLoader.LoadPage(View); // Clear any existing text selection @@ -364,6 +385,19 @@ procedure TDetailViewFrame.Display(View: IView); Supports(Query.LatestSearch.Filter, ITextSearchFilter, Filter) then HighlightSearchResults(Filter); + +end; + +function TDetailViewFrame.GetHeadingColour(AView: IView): TColor; +var + SnippetView: ISnippetView; +begin + if Supports(AView, ISnippetView, SnippetView) then + Result := Preferences.GetSnippetHeadingColour( + SnippetView.Snippet.VaultID + ) + else + Result := Preferences.GroupHeadingColour; end; procedure TDetailViewFrame.HighlightSearchResults( diff --git a/Src/FrDisplayPrefs.dfm b/Src/FrDisplayPrefs.dfm index 80a7370ef..bdec62876 100644 --- a/Src/FrDisplayPrefs.dfm +++ b/Src/FrDisplayPrefs.dfm @@ -1,8 +1,8 @@ inherited DisplayPrefsFrame: TDisplayPrefsFrame - Width = 397 - Height = 311 - ExplicitWidth = 397 - ExplicitHeight = 311 + Width = 438 + Height = 347 + ExplicitWidth = 438 + ExplicitHeight = 347 object lblOverviewTree: TLabel Left = 16 Top = 6 @@ -11,30 +11,31 @@ inherited DisplayPrefsFrame: TDisplayPrefsFrame Caption = 'Start &overview pane treeview as:' FocusControl = cbOverviewTree end - object lblMainColour: TLabel + object lblGroupHeadingColour: TLabel Left = 16 - Top = 96 - Width = 193 + Top = 112 + Width = 191 Height = 13 - Caption = 'Heading colour for &main database items:' + Caption = '&Group heading colour in overview pane:' end - object lblUserColour: TLabel + object lblVaultColours: TLabel Left = 16 - Top = 115 - Width = 192 + Top = 139 + Width = 220 Height = 13 - Caption = 'Heading colour for &user database items:' + Caption = 'Heading colour snippets from different &vaults:' + FocusControl = cbVaults end object lblSourceBGColour: TLabel Left = 16 - Top = 134 + Top = 200 Width = 170 Height = 13 Caption = 'Background colour for &source code:' end object lblOverviewFontSize: TLabel Left = 16 - Top = 200 + Top = 253 Width = 145 Height = 13 Caption = 'Overview tree view &font size: ' @@ -42,7 +43,7 @@ inherited DisplayPrefsFrame: TDisplayPrefsFrame end object lblDetailFontSize: TLabel Left = 16 - Top = 232 + Top = 280 Width = 105 Height = 13 Caption = 'Detail pane font si&ze: ' @@ -50,9 +51,9 @@ inherited DisplayPrefsFrame: TDisplayPrefsFrame end object lblHiliterInfo: TLabel Left = 16 - Top = 256 - Width = 370 - Height = 36 + Top = 304 + Width = 358 + Height = 26 Caption = 'To change the size of the source code font use the the Syntax Hi' + 'ghlighter options page.' @@ -88,16 +89,16 @@ inherited DisplayPrefsFrame: TDisplayPrefsFrame end object btnDefColours: TButton Left = 16 - Top = 156 + Top = 219 Width = 192 Height = 25 - Caption = 'Use Default &Colours' + Caption = 'Use &Default Colours' TabOrder = 3 OnClick = btnDefColoursClick end object cbOverviewFontSize: TComboBox Left = 192 - Top = 197 + Top = 250 Width = 57 Height = 21 TabOrder = 4 @@ -105,10 +106,19 @@ inherited DisplayPrefsFrame: TDisplayPrefsFrame end object cbDetailFontSize: TComboBox Left = 192 - Top = 229 + Top = 277 Width = 57 Height = 21 TabOrder = 5 OnChange = FontSizeChange end + object cbVaults: TComboBox + Left = 16 + Top = 158 + Width = 170 + Height = 21 + Style = csDropDownList + TabOrder = 6 + OnChange = cbVaultsChange + end end diff --git a/Src/FrDisplayPrefs.pas b/Src/FrDisplayPrefs.pas index 015d1ea02..94c204c65 100644 --- a/Src/FrDisplayPrefs.pas +++ b/Src/FrDisplayPrefs.pas @@ -19,9 +19,18 @@ interface uses // Delphi - Controls, StdCtrls, Classes, + Controls, + StdCtrls, + Classes, + Graphics, + Generics.Collections, // Project - FrPrefsBase, UColorBoxEx, UColorDialogEx, UPreferences; + DB.Vaults, + FrPrefsBase, + UColorBoxEx, + UColorDialogEx, + UI.Adapters.VaultList, + UPreferences; type @@ -31,8 +40,8 @@ TDisplayPrefsFrame = class(TPrefsBaseFrame) cbOverviewTree: TComboBox; chkHideEmptySections: TCheckBox; chkSnippetsInNewTab: TCheckBox; - lblMainColour: TLabel; - lblUserColour: TLabel; + lblGroupHeadingColour: TLabel; + lblVaultColours: TLabel; btnDefColours: TButton; lblSourceBGColour: TLabel; lblOverviewFontSize: TLabel; @@ -40,19 +49,29 @@ TDisplayPrefsFrame = class(TPrefsBaseFrame) lblDetailFontSize: TLabel; cbDetailFontSize: TComboBox; lblHiliterInfo: TLabel; + cbVaults: TComboBox; procedure chkHideEmptySectionsClick(Sender: TObject); procedure btnDefColoursClick(Sender: TObject); procedure FontSizeChange(Sender: TObject); + procedure cbVaultsChange(Sender: TObject); strict private var /// Flag indicating if changes affect UI. fUIChanged: Boolean; - fMainColourBox: TColorBoxEx; - fMainColourDlg: TColorDialogEx; - fUserColourBox: TColorBoxEx; - fUserColourDlg: TColorDialogEx; + + /// Local copy of snippet heading / tree node colour for each + /// vault. + fSnippetHeadingColours: TDictionary; + + fGroupHeadingColourBox: TColorBoxEx; + fGroupHeadingColourDlg: TColorDialogEx; + fSnippetHeadingColourBox: TColorBoxEx; + fSnippetHeadingColourDlg: TColorDialogEx; fSourceBGColourBox: TColorBoxEx; fSourceBGColourDlg: TColorDialogEx; + + fVaultList: TVaultListAdapter; + procedure SelectOverviewTreeState(const State: TOverviewStartState); {Selects combo box item associated with a overview treeview startup state. @param State [in] Startup state to be selected. @@ -62,15 +81,23 @@ TDisplayPrefsFrame = class(TPrefsBaseFrame) @param State [in] State for which description is required. @return Required description. } - function CreateCustomColourBox(const ColourDlg: TColorDialogEx): + function CreateCustomColourBox(const ColourDlg: TColorDialogEx; + ChangeHandler: TNotifyEvent): TColorBoxEx; procedure ColourBoxChangeHandler(Sender: TObject); + procedure SnippetHeadingColourBoxChange(Sender: TObject); procedure PopulateFontSizeCombos; + procedure SetTabOrder; + function SelectedVaultID: TVaultID; public constructor Create(AOwner: TComponent); override; - {Class constructor. Sets up frame and populates controls. + {Object constructor. Sets up frame and populates controls. @param AOwner [in] Component that owns frame. } + + /// Object destructor. Frees owned objects. + destructor Destroy; override; + procedure Activate(const Prefs: IPreferences; const Flags: UInt64); override; {Called when page activated. Updates controls. @@ -105,9 +132,16 @@ implementation uses // Delphi - SysUtils, Math, Graphics, ExtCtrls, + SysUtils, + Generics.Defaults, + Math, + ExtCtrls, // Project - FmPreferencesDlg, UColours, UCtrlArranger, UFontHelper, UGraphicUtils, + FmPreferencesDlg, + UColours, + UCtrlArranger, + UFontHelper, + UGraphicUtils, UMessageBox; @@ -127,93 +161,143 @@ procedure TDisplayPrefsFrame.Activate(const Prefs: IPreferences; {Called when page activated. Updates controls. @param Prefs [in] Object that provides info used to update controls. } +var + Vault: TVault; begin + cbVaults.ItemIndex := fVaultList.IndexOfUID(TVaultID.Default); + Assert(cbVaults.ItemIndex >= 0, + ClassName + '.Activate: no default vault found in cbVaults'); SelectOverviewTreeState(Prefs.OverviewStartState); chkHideEmptySections.OnClick := nil; // prevent OnClick when Checked set chkHideEmptySections.Checked := not Prefs.ShowEmptySections; chkHideEmptySections.OnClick := chkHideEmptySectionsClick; chkSnippetsInNewTab.Checked := Prefs.ShowNewSnippetsInNewTabs; - fMainColourBox.Selected := Prefs.DBHeadingColours[False]; - fUserColourBox.Selected := Prefs.DBHeadingColours[True]; + fGroupHeadingColourBox.Selected := Prefs.GroupHeadingColour; + fSnippetHeadingColours.Clear; + for Vault in TVaults.Instance do + fSnippetHeadingColours.Add( + Vault.UID, Prefs.GetSnippetHeadingColour(Vault.UID) + ); + fSnippetHeadingColourBox.Selected := + Prefs.GetSnippetHeadingColour(SelectedVaultID); fSourceBGColourBox.Selected := Prefs.SourceCodeBGcolour; - Prefs.DBHeadingCustomColours[False].CopyTo(fMainColourDlg.CustomColors, True); - Prefs.DBHeadingCustomColours[True].CopyTo(fUserColourDlg.CustomColors, True); + Prefs.GroupHeadingCustomColours.CopyTo( + fGroupHeadingColourDlg.CustomColors, True + ); Prefs.SourceCodeBGCustomColours.CopyTo(fSourceBGColourDlg.CustomColors, True); cbOverviewFontSize.Tag := Prefs.OverviewFontSize; // store font size in .Tag cbOverviewFontSize.Text := IntToStr(Prefs.OverviewFontSize); cbDetailFontSize.Tag := Prefs.DetailFontSize; // store font size in .Tag cbDetailFontSize.Text := IntToStr(Prefs.DetailFontSize); + end; procedure TDisplayPrefsFrame.ArrangeControls; {Arranges controls on frame. Called after frame has been sized. } begin + // Align controls on left TCtrlArranger.AlignLefts( [ - lblOverviewTree, chkHideEmptySections, chkSnippetsInNewTab, - lblMainColour, lblUserColour, lblSourceBGColour, btnDefColours, - lblOverviewFontSize, lblDetailFontSize, lblHiliterInfo + lblOverviewTree, chkSnippetsInNewTab, chkHideEmptySections, + lblGroupHeadingColour, lblVaultColours, lblSourceBGColour, + btnDefColours, lblOverviewFontSize, lblDetailFontSize, lblHiliterInfo ], 0 ); + // Align vaults combo indented from left + cbVaults.Left := 8; + + // Align controls on right: make sure they are all to right of everything + // on left that is on same line as any of them. TCtrlArranger.AlignLefts( [ - cbOverviewTree, fMainColourBox, fUserColourBox, fSourceBGColourBox, - cbOverviewFontSize, cbDetailFontSize + cbOverviewTree, fGroupHeadingColourBox, fSnippetHeadingColourBox, + fSourceBGColourBox, cbOverviewFontSize, cbDetailFontSize ], TCtrlArranger.RightOf( - [lblOverviewTree, lblMainColour, lblUserColour, lblSourceBGColour], + [ + lblOverviewTree, lblGroupHeadingColour, cbVaults, lblSourceBGColour, + lblOverviewFontSize, lblDetailFontSize + ], 8 ) ); + + // Align rows: + // 1st row TCtrlArranger.AlignVCentres(3, [lblOverviewTree, cbOverviewTree]); + // 2nd row TCtrlArranger.MoveBelow( [lblOverviewTree, cbOverviewTree], chkSnippetsInNewTab, 12 ); + chkSnippetsInNewTab.Width := Self.Width - 16; + // 3rd row TCtrlArranger.MoveBelow(chkSnippetsInNewTab, chkHideEmptySections, 8); + chkHideEmptySections.Width := Self.Width - 16; + // 4th row TCtrlArranger.AlignVCentres( TCtrlArranger.BottomOf(chkHideEmptySections, 12), - [lblMainColour, fMainColourBox] + [lblGroupHeadingColour, fGroupHeadingColourBox] + ); + // 5th row + TCtrlArranger.MoveBelow( + [lblGroupHeadingColour, fGroupHeadingColourBox], + lblVaultColours, + 12 ); + // 6th row TCtrlArranger.AlignVCentres( - TCtrlArranger.BottomOf([lblMainColour, fMainColourBox], 6), - [lblUserColour, fUserColourBox] + TCtrlArranger.BottomOf(lblVaultColours, 6), + [cbVaults, fSnippetHeadingColourBox] ); + // 7th row TCtrlArranger.AlignVCentres( - TCtrlArranger.BottomOf([lblUserColour, fUserColourBox], 6), + TCtrlArranger.BottomOf([cbVaults, fSnippetHeadingColourBox], 18), [lblSourceBGColour, fSourceBGColourBox] ); + // 8th row TCtrlArranger.MoveBelow( - [lblSourceBGColour, fSourceBGColourBox], btnDefColours, 6 + [lblSourceBGColour, fSourceBGColourBox], btnDefColours, 12 ); + // 9th row TCtrlArranger.AlignVCentres( TCtrlArranger.BottomOf(btnDefColours, 12), [lblOverviewFontSize, cbOverviewFontSize] ); + // 10th row TCtrlArranger.AlignVCentres( - TCtrlArranger.BottomOf(cbOverviewFontSize, 8), + TCtrlArranger.BottomOf([lblOverviewFontSize, cbOverviewFontSize], 8), [lblDetailFontSize, cbDetailFontSize] ); + // 11th row TCtrlArranger.MoveBelow( [lblDetailFontSize, cbDetailFontSize], lblHiliterInfo, 12 ); lblHiliterInfo.Width := Self.ClientWidth; TCtrlArranger.SetLabelHeight(lblHiliterInfo); - chkHideEmptySections.Width := Self.Width - 16; - chkSnippetsInNewTab.Width := Self.Width - 16; end; procedure TDisplayPrefsFrame.btnDefColoursClick(Sender: TObject); +var + Vault: TVault; begin // Restores default heading and source code background colours in colour // combo boxes - fMainColourBox.Selected := clMainSnippet; - fUserColourBox.Selected := clUserSnippet; + fGroupHeadingColourBox.Selected := clDefGroupHeading; + fSnippetHeadingColourBox.Selected := clDefSnippetHeading; + for Vault in TVaults.Instance do + fSnippetHeadingColours[Vault.UID] := clDefSnippetHeading; fSourceBGColourBox.Selected := clSourceBg; fUIChanged := True; end; +procedure TDisplayPrefsFrame.cbVaultsChange(Sender: TObject); +begin + fSnippetHeadingColourBox.Selected := + fSnippetHeadingColours[SelectedVaultID]; +end; + procedure TDisplayPrefsFrame.chkHideEmptySectionsClick(Sender: TObject); {Handles clicks on "Hide Empty Sections" check box. Flags UI preferences has having changed. @@ -234,6 +318,7 @@ constructor TDisplayPrefsFrame.Create(AOwner: TComponent); } resourcestring sHeadingColourDlgTitle = 'Heading Colour'; + sGroupHeadingColourDlgTitle = 'Group Heading Colour'; sSourceBGColourDlgTitle = 'Source Code Background Colour'; var OTStateIdx: TOverviewStartState; // loops thru each overview tree start state @@ -246,28 +331,42 @@ constructor TDisplayPrefsFrame.Create(AOwner: TComponent); OverviewTreeStateDesc(OTStateIdx), TObject(OTStateIdx) ); // Create colour dialogue boxes - fMainColourDlg := TColorDialogEx.Create(Self); - fMainColourDlg.Title := sHeadingColourDlgTitle; - fUserColourDlg := TColorDialogEx.Create(Self); - fUserColourDlg.Title := sHeadingColourDlgTitle; + fGroupHeadingColourDlg := TColorDialogEx.Create(Self); + fGroupHeadingColourDlg.Title := sGroupHeadingColourDlgTitle; + fSnippetHeadingColourDlg := TColorDialogEx.Create(Self); + fSnippetHeadingColourDlg.Title := sHeadingColourDlgTitle; fSourceBGColourDlg := TColorDialogEx.Create(Self); fSourceBGColourDlg.Title := sSourceBGColourDlgTitle; // Create colour combo boxes - fMainColourBox := CreateCustomColourBox(fMainColourDlg); - fMainColourBox.TabOrder := 3; - lblMainColour.FocusControl := fMainColourBox; - fUserColourBox := CreateCustomColourBox(fUserColourDlg); - fUserColourBox.TabOrder := 4; - lblUserColour.FocusControl := fUserColourBox; - fSourceBGColourBox := CreateCustomColourBox(fSourceBGColourDlg); - fSourceBGColourBox.TabOrder := 5; + fGroupHeadingColourBox := CreateCustomColourBox( + fGroupHeadingColourDlg, ColourBoxChangeHandler + ); + lblGroupHeadingColour.FocusControl := fGroupHeadingColourBox; + fSnippetHeadingColourBox := CreateCustomColourBox( + fSnippetHeadingColourDlg, SnippetHeadingColourBoxChange + ); + fSnippetHeadingColourBox.OnChange := SnippetHeadingColourBoxChange; + lblVaultColours.FocusControl := cbVaults; + fSourceBGColourBox := CreateCustomColourBox( + fSourceBGColourDlg, ColourBoxChangeHandler + ); lblSourceBGColour.FocusControl := fSourceBGColourBox; PopulateFontSizeCombos; + + fSnippetHeadingColours := TDictionary.Create( + TVaultID.TComparer.Create + ); + + fVaultList := TVaultListAdapter.Create; + fVaultList.ToStrings(cbVaults.Items); + Assert(cbVaults.Items.Count > 0, ClassName + '.Create: no vaults'); + + SetTabOrder; end; function TDisplayPrefsFrame.CreateCustomColourBox( - const ColourDlg: TColorDialogEx): TColorBoxEx; + const ColourDlg: TColorDialogEx; ChangeHandler: TNotifyEvent): TColorBoxEx; begin // Create and initialise custom color combo box Result := TColorBoxEx.Create(Self); // automatically freed @@ -281,28 +380,31 @@ function TDisplayPrefsFrame.CreateCustomColourBox( Result.ItemHeight := 16; if Assigned(ColourDlg) then Result.ColorDialog := ColourDlg; - Result.OnChange := ColourBoxChangeHandler; + Result.OnChange := ChangeHandler; end; procedure TDisplayPrefsFrame.Deactivate(const Prefs: IPreferences); {Called when page is deactivated. Stores information entered by user. @param Prefs [in] Object used to store information. } +var + Vault: TVault; begin Prefs.ShowNewSnippetsInNewTabs := chkSnippetsInNewTab.Checked; Prefs.ShowEmptySections := not chkHideEmptySections.Checked; Prefs.OverviewStartState := TOverviewStartState( cbOverviewTree.Items.Objects[cbOverviewTree.ItemIndex] ); - Prefs.DBHeadingColours[False] := fMainColourBox.Selected; - Prefs.DBHeadingColours[True] := fUserColourBox.Selected; + Prefs.GroupHeadingColour := fGroupHeadingColourBox.Selected; Prefs.SourceCodeBGcolour := fSourceBGColourBox.Selected; - Prefs.DBHeadingCustomColours[False].CopyFrom( - fMainColourDlg.CustomColors, True - ); - Prefs.DBHeadingCustomColours[True].CopyFrom( - fUserColourDlg.CustomColors, True + Prefs.GroupHeadingCustomColours.CopyFrom( + fGroupHeadingColourDlg.CustomColors, True ); + + for Vault in TVaults.Instance do + Prefs.SetSnippetHeadingColour( + Vault.UID, fSnippetHeadingColours[Vault.UID] + ); Prefs.SourceCodeBGCustomColours.CopyFrom( fSourceBGColourDlg.CustomColors, True ); @@ -312,6 +414,13 @@ procedure TDisplayPrefsFrame.Deactivate(const Prefs: IPreferences); Prefs.DetailFontSize := StrToIntDef(cbDetailFontSize.Text, -1); end; +destructor TDisplayPrefsFrame.Destroy; +begin + fVaultList.Free; + fSnippetHeadingColours.Free; + inherited; +end; + function TDisplayPrefsFrame.DisplayName: string; {Caption that is displayed in the tab sheet that contains this frame when displayed in the preference dialog box. @@ -400,6 +509,13 @@ procedure TDisplayPrefsFrame.PopulateFontSizeCombos; TFontHelper.ListCommonFontSizes(cbDetailFontSize.Items); end; +function TDisplayPrefsFrame.SelectedVaultID: TVaultID; +begin + Assert(cbVaults.ItemIndex >= 0, + ClassName + '.SelectedVaultID: no vault selected'); + Result := fVaultList.Vault(cbVaults.ItemIndex).UID; +end; + procedure TDisplayPrefsFrame.SelectOverviewTreeState( const State: TOverviewStartState); {Selects combo box item associated with a overview treeview startup state. @@ -418,6 +534,27 @@ procedure TDisplayPrefsFrame.SelectOverviewTreeState( end; end; +procedure TDisplayPrefsFrame.SetTabOrder; +begin + cbOverviewTree.TabOrder := 0; + chkSnippetsInNewTab.TabOrder := 1; + chkHideEmptySections.TabOrder := 2; + fGroupHeadingColourBox.TabOrder := 3; + cbVaults.TabOrder := 4; + fSnippetHeadingColourBox.TabOrder := 5; + fSourceBGColourBox.TabOrder := 6; + btnDefColours.TabOrder := 7; + cbOverviewFontSize.TabOrder := 8; + cbDetailFontSize.TabOrder := 9; +end; + +procedure TDisplayPrefsFrame.SnippetHeadingColourBoxChange(Sender: TObject); +begin + ColourBoxChangeHandler(Sender); + fSnippetHeadingColours[SelectedVaultID] := + fSnippetHeadingColourBox.Selected +end; + function TDisplayPrefsFrame.UIUpdated: Boolean; begin Result := fUIChanged; diff --git a/Src/FrOverview.dfm b/Src/FrOverview.dfm index 159f3cddc..b47989bbd 100644 --- a/Src/FrOverview.dfm +++ b/Src/FrOverview.dfm @@ -1,9 +1,9 @@ inherited OverviewFrame: TOverviewFrame inherited pnlTitle: TPanel inherited lblTitle: TLabel - Width = 54 + Width = 53 Caption = 'Overview' - ExplicitWidth = 54 + ExplicitWidth = 53 end object tbarOverview: TToolBar Left = 224 diff --git a/Src/FrOverview.pas b/Src/FrOverview.pas index 17f912f81..742b812e1 100644 --- a/Src/FrOverview.pas +++ b/Src/FrOverview.pas @@ -22,10 +22,25 @@ interface uses // Delphi Generics.Collections, - ComCtrls, Controls, Classes, Windows, ExtCtrls, StdCtrls, ToolWin, Menus, + ComCtrls, + Controls, + Classes, + Windows, + ExtCtrls, + StdCtrls, + ToolWin, + Menus, // Project - DB.USnippet, FrTitled, IntfFrameMgrs, IntfNotifier, UCommandBars, - UOverviewTreeState, USnippetsTVDraw, UView, UViewItemTreeNode; + DB.Snippets, + DB.Vaults, + FrTitled, + IntfFrameMgrs, + IntfNotifier, + UCommandBars, + UOverviewTreeState, + USnippetsTVDraw, + UView, + UViewItemTreeNode; type @@ -78,11 +93,15 @@ TOverviewFrame = class(TTitledFrame, } TTVDraw = class(TSnippetsTVDraw) strict protected - function IsUserDefinedNode(const Node: TTreeNode): Boolean; override; - {Checks if a node represents a user defined snippets object. - @param Node [in] Node to be checked. - @return True if node represents user defined object, False if not. - } + /// Gets the vault ID, if any, associated with a tree node. + /// + /// TTreeNode [in] Node to be checked. + /// + /// TVaultID. Associated vault ID. If Node has + /// no associated vault then a null vault ID is returned. + function GetVaultID(const Node: TTreeNode): TVaultID; + override; + function IsSectionHeadNode(const Node: TTreeNode): Boolean; override; {Checks if a node represents a section header. @@ -242,9 +261,11 @@ implementation uses // Delphi + SysUtils, Messages, // Project - UKeysHelper, UOverviewTreeBuilder; + UKeysHelper, + UOverviewTreeBuilder; {$R *.dfm} @@ -965,29 +986,24 @@ procedure TOverviewFrame.UpdateTreeState(const State: TTreeNodeAction); { TOverviewFrame.TTVDraw } -function TOverviewFrame.TTVDraw.IsSectionHeadNode( - const Node: TTreeNode): Boolean; - {Checks if a node represents a section header. - @param Node [in] Node to be checked. - @return True if node is a section header, False if not. - } +function TOverviewFrame.TTVDraw.GetVaultID(const Node: TTreeNode): TVaultID; var - ViewItem: IView; // view item represented by node + ViewItem: IView; // view item represented by node + SnippetView: ISnippetView; // view item if node represents a snippet begin + // TODO -cBug: Exception reported as issue #70 could have moved here ViewItem := (Node as TViewItemTreeNode).ViewItem; - // Workaround for possibility that ViewItem might be nil when restarting after - // hibernation. - if Assigned(ViewItem) then - Result := ViewItem.IsGrouping + if Assigned(ViewItem) and Supports(ViewItem, ISnippetView, SnippetView) then + Result := SnippetView.Snippet.VaultID else - Result := False; + Result := TVaultID.CreateNull; end; -function TOverviewFrame.TTVDraw.IsUserDefinedNode( +function TOverviewFrame.TTVDraw.IsSectionHeadNode( const Node: TTreeNode): Boolean; - {Checks if a node represents a user defined snippets object. + {Checks if a node represents a section header. @param Node [in] Node to be checked. - @return True if node represents user defined object, False if not. + @return True if node is a section header, False if not. } var ViewItem: IView; // view item represented by node @@ -996,7 +1012,7 @@ function TOverviewFrame.TTVDraw.IsUserDefinedNode( // Workaround for possibility that ViewItem might be nil when restarting after // hibernation. if Assigned(ViewItem) then - Result := ViewItem.IsUserDefined + Result := ViewItem.IsGrouping else Result := False; end; diff --git a/Src/FrSelectSnippets.pas b/Src/FrSelectSnippets.pas index 6552d8ead..9bb9d3152 100644 --- a/Src/FrSelectSnippets.pas +++ b/Src/FrSelectSnippets.pas @@ -18,9 +18,14 @@ interface uses // Delphi - ImgList, Controls, Classes, ComCtrls, + ImgList, + Controls, + Classes, + ComCtrls, // Project - DB.UCategory, DB.USnippet, FrSelectSnippetsBase; + DB.Categories, + DB.Snippets, + FrSelectSnippetsBase; type diff --git a/Src/FrSelectSnippetsBase.pas b/Src/FrSelectSnippetsBase.pas index 4952a2ace..3410d6849 100644 --- a/Src/FrSelectSnippetsBase.pas +++ b/Src/FrSelectSnippetsBase.pas @@ -18,9 +18,16 @@ interface uses // Delphi - ImgList, Controls, Classes, ComCtrls, + ImgList, + Controls, + Classes, + ComCtrls, // Project - DB.UCategory, DB.USnippet, FrCheckedTV, USnippetsTVDraw; + DB.Categories, + DB.Snippets, + DB.Vaults, + FrCheckedTV, + USnippetsTVDraw; type @@ -42,11 +49,16 @@ TSelectSnippetsBaseFrame = class(TCheckedTVFrame) } TTVDraw = class(TSnippetsTVDraw) strict protected - function IsUserDefinedNode(const Node: TTreeNode): Boolean; override; - {Checks if a node represents a user defined snippets object. - @param Node [in] Node to be checked. - @return True if node represents user defined object, False if not. - } + + /// Gets the vault ID, if any, associated with a tree node. + /// + /// TTreeNode [in] Node to be checked. + /// + /// TVaultID. Associated vault ID. If Node has + /// no associated vault then a null vault ID is returned. + function GetVaultID(const Node: TTreeNode): TVaultID; + override; + function IsSectionHeadNode(const Node: TTreeNode): Boolean; override; {Checks if a node represents a section header. @@ -118,9 +130,11 @@ implementation uses // Delphi - SysUtils, StdCtrls, + SysUtils, + StdCtrls, // Project - DB.UMain, UGroups; + DB.Main, + UGroups; {$R *.dfm} @@ -260,6 +274,18 @@ function TSelectSnippetsBaseFrame.SnippetFromNode( { TSelectSnippetsBaseFrame.TTVDraw } +function TSelectSnippetsBaseFrame.TTVDraw.GetVaultID( + const Node: TTreeNode): TVaultID; +var + SnipObj: TObject; // object referenced in Node.Data +begin + SnipObj := TObject(Node.Data); + if SnipObj is TSnippet then + Result := (SnipObj as TSnippet).VaultID + else + Result := TVaultID.CreateNull +end; + function TSelectSnippetsBaseFrame.TTVDraw.IsSectionHeadNode( const Node: TTreeNode): Boolean; {Checks if a node represents a section header. @@ -271,22 +297,5 @@ function TSelectSnippetsBaseFrame.TTVDraw.IsSectionHeadNode( Result := TObject(Node.Data) is TCategory; end; -function TSelectSnippetsBaseFrame.TTVDraw.IsUserDefinedNode( - const Node: TTreeNode): Boolean; - {Checks if a node represents a user defined snippets object. - @param Node [in] Node to be checked. - @return True if node represents user defined object, False if not. - } -var - SnipObj: TObject; // object referenced in Node.Data -begin - SnipObj := TObject(Node.Data); - Result := False; - if SnipObj is TSnippet then - Result := (SnipObj as TSnippet).UserDefined - else if SnipObj is TCategory then - Result := (SnipObj as TCategory).UserDefined; -end; - end. diff --git a/Src/FrSelectUserSnippets.pas b/Src/FrSelectUserSnippets.pas index 28c684c67..77850d845 100644 --- a/Src/FrSelectUserSnippets.pas +++ b/Src/FrSelectUserSnippets.pas @@ -18,9 +18,14 @@ interface uses // Delphi - ImgList, Controls, Classes, ComCtrls, + ImgList, + Controls, + Classes, + ComCtrls, // Project - DB.UCategory, DB.USnippet, FrSelectSnippetsBase; + DB.Categories, + DB.Snippets, + FrSelectSnippetsBase; type @@ -51,9 +56,27 @@ TSelectUserSnippetsFrame = class(TSelectSnippetsBaseFrame) implementation +uses + DB.Vaults; + + {$R *.dfm} +{TODO -cRefactor: TSelectUserSnippetsFrame is now identical to + TSelectSnippetsFrame, so both can be collapsed into base class, + TSelectSnippetsBaseFrame. + + Add an event that the owning form can handle to filter out any unwanted + snippets from being displayed. + + TSelectUserSnippetsFrame and TSelectSnippetsFrame should then be removed + and TSelectSnippetsBaseFrame should be renamed as TSelectSnippetsFrame. + + Finally FrSelectUserSnippets and FrSelectSnippets units can be removed + and FrSelectSnippetsBase can be renamed as FrSelectSnippets. +} + { TSelectUserSnippetsFrame } function TSelectUserSnippetsFrame.CanAddCatNode(const Cat: TCategory): Boolean; @@ -62,7 +85,7 @@ function TSelectUserSnippetsFrame.CanAddCatNode(const Cat: TCategory): Boolean; @return True if category contains any user-defined snippets. } begin - Result := Cat.Snippets.Count(True) > 0; + Result := not Cat.Snippets.IsEmpty; end; function TSelectUserSnippetsFrame.CanAddSnippetNode( @@ -72,7 +95,7 @@ function TSelectUserSnippetsFrame.CanAddSnippetNode( @return True if snippet is user-defined. } begin - Result := Snippet.UserDefined; + Result := True; end; end. diff --git a/Src/FrSnippetLayoutPrefs.pas b/Src/FrSnippetLayoutPrefs.pas index a16cc1da4..7cc78daee 100644 --- a/Src/FrSnippetLayoutPrefs.pas +++ b/Src/FrSnippetLayoutPrefs.pas @@ -18,9 +18,17 @@ interface uses // Delphi - StdCtrls, ImgList, Controls, Classes, ActnList, Buttons, + StdCtrls, + ImgList, + Controls, + Classes, + ActnList, + Buttons, // Project - DB.USnippetKind, FrPrefsBase, UPreferences, USnippetPageStructure; + DB.SnippetKind, + FrPrefsBase, + UPreferences, + USnippetPageStructure; type TSnippetLayoutPrefsFrame = class(TPrefsBaseFrame) diff --git a/Src/HTML.hrc b/Src/HTML.hrc index 600d279b8..90e550c11 100644 --- a/Src/HTML.hrc +++ b/Src/HTML.hrc @@ -13,7 +13,6 @@ # about box Res\HTML\dlg-about-head-tplt.html Res\HTML\dlg-about-program-tplt.html -Res\HTML\dlg-about-database-tplt.html # easter egg Res\HTML\dlg-easter-egg.html diff --git a/Src/IntfFrameMgrs.pas b/Src/IntfFrameMgrs.pas index 813d320ad..67a1f6e07 100644 --- a/Src/IntfFrameMgrs.pas +++ b/Src/IntfFrameMgrs.pas @@ -20,7 +20,11 @@ interface // Delphi SHDocVw, ActiveX, // Project - Browser.IntfDocHostUI, DB.USnippet, Compilers.UGlobals, UCommandBars, UView; + Browser.IntfDocHostUI, + DB.Snippets, + Compilers.UGlobals, + UCommandBars, + UView; const diff --git a/Src/IntfNotifier.pas b/Src/IntfNotifier.pas index cb0e460c9..e8aa01bca 100644 --- a/Src/IntfNotifier.pas +++ b/Src/IntfNotifier.pas @@ -20,6 +20,7 @@ interface // Delphi Classes, ActiveX, Windows, // Project + DB.Vaults, UView; @@ -29,18 +30,15 @@ interface INotifier = interface(IInterface) ['{13962DE4-784A-4B70-9D3F-FD434FAE4F4F}'] - /// Requests a database update. - procedure UpdateDbase; - /// Displays a snippet. - /// WideString [in] Name of required snippet. + /// WideString [in] Required snippet's key. + /// + /// TVaultID [in] ID of the snippet's vault. /// - /// WordBool [in] Indicates whether snippet is - /// user defined. /// WordBool [in] Whether to display snippet in a new /// detail pane tab. - procedure DisplaySnippet(const SnippetName: WideString; - UserDefined: WordBool; NewTab: WordBool); + procedure DisplaySnippet(const Key: WideString; AVaultID: TVaultID; + NewTab: WordBool); /// Displays a category. /// WideString [in] ID of required category. @@ -67,12 +65,10 @@ interface procedure ChangeDetailPane(const Pane: Integer); /// Edits a snippet in Snippets Editor. - /// WideString [in] Name of snippet. - /// Snippet must be user defined. - procedure EditSnippet(const SnippetName: WideString); - - /// Opens Snippets Editor ready to create a new snippet. - procedure NewSnippet; + /// WideString [in] Snippet's key. + /// TVaultID [in] ID of the snippet's vault. + /// + procedure EditSnippet(const Key: WideString; const AVaultID: TVaultID); /// Displays news items from the CodeSnip news feed. procedure ShowNews; @@ -90,10 +86,6 @@ interface ISetActions = interface(IInterface) ['{A4B7AFE2-EE6C-4D39-BEA6-B52CC8AAC1DE}'] - /// Sets action used to request a database update. - /// TBasicAction [in] Required action. - procedure SetUpdateDbaseAction(const Action: TBasicAction); - /// Sets action used to display a snippet. /// TBasicAction [in] Required action. procedure SetDisplaySnippetAction(const Action: TBasicAction); @@ -130,11 +122,6 @@ interface /// TBasicAction [in] Required action. procedure SetDisplayCategoryAction(const Action: TBasicAction); - /// Sets action used to open snippets editor to create a new - /// snippet. - /// TBasicAction [in] Required action. - procedure SetNewSnippetAction(const Action: TBasicAction); - /// Sets action used to display news items from the CodeSnip news /// feed. /// TBasicAction [in] Required action. diff --git a/Src/Res/CSS/detail.css b/Src/Res/CSS/detail.css index bea2dc732..6cffb8689 100644 --- a/Src/Res/CSS/detail.css +++ b/Src/Res/CSS/detail.css @@ -130,11 +130,7 @@ pre { border-bottom: 1px solid silver; } -#user-db .caption { - background-color: #D5E0FF; -} - -#main-db .caption { +#vaults .caption { background-color: #DBD1FF; } @@ -174,10 +170,17 @@ pre { } .testing-img { - float: right; width: 16px; height: 16px; padding: 0; - margin: 2px 0 0 8px; + margin: 0 0 0 8px; + vertical-align: middle; } +#editlink { + padding-top: 2px; + margin: 0; + float: right; + vertical-align: baseline; + text-align: right; +} diff --git a/Src/Res/HTML/dlg-about-database-tplt.html b/Src/Res/HTML/dlg-about-database-tplt.html deleted file mode 100644 index ccc4f9797..000000000 --- a/Src/Res/HTML/dlg-about-database-tplt.html +++ /dev/null @@ -1,114 +0,0 @@ - - - - - - - - - - dlg-about-database-tplt.html - - - - - -

- The DelphiDabbler - Code Snippets Database is a resource containing numerous fragments of useful Object Pascal code. You are using version <%Version%>. -

- -
- -
- -

- The source code in the database is copyright © <%CopyrightYear%> by <%CopyrightHolders%>. It is made available under the terms of the <%DBLicense%>. -

- -

- No copyright or licensing information is available. -

- -

- The code is used entirely at your own risk. -

- -

- Credits -

- -

- The following people have contributed code to the database, or have helped to test it: -

- -
-
- Contributors -
-
- <%ContribList%> -
-
- Testers -
-
- <%TesterList%> -
-
- -
- -

- Credits, License and Copyright information are not available. The main database may be corrupt. Please use the Database | Install or Update DelphiDabbler Snippets Database menu option to display the Install or Update DelphiDabbler Snippets Database dialogue box and follow the instructions there to get the latest version of the database. -

- -
- -
- -

- The database is not installed. -

- -

- You can install it from the Database | Install or Update DelphiDabbler Snippets Database menu option. Learn more. -

- -
- - - - - diff --git a/Src/Res/HTML/dlg-dbdelete.html b/Src/Res/HTML/dlg-dbdelete.html index b21cfb4c7..f8a32d30c 100644 --- a/Src/Res/HTML/dlg-dbdelete.html +++ b/Src/Res/HTML/dlg-dbdelete.html @@ -11,8 +11,8 @@ * * Copyright (C) 2022, Peter Johnson (gravatar.com/delphidabbler). * - * Warning information displayed in dialogue box used to confirm deletion on the - * user database. + * Warning information displayed in dialogue box used to confirm deletion of a + * selected vault. --> @@ -28,19 +28,19 @@

- Before going any further you are strongly advised to take a backup of your snippets database. Use the Database | Backup User Database menu option to do this. + This action cannot be undone. You will loose all the snippets in the chosen vault. The vault itself will remain but will be empty.

- This action cannot be undone: you will loose all your user-defined snippets. + Before going any further you are strongly advised to take a backup of the vault you are planning to delete. Use the Database | Backup Vault menu option to do this.

- To confirm enter DELETE MY SNIPPETS (in capital letters) in the box below, then click OK. + To proceed, first choose the vault you want to delete from the Choose vault drop down list. Then confirm the action by entering DELETE MY SNIPPETS (in capital letters) in the Confirm deletion edit box.

- There will be no further chances to change your mind. + When you click OK there will be no further chances to change your mind.

diff --git a/Src/Res/HTML/info-empty-selection-tplt.html b/Src/Res/HTML/info-empty-selection-tplt.html index dd2b9fdd3..208243076 100644 --- a/Src/Res/HTML/info-empty-selection-tplt.html +++ b/Src/Res/HTML/info-empty-selection-tplt.html @@ -23,7 +23,7 @@ -

+

<%Heading%>

diff --git a/Src/Res/HTML/info-snippet-list-tplt.html b/Src/Res/HTML/info-snippet-list-tplt.html index e762589f9..3e929ec7a 100644 --- a/Src/Res/HTML/info-snippet-list-tplt.html +++ b/Src/Res/HTML/info-snippet-list-tplt.html @@ -27,7 +27,7 @@ -

+

<%Heading%>

diff --git a/Src/Res/HTML/info-snippet-tplt.html b/Src/Res/HTML/info-snippet-tplt.html index a362b8bdc..1d44327f4 100644 --- a/Src/Res/HTML/info-snippet-tplt.html +++ b/Src/Res/HTML/info-snippet-tplt.html @@ -34,15 +34,9 @@
-
- <%TestingInfoImg%> -
- - + -

- <%SnippetName%> +

+ <%SnippetName%><%TestingInfoImg%>

diff --git a/Src/Res/HTML/welcome-tplt.html b/Src/Res/HTML/welcome-tplt.html index 55a23c116..e54de5764 100644 --- a/Src/Res/HTML/welcome-tplt.html +++ b/Src/Res/HTML/welcome-tplt.html @@ -27,72 +27,25 @@

- CodeSnip 4 by DelphiDabbler + CodeSnip Vault by DelphiDabbler (experimental)

-
+
- Local User database + Vaults
-
+
- There are <%UserDBCount%> snippets in the local user - database. + There are <%VaultCount%> vaults in the database:
-
-
-
- No user defined snippets have been created yet. -
- -
-
- -
-
- DelphiDabbler Code Snippets database -
-
-
- There are <%MainDBCount%> snippets in the DelphiDabbler - Code Snippets database. -
-
-
-
- The DelphiDabbler Code Snippets Database has not been - installed. - Learn more -
-
- Install it now +
    + <%VaultList%> +
-
diff --git a/Src/Res/Img/Branding/Splash.gif b/Src/Res/Img/Branding/Splash.gif index 6bddefedf..496a900db 100644 Binary files a/Src/Res/Img/Branding/Splash.gif and b/Src/Res/Img/Branding/Splash.gif differ diff --git a/Src/Res/Scripts/external.js b/Src/Res/Scripts/external.js index 0de9f998d..8c79d9bb6 100644 --- a/Src/Res/Scripts/external.js +++ b/Src/Res/Scripts/external.js @@ -21,25 +21,16 @@ function configCompilers() { return false; } -/* - * Calls external object to get host application to display Update Database - * dialog box. - * @return False. - */ -function updateDbase() { - external.UpdateDbase(); - return false; -} - /* * Calls external object to get host application to display a named snippet. - * @param string snippet [in] Name of snippet to be displayed. - * @param boolean userdefined [in] Whether snippet is user defined. + * @param string snippet [in] Key of snippet to be displayed. + * @param string vaultId [in] Hex string representation of the vault to which + * the snippet belongs. * @return False. */ -function displaySnippet(snippet, userdefined) { +function displaySnippet(snippet, vaultId) { var e = window.event; - external.DisplaySnippet(snippet, userdefined, e.ctrlKey); + external.DisplaySnippet(snippet, vaultId, e.ctrlKey); return false; } @@ -56,22 +47,14 @@ function displayCategory(catid) { /* * Calls external object to get host application to edit a named snippet. - * @param string snippet [in] Name of snippet to be edited. Must be user + * @param string snippet [in] Key of snippet to be edited. Must be user * defined. + * @param string vaultId [in] Hex string representation of the vault to which + * the snippet belongs. * @return False. */ -function editSnippet(snippet) { - external.EditSnippet(snippet); - return false; -} - -/* - * Calls external object to get host application to start Snippets Editor ready - * for a new snippet to be entered. - * @return False. - */ -function newSnippet() { - external.NewSnippet(); +function editSnippet(snippet, vaultId) { + external.EditSnippet(snippet, vaultId); return false; } diff --git a/Src/SWAG.UImporter.pas b/Src/SWAG.UImporter.pas index ab193dd22..ae5cdafab 100644 --- a/Src/SWAG.UImporter.pas +++ b/Src/SWAG.UImporter.pas @@ -21,7 +21,9 @@ interface Generics.Collections, // Project ActiveText.UMain, - DB.USnippet, + DB.Categories, + DB.Snippets, + DB.Vaults, SWAG.UCommon; @@ -41,6 +43,11 @@ TSWAGImporter = class(TObject) /// TProgressCallback = reference to procedure ( const SWAGPacket: TSWAGPacket); + const + {TODO -cVault: Let user select or create a category rather than imposing + this one} + /// ID of category used to import snippets. + SWAGCatID = '_swag_'; var /// List of SWAG packets to be imported. fImportList: TList; @@ -55,9 +62,12 @@ TSWAGImporter = class(TObject) ///
function BuildSnippetInfo(const SWAGPacket: TSWAGPacket): TSnippetEditData; - /// Imports (i.e. adds) the given SWAG packet into the user - /// database as a CodeSnip format snippet. - procedure ImportPacketAsSnippet(const SWAGPacket: TSWAGPacket); + /// Imports (i.e. adds) the given SWAG packet into the specified + /// vault. + procedure ImportPacketAsSnippet(const AVaultID: TVaultID; + const SWAGPacket: TSWAGPacket); + + class procedure EnsureSWAGCategoryExists; public /// Constructs new object instance. constructor Create; @@ -72,15 +82,14 @@ TSWAGImporter = class(TObject) procedure IncludePacket(const SWAGPacket: TSWAGPacket); /// Imports all the required SWAG packets into the user database /// as new snippets. + /// TVaultID [in] Vault into which packets + /// are imported. /// TProgressCallback [in] Optional callback to be /// called after each SWAG packet is imported. /// The packets that are imported are those that have been /// recorded by calling IncludePacket. - procedure Import(const Callback: TProgressCallback = nil); - /// Creates and returns a valid CodeSnip snippet name, based on - /// the given SWAG packet ID, that is unique in the user database. - /// - class function MakeValidSnippetName(SWAGPacketID: Cardinal): string; + procedure Import(const AVaultID: TVaultID; + const Callback: TProgressCallback = nil); /// Description of the category in the user database used for all /// imported SWAG packets. class function SWAGCategoryDesc: string; @@ -94,10 +103,8 @@ implementation // Delphi SysUtils, // Project - DB.UCategory, - DB.UMain, - DB.USnippetKind, - UReservedCategories, + DB.Main, + DB.SnippetKind, USnippetValidator; @@ -136,7 +143,7 @@ function TSWAGImporter.BuildSnippetInfo(const SWAGPacket: TSWAGPacket): begin Result.Init; Result.Props.Kind := skFreeform; - Result.Props.Cat := TReservedCategories.SWAGCatID; + Result.Props.Cat := SWAGCatID; Result.Props.Desc := BuildDescription; Result.Props.SourceCode := SWAGPacket.SourceCode; Result.Props.HiliteSource := not SWAGPacket.IsDocument; @@ -149,6 +156,7 @@ constructor TSWAGImporter.Create; begin inherited Create; fImportList := TList.Create; + EnsureSWAGCategoryExists; end; destructor TSWAGImporter.Destroy; @@ -157,6 +165,22 @@ destructor TSWAGImporter.Destroy; inherited; end; +class procedure TSWAGImporter.EnsureSWAGCategoryExists; +resourcestring + SWAGCatDesc = 'SWAG Imports'; +var + SWAGCatData: TCategoryData; + SWAGCat: TCategory; +begin + SWAGCat := Database.Categories.Find(SWAGCatID); + if not Assigned(SWAGCat) then + begin + SWAGCatData.Init; + SWAGCatData.Desc := SWAGCatDesc; + Database.AddCategory(SWAGCatID, SWAGCatData); + end; +end; + function TSWAGImporter.ExtraBoilerplate: IActiveText; procedure AddText(const Text: string); @@ -234,7 +258,8 @@ function TSWAGImporter.ExtraBoilerplate: IActiveText; Result := fExtraBoilerplate; end; -procedure TSWAGImporter.Import(const Callback: TProgressCallback); +procedure TSWAGImporter.Import(const AVaultID: TVaultID; + const Callback: TProgressCallback); var SWAGPacket: TSWAGPacket; begin @@ -242,18 +267,19 @@ procedure TSWAGImporter.Import(const Callback: TProgressCallback); begin if Assigned(Callback) then Callback(SWAGPacket); - ImportPacketAsSnippet(SWAGPacket); + ImportPacketAsSnippet(AVaultID, SWAGPacket); end; end; -procedure TSWAGImporter.ImportPacketAsSnippet(const SWAGPacket: TSWAGPacket); +procedure TSWAGImporter.ImportPacketAsSnippet( + const AVaultID: TVaultID; const SWAGPacket: TSWAGPacket); var - SnippetName: string; // unique name of new snippet + SnippetKey: string; // unique ID of new snippet SnippetDetails: TSnippetEditData; // data describing new snippet begin - SnippetName := MakeValidSnippetName(SWAGPacket.ID); + SnippetKey := Database.GetUniqueSnippetKey(AVaultID); SnippetDetails := BuildSnippetInfo(SWAGPacket); - (Database as IDatabaseEdit).AddSnippet(SnippetName, SnippetDetails); + Database.AddSnippet(SnippetKey, AVaultID, SnippetDetails); end; procedure TSWAGImporter.IncludePacket(const SWAGPacket: TSWAGPacket); @@ -261,37 +287,15 @@ procedure TSWAGImporter.IncludePacket(const SWAGPacket: TSWAGPacket); fImportList.Add(SWAGPacket); end; -class function TSWAGImporter.MakeValidSnippetName(SWAGPacketID: Cardinal): - string; -var - Appendix: Integer; - RootName: string; -begin - RootName := 'SWAG_' + IntToStr(SWAGPacketID); - Assert(IsValidIdent(RootName, False), ClassName - + '.MakeValidSnippetName: RootName is not a valid snippet identifier'); - Result := RootName; - Appendix := 0; - while not TSnippetValidator.ValidateName(Result, True) do - begin - Inc(Appendix); - Result := RootName + '_' + IntToStr(Appendix); - end; -end; - procedure TSWAGImporter.Reset; begin fImportList.Clear; end; class function TSWAGImporter.SWAGCategoryDesc: string; -var - Cat: TCategory; // reserved SWAG category in code snippets database begin - Cat := Database.Categories.Find(TReservedCategories.SWAGCatID); - Assert(Assigned(Cat), - ClassName + '.SWAGCategoryDesc: Can''t find SWAG category'); - Result := Cat.Description; + EnsureSWAGCategoryExists; + Result := Database.Categories.Find(SWAGCatID).Description; end; end. diff --git a/Src/UAppInfo.pas b/Src/UAppInfo.pas index 7bc91fd6e..9993d7941 100644 --- a/Src/UAppInfo.pas +++ b/Src/UAppInfo.pas @@ -36,10 +36,12 @@ TAppInfo = class(TNoConstructObject) const ProgramName = 'CodeSnip-p'; {$ENDIF} {Name of program} - const FullProgramName = CompanyName + ' CodeSnip'; + const FullProgramName = CompanyName + ' CodeSnip.Vault'; {Full name of program, including company name} const ProgramID = 'codesnip'; + {TODO -cVault: Remove unused ProgramID const} {Machine readable identifier of program} + public class function UserAppDir: string; {Gets the CodeSnip data directory stored within the user's application data directory. @@ -51,25 +53,30 @@ TAppInfo = class(TNoConstructObject) @return Full path to common application data directory. } class function AppDataDir: string; + {TODO -cVault: Remove AppDataDir method: used for "main" database} {Returns the directory where CodeSnip stores the "database" files. @return Full path to database sub directory. } - class function UserDataDir: string; - {Returns the directory where CodeSnip stores the user's "database" files. - @return Full path to database sub directory. - } - class function DefaultUserDataDir: string; - {Returns the default directory where CodeSnip stores the uer's "database" - files. - @return Full path to required directory. - } - class procedure ChangeUserDataDir(const NewDir: string); - {Changes directory where CodeSnip stores the user's "database" files and - records it in the user config file. - Does nothing on portable edition since it does not permit the user - database to be moved. - @param NewDir [in] New directory. - } + + /// Returns the path where vaults are recommended to be stored for + /// the current user. + /// + /// Vaults each have their own sub-directory of this directory. + /// + /// The user may ignore this recommendation and install vaults + /// anywhere they choose. + /// + class function UserVaultsDir: string; + + /// Returns the path where the Default vault is recommended to be + /// stored for the current user. + /// + /// If the Default vault is not present then CodeSnip will + /// automatically create it in this directory. + /// The user may move the Default vault anywhere they choose. + /// + class function UserDefaultVaultDir: string; + class function AppExeFilePath: string; {Returns fully specified name of program's executable file. @return Name of file. @@ -88,6 +95,15 @@ TAppInfo = class(TNoConstructObject) class function UserConfigFileName: string; {Returns fully specified name of per-user config file. } + + /// Returns fully specified name of the current user's global + /// categories file. + class function UserCategoriesFileName: string; + + /// Returns fully specified name of the current user's favourites + /// file. + class function UserFavouritesFileName: string; + class function ProgramReleaseInfo: string; {Gets information about the current program release. Includes any special build information if present in version information. @@ -115,6 +131,7 @@ implementation // Delphi SysUtils, // Project + DB.Vaults, USettings, UStrUtils, USystemInfo, @@ -156,28 +173,6 @@ class function TAppInfo.AppExeFilePath: string; Result := ParamStr(0); end; -class procedure TAppInfo.ChangeUserDataDir(const NewDir: string); - {Changes directory where CodeSnip stores the user's "database" files and - records it in the user config file. - Does nothing on portable edition since it does not permit the user database - to be moved. - @param NewDir [in] New directory. - } -{$IFNDEF PORTABLE} -var - Section: ISettingsSection; -{$ENDIF} -begin - {$IFNDEF PORTABLE} - Section := Settings.ReadSection(ssDatabase); - if StrSameText(ExcludeTrailingPathDelimiter(NewDir), DefaultUserDataDir) then - Section.DeleteItem('UserDataDir') - else - Section.SetString('UserDataDir', NewDir); - Section.Save; - {$ENDIF} -end; - class function TAppInfo.CommonAppDir: string; {Gets the CodeSnip data directory stored within the common application data directory. @@ -185,22 +180,9 @@ class function TAppInfo.CommonAppDir: string; } begin {$IFNDEF PORTABLE} - Result := TSystemFolders.CommonAppData + '\DelphiDabbler\CodeSnip.4'; + Result := TSystemFolders.CommonAppData + '\DelphiDabbler\CodeSnip.Vault'; {$ELSE} - Result := AppExeDir + '\AppData'; - {$ENDIF} -end; - -class function TAppInfo.DefaultUserDataDir: string; - {Returns the default directory where CodeSnip stores the uer's "database" - files. - @return Full path to required directory. - } -begin - {$IFNDEF PORTABLE} - Result := UserAppDir + '\UserDatabase'; - {$ELSE} - Result := UserAppDir + '\UserDB'; + Result := AppExeDir + '\AppData.Vault'; {$ENDIF} end; @@ -218,7 +200,7 @@ class function TAppInfo.ProgramCaption: string; begin ProductVer := TVersionInfo.ProductVerNum; Result := Format( - 'CodeSnip v%d.%d.%d', [ProductVer.V1, ProductVer.V2, ProductVer.V3] + 'CodeSnip.Vault v%d.%d.%d', [ProductVer.V1, ProductVer.V2, ProductVer.V3] ); {$IFDEF PORTABLE} Result := Result + ' (Portable Edition)' @@ -259,32 +241,35 @@ class function TAppInfo.UserAppDir: string; } begin {$IFNDEF PORTABLE} - Result := TSystemFolders.PerUserAppData + '\DelphiDabbler\CodeSnip.4'; + Result := TSystemFolders.PerUserAppData + '\DelphiDabbler\CodeSnip.Vault'; {$ELSE} Result := CommonAppDir; {$ENDIF} end; +class function TAppInfo.UserCategoriesFileName: string; +begin + Result := UserAppDir + '\Categories'; +end; + class function TAppInfo.UserConfigFileName: string; begin Result := UserAppDir + '\User.config'; end; -class function TAppInfo.UserDataDir: string; - {Returns the directory where CodeSnip stores the user's "database" files. - @return Full path to database sub directory. - } -{$IFNDEF PORTABLE} -var - Section: ISettingsSection; // persistent storage where code is recorded -{$ENDIF} +class function TAppInfo.UserDefaultVaultDir: string; begin - {$IFNDEF PORTABLE} - Section := Settings.ReadSection(ssDatabase); - Result := Section.GetString('UserDataDir', DefaultUserDataDir); - {$ELSE} - Result := DefaultUserDataDir; - {$ENDIF} + Result := UserVaultsDir + '\Default'; +end; + +class function TAppInfo.UserFavouritesFileName: string; +begin + Result := UserAppDir + '\Favourites'; +end; + +class function TAppInfo.UserVaultsDir: string; +begin + Result := UserAppDir + '\Vaults'; end; end. diff --git a/Src/UCategoryAction.pas b/Src/UCategoryAction.pas index 7e888c185..8b492e5a5 100644 --- a/Src/UCategoryAction.pas +++ b/Src/UCategoryAction.pas @@ -64,7 +64,9 @@ implementation uses // Project - DB.UCategory, DB.UMain, UView; + DB.Categories, + DB.Main, + UView; { TCategoryAction } diff --git a/Src/UCodeImportMgr.pas b/Src/UCodeImportMgr.pas index ba328ea9e..4d7bc6e2d 100644 --- a/Src/UCodeImportMgr.pas +++ b/Src/UCodeImportMgr.pas @@ -18,9 +18,14 @@ interface uses // Delphi - Generics.Collections, Generics.Defaults, + SysUtils, + Generics.Collections, + Generics.Defaults, // Project - UCodeImportExport, UExceptions, UIStringList; + DB.Vaults, + DB.IO.ImportExport.CS4, + UExceptions, + UIStringList; type @@ -30,18 +35,21 @@ interface TImportInfo = record strict private // Property values - fOrigName: string; - fImportAsName: string; + fOrigKey: string; + fNewKey: string; + fDisplayName: string; fSkip: Boolean; public /// Initialises properties to given values. - constructor Create(const AOrigName, AImportAsName: string; + constructor Create(const AOrigKey, ANewKey, ADisplayName: string; const ASkip: Boolean = False); - /// Name of snippet per import file. - property OrigName: string read fOrigName; - /// Name of snippet to be used when updating database. - /// Can be changed by user. - property ImportAsName: string read fImportAsName write fImportAsName; + /// Snippet key per import file. + property OrigKey: string read fOrigKey; + /// New, unique snippet key under which the snippet will be + /// imported.
+ property NewKey: string read fNewKey; + /// Snippet's display name. + property DisplayName: string read fDisplayName; /// Flag indicating if snippet is to be skipped (ignored) when /// updating database. property Skip: Boolean read fSkip write fSkip; @@ -68,16 +76,22 @@ TImportInfoList = class(TList) public /// Constructs list with appropriate comparer. constructor Create; - /// Finds a record based on its OrigName field value. - /// string [in] Name to be found. + /// Finds a record based on its OrigKey field value. + /// string [in] Key to be found. /// TImportInfo [out] Found record. Undefined if /// Name not found. - /// Boolean: True if Name found, False if not. - function FindByName(const Name: string; out ImportInfo: TImportInfo): + /// Boolean: True if Key found, False if not. + function FindByKey(const Key: string; out ImportInfo: TImportInfo): Boolean; - /// Returns index of record in list whose OrigName field matches + /// Returns index of record in list whose OrigKey field matches /// given name or -1 if name not found. - function IndexOfName(const Name: string): Integer; + function IndexOfKey(const Key: string): Integer; + /// Updates Skip property of a given list item. + /// string [in] Key that identifies list item to + /// be updated. + /// Boolean [in] Value to be stored in the given + /// list item's Skip property. + procedure SetSkip(const AKey: string; const AFlag: Boolean); end; type @@ -94,27 +108,11 @@ TCodeImportMgr = class sealed(TObject) fSnippetInfoList: TSnippetInfoList; /// Value of ImportInfo property. fImportInfoList: TImportInfoList; + /// Value of RequestVaultCallback property. + fRequestVaultCallback: TFunc; /// Initialises import information list with details of snippets /// read from import file. procedure InitImportInfoList; - /// Returns list of names that can't be used to rename an imported - /// snippet. - /// string [in] Name of snippet to be excluded - /// from import list. - /// IStringList: List of disallowed snippet names. - /// List is made up of all names of snippets in user database plus - /// names of all imported snippets except for ExcludedName. ExcludedName - /// should be the name of a snippet being renamed. - function DisallowedNames(const ExcludedName: string): IStringList; - /// Returns a name for snippet SnippetName that does not already - /// exist in user database or imported snippet list. - /// - /// If SnippetName is not in user database then it is returned - /// unchanged. - /// If SnippetName is in user database then numbers are appended - /// sequentially until a unique name is found. - /// - function GetUniqueSnippetName(const SnippetName: string): string; public /// Constructor. Sets up object. constructor Create; @@ -126,13 +124,21 @@ TCodeImportMgr = class sealed(TObject) /// customisation. procedure Import(const FileName: string); /// Updates database based on imported snippets and customisation - /// described by ImportInfo property. - /// Any existing snippets with same name as imported snippets are - /// overwritten. + /// described by ImportInfo property, using the vault specified in + /// RequestVaultCallback. + /// Any snippets referenced in the an imported snippet's + /// Depends or XRefs property must also be included in the + /// import otherwise the snippet is stripped from the dependency list. + /// procedure UpdateDatabase; /// List of information describing if and how to import snippets /// in import file. Permits customisation of import. property ImportInfo: TImportInfoList read fImportInfoList; + /// Callback that gets the ID of the vault that will receive the + /// imported snippets. + /// Defaults to the default vault ID if not assigned. + property RequestVaultCallback: TFunc + read fRequestVaultCallback write fRequestVaultCallback; end; type @@ -148,9 +154,15 @@ implementation uses // Delphi - SysUtils, Classes, + Classes, // Project - ActiveText.UMain, DB.UMain, DB.USnippet, UIOUtils, USnippetIDs, UStrUtils; + ActiveText.UMain, + DB.Main, + DB.SnippetIDs, + DB.Snippets, + IntfCommon, + UIOUtils, + UStrUtils; { TCodeImportMgr } @@ -160,6 +172,11 @@ constructor TCodeImportMgr.Create; inherited Create; SetLength(fSnippetInfoList, 0); fImportInfoList := TImportInfoList.Create; + // set default event handler + fRequestVaultCallback := function: TVaultID + begin + Result := TVaultID.Default; + end; end; destructor TCodeImportMgr.Destroy; @@ -169,38 +186,6 @@ destructor TCodeImportMgr.Destroy; inherited; end; -function TCodeImportMgr.DisallowedNames(const ExcludedName: string): - IStringList; -var - Snippet: TSnippet; // each snippet in user database - SnippetInfo: TSnippetInfo; // info about each imported snippet -begin - Result := TIStringList.Create; - Result.CaseSensitive := False; - for Snippet in Database.Snippets do - if Snippet.UserDefined then - Result.Add(Snippet.Name); - for SnippetInfo in fSnippetInfoList do - if not StrSameText(SnippetInfo.Name, ExcludedName) then - Result.Add(SnippetInfo.Name); -end; - -function TCodeImportMgr.GetUniqueSnippetName( - const SnippetName: string): string; -var - UsedNames: IStringList; // list of snippet names in use - Postfix: Cardinal; // number to be appended to name to make unique -begin - UsedNames := DisallowedNames(SnippetName); - if not UsedNames.Contains(SnippetName) then - Exit(SnippetName); - Postfix := 1; - repeat - Inc(PostFix); - Result := SnippetName + IntToStr(PostFix); - until not UsedNames.Contains(Result); -end; - procedure TCodeImportMgr.Import(const FileName: string); var Data: TBytes; // content of import file as bytes @@ -208,11 +193,11 @@ procedure TCodeImportMgr.Import(const FileName: string); fImportInfoList.Clear; try Data := TFileIO.ReadAllBytes(FileName); - TCodeImporter.ImportData(fSnippetInfoList, Data); + TCS4SnippetImporter.ImportData(fSnippetInfoList, Data); except on E: EStreamError do raise ECodeImportMgr.Create(E); - on E: ECodeImporter do + on E: ECS4SnippetImporter do raise ECodeImportMgr.Create(E); end; InitImportInfoList; @@ -221,13 +206,20 @@ procedure TCodeImportMgr.Import(const FileName: string); procedure TCodeImportMgr.InitImportInfoList; var SnippetInfo: TSnippetInfo; // info about each snippet in import file + begin fImportInfoList.Clear; for SnippetInfo in fSnippetInfoList do begin fImportInfoList.Add( TImportInfo.Create( - SnippetInfo.Name, GetUniqueSnippetName(SnippetInfo.Name) + SnippetInfo.Key, + Database.GetUniqueSnippetKey(RequestVaultCallback), + StrIf( + SnippetInfo.Data.Props.DisplayName = '', + SnippetInfo.Key, + SnippetInfo.Data.Props.DisplayName + ) ) ); end; @@ -235,70 +227,115 @@ procedure TCodeImportMgr.InitImportInfoList; procedure TCodeImportMgr.UpdateDatabase; - // Adjusts a snippet's dependency list so that main database is searched for a - // required snippet if it is not in the user database. - procedure AdjustDependsList(const Depends: ISnippetIDList); + // Adjusts a snippet's references list to exclude snippets not included in the + // import. + function AdjustRefsList(const ARefs: ISnippetIDList): ISnippetIDList; var - Idx: Integer; // loops through dependencies SnippetID: TSnippetID; // each snippet ID in dependency list + Info: TImportInfo; begin - // NOTE: The data file format does not record which database a required - // snippet belongs to, so we first look in the user database and if it's - // not there, we assume the main database - for Idx := 0 to Pred(Depends.Count) do + // We only include snippets in depends list if it is included in the import + Result := TSnippetIDList.Create; + for SnippetID in ARefs do begin - SnippetID := Depends[Idx]; - SnippetID.UserDefined := - Database.Snippets.Find(SnippetID.Name, True) <> nil; - Depends[Idx] := SnippetID; + if fImportInfoList.FindByKey(SnippetID.Key, Info) and not Info.Skip then + Result.Add(TSnippetID.Create(Info.NewKey, SnippetID.VaultID)); end; end; +type + // Record used to save a snippet's references + TSavedReferences = record + Snippet: TSnippet; + Data: TSnippetEditData; + end; + var - Editor: IDatabaseEdit; // object used to update user database - Snippet: TSnippet; // reference any existing snippet to overwrite - SnippetInfo: TSnippetInfo; // info about each snippet from import file - ImportInfo: TImportInfo; // info about how / whether to import a snippet + SnippetInfo: TSnippetInfo; // info about each snippet from import file + ImportInfo: TImportInfo; // info about how / whether to import a snippet + VaultID: TVaultID; // vault into which we're importing + SavedRefs: TList; // preserved references for each snippet + SavedRef: TSavedReferences; // each record in Refs list + SnippetDataNoRefs: TSnippetEditData; // snippet data with references cleared resourcestring // Error message - sBadNameError = 'Can''t find snippet "%s" in import data'; + sBadNameError = 'Can''t find snippet with key "%s" in import data'; begin - Editor := Database as IDatabaseEdit; - for SnippetInfo in fSnippetInfoList do - begin - if not fImportInfoList.FindByName(SnippetInfo.Name, ImportInfo) then - raise EBug.CreateFmt(sBadNameError, [SnippetInfo.Name]); - - if ImportInfo.Skip then - Continue; + {TODO -cRefactor: Tidy up messy use of both fSnippetInfoList and + fImportInfoList: include all required info in fImportInfoList? + } + + VaultID := RequestVaultCallback(); + + SavedRefs := TList.Create( + TDelegatedComparer.Create( + function (const Left, Right: TSavedReferences): Integer + begin + Result := Left.Snippet.CompareTo(Right.Snippet); + end + ) + ); + try + for SnippetInfo in fSnippetInfoList do + begin + if not fImportInfoList.FindByKey(SnippetInfo.Key, ImportInfo) then + raise EBug.CreateFmt(sBadNameError, [SnippetInfo.Key]); + + if ImportInfo.Skip then + Continue; + + // Exclude snippet from depends list if snippet not included in import. + (SnippetInfo.Data.Refs.Depends as IAssignable).Assign( + AdjustRefsList(SnippetInfo.Data.Refs.Depends) + ); + + // store snippet data with references + SavedRef.Data.Assign(SnippetInfo.Data); + + // clear references before adding snippet: it will probably delete most + // anyway if reference is to a snippet after this one in the import list + SnippetDataNoRefs.Assign(SnippetInfo.Data); + // .. XRef should be clear regardless, because XRefs not included in + // export files. + SnippetDataNoRefs.Refs.XRef.Clear; + SnippetDataNoRefs.Refs.Depends.Clear; + + // add snippet without any dependency + SavedRef.Snippet := Database.AddSnippet( + ImportInfo.NewKey, VaultID, SnippetDataNoRefs + ); + + // save snippet with its dependencies + SavedRefs.Add(SavedRef); + end; - AdjustDependsList(SnippetInfo.Data.Refs.Depends); + // Add back the saved snippet references + for SavedRef in SavedRefs do + if SavedRef.Data.Refs.Depends.Count > 0 then + Database.UpdateSnippet(SavedRef.Snippet, SavedRef.Data); - Snippet := Database.Snippets.Find(ImportInfo.ImportAsName, True); - if Assigned(Snippet) then - // snippet already exists: overwrite it - Editor.UpdateSnippet(Snippet, SnippetInfo.Data) - else - // snippet is new: add to database - Editor.AddSnippet(ImportInfo.ImportAsName, SnippetInfo.Data); + finally + SavedRefs.Free; end; + end; { TImportInfo } -constructor TImportInfo.Create(const AOrigName, AImportAsName: string; - const ASkip: Boolean); +constructor TImportInfo.Create(const AOrigKey, ANewKey, ADisplayName: string; + const ASkip: Boolean = False); begin - fOrigName := AOrigName; - fImportAsName := AImportAsName; + fOrigKey := AOrigKey; + fNewKey := ANewKey; fSkip := ASkip; + fDisplayName := ADisplayName; end; { TImportInfoComparer } function TImportInfoComparer.Compare(const Left, Right: TImportInfo): Integer; begin - Result := TSnippetID.CompareNames(Left.OrigName, Right.OrigName); + Result := TSnippetID.CompareKeys(Left.OrigKey, Right.OrigKey); end; { TImportInfoList } @@ -308,21 +345,37 @@ constructor TImportInfoList.Create; inherited Create(TImportInfoComparer.Create); end; -function TImportInfoList.FindByName(const Name: string; +function TImportInfoList.FindByKey(const Key: string; out ImportInfo: TImportInfo): Boolean; var Idx: Integer; // index of named snippet in list begin - Idx := IndexOf(TImportInfo.Create(Name, '')); + Idx := IndexOfKey(Key); if Idx = -1 then Exit(False); ImportInfo := Items[Idx]; Result := True; end; -function TImportInfoList.IndexOfName(const Name: string): Integer; +function TImportInfoList.IndexOfKey(const Key: string): Integer; begin - Result := IndexOf(TImportInfo.Create(Name, '')); + Result := IndexOf(TImportInfo.Create(Key, '', '')); +end; + +procedure TImportInfoList.SetSkip(const AKey: string; const AFlag: Boolean); +const + // Do not localise + sKeyNotFound = 'Snippet key "%s" not found while setting import skip flag'; +var + ImportInfo: TImportInfo; + Idx: Integer; +begin + Idx := IndexOfKey(AKey); + if Idx < 0 then + raise EBug.CreateFmt(sKeyNotFound, [AKey]); + ImportInfo := Items[Idx]; + ImportInfo.Skip := AFlag; + Items[Idx] := ImportInfo; end; end. diff --git a/Src/UCodeShareMgr.pas b/Src/UCodeShareMgr.pas index 3f811b898..a88b2aecb 100644 --- a/Src/UCodeShareMgr.pas +++ b/Src/UCodeShareMgr.pas @@ -6,8 +6,7 @@ * Copyright (C) 2008-2021, Peter Johnson (gravatar.com/delphidabbler). * * Implements a static class that manages sharing of user defined snippets. - * Provides support for exporting snippets, importing snippets and submitting - * snippets to the online database. + * Provides support for exporting and importing snippets. } @@ -19,39 +18,37 @@ interface uses // Project - DB.USnippet, UBaseObjects, UView; + DB.Snippets, + UBaseObjects, + UView; type - { - TCodeShareMgr: - Sealed static class that manages sharing of user defined snippets. Provides - support for exporting snippets, importing snippets and submitting snippets - to the online database. - } + /// Manages sharing snippets. Provides support for exporting and + /// importing snippets. TCodeShareMgr = class sealed(TNoConstructObject) strict private + /// Gets reference to any snippet represented by a view item. + /// + /// IView [in] View item fromm which snippet + /// is to be extracted, if present. + /// TSnippet. Reference to the required snippet or nil if + /// the view item does not represent a snippet. class function GetSnippetFromView(ViewItem: IView): TSnippet; - {Gets reference to any user defined snippet represented by a view item. - @param ViewItem [in] View item for which snippet is required. - @return Reference to required snippet or nil if view item does not - represent a snippet or if snippet is not user defined. - } public + /// Checks if there are any snippets that can be shared (i.e. + /// exported). + /// Boolean. True if database is not empty, + /// False otherwise. class function CanShare: Boolean; - {Checks if there are any user defined snippets that can be shared (i.e. - exported or submitted. - @return True if user defined snippets exist in database. - } + /// Exports snippets to an export file. + /// IView [in] View item that may contain a + /// snippet. If so the snippet is included in the export file by default. + /// class procedure ExportCode(ViewItem: IView); - {Exports user defined code to an export file. - @param ViewItem [in] View item that may contain a user defined snippet. - If so the snippet is included in the export file by default. - } + /// Imports snippets from an export file. class procedure ImportCode; - {Imports user defined code from an export file. - } end; @@ -62,49 +59,37 @@ implementation // Delphi SysUtils, // Project - DB.UMain, FmCodeExportDlg, FmCodeImportDlg, UCodeImportMgr; + DB.Main, + DB.Vaults, + FmCodeExportDlg, + FmCodeImportDlg, + UCodeImportMgr; { TCodeShareMgr } class function TCodeShareMgr.CanShare: Boolean; - {Checks if there are any user defined snippets that can be shared (i.e. - exported or submitted. - @return True if user defined snippets exist in database. - } begin - Result := Database.Snippets.Count(True) > 0; + Result := not Database.Snippets.IsEmpty; end; class procedure TCodeShareMgr.ExportCode(ViewItem: IView); - {Exports user defined code to an export file. - @param ViewItem [in] View item that may contain a user defined snippet. If - so the snippet is included in the export file by default. - } begin TCodeExportDlg.Execute(nil, GetSnippetFromView(ViewItem)); end; class function TCodeShareMgr.GetSnippetFromView( ViewItem: IView): TSnippet; - {Gets reference to any user defined snippet represented by a view item. - @param ViewItem [in] View item for which snippet is required. - @return Reference to required snippet or nil if view item does not represent - a snippet or if snippet is not user defined. - } var SnippetView: ISnippetView; // ViewItem as snippet view if supported begin - if Supports(ViewItem, ISnippetView, SnippetView) - and (SnippetView.Snippet.UserDefined) then + if Supports(ViewItem, ISnippetView, SnippetView) then Result := SnippetView.Snippet else Result := nil; end; class procedure TCodeShareMgr.ImportCode; - {Imports user defined code from an export file. - } var ImportMgr: TCodeImportMgr; // manages import of code begin @@ -118,3 +103,4 @@ class procedure TCodeShareMgr.ImportCode; end. + diff --git a/Src/UColours.pas b/Src/UColours.pas index 219745f46..e0e9bef20 100644 --- a/Src/UColours.pas +++ b/Src/UColours.pas @@ -53,11 +53,13 @@ interface clSplashShadowText = clWhite; // splash screen text shadow // new tab - clNewTabText = cl3DLight; // color of text displayed in new tabs + clNewTabText = cl3DLight; // text displayed in new tabs - // colours of snippet titles / heading - clMainSnippet = clWindowText; // main database snippets - clUserSnippet = clBlue; // user database snippets + // group headings + clDefGroupHeading = clWindowText; // default for overview group headings + + // snippet headings + clDefSnippetHeading = clWindowText; // default for snippet headings // markup tags clVarText = clPurple; // tag text diff --git a/Src/UCompileMgr.pas b/Src/UCompileMgr.pas index ded36eca3..839585eb7 100644 --- a/Src/UCompileMgr.pas +++ b/Src/UCompileMgr.pas @@ -20,7 +20,9 @@ interface // Delphi Classes, Controls, // Project - Compilers.UGlobals, DB.USnippet, UView; + Compilers.UGlobals, + DB.Snippets, + UView; type @@ -138,7 +140,7 @@ implementation Compilers.UAutoDetect, Compilers.UCompilers, Compilers.USettings, - DB.UMain, + DB.Main, FmCompErrorDlg, FmCompilersDlg, FmRegisterCompilersDlg, @@ -169,9 +171,7 @@ procedure TCompileMgr.Compile(const UIParent: TWinControl; DisplayProc(fCompilers); // Copy snippet to LastCompiledSnippet property fLastCompiledSnippet.Free; - fLastCompiledSnippet := (Database as IDatabaseEdit).CreateTempSnippet( - Snippet - ); + fLastCompiledSnippet := Database.CreateTempSnippet(Snippet); end; constructor TCompileMgr.Create(AOwner: TComponent); diff --git a/Src/UDBUpdateMgr.pas b/Src/UDBUpdateMgr.pas index 3cf1df472..ea323882e 100644 --- a/Src/UDBUpdateMgr.pas +++ b/Src/UDBUpdateMgr.pas @@ -99,11 +99,12 @@ implementation // Delphi IOUtils, // Project - DB.UMetaData, UAppInfo, UFileUpdater, + UIOUtils, UStrUtils, - UUtils; + UUtils, + UVersionInfo; { TDBUpdateMgr } @@ -158,9 +159,14 @@ class procedure TDBUpdateMgr.ValidateUpdate(const UpdateDir: string); sUnsupportedDatabaseError = 'Database in "%0:s" is version %1:s. This ' + 'version is not currently supported by CodeSnip.'; sCurruptDatabaseError = 'The update database in "%s" is corrupt'; +const + VersionFileName = 'VERSION'; var Dir: string; - MetaData: IDBMetaData; + VersionFilePath: string; + VersionStr: string; + Version: TVersionNumber; + begin Assert(UpdateDir <> '', ClassName + '.ValidateUpdate: UpdateDir cannot be empty string'); @@ -191,23 +197,26 @@ class procedure TDBUpdateMgr.ValidateUpdate(const UpdateDir: string); if TDirectory.IsEmpty(Dir) then raise EDBUpdateValidationError.CreateFmt(sEmptyDirError, [Dir]); - // Check contents - MetaData := TMainDBMetaDataFactory.UpdateMetaDataInstance(Dir); + // Version file must exist + VersionFilePath := TPath.Combine(Dir, VersionFileName); + if not TFile.Exists(TPath.Combine(Dir, VersionFilePath)) then + raise EDBUpdateValidationError.Create(sInvalidDatabaseError); - // check if data files are recognised as valid database - if not MetaData.IsRecognised then - raise EDBUpdateValidationError.CreateFmt(sUnrecognisedDatabaseError, [Dir]); + // Version file must contain a valid version string + VersionStr := TFileIO.ReadAllText(VersionFilePath, TEncoding.UTF8, True); + if not TVersionNumber.TryStrToVersionNumber(VersionStr, Version) then + raise EDBUpdateValidationError.CreateFmt( + sUnrecognisedDatabaseError, [Dir] + ); - // seems to be valid database: check if it's a supported version - if not MetaData.IsSupportedVersion then + // Version must be supported + if Version.V1 <> 2 then raise EDBUpdateValidationError.CreateFmt( - sUnsupportedDatabaseError, [Dir, string(MetaData.GetVersion)] + sUnsupportedDatabaseError, [Dir, string(Version)] ); - // database version supported: check if required meta data files and master db - // file are present - if MetaData.IsCorrupt - or not TFile.Exists(Dir + PathDelim + 'categories.ini', False) then + // Master db file must exist + if not TFile.Exists(Dir + PathDelim + 'categories.ini', False) then raise EDBUpdateValidationError.CreateFmt(sCurruptDatabaseError, [Dir]); end; diff --git a/Src/UDatabaseLoader.pas b/Src/UDatabaseLoader.pas index d91c11120..60cf74f72 100644 --- a/Src/UDatabaseLoader.pas +++ b/Src/UDatabaseLoader.pas @@ -57,7 +57,8 @@ implementation uses // Project - UQuery, DB.UMain; + UQuery, + DB.Main; { TDatabaseLoader } diff --git a/Src/UDetailPageHTML.pas b/Src/UDetailPageHTML.pas index fe7946c5b..38e6ca467 100644 --- a/Src/UDetailPageHTML.pas +++ b/Src/UDetailPageHTML.pas @@ -66,10 +66,25 @@ implementation // Delphi SysUtils, Generics.Defaults, // Project - Compilers.UGlobals, Compilers.UCompilers, DB.UMain, DB.USnippet, UConsts, - UContainers, UCSSUtils, UEncodings, UHTMLTemplate, UHTMLUtils, - UJavaScriptUtils, UPreferences, UQuery, UResourceUtils, USnippetHTML, - USnippetPageHTML, UStrUtils, USystemInfo; + Compilers.UGlobals, + Compilers.UCompilers, + DB.Main, + DB.Snippets, + DB.Vaults, + UConsts, + UContainers, + UCSSUtils, + UEncodings, + UHTMLTemplate, + UHTMLUtils, + UJavaScriptUtils, + UPreferences, + UQuery, + UResourceUtils, + USnippetHTML, + USnippetPageHTML, + UStrUtils, + USystemInfo; type @@ -223,11 +238,6 @@ TSnippetListPageHTML = class abstract(TDetailPageTpltHTML) /// snippets to be displayed. function IsSnippetRequired(const Snippet: TSnippet): Boolean; virtual; abstract; - /// Returns name of CSS class to be used for page heading. - /// - /// Provides default class name. Descendant classes should - /// override as necessary. - function GetH1ClassName: string; virtual; /// Returns page's heading text. /// Returns view's description by default. Descendants can /// override if different behaviour is required. @@ -263,9 +273,6 @@ TCategoryPageHTML = class sealed(TSnippetListPageHTML) /// The snippet is to be displayed if it is in the category being /// displayed. function IsSnippetRequired(const Snippet: TSnippet): Boolean; override; - /// Returns name of CSS class to be used for page heading. - /// - function GetH1ClassName: string; override; /// Returns narrative to be used at top of any page that displays /// a snippet list. function GetNarrative: string; override; @@ -407,8 +414,9 @@ function TWelcomePageHTML.GetTemplateResName: string; procedure TWelcomePageHTML.ResolvePlaceholders(const Tplt: THTMLTemplate); var - UserDBCount: Integer; - MainDBCount: Integer; + Vault: TVault; + VaultCount: Integer; + VaultList: TStringBuilder; Compilers: ICompilers; Compiler: ICompiler; CompilerList: TStringBuilder; @@ -418,27 +426,22 @@ procedure TWelcomePageHTML.ResolvePlaceholders(const Tplt: THTMLTemplate); 'externalScript', TJavaScript.LoadScript('external.js', etWindows1252) ); - UserDBCount := Database.Snippets.Count(True); - Tplt.ResolvePlaceholderHTML( - 'HaveUserDB', TCSS.BlockDisplayProp(UserDBCount > 0) - ); - Tplt.ResolvePlaceholderHTML( - 'NoUserDB', TCSS.BlockDisplayProp(UserDBCount <= 0) - ); - Tplt.ResolvePlaceholderText( - 'UserDBCount', IntToStr(UserDBCount) - ); + VaultCount := TVaults.Instance.Count; + Tplt.ResolvePlaceholderHTML('VaultCount', IntToStr(VaultCount)); - MainDBCount := Database.Snippets.Count(False); - Tplt.ResolvePlaceholderHTML( - 'HaveMainDB', TCSS.BlockDisplayProp(MainDBCount > 0) - ); - Tplt.ResolvePlaceholderHTML( - 'NoMainDB', TCSS.BlockDisplayProp(MainDBCount <= 0) - ); - Tplt.ResolvePlaceholderText( - 'MainDBCount', IntToStr(MainDBCount) - ); + VaultList := TStringBuilder.Create; + try + for Vault in TVaults.Instance do + VaultList.AppendLine( + THTML.CompoundTag( + 'li', + THTML.Entities(Vault.Name) + ) + ); + Tplt.ResolvePlaceholderHTML('VaultList', VaultList.ToString); + finally + VaultList.Free; + end; Compilers := TCompilersFactory.CreateAndLoadCompilers; Tplt.ResolvePlaceholderHTML( @@ -507,24 +510,15 @@ procedure TSnippetInfoPageHTML.ResolvePlaceholders(const Tplt: THTMLTemplate); 'overflowXFixScript', 'window.onload = null;' ); - if GetSnippet.UserDefined then - Tplt.ResolvePlaceholderHTML('SnippetCSSClass', 'userdb') - else - Tplt.ResolvePlaceholderHTML('SnippetCSSClass', 'maindb'); - Tplt.ResolvePlaceholderHTML( - 'TestingInfo', TCSS.BlockDisplayProp(not GetSnippet.UserDefined) - ); - Tplt.ResolvePlaceholderHTML( - 'EditLink', TCSS.BlockDisplayProp(GetSnippet.UserDefined) - ); Tplt.ResolvePlaceholderText( 'EditEventHandler', - TJavaScript.LiteralFunc('editSnippet', [GetSnippet.Name]) + TJavaScript.LiteralFunc( + 'editSnippet', [GetSnippet.Key, GetSnippet.VaultID.ToHexString] + ) ); SnippetHTML := TSnippetHTML.Create(GetSnippet); try - if not GetSnippet.UserDefined then - Tplt.ResolvePlaceholderHTML('TestingInfoImg', SnippetHTML.TestingImage); + Tplt.ResolvePlaceholderHTML('TestingInfoImg', SnippetHTML.TestingImage); Tplt.ResolvePlaceholderHTML('SnippetName', SnippetHTML.SnippetName); finally SnippetHTML.Free; @@ -564,11 +558,6 @@ destructor TSnippetListPageHTML.Destroy; inherited; end; -function TSnippetListPageHTML.GetH1ClassName: string; -begin - Result := 'maindb'; -end; - function TSnippetListPageHTML.GetHeading: string; begin Result := View.Description; @@ -590,7 +579,6 @@ function TSnippetListPageHTML.HaveSnippets: Boolean; procedure TSnippetListPageHTML.ResolvePlaceholders(const Tplt: THTMLTemplate); begin inherited; - Tplt.ResolvePlaceholderHTML('H1Class', GetH1ClassName); Tplt.ResolvePlaceholderText('Heading', GetHeading); if HaveSnippets then begin @@ -646,14 +634,6 @@ function TCategoryPageHTML.GetEmptyListNote: string; Result := sNote; end; -function TCategoryPageHTML.GetH1ClassName: string; -begin - if (View as ICategoryView).Category.UserDefined then - Result := 'userdb' - else - Result := inherited GetH1ClassName; -end; - function TCategoryPageHTML.GetNarrative: string; resourcestring sNarrative = 'List of selected snippets in this category.'; diff --git a/Src/UDialogMgr.pas b/Src/UDialogMgr.pas index be168c158..bbbe56204 100644 --- a/Src/UDialogMgr.pas +++ b/Src/UDialogMgr.pas @@ -19,7 +19,9 @@ interface // Delphi Classes, // Project - DB.USnippet, UCompileMgr, USearch; + DB.Snippets, + UCompileMgr, + USearch; type diff --git a/Src/UEditSnippetAction.pas b/Src/UEditSnippetAction.pas index 4b33cc385..5862f7a29 100644 --- a/Src/UEditSnippetAction.pas +++ b/Src/UEditSnippetAction.pas @@ -5,7 +5,7 @@ * * Copyright (C) 2008-2021, Peter Johnson (gravatar.com/delphidabbler). * - * Custom action used to request editing of a named user-defined snippet. + * Custom action used to request editing of a user-defined snippet. } @@ -17,22 +17,22 @@ interface uses // Delphi - Classes; + Classes, + // Project + DB.SnippetIDs; type - /// - /// Custom action used to request that a named user defined snippet is - /// edited. + /// Custom action used to request that a snippet is edited. /// TEditSnippetAction = class(TBasicAction) strict private var - /// Value of SnippetName property. - fSnippetName: string; + /// Value of ID property. + fID: TSnippetID; public - /// Name of snippet to be edited. - property SnippetName: string read fSnippetName write fSnippetName; + /// ID of snippet to be edited. + property ID: TSnippetID read fID write fID; end; diff --git a/Src/UFolderBackup.pas b/Src/UFolderBackup.pas index f4ca63668..2ed119b70 100644 --- a/Src/UFolderBackup.pas +++ b/Src/UFolderBackup.pas @@ -17,6 +17,13 @@ interface +uses + // Delphi + SysUtils, + // Project + UExceptions; + + type /// @@ -28,47 +35,71 @@ TFolderBackup = class(TObject) var fSrcFolder: string; // Folder to be backed up or restored var fBakFile: string; // Full path to backup file var fFileID: SmallInt; // Identifies the type of file + var fCustomHeader: TBytes; public - /// - /// Creates object for a specific folder and backup file type. + /// Creates object for a specific folder and backup file type. /// - /// Folder containing files to be backed up. - /// Sub-directories are ignored. - /// Name of backup file. - /// Backup file type identifier. Specified backup file - /// must have this identifier. + /// string [in] Folder containing files to + /// be backed up. Sub-directories are ignored. + /// string [in] Name of backup file. + /// SmallInt [in] Backup file type identifier. + /// + /// When restoring a folder BakFile must have the file ID + /// specified by FileID and no custom header. constructor Create(const SrcFolder, BakFile: string; - const FileID: SmallInt); - /// - /// Backs up the files from the source folder passed to constructor into a - /// single backup file. - /// + const FileID: SmallInt); overload; + + /// Creates object for a specific folder, backup file type and + /// custom header. + /// string [in] Folder containing files to + /// be backed up. Sub-directories are ignored. + /// string [in] Name of backup file. + /// SmallInt [in] Backup file type identifier. + /// + /// TBytes [in] Backup file's custom + /// header. Can contain zero to High(SmallInt) bytes. /// - /// Backup file is marked with the file ID passed to constructor. + /// When restoring a folder BakFile must have the file ID + /// specified by FileID and the custom header specified by + /// CustomHeader. + /// This constructor can only be used with file format v5 or later, + /// unless CustomHeader has length 0. /// + constructor Create(const SrcFolder, BakFile: string; + const FileID: SmallInt; const CustomHeader: TBytes); overload; + + /// Backs up the files from the source folder passed to + /// constructor into a single file. + /// Backup file is marked with the file ID and any custom header + /// passed to constructor. procedure Backup; - /// - /// Restores files from backup file into source folder passed to - /// constructor - /// - /// - /// An exception is raised if file type id is not the one passed to the - /// constructor or if any checksum errors are detected. - /// + /// Restores files from backup file into source folder passed to + /// constructor. + /// An exception is raised if file type id or any optional custom + /// header are not the sames as those passed to the constructor, or if any + /// checksum errors are detected. procedure Restore; end; + /// Type of exception raised by backup file loader objects. + EBackupFileLoader = class(ECodeSnip); + implementation uses // Delphi - SysUtils, Classes, Generics.Collections, + Classes, + Generics.Collections, // DelphiDabbler library PJMD5, // Project - UBaseObjects, UDataStreamIO, UDOSDateTime, UEncodings, UExceptions, UIOUtils, + UBaseObjects, + UDataStreamIO, + UDOSDateTime, + UEncodings, + UIOUtils, UUtils; @@ -91,18 +122,20 @@ TBackupFileInfo = class(TNoConstructObject) /// Class that writes files to a backup file using the latest file format. TBackupFileWriter = class(TObject) strict private - var fFiles: TStrings; // Files to be backed up - var fStream: TStream; // Stream to receive backed up files - var fFileID: SmallInt; // ID of backup file + var + fFiles: TStrings; // Files to be backed up + fStream: TStream; // Stream to receive backed up files + fFileID: SmallInt; // ID of backup file + fCustomHeader: TBytes; // Bytes of optional custom header /// Writes file header procedure WriteHeader; /// Writes meta information and contents of a specified file. procedure WriteFileInfo(const FileName: string); public /// Sets up object to write specified files to a given stream marked with - /// given file ID. + /// given file ID and optional custom header. constructor Create(const Files: TStrings; const Stream: TStream; - const FileID: SmallInt); + const FileID: SmallInt; const CustomHeader: TBytes); overload; /// Generates backup file and writes it to stream passed to constructor. procedure Generate; end; @@ -122,6 +155,7 @@ TFileInfo = record const NulFileID = 0; // Used for File ID is formats that don't support it strict private var fFileID: SmallInt; // Value of FileID property + var fCustomHeader: TBytes; var fFiles: TList; // List of file info records var fEncoding: TEncoding; // Text encoding used in backup file var fStream: TStream; // Stream containing backup data being read @@ -138,7 +172,8 @@ TFileInfo = record /// Skips over watermark at start of file. procedure SkipWatermark; /// Reads header information from the backup file. - procedure ReadHeader(out FileID, FileCount: SmallInt); virtual; abstract; + procedure ReadHeader(out FileID: SmallInt; out CustomHeader: TBytes; + out FileCount: SmallInt); virtual; abstract; /// Reads information about a file to be restored from the backup file. procedure ReadFileInfo(out FileInfo: TFileInfo); virtual; abstract; /// Reference to encoding used to read text from the backup file stream. @@ -155,6 +190,9 @@ TFileInfo = record procedure Load; /// Backup file identifier. property FileID: SmallInt read fFileID; + + property CustomHeader: TBytes read fCustomHeader; + /// Gets enumerator for file list. function GetEnumerator: TEnumerator; /// Gets file's unique watermark @@ -184,7 +222,8 @@ TV1BackupFileLoader = class(TTextBackupFileLoader) /// Returns the backup file's text encoding function GetFileEncoding: TEncoding; override; /// Reads header information from the backup file. - procedure ReadHeader(out FileID, FileCount: SmallInt); override; + procedure ReadHeader(out FileID: SmallInt; out CustomHeader: TBytes; + out FileCount: SmallInt); override; /// Reads information about a file to be restored from the backup file. procedure ReadFileInfo(out FileInfo: TBackupFileLoader.TFileInfo); override; /// Returns the watermark that identifies the file format. In the v1 file @@ -199,7 +238,8 @@ TV2BackupFileLoader = class(TTextBackupFileLoader) /// Returns the backup file's text encoding function GetFileEncoding: TEncoding; override; /// Reads header information from the backup file. - procedure ReadHeader(out FileID, FileCount: SmallInt); override; + procedure ReadHeader(out FileID: SmallInt; out CustomHeader: TBytes; + out FileCount: SmallInt); override; /// Reads information about a file to be restored from the backup file. procedure ReadFileInfo(out FileInfo: TBackupFileLoader.TFileInfo); override; /// Returns the watermark that identifies the file format. @@ -213,7 +253,8 @@ TV3BackupFileLoader = class(TTextBackupFileLoader) /// Returns the backup file's text encoding function GetFileEncoding: TEncoding; override; /// Reads header information from the backup file. - procedure ReadHeader(out FileID, FileCount: SmallInt); override; + procedure ReadHeader(out FileID: SmallInt; out CustomHeader: TBytes; + out FileCount: SmallInt); override; /// Reads information about a file to be restored from the backup file. procedure ReadFileInfo(out FileInfo: TBackupFileLoader.TFileInfo); override; /// Returns the watermark that identifies the file format. @@ -227,7 +268,23 @@ TV4BackupFileLoader = class(TBinaryBackupFileLoader) /// Returns the backup file's text encoding function GetFileEncoding: TEncoding; override; /// Reads header information from the backup file. - procedure ReadHeader(out FileID, FileCount: SmallInt); override; + procedure ReadHeader(out FileID: SmallInt; out CustomHeader: TBytes; + out FileCount: SmallInt); override; + /// Reads information about a file to be restored from the backup file. + procedure ReadFileInfo(out FileInfo: TBackupFileLoader.TFileInfo); override; + /// Returns the watermark that identifies the file format. + class function GetWatermark: TBytes; override; + end; + + /// Loads and provides access to data from a backup file that has + /// the version 5 file format. + TV5BackupFileLoader = class(TBinaryBackupFileLoader) + strict protected + /// Returns the backup file's text encoding + function GetFileEncoding: TEncoding; override; + /// Reads header information from the backup file. + procedure ReadHeader(out FileID: SmallInt; out CustomHeader: TBytes; + out FileCount: SmallInt); override; /// Reads information about a file to be restored from the backup file. procedure ReadFileInfo(out FileInfo: TBackupFileLoader.TFileInfo); override; /// Returns the watermark that identifies the file format. @@ -254,9 +311,6 @@ TBackupFileLoaderFactory = class sealed(TNoConstructObject) class function Create(const Stream: TStream): TBackupFileLoader; end; - /// Type of exception raised by backup file loader objects. - EBackupFileLoader = class(ECodeSnip); - { TFolderBackup } procedure TFolderBackup.Backup; @@ -270,7 +324,9 @@ procedure TFolderBackup.Backup; ListFiles(fSrcFolder, '*.*', Files, False); FS := TFileStream.Create(fBakFile, fmCreate); try - FileWriter := TBackupFileWriter.Create(Files, FS, fFileID); + FileWriter := TBackupFileWriter.Create( + Files, FS, fFileID, fCustomHeader + ); try FileWriter.Generate; finally @@ -291,18 +347,27 @@ constructor TFolderBackup.Create(const SrcFolder, BakFile: string; fSrcFolder := ExcludeTrailingPathDelimiter(SrcFolder); fBakFile := BakFile; fFileID := FileID; + SetLength(fCustomHeader, 0); +end; + +constructor TFolderBackup.Create(const SrcFolder, BakFile: string; + const FileID: SmallInt; const CustomHeader: TBytes); +begin + Create(SrcFolder, BakFile, FileID); + fCustomHeader := Copy(CustomHeader); end; procedure TFolderBackup.Restore; var BakFileStream: TStream; // stream onto backup file BakFileLoader: TBackupFileLoader; // loads & analyses backup file - FileSpec: string; // name & path of each file to restore + RestoreFileSpec: string; // name & path of each file to restore DOSDateTime: IDOSDateTime; // date stamp of each file to restore FileInfo: TBackupFileLoader.TFileInfo; // info about each file to restore resourcestring // Error message sBadFileID = 'Invalid file ID for file "%s"'; + sBadCustomHeader = 'Invalid custom header for file "%s"'; begin // Make sure restore folder exists EnsureFolders(fSrcFolder); @@ -315,16 +380,19 @@ procedure TFolderBackup.Restore; // Test for correct file ID if present (NulFileID indicates not present) if (BakFileLoader.FileID <> TBackupFileLoader.NulFileID) and (BakFileLoader.FileID <> fFileID) then - raise EBackupFileLoader.CreateFmt(sBadFileID, [FileSpec]); + raise EBackupFileLoader.CreateFmt(sBadFileID, [fBakFile]); + if not IsEqualBytes(BakFileLoader.CustomHeader, fCustomHeader) then + raise EBackupFileLoader.CreateFmt(sBadCustomHeader, [fBakFile]); // Restore each file for FileInfo in BakFileLoader do begin - FileSpec := IncludeTrailingPathDelimiter(fSrcFolder) + FileInfo.Name; + RestoreFileSpec := IncludeTrailingPathDelimiter(fSrcFolder) + + FileInfo.Name; DOSDateTime := TDOSDateTimeFactory.CreateFromDOSTimeStamp( FileInfo.TimeStamp ); - TFileIO.WriteAllBytes(FileSpec, FileInfo.Content); - DOSDateTime.ApplyToFile(FileSpec); + TFileIO.WriteAllBytes(RestoreFileSpec, FileInfo.Content); + DOSDateTime.ApplyToFile(RestoreFileSpec); end; finally BakFileLoader.Free; @@ -367,7 +435,7 @@ procedure TBackupFileLoader.Load; begin try SkipWatermark; - ReadHeader(fFileID, FileCount); + ReadHeader(fFileID, fCustomHeader, FileCount); for I := 1 to FileCount do begin ReadFileInfo(FI); @@ -435,9 +503,11 @@ procedure TV1BackupFileLoader.ReadFileInfo( FileInfo.Content := Reader.ReadSizedRawData16; end; -procedure TV1BackupFileLoader.ReadHeader(out FileID, FileCount: SmallInt); +procedure TV1BackupFileLoader.ReadHeader(out FileID: SmallInt; + out CustomHeader: TBytes; out FileCount: SmallInt); begin FileID := NulFileID; + SetLength(CustomHeader, 0); FileCount := Reader.ReadInt16; end; @@ -464,9 +534,11 @@ procedure TV2BackupFileLoader.ReadFileInfo( FileInfo.Content := Reader.ReadSizedRawData32; end; -procedure TV2BackupFileLoader.ReadHeader(out FileID, FileCount: SmallInt); +procedure TV2BackupFileLoader.ReadHeader(out FileID: SmallInt; + out CustomHeader: TBytes; out FileCount: SmallInt); begin FileID := NulFileID; + SetLength(CustomHeader, 0); FileCount := Reader.ReadInt16; end; @@ -497,9 +569,11 @@ procedure TV3BackupFileLoader.ReadFileInfo( FileInfo.Content := Reader.ReadSizedRawData32; end; -procedure TV3BackupFileLoader.ReadHeader(out FileID, FileCount: SmallInt); +procedure TV3BackupFileLoader.ReadHeader(out FileID: SmallInt; + out CustomHeader: TBytes; out FileCount: SmallInt); begin FileID := Reader.ReadInt16; + SetLength(CustomHeader, 0); FileCount := Reader.ReadInt16; end; @@ -524,21 +598,51 @@ procedure TV4BackupFileLoader.ReadFileInfo( FileInfo.Content := Reader.ReadSizedRawData32; end; -procedure TV4BackupFileLoader.ReadHeader(out FileID, FileCount: SmallInt); +procedure TV4BackupFileLoader.ReadHeader(out FileID: SmallInt; + out CustomHeader: TBytes; out FileCount: SmallInt); begin FileID := Reader.ReadInt16; + SetLength(CustomHeader, 0); FileCount := Reader.ReadInt16; end; -{ TBackupFileWriter } +{ TV5BackupFileLoader } + +function TV5BackupFileLoader.GetFileEncoding: TEncoding; +begin + Result := TEncoding.UTF8; +end; + +class function TV5BackupFileLoader.GetWatermark: TBytes; +begin + Result := TBackupFileInfo.WatermarkBytes('FFFF000500000000'); +end; + +procedure TV5BackupFileLoader.ReadFileInfo( + out FileInfo: TBackupFileLoader.TFileInfo); +begin + FileInfo.Name := Reader.ReadSizedString16; + FileInfo.TimeStamp := Reader.ReadInt32; + FileInfo.Checksum := Reader.ReadBytes(SizeOf(FileInfo.Checksum)); + FileInfo.Content := Reader.ReadSizedRawData32; +end; + +procedure TV5BackupFileLoader.ReadHeader(out FileID: SmallInt; + out CustomHeader: TBytes; out FileCount: SmallInt); +begin + FileID := Reader.ReadInt16; + CustomHeader := Reader.ReadSizedBytes16; + FileCount := Reader.ReadInt16; +end; constructor TBackupFileWriter.Create(const Files: TStrings; - const Stream: TStream; const FileID: SmallInt); + const Stream: TStream; const FileID: SmallInt; const CustomHeader: TBytes); begin inherited Create; fFiles := Files; fStream := Stream; fFileID := FileID; + fCustomHeader := Copy(CustomHeader); end; procedure TBackupFileWriter.Generate; @@ -581,6 +685,7 @@ procedure TBackupFileWriter.WriteHeader; TBackupFileInfo.CurrentLoader.GetWatermark ); BinWriter.WriteInt16(fFileID); + BinWriter.WriteSizedBytes16(fCustomHeader); BinWriter.WriteInt16(fFiles.Count); finally BinWriter.Free; @@ -616,7 +721,8 @@ class function TBackupFileLoaderFactory.Create( begin fClassList := TArray.Create( TV1BackupFileLoader, TV2BackupFileLoader, - TV3BackupFileLoader, TV4BackupFileLoader + TV3BackupFileLoader, TV4BackupFileLoader, + TV5BackupFileLoader ); end; @@ -694,7 +800,7 @@ class function TBackupFileLoaderFactory.GetLoaderClass( class function TBackupFileInfo.CurrentLoader: TBackupFileLoaderClass; begin - Result := TV4BackupFileLoader; + Result := TV5BackupFileLoader; end; class function TBackupFileInfo.WatermarkBytes(const Watermark: string): diff --git a/Src/UGroups.pas b/Src/UGroups.pas index 1b69a0794..f8f3262bf 100644 --- a/Src/UGroups.pas +++ b/Src/UGroups.pas @@ -19,7 +19,11 @@ interface // Delphi Generics.Collections, // Project - DB.UCategory, DB.USnippet, DB.USnippetKind, UContainers, UInitialLetter; + DB.Categories, + DB.SnippetKind, + DB.Snippets, + UContainers, + UInitialLetter; type @@ -262,7 +266,8 @@ implementation // Delphi Generics.Defaults, // Project - DB.UMain, UStrUtils; + DB.Main, + UStrUtils; { TGrouping } diff --git a/Src/UHTMLSnippetDoc.pas b/Src/UHTMLSnippetDoc.pas index 27ca5d861..5ae992dc2 100644 --- a/Src/UHTMLSnippetDoc.pas +++ b/Src/UHTMLSnippetDoc.pas @@ -20,6 +20,7 @@ interface // Project ActiveText.UHTMLRenderer, ActiveText.UMain, + DB.Vaults, Hiliter.UGlobals, UColours, UEncodings, @@ -80,11 +81,10 @@ THTMLSnippetDoc = class abstract (TSnippetDoc) // Names of HTML attributes used in the document ClassAttr = 'class'; + StyleAttr = 'style'; // Names of HTML classes used in the document - DBInfoClass = 'db-info'; - MainDBClass = 'main-db'; - UserDBClass = 'user-db'; + VaultInfoClass = 'vault-info'; IndentClass = 'indent'; WarningClass = 'warning'; @@ -96,9 +96,9 @@ THTMLSnippetDoc = class abstract (TSnippetDoc) H1FontSize = 14; // points /// Size of H2 heading font, in points. H2FontSize = 12; // points - /// Size of font used for database information, in points. + /// Size of font used for vault information, in points. /// - DBInfoFontSize = 9; // points + VaultInfoFontSize = 9; // points strict private /// Creates and returns the inline CSS used in the HTML document. @@ -112,12 +112,12 @@ THTMLSnippetDoc = class abstract (TSnippetDoc) function BuilderClass: THTMLBuilderClass; virtual; abstract; /// Initialises the HTML document. procedure InitialiseDoc; override; - /// Adds the given heading (i.e. snippet name) to the document. - /// Can be user defined or from main database. - /// The heading is coloured according to whether user defined or - /// not iff coloured output is required. - procedure RenderHeading(const Heading: string; const UserDefined: Boolean); - override; + /// Output given heading, i.e. snippet name for snippet from a + /// given vault. + /// Heading may be rendered differently depending on the snippet's + /// vault. + procedure RenderHeading(const Heading: string; + const AVaultID: TVaultID); override; /// Adds the given snippet description to the document. /// Active text formatting is observed and styled to suit the /// document. @@ -145,9 +145,8 @@ THTMLSnippetDoc = class abstract (TSnippetDoc) /// Active text formatting is observed and styled to suit the /// document. procedure RenderExtra(const ExtraText: IActiveText); override; - /// Adds the given information about a code snippets database to - /// the document. - procedure RenderDBInfo(const Text: string); override; + /// Output given information about a vault. + procedure RenderVaultInfo(const Text: string); override; /// Finalises the document and returns its content as encoded /// data. function FinaliseDoc: TEncodedData; override; @@ -281,12 +280,9 @@ function THTMLSnippetDoc.BuildCSS: string; .AddProperty(TCSS.PaddingProp(cssLeft, 0)) .AddProperty(TCSS.MarginProp(0)); - // class used to denote snippet is user defined - CSS.AddSelector('.' + UserDBClass) - .AddProperty(TCSS.ColorProp(Preferences.DBHeadingColours[True])); - // class used for smaller text describing database - CSS.AddSelector('.' + DBInfoClass) - .AddProperty(TCSS.FontSizeProp(DBInfoFontSize)) + // class used for smaller text describing vault + CSS.AddSelector('.' + VaultInfoClass) + .AddProperty(TCSS.FontSizeProp(VaultInfoFontSize)) .AddProperty(TCSS.FontStyleProp(cfsItalic)); // class used to indent tag content CSS.AddSelector('.' + IndentClass) @@ -411,17 +407,6 @@ procedure THTMLSnippetDoc.RenderCompilerInfo(const Heading: string; .AppendLine(fTagGen.ClosingTag(TableTag)); end; -procedure THTMLSnippetDoc.RenderDBInfo(const Text: string); -begin - fDocument.AppendLine( - fTagGen.CompoundTag( - ParaTag, - THTMLAttributes.Create(ClassAttr, DBInfoClass), - fTagGen.Entities(Text) - ) - ); -end; - procedure THTMLSnippetDoc.RenderDescription(const Desc: IActiveText); begin fDocument.AppendLine(ActiveTextToHTML(Desc)); @@ -433,13 +418,13 @@ procedure THTMLSnippetDoc.RenderExtra(const ExtraText: IActiveText); end; procedure THTMLSnippetDoc.RenderHeading(const Heading: string; - const UserDefined: Boolean); + const AVaultID: TVaultID); var Attrs: IHTMLAttributes; -const - DBClasses: array[Boolean] of string = (MainDBClass, UserDBClass); begin - Attrs := THTMLAttributes.Create(ClassAttr, DBClasses[UserDefined]); + Attrs := THTMLAttributes.Create( + StyleAttr, TCSS.ColorProp(Preferences.GetSnippetHeadingColour(AVaultID)) + ); fDocument.AppendLine( fTagGen.CompoundTag(H1Tag, Attrs, fTagGen.Entities(Heading)) ); @@ -511,6 +496,17 @@ procedure THTMLSnippetDoc.RenderTitledText(const Title, Text: string); ); end; +procedure THTMLSnippetDoc.RenderVaultInfo(const Text: string); +begin + fDocument.AppendLine( + fTagGen.CompoundTag( + ParaTag, + THTMLAttributes.Create(ClassAttr, VaultInfoClass), + fTagGen.Entities(Text) + ) + ); +end; + { TXHTMLSnippetDoc } function TXHTMLSnippetDoc.BuilderClass: THTMLBuilderClass; diff --git a/Src/UHistory.pas b/Src/UHistory.pas index 44bca7d20..3213e8038 100644 --- a/Src/UHistory.pas +++ b/Src/UHistory.pas @@ -108,7 +108,8 @@ implementation // Delphi SysUtils, // Project - DB.UMain, UExceptions; + DB.Main, + UExceptions; { THistory } diff --git a/Src/UCategoryListAdapter.pas b/Src/UI.Adapters.CategoryList.pas similarity index 98% rename from Src/UCategoryListAdapter.pas rename to Src/UI.Adapters.CategoryList.pas index 8f27e6d15..0758d44e7 100644 --- a/Src/UCategoryListAdapter.pas +++ b/Src/UI.Adapters.CategoryList.pas @@ -11,7 +11,7 @@ } -unit UCategoryListAdapter; +unit UI.Adapters.CategoryList; interface @@ -21,7 +21,8 @@ interface // Delphi Classes, // Project - DB.UCategory, UContainers; + DB.Categories, + UContainers; type diff --git a/Src/USnipKindListAdapter.pas b/Src/UI.Adapters.SnippetKindList.pas similarity index 97% rename from Src/USnipKindListAdapter.pas rename to Src/UI.Adapters.SnippetKindList.pas index 745e819e1..35218b669 100644 --- a/Src/USnipKindListAdapter.pas +++ b/Src/UI.Adapters.SnippetKindList.pas @@ -11,7 +11,7 @@ } -unit USnipKindListAdapter; +unit UI.Adapters.SnippetKindList; interface @@ -21,7 +21,9 @@ interface // Delphi Classes, // Project - DB.USnippet, DB.USnippetKind, UContainers; + DB.SnippetKind, + DB.Snippets, + UContainers; type diff --git a/Src/UI.Adapters.VaultList.pas b/Src/UI.Adapters.VaultList.pas new file mode 100644 index 000000000..a17a76ded --- /dev/null +++ b/Src/UI.Adapters.VaultList.pas @@ -0,0 +1,115 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2024, Peter Johnson (gravatar.com/delphidabbler). + * + * Implements a class that adapts a list of snippet vaults by providing an + * alternative interface to the list, sorted by description. Designed for use + * with GUI controls. +} + +unit UI.Adapters.VaultList; + +interface + +uses + // Delphi + Classes, + // Project + DB.Vaults, + UContainers; + +type + + /// Class that adapts a list of snippet vaults by providing an + /// alternative interface to the list, sorted by description. Designed for + /// use with GUI controls. + TVaultListAdapter = class(TObject) + strict private + var + fVaultList: TSortedList; + + public + + /// Object constructor. Sets up object with a sorted list of + /// vaults. + constructor Create; + + /// Object destructor. Tears down object. + destructor Destroy; override; + + /// Copies vault descriptions to a string list. + /// TStrings [in] String list that receives + /// vault descriptions. + procedure ToStrings(const AStrings: TStrings); + + /// Gets the vault at a specified index in the sorted list. + /// + /// Integer [in] Index of required vault. + /// + /// TVault. Required vault. + function Vault(const AIndex: Integer): TVault; + + /// Gets list index of the vault with the specified UID. + function IndexOfUID(const AUID: TVaultID): Integer; + end; + +implementation + +uses + // Delphi + Generics.Defaults, + // Project + UStrUtils; + +{ TVaultListAdapter } + +constructor TVaultListAdapter.Create; +var + Vault: TVault; +begin + inherited Create; + fVaultList := TSortedList.Create( + TDelegatedComparer.Create( + function (const Left, Right: TVault): Integer + begin + Result := StrCompareText(Left.Name, Right.Name) + end + ) + ); + for Vault in TVaults.Instance do + fVaultList.Add(Vault); +end; + +destructor TVaultListAdapter.Destroy; +begin + fVaultList.Free; + inherited; +end; + +function TVaultListAdapter.IndexOfUID(const AUID: TVaultID): Integer; +var + Idx: Integer; +begin + Result := -1; + for Idx := 0 to Pred(fVaultList.Count) do + if fVaultList[Idx].UID = AUID then + Exit(Idx); +end; + +procedure TVaultListAdapter.ToStrings(const AStrings: TStrings); +var + Vault: TVault; +begin + for Vault in fVaultList do + AStrings.Add(Vault.Name); +end; + +function TVaultListAdapter.Vault(const AIndex: Integer): TVault; +begin + Result := fVaultList[AIndex]; +end; + +end. diff --git a/Src/UI.Forms.BackupVaultDlg.dfm b/Src/UI.Forms.BackupVaultDlg.dfm new file mode 100644 index 000000000..9c0d7fbf9 --- /dev/null +++ b/Src/UI.Forms.BackupVaultDlg.dfm @@ -0,0 +1,70 @@ +inherited VaultBackupDlg: TVaultBackupDlg + Caption = 'Choose Vault & Backup File' + ExplicitWidth = 474 + ExplicitHeight = 375 + PixelsPerInch = 96 + TextHeight = 13 + inherited pnlBody: TPanel + object lblVaults: TLabel + Left = 0 + Top = 7 + Width = 60 + Height = 13 + Caption = 'Select &vault:' + FocusControl = cbVaults + end + object lblPath: TLabel + Left = 0 + Top = 61 + Width = 180 + Height = 13 + Caption = 'Enter the full path of the back up &file:' + FocusControl = edPath + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False + end + object cbVaults: TComboBox + Left = 0 + Top = 24 + Width = 358 + Height = 21 + Style = csDropDownList + TabOrder = 0 + end + object edPath: TEdit + Left = 0 + Top = 80 + Width = 325 + Height = 21 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False + TabOrder = 1 + end + object btnBrowse: TButton + Left = 331 + Top = 80 + Width = 27 + Height = 21 + Caption = '...' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False + TabOrder = 2 + OnClick = btnBrowseClick + end + end + inherited btnOK: TButton + OnClick = btnOKClick + end +end diff --git a/Src/UI.Forms.BackupVaultDlg.pas b/Src/UI.Forms.BackupVaultDlg.pas new file mode 100644 index 000000000..9d5fe83c8 --- /dev/null +++ b/Src/UI.Forms.BackupVaultDlg.pas @@ -0,0 +1,152 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2024, Peter Johnson (gravatar.com/delphidabbler). + * + * Implements a dialogue box that enables the user to choose a vault to backup + * or restore along with the directory to backup to or restore from. +} + + +unit UI.Forms.BackupVaultDlg; + +interface + +uses + // Delphi + Classes, + Controls, + StdCtrls, + ExtCtrls, + // Project + DB.Vaults, + FmGenericOKDlg, + UI.Adapters.VaultList; + +type + TVaultBackupDlg = class(TGenericOKDlg) + lblVaults: TLabel; + cbVaults: TComboBox; + lblPath: TLabel; + edPath: TEdit; + btnBrowse: TButton; + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure btnBrowseClick(Sender: TObject); + procedure btnOKClick(Sender: TObject); + strict private + var + fFileName: string; + fVault: TVault; + fVaultList: TVaultListAdapter; + function GetFilePathFromEditCtrl: string; + strict protected + procedure ConfigForm; override; + procedure ArrangeForm; override; + public + class function Execute(AOwner: TComponent; + out AFileName: string; out AVault: TVault): Boolean; + end; + +implementation + +{$R *.dfm} + +uses + // Delphi + IOUtils, + Dialogs, + // Project + UCtrlArranger, + UMessageBox, + UOpenDialogHelper, + USaveDialogEx, + UStrUtils; + +procedure TVaultBackupDlg.ArrangeForm; +begin + TCtrlArranger.AlignLefts([lblVaults, cbVaults, lblPath, edPath], 0); + // row 1 + lblVaults.Top := 0; + // row 2 + TCtrlArranger.MoveBelow(lblVaults, cbVaults, 6); + // row 3 + TCtrlArranger.MoveBelow(cbVaults, lblPath, 12); + // row 4 + TCtrlArranger.MoveToRightOf(edPath, btnBrowse, 6); + TCtrlArranger.AlignVCentres( + TCtrlArranger.BottomOf(lblPath, 6), [edPath, btnBrowse] + ); + pnlBody.ClientWidth := TCtrlArranger.TotalControlWidth(pnlBody); + pnlBody.ClientHeight := TCtrlArranger.TotalControlHeight(pnlBody) + 8; + inherited; +end; + +procedure TVaultBackupDlg.btnBrowseClick(Sender: TObject); +var + SaveDlg: TSaveDialogEx; // save dialog box used to name backup file +resourcestring + // Dialog box caption + sCaption = 'Save Backup'; +begin + // Get backup file name from user via standard save dialog box + SaveDlg := TSaveDialogEx.Create(nil); + try + SaveDlg.Title := sCaption; + SaveDlg.Options := [ofShowHelp, ofExtensionDifferent, ofPathMustExist, + ofNoTestFileCreate, ofEnableSizing]; + SaveDlg.HelpKeyword := 'SaveBackupDlg'; + if SaveDlg.Execute then + edPath.Text := SaveDlg.FileName; + finally + SaveDlg.Free; + end; +end; + +procedure TVaultBackupDlg.btnOKClick(Sender: TObject); +begin + fFileName := GetFilePathFromEditCtrl; + fVault := fVaultList.Vault(cbVaults.ItemIndex); +end; + +procedure TVaultBackupDlg.ConfigForm; +begin + inherited; + fVaultList.ToStrings(cbVaults.Items); + cbVaults.ItemIndex := fVaultList.IndexOfUID(TVaultID.Default); +end; + +class function TVaultBackupDlg.Execute(AOwner: TComponent; + out AFileName: string; out AVault: TVault): Boolean; +var + Dlg: TVaultBackupDlg; +begin + Dlg := TVaultBackupDlg.Create(AOwner); + Result := Dlg.ShowModal = mrOK; + if Result then + begin + AFileName := Dlg.fFileName; + AVault := Dlg.fVault; + end; +end; + +procedure TVaultBackupDlg.FormCreate(Sender: TObject); +begin + inherited; + fVaultList := TVaultListAdapter.Create; +end; + +procedure TVaultBackupDlg.FormDestroy(Sender: TObject); +begin + fVaultList.Free; + inherited; +end; + +function TVaultBackupDlg.GetFilePathFromEditCtrl: string; +begin + Result := StrTrim(edPath.Text); +end; + +end. diff --git a/Src/FmDeleteUserDBDlg.dfm b/Src/UI.Forms.DeleteVaultDlg.dfm similarity index 66% rename from Src/FmDeleteUserDBDlg.dfm rename to Src/UI.Forms.DeleteVaultDlg.dfm index 1bd52b82a..3552eeeb0 100644 --- a/Src/FmDeleteUserDBDlg.dfm +++ b/Src/UI.Forms.DeleteVaultDlg.dfm @@ -1,16 +1,32 @@ -inherited DeleteUserDBDlg: TDeleteUserDBDlg - Caption = 'Delete User Database' +inherited DeleteVaultDlg: TDeleteVaultDlg + Caption = 'Delete All Snippets From A Vault' ExplicitWidth = 474 ExplicitHeight = 375 PixelsPerInch = 96 TextHeight = 13 inherited pnlBody: TPanel - object edConfirm: TEdit + object lblConfirm: TLabel + Left = 0 + Top = 256 + Width = 82 + Height = 13 + Caption = 'Confirm &deletion:' + FocusControl = edConfirm + end + object lblVaults: TLabel Left = 0 - Top = 216 - Width = 201 + Top = 224 + Width = 67 + Height = 13 + Caption = 'Choose &vault:' + FocusControl = cbVaults + end + object edConfirm: TEdit + Left = 120 + Top = 248 + Width = 249 Height = 21 - TabOrder = 0 + TabOrder = 2 end inline frmWarning: TFixedHTMLDlgFrame Left = 0 @@ -18,7 +34,7 @@ inherited DeleteUserDBDlg: TDeleteUserDBDlg Width = 369 Height = 210 Align = alTop - TabOrder = 1 + TabOrder = 0 TabStop = True ExplicitWidth = 369 ExplicitHeight = 210 @@ -41,6 +57,14 @@ inherited DeleteUserDBDlg: TDeleteUserDBDlg end end end + object cbVaults: TComboBox + Left = 120 + Top = 221 + Width = 249 + Height = 21 + Style = csDropDownList + TabOrder = 1 + end end inherited btnOK: TButton OnClick = btnOKClick diff --git a/Src/UI.Forms.DeleteVaultDlg.pas b/Src/UI.Forms.DeleteVaultDlg.pas new file mode 100644 index 000000000..5533d7b6c --- /dev/null +++ b/Src/UI.Forms.DeleteVaultDlg.pas @@ -0,0 +1,157 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2022-2023, Peter Johnson (gravatar.com/delphidabbler). + * + * Implements a dialogue box that enables the user to choose a vault from which + * to delete all snippets. +} + + +unit UI.Forms.DeleteVaultDlg; + +interface + +uses + // Delphi + Forms, + StdCtrls, + Controls, + ExtCtrls, + Classes, + // Project + DB.Vaults, + FmGenericOKDlg, + FrBrowserBase, + FrHTMLDlg, + FrFixedHTMLDlg, + UBaseObjects, + UI.Adapters.VaultList; + +type + TDeleteVaultDlg = class(TGenericOKDlg, INoPublicConstruct) + edConfirm: TEdit; + frmWarning: TFixedHTMLDlgFrame; + lblConfirm: TLabel; + lblVaults: TLabel; + cbVaults: TComboBox; + procedure btnOKClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + strict private + const + cConfirmText = 'DELETE MY SNIPPETS'; + var + fPermissionGranted: Boolean; + fVault: TVault; + fVaultList: TVaultListAdapter; + function SelectedVault: TVault; + function IsValidPassword: Boolean; + strict protected + /// Protected constructor that sets up form. + constructor InternalCreate(AOwner: TComponent); override; + procedure ConfigForm; override; + procedure ArrangeForm; override; + public + class function Execute(AOwner: TComponent; out AVault: TVault): Boolean; + end; + +implementation + +uses + // Delphi + SysUtils, + // Project + UCtrlArranger, + UMessageBox; + +{$R *.dfm} + +procedure TDeleteVaultDlg.ArrangeForm; +begin + frmWarning.Height := frmWarning.DocHeight; + TCtrlArranger.AlignLefts([frmWarning, lblConfirm, lblVaults], 0); + TCtrlArranger.AlignRights([frmWarning, cbVaults, edConfirm]); + TCtrlArranger.AlignVCentres( + TCtrlArranger.BottomOf(frmWarning, 12), + [lblVaults, cbVaults] + ); + TCtrlArranger.AlignVCentres( + TCtrlArranger.BottomOf([lblVaults, cbVaults], 12), + [lblConfirm, edConfirm] + ); + pnlBody.ClientHeight := TCtrlArranger.TotalControlHeight(pnlBody) + 8; + inherited; +end; + +procedure TDeleteVaultDlg.btnOKClick(Sender: TObject); +resourcestring + sBadPassword = 'Invalid confirmation text entered'; +begin + inherited; + fPermissionGranted := IsValidPassword; + fVault := SelectedVault; + if not fPermissionGranted then + begin + TMessageBox.Error(Self, sBadPassword); + edConfirm.Text := ''; + ModalResult := mrNone; + end; +end; + +procedure TDeleteVaultDlg.ConfigForm; +begin + inherited; + frmWarning.Initialise('dlg-dbdelete.html'); + fVaultList.ToStrings(cbVaults.Items); + cbVaults.ItemIndex := fVaultList.IndexOfUID(TVaultID.Default); +end; + +class function TDeleteVaultDlg.Execute(AOwner: TComponent; out AVault: TVault): + Boolean; +var + Dlg: TDeleteVaultDlg; +begin + Dlg := InternalCreate(AOwner); + try + Dlg.ShowModal; + Result := Dlg.fPermissionGranted; + if Result then + AVault := Dlg.fVault; + finally + Dlg.Free; + end; +end; + +procedure TDeleteVaultDlg.FormCreate(Sender: TObject); +begin + inherited; + fVaultList := TVaultListAdapter.Create; +end; + +procedure TDeleteVaultDlg.FormDestroy(Sender: TObject); +begin + fVaultList.Free; + inherited; +end; + +constructor TDeleteVaultDlg.InternalCreate(AOwner: TComponent); +begin + Assert(Supports(Self, INoPublicConstruct), ClassName + '.InternalCreate: ' + + 'Form''s protected constructor can''t be called'); + inherited InternalCreate(AOwner); +end; + +function TDeleteVaultDlg.IsValidPassword: Boolean; +begin + Result := edConfirm.Text = cConfirmText; +end; + +function TDeleteVaultDlg.SelectedVault: TVault; +begin + Result := fVaultList.Vault(cbVaults.ItemIndex); +end; + +end. diff --git a/Src/UI.Forms.MoveVaultDlg.dfm b/Src/UI.Forms.MoveVaultDlg.dfm new file mode 100644 index 000000000..0fe753ee0 --- /dev/null +++ b/Src/UI.Forms.MoveVaultDlg.dfm @@ -0,0 +1,159 @@ +inherited MoveVaultDlg: TMoveVaultDlg + Caption = 'Move Vault' + ExplicitWidth = 474 + ExplicitHeight = 375 + PixelsPerInch = 96 + TextHeight = 13 + inherited pnlBody: TPanel + Top = 9 + Height = 329 + ExplicitTop = 9 + ExplicitHeight = 329 + object lblInstructions: TLabel + Left = 0 + Top = 0 + Width = 377 + Height = 25 + AutoSize = False + Caption = + 'Use this dialogue box to move a vault to a new directory.'#13#10'Choos' + + 'e the vault you wish to move then enter the directory you wish t' + + 'o move it to.' + WordWrap = True + end + object lblWarning: TLabel + Left = 0 + Top = 31 + Width = 377 + Height = 34 + AutoSize = False + Caption = + 'You are strongly advised to make a backup of the vault before co' + + 'ntinuing.' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [fsBold] + ParentFont = False + WordWrap = True + end + object lblPath: TLabel + Left = 0 + Top = 125 + Width = 217 + Height = 13 + Caption = 'Enter the full path of the new data &directory:' + FocusControl = edPath + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False + end + object lblExplainMove: TLabel + Left = 0 + Top = 171 + Width = 361 + Height = 62 + AutoSize = False + Caption = + 'The directory must be empty and must not be a sub-directory of t' + + 'he current vault'#39's data directory. If the directory does not exi' + + 'st a new one will be created.' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False + WordWrap = True + end + object lblVaults: TLabel + Left = 0 + Top = 71 + Width = 102 + Height = 13 + Caption = 'Select &vault to move:' + FocusControl = cbVaults + end + inline frmProgress: TProgressFrame + Left = 57 + Top = 0 + Width = 320 + Height = 82 + ParentBackground = False + TabOrder = 4 + Visible = False + ExplicitLeft = 57 + ExplicitHeight = 82 + inherited pnlBody: TPanel + Height = 82 + ExplicitHeight = 82 + end + end + object btnMove: TButton + Left = 87 + Top = 199 + Width = 153 + Height = 41 + Action = actMove + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False + TabOrder = 3 + end + object edPath: TEdit + Left = 0 + Top = 144 + Width = 325 + Height = 21 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False + TabOrder = 1 + end + object btnBrowse: TButton + Left = 331 + Top = 144 + Width = 27 + Height = 21 + Action = actBrowse + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False + TabOrder = 2 + end + object cbVaults: TComboBox + Left = 0 + Top = 88 + Width = 358 + Height = 21 + Style = csDropDownList + TabOrder = 0 + end + end + object alDlg: TActionList + Left = 152 + Top = 304 + object actBrowse: TAction + Caption = '...' + OnExecute = actBrowseExecute + end + object actMove: TAction + Caption = '&Move' + OnExecute = actMoveExecute + OnUpdate = actMoveUpdate + end + end +end diff --git a/Src/FmUserDataPathDlg.pas b/Src/UI.Forms.MoveVaultDlg.pas similarity index 55% rename from Src/FmUserDataPathDlg.pas rename to Src/UI.Forms.MoveVaultDlg.pas index 9c6bbbbbe..30616aba2 100644 --- a/Src/FmUserDataPathDlg.pas +++ b/Src/UI.Forms.MoveVaultDlg.pas @@ -5,12 +5,12 @@ * * Copyright (C) 2013-2023, Peter Johnson (gravatar.com/delphidabbler). * - * Implements a dialogue box that can be used to move the user database to a - * different directory. + * Implements a dialogue box that can be used to move vaults to a different + * directory. } -unit FmUserDataPathDlg; +unit UI.Forms.MoveVaultDlg; interface @@ -18,66 +18,67 @@ interface uses // Delphi - SysUtils, Forms, Classes, ActnList, StdCtrls, Controls, ExtCtrls, + SysUtils, + Forms, + Classes, + ActnList, + StdCtrls, + Controls, + ExtCtrls, // Project - FmGenericViewDlg, FrProgress, UBaseObjects, - UControlStateMgr, UUserDBMove; + FmGenericViewDlg, + FrProgress, + UBaseObjects, + UControlStateMgr, + UI.Adapters.VaultList, + VaultMover; type - /// Dialogue box that is used to move the user database to a new - /// directory or to restore a previously moved database to its default - /// directory. + /// Dialogue box that is used to move vault data to a new directory. + /// /// IMPORTANT: This dialogue box is for use only with the standard /// edition of CodeSnip. It MUST NOT be displayed from the portable edition. /// - TUserDataPathDlg = class(TGenericViewDlg, INoPublicConstruct) + TMoveVaultDlg = class(TGenericViewDlg, INoPublicConstruct) actBrowse: TAction; - actDefaultPath: TAction; actMove: TAction; alDlg: TActionList; - btnBrowse: TButton; - btnDefaultPath: TButton; - btnMove: TButton; - gbMove: TGroupBox; - gbRestore: TGroupBox; - lblExplainDefaultPath: TLabel; - lblExplainMove: TLabel; lblInstructions: TLabel; - lblPath: TLabel; lblWarning: TLabel; - edPath: TEdit; frmProgress: TProgressFrame; + lblPath: TLabel; + lblExplainMove: TLabel; + btnMove: TButton; + edPath: TEdit; + btnBrowse: TButton; + lblVaults: TLabel; + cbVaults: TComboBox; /// Dispays Browse For Folder dialogue box and copies any chosen /// folder to the edPath edit control. procedure actBrowseExecute(Sender: TObject); - /// Moves user database back to default directory and records the - /// changed path. - /// Raises exception if default path can't be used for any - /// reason or if there was an error copying the database. - procedure actDefaultPathExecute(Sender: TObject); - /// Enables / disables Default Path action according to whether - /// database is already in default path. - procedure actDefaultPathUpdate(Sender: TObject); - /// Moves user database to path entered by user and records the - /// changed path. - /// Raises exception given path can't be used for any reason or - /// if there was an error copying the database. + /// Moves the chosen vault to the path entered by the user and + /// records the changed path. + /// Raises exception if the given path can't be used for any + /// reason or if there was an error copying the vault. procedure actMoveExecute(Sender: TObject); /// Enables / disables Move action according to whether a suitable /// path has been entered by user. procedure actMoveUpdate(Sender: TObject); - /// Constructs and initialises form's owned object. + /// Constructs and initialises form's owned objects. procedure FormCreate(Sender: TObject); /// Destroys form's owned objects. procedure FormDestroy(Sender: TObject); strict private var - /// Object that moves the user database to a new location. + /// Object that moves a vault's data to a new location. /// - fMover: TUserDBMove; + fMover: TVaultMover; /// Object used to disable and enable all controls on the form. /// fControlStateMgr: TControlStateMgr; + /// Object used to provide and interogate a sorted list of + /// vault names displayed in cbVault. + fVaultList: TVaultListAdapter; /// Sets visibility of all child controls of a parent control. /// /// TWinControl [in] Parent of affected controls. @@ -85,31 +86,33 @@ TUserDataPathDlg = class(TGenericViewDlg, INoPublicConstruct) /// Boolean [in] Flag indicating required visibility. /// Pass True to show the controls and False to hide them. procedure SetVisibility(const ParentCtrl: TWinControl; const Show: Boolean); - /// Performs the database move to the directory given by NewDir, - /// displaying a progress base located over the given host window. - /// + /// Move the chosen vault data to the directory given by + /// NewDir, displaying a progress base located over the given host + /// window. /// The new directory is checked to be empty and the user is asked /// for confirmation. procedure DoMove(const NewDir: string; const ProgressHostCtrl: TWinControl); - /// Handles the database mover object's OnCopyFile event by - /// updating the progress frame. + /// Handles the vault data mover object's OnCopyFile event + /// by updating the progress frame. procedure CopyFileHandler(Sender: TObject; const Percent: Byte); - /// Handles the database mover object's OnDeleteFile event by - /// updating the progress frame. + /// Handles the vault data mover object's OnDeleteFile + /// event by updating the progress frame. procedure DeleteFileHandler(Sender: TObject; const Percent: Byte); - /// Gets directory entered in edPath edit control. - /// Edit control contents are trimmed of spaces and any trailing - /// path delimiter. + /// Gets the directory entered in the edPath edit control. + /// + /// The edit control contents are trimmed of spaces and any + /// trailing path delimiter. function NewDirFromEditCtrl: string; - /// Handles given exception, converting expected exceptions into - /// ECodeSnip and re-raising all other unchanged. + /// Handles the given exception E, converting expected + /// exceptions into ECodeSnip exceptions and re-raising all other + /// exceptions unchanged. /// Always raises a new exception. /// This method is designed to handle exceptions raised when the - /// user database is moved. + /// vault data is moved. procedure HandleException(const E: Exception); strict protected - /// Sets controls with ParentFont=False to use system default - /// fonts, preserving font styles for those fonts that need them. + /// Initialises the form's controls and associated objects. + /// procedure ConfigForm; override; /// Arranges form's controls and sizes the dialogue box to fit. /// @@ -117,8 +120,8 @@ TUserDataPathDlg = class(TGenericViewDlg, INoPublicConstruct) public /// Displays the dialogue box aligned over the given owner /// control. - /// Raises EBug if called by the portable edition of CodeSnip. - /// + /// Raises EBug if called from the portable edition of + /// CodeSnip. class procedure Execute(AOwner: TComponent); end; @@ -128,20 +131,27 @@ implementation uses // Delphi - IOUtils, + IOUtils, // Project - UAppInfo, UBrowseForFolderDlg, UCtrlArranger, UExceptions, UFontHelper, - UMessageBox, UStrUtils, UStructs; + DB.Vaults, + UAppInfo, + UBrowseForFolderDlg, + UCtrlArranger, + UExceptions, + UFontHelper, + UMessageBox, + UStrUtils, + UStructs; {$R *.dfm} { TUserDataPathDlg } -procedure TUserDataPathDlg.actBrowseExecute(Sender: TObject); +procedure TMoveVaultDlg.actBrowseExecute(Sender: TObject); var Dlg: TBrowseForFolderDlg; // browse for folder standard dialogue box resourcestring - sDlgTitle = 'Choose Database Directory'; + sDlgTitle = 'Choose Vault Data Directory'; sDlgHeading = 'Choose an empty directory or create a new one'; begin Dlg := TBrowseForFolderDlg.Create(nil); @@ -156,70 +166,80 @@ procedure TUserDataPathDlg.actBrowseExecute(Sender: TObject); end; end; -procedure TUserDataPathDlg.actDefaultPathExecute(Sender: TObject); +procedure TMoveVaultDlg.actMoveExecute(Sender: TObject); begin - DoMove(TAppInfo.DefaultUserDataDir, gbRestore); + DoMove(NewDirFromEditCtrl, Self); end; -procedure TUserDataPathDlg.actDefaultPathUpdate(Sender: TObject); -begin - actDefaultPath.Enabled := - not StrSameText(TAppInfo.UserDataDir, TAppInfo.DefaultUserDataDir) - and Self.Enabled; -end; - -procedure TUserDataPathDlg.actMoveExecute(Sender: TObject); -begin - DoMove(NewDirFromEditCtrl, gbMove); -end; - -procedure TUserDataPathDlg.actMoveUpdate(Sender: TObject); +procedure TMoveVaultDlg.actMoveUpdate(Sender: TObject); begin actMove.Enabled := (NewDirFromEditCtrl <> '') - and not StrSameText(NewDirFromEditCtrl, TAppInfo.UserDataDir) + and not StrSameText( + NewDirFromEditCtrl, + fVaultList.Vault(cbVaults.ItemIndex).Storage.Directory + ) and Self.Enabled; end; -procedure TUserDataPathDlg.ArrangeForm; +procedure TMoveVaultDlg.ArrangeForm; begin TCtrlArranger.SetLabelHeights(Self); pnlBody.ClientWidth := TCtrlArranger.TotalControlWidth(pnlBody); - TCtrlArranger.AlignVCentres( - TCtrlArranger.BottomOf(lblPath, 4), [edPath, btnBrowse] + TCtrlArranger.AlignLefts( + [ + lblInstructions, lblWarning, lblVaults, cbVaults, lblPath, edPath, + lblExplainMove + ], + 0 ); - TCtrlArranger.MoveBelow([edPath, btnBrowse], lblExplainMove, 8); - TCtrlArranger.MoveBelow(lblExplainMove, btnMove, 8); - gbMove.ClientHeight := TCtrlArranger.TotalControlHeight(gbMove) + 8; - - TCtrlArranger.MoveBelow(lblExplainDefaultPath, btnDefaultPath, 12); - gbRestore.ClientHeight := TCtrlArranger.TotalControlHeight(gbRestore) + 12; - + // Row 1 + lblInstructions.Top := 0; + lblInstructions.Width := pnlBody.ClientWidth; + // Row 2 TCtrlArranger.MoveBelow(lblInstructions, lblWarning, 8); - TCtrlArranger.MoveBelow(lblWarning, gbMove, 12); - TCtrlArranger.MoveBelow(gbMove, gbRestore, 12); + lblWarning.Width := pnlBody.ClientWidth; + // Row 3 + TCtrlArranger.MoveBelow(lblWarning, lblVaults, 12); + // Row 4 + TCtrlArranger.MoveBelow(lblVaults, cbVaults, 6); + cbVaults.Width := pnlBody.ClientWidth; + // Row 5 + TCtrlArranger.MoveBelow(cbVaults, lblPath, 12); + // Row 6 + TCtrlArranger.AlignRights([btnBrowse], pnlBody.ClientWidth); + edPath.Width := btnBrowse.Left - 6 - edPath.Left; + TCtrlArranger.AlignVCentres( + TCtrlArranger.BottomOf(lblPath, 6), [edPath, btnBrowse] + ); + // Row 7 + TCtrlArranger.MoveBelow([edPath, btnBrowse], lblExplainMove, 12); + lblExplainMove.Width := pnlBody.ClientWidth; + // Row 8 + TCtrlArranger.MoveBelow(lblExplainMove, btnMove, 12); + btnMove.Left := (pnlBody.Width - btnMove.Width) div 2; pnlBody.ClientHeight := TCtrlArranger.TotalControlHeight(pnlBody) + 8; + inherited; end; -procedure TUserDataPathDlg.ConfigForm; +procedure TMoveVaultDlg.ConfigForm; begin inherited; - TFontHelper.SetDefaultBaseFonts([ - gbMove.Font, gbRestore.Font, lblWarning.Font] - ); + TFontHelper.SetDefaultBaseFonts([lblWarning.Font]); TFontHelper.SetDefaultFonts([ lblPath.Font, edPath.Font, lblExplainMove.Font, - btnBrowse.Font, btnMove.Font, lblExplainDefaultPath.Font, - btnDefaultPath.Font + btnBrowse.Font, btnMove.Font ]); frmProgress.Visible := False; frmProgress.Range := TRange.Create(0, 100); + fVaultList.ToStrings(cbVaults.Items); + cbVaults.ItemIndex := fVaultList.IndexOfUID(TVaultID.Default); end; -procedure TUserDataPathDlg.CopyFileHandler(Sender: TObject; +procedure TMoveVaultDlg.CopyFileHandler(Sender: TObject; const Percent: Byte); resourcestring sCopying = 'Copying files...'; @@ -230,7 +250,7 @@ procedure TUserDataPathDlg.CopyFileHandler(Sender: TObject; Application.ProcessMessages; end; -procedure TUserDataPathDlg.DeleteFileHandler(Sender: TObject; +procedure TMoveVaultDlg.DeleteFileHandler(Sender: TObject; const Percent: Byte); resourcestring sDeleting = 'Deleting files...'; @@ -241,11 +261,11 @@ procedure TUserDataPathDlg.DeleteFileHandler(Sender: TObject; Application.ProcessMessages; end; -procedure TUserDataPathDlg.DoMove(const NewDir: string; +procedure TMoveVaultDlg.DoMove(const NewDir: string; const ProgressHostCtrl: TWinControl); resourcestring sNonEmptyDir = 'The specified directory is not empty.'; - sConfirmMsg = 'Are you sure you want to move the database?'; + sConfirmMsg = 'Are you sure you want to move the vault data?'; begin if TDirectory.Exists(NewDir) and not TDirectory.IsEmpty(NewDir) then @@ -258,7 +278,9 @@ procedure TUserDataPathDlg.DoMove(const NewDir: string; SetVisibility(ProgressHostCtrl, False); frmProgress.Show(ProgressHostCtrl); try - fMover.MoveTo(NewDir); + fMover.MoveTo( + fVaultList.Vault(cbVaults.ItemIndex), NewDir + ); except on E: Exception do HandleException(E); @@ -271,13 +293,14 @@ procedure TUserDataPathDlg.DoMove(const NewDir: string; end; end; -class procedure TUserDataPathDlg.Execute(AOwner: TComponent); +class procedure TMoveVaultDlg.Execute(AOwner: TComponent); {$IFNDEF PORTABLE} var - Dlg: TUserDataPathDlg; + Dlg: TMoveVaultDlg; {$ENDIF} begin {$IFDEF PORTABLE} + {TODO -cVault: Permit this, but restrict to sub-dirs of install dir} raise EBug.Create(ClassName + '.Execute: Call forbidden in portable edition'); {$ELSE} Dlg := InternalCreate(AOwner); @@ -289,23 +312,25 @@ class procedure TUserDataPathDlg.Execute(AOwner: TComponent); {$ENDIF} end; -procedure TUserDataPathDlg.FormCreate(Sender: TObject); +procedure TMoveVaultDlg.FormCreate(Sender: TObject); begin inherited; - fMover := TUserDBMove.Create; + fMover := TVaultMover.Create; fMover.OnCopyFile := CopyFileHandler; fMover.OnDeleteFile := DeleteFileHandler; fControlStateMgr := TControlStateMgr.Create(Self); + fVaultList := TVaultListAdapter.Create; end; -procedure TUserDataPathDlg.FormDestroy(Sender: TObject); +procedure TMoveVaultDlg.FormDestroy(Sender: TObject); begin + fVaultList.Free; fControlStateMgr.Free; fMover.Free; inherited; end; -procedure TUserDataPathDlg.HandleException(const E: Exception); +procedure TMoveVaultDlg.HandleException(const E: Exception); begin if (E is EInOutError) or (E is ENotSupportedException) or (E is EDirectoryNotFoundException) or (E is EPathTooLongException) @@ -314,12 +339,12 @@ procedure TUserDataPathDlg.HandleException(const E: Exception); raise E; end; -function TUserDataPathDlg.NewDirFromEditCtrl: string; +function TMoveVaultDlg.NewDirFromEditCtrl: string; begin Result := ExcludeTrailingPathDelimiter(StrTrim(edPath.Text)); end; -procedure TUserDataPathDlg.SetVisibility(const ParentCtrl: TWinControl; +procedure TMoveVaultDlg.SetVisibility(const ParentCtrl: TWinControl; const Show: Boolean); var I: Integer; diff --git a/Src/UIStringList.pas b/Src/UIStringList.pas index 90a630931..4a0239917 100644 --- a/Src/UIStringList.pas +++ b/Src/UIStringList.pas @@ -170,15 +170,19 @@ TIStringList = class(TInterfacedObject, constructor Create; overload; {Class constructor. Creates new empty list. } + + /// Create a new list containing all the strings contained in a + /// given string list. + /// TStrings [in] List of strings to add. An + /// empty list is created if Strs is empty or nil. constructor Create(const Strs: TStrings); overload; - {Class constructor. Creates new list containing specified strings. - @param Strs [in] List of strings to be stored in list. - } + + /// Create a new list containing all the strings contained in a + /// given string list. + /// IStringList [in] List of strings to add. An + /// empty list is created if Strs is empty or nil. constructor Create(const Strs: IStringList); overload; - {Class constructor. Creates new list containing strings from another - IStringList instance. - @param Strs [in] List of strings to be stored in list. - } + constructor Create(const Str: string); overload; {Class constructor. Creates new list containing a single string. @param Str [in] String to be included in list. @@ -194,10 +198,13 @@ TIStringList = class(TInterfacedObject, @param Trim [in] Determines whether strings are trimmed of trailing and leading spaces before adding to list. } + + /// Create a new list containing all the strings contained in a + /// given array. + /// array of string [in] List of strings to add. + /// An empty list is created if Strs is empty. constructor Create(const Strs: array of string); overload; - {Class constructor. Creates new list containing strings from array. - @param Strs [in] Array of strings to be included in list. - } + destructor Destroy; override; {Class destructor. Tears down object. } @@ -207,18 +214,25 @@ TIStringList = class(TInterfacedObject, @param Str [in] String to be added to list. @return Index of new string in list. } + + /// Adds all strings from a string list to the end of the list. + /// + /// TStrings [in] List of strings to add. Does + /// nothing if Strs is nil or empty. procedure Add(const Strs: TStrings); overload; - {Adds all items from a string list to end of list. - @param Strs [in] String list to be added. - } + + /// Adds all strings from a string list to the end of the list. + /// + /// IStringList [in] List of strings to add. Does + /// nothing if Strs is nil or empty. procedure Add(const Strs: IStringList); overload; - {Adds all items from another IStringList instance to end of list. - @param Strs [in] String list to be added. - } + + /// Adds all strings from an array of strings to the end of the + /// list. + /// array of string [in] Array of strings to add. + /// Does nothing if Strs is empty. procedure Add(const Strs: array of string); overload; - {Adds all strings from an array to end of list. - @param Strs [in] Dynamic array of strings to be added. - } + procedure Add(const Str: string; const Delim: string; const AllowEmpty: Boolean; const Trim: Boolean = False); overload; {Splits a string at delimiter and adds component parts of string to end of @@ -345,11 +359,9 @@ implementation { TIStringList } procedure TIStringList.Add(const Strs: TStrings); - {Adds all items from a string list to end of list. - @param Strs [in] String list to be added. - } begin - fStrings.AddStrings(Strs); + if Assigned(Strs) then + fStrings.AddStrings(Strs); end; function TIStringList.Add(const Str: string): Integer; @@ -362,14 +374,12 @@ function TIStringList.Add(const Str: string): Integer; end; procedure TIStringList.Add(const Strs: IStringList); - {Adds all items from another IStringList instance to end of list. - @param Strs [in] String list to be added. - } var - Idx: Integer; // loops through strings in added list + S: string; begin - for Idx := 0 to Pred(Strs.Count) do - Add(Strs[Idx]); + if Assigned(Strs) then + for S in Strs do + Add(S); end; procedure TIStringList.Add(const Str: string; const Delim: string; @@ -398,9 +408,6 @@ procedure TIStringList.Add(const Str: string; const Delim: string; end; procedure TIStringList.Add(const Strs: array of string); - {Adds all strings from an array to end of list. - @param Strs [in] Dynamic array of strings to be added. - } var Idx: Integer; // loops thru elements of array begin diff --git a/Src/UIniDataLoader.pas b/Src/UIniDataLoader.pas deleted file mode 100644 index 8f40ee460..000000000 --- a/Src/UIniDataLoader.pas +++ /dev/null @@ -1,579 +0,0 @@ -{ - * This Source Code Form is subject to the terms of the Mozilla Public License, - * v. 2.0. If a copy of the MPL was not distributed with this file, You can - * obtain one at https://mozilla.org/MPL/2.0/ - * - * Copyright (C) 2009-2021, Peter Johnson (gravatar.com/delphidabbler). - * - * Implements an extension of TMemIniFile that loads the ini data from a set of - * associated files and pre-processes the data. -} - - -unit UIniDataLoader; - - -interface - - -uses - // Delphi - Classes, IniFiles, - // Project - UBaseObjects, UExceptions, UIStringList, UMainDBFileReader; - - -type - /// - /// Extension of TMemIniFile that loads the ini data from a set of associated - /// files. Any quotes enclosing values read from ini file are stripped. Files - /// are pre-processed, and modified according to any pre-processing - /// directives. - /// - TDatabaseIniFile = class(TMemIniFile) - strict private - var - /// Loads database files using correct encoding. - fFileReader: TMainDBFileReader; - /// - /// Concatenates the content of a list of text files. - /// - /// IStringList [in] List of text files. - /// IStringList containing concatenation of lines read from the - /// files. - function LoadFiles(const FileNames: IStringList): IStringList; - public - /// - /// Object constructor. Sets up ini file object and loads data into it from - /// a set of associated files. - /// - /// TMainDBFileReader [in] Object used to read - /// database text files using correct encoding. - /// string [in] Base name of associated files - /// containing data. - constructor Create(const FileReader: TMainDBFileReader; - const FileName: string); - /// - /// Retrieves a string value from an ini file. - /// - /// string [in] Section containing value. - /// string [in] Identifier of value. - /// string [in] Default value used if ident is not - /// present or not assigned. - /// string containing required value, with any enclosing quotes - /// removed. - /// - /// Overrides method in base class to strip enclosing quotes. - /// - function ReadString(const Section, Ident, Default: string): string; - override; - /// - /// Loads ini object's data from a string list. - /// - /// IStringList [in] Strings to be loaded. - /// - /// Overloads inherited SetStrings to load data from IStringList as well - /// as TStringList. - /// - procedure SetStrings(const Strings: IStringList); overload; - end; - -type - /// Type of exception raised by TDatabaseIniFile. - EDatabaseIniFile = class(ECodeSnip); - - -implementation - - -uses - // Delphi - SysUtils, - // Project - UConsts, UStrUtils, UVersionInfo; - - -type - { - TDatabaseFileMapper: - Static class that gets a list of file names associated with a specified file - name. Used to associate database file names visible only to early versions - of CodeSnip with file names visible to later versions. - } - TDatabaseFileMapper = class(TNoConstructObject) - strict private - class function AlternateFileName(const FileName, InnerExt: string): string; - {Creates an alternate file name for a specified file and an "inner" - extension that is inserted before the file's current extension. - @param FileName [in] File name to form basis of alternate name. - @param InnerExt [in] "Inner" extension that comes between file name and - its last extension. - @return Alternate file name. - } - public - class function GetRelatedFiles(const FileName: string): IStringList; - {Builds a list of file names associated with a file name. - @param FileName [in] Original file name. - @return List of associated files, all of which exist. Original file name - may be omitted from the list if it doesn't exist. - } - end; - -type - { - TDatabasePreprocessor: - Static class used to pre-process ini file, acting on pre-processor - instructions. Does not support nesting of directives. Supported instructions - are: - #if-ver-eq - Checks if application version is equal to . - #if-ver-neq - Checks if application version is not equal to . - #if-ver-lt - Checks if application version is less than . - #if-ver-gt - Checks if application version is greater than . - #if-ver-inrange - Checks if application version is in the range of versions specified from - to , inclusive. - #end-if - Ends a block started by any of the #if- instructions above. - When a #if- instruction evaluates true then all the following lines in the - ini file up to the #end-if instruction and included. If it evaluates false - the enclosed lines are ignored. - Version numbers are in form 9.9.9.9. Minor version numbers are optional - and are filled with zeroes, so specifying 3 is equivalent to 3.0.0.0 and - 2.1 is equivalent to 2.1.0.0. - Unrecognised instructions are ignored and are not included in the output. - } - TDatabasePreprocessor = class(TNoConstructObject) - strict private - type - { - TVerCompareMethod: - Type of methods used to compare version numbers. - @param Ver1 [in] First version number to compare. - @param Ver2 [in] Second version number to compare. - @return True if required condition applies, False if not. - } - TVerCompareMethod = function(Ver1, Ver2: TVersionNumber): Boolean - of object; - const - // Symbols that prefix every pre-processor instruction - cPreProcPrefix = ';#'; - // Pre-processor instructions / directives - cEndIf = cPreProcPrefix + 'end-if'; // ends if instruction - cIfVerEQ = cPreProcPrefix + 'if-ver-eq'; // appver = param - cIfVerNEQ = cPreProcPrefix + 'if-ver-neq'; // appver <> param - cIfVerLT = cPreProcPrefix + 'if-ver-lt'; // appver < param - cIfVerGT = cPreProcPrefix + 'if-ver-gt'; // appver > param - cIfVerInRange = cPreProcPrefix + 'if-ver-inrange'; // appver in range - class function ProcessVerEQ(const Lines: IStringList; - var LineIdx: Integer): IStringList; - {Processes a ifvereq pre-processor directive. Includes lines before endif - directive only if condition is met, i.e. app version is equal to version - specified in directive. - @param Lines [in] Lines of ini file. - @param LineIdx [in/out] In: index of current line before processing. - Out: index of last line processed. - } - class function ProcessVerNEQ(const Lines: IStringList; - var LineIdx: Integer): IStringList; - {Processes a ifverneq pre-processor directive. Includes lines before endif - directive only if condition is met, i.e. app version is not equal to - version specified in directive. - @param Lines [in] Lines of ini file. - @param LineIdx [in/out] In: index of current line before processing. - Out: index of last line processed. - } - class function ProcessVerLT(const Lines: IStringList; - var LineIdx: Integer): IStringList; - {Processes a ifverlt pre-processor directive. Includes lines before endif - directive only if condition is met, i.e. app version is less than version - specified in directive. - @param Lines [in] Lines of ini file. - @param LineIdx [in/out] In: index of current line before processing. - Out: index of last line processed. - } - class function ProcessVerGT(const Lines: IStringList; - var LineIdx: Integer): IStringList; - {Processes a ifvergt pre-processor directive. Includes lines before endif - directive only if condition is met, i.e. app version is greater than - version specified in directive. - @param Lines [in] Lines of ini file. - @param LineIdx [in/out] In: index of current line before processing. - Out: index of last line processed. - } - class function ProcessVerInRange(const Lines: IStringList; - var LineIdx: Integer): IStringList; - {Processes ifverinrange pre-processor directive. Includes lines before - endif directive only if condition is met, i.e. app version is in range of - version numbers specified in directive. - @param Lines [in] Lines of ini file. - @param LineIdx [in/out] In: index of current kine before processing. - Out: index of last line processed. - } - class function CompareEQ(Ver1, Ver2: TVersionNumber): Boolean; - {Compares two version numbers to check if first is equal to second. - @param Ver1 [in] First version number to compare. - @param Ver2 [in] Second version number to compare. - @return True if Ver1 = Ver2, False if not. - } - class function CompareNEQ(Ver1, Ver2: TVersionNumber): Boolean; - {Compares two version numbers to check if first is not equal to second. - @param Ver1 [in] First version number to compare. - @param Ver2 [in] Second version number to compare. - @return True if Ver1 <> Ver2, False if not. - } - class function CompareGT(Ver1, Ver2: TVersionNumber): Boolean; - {Compares two version numbers to check if first is greater than second. - @param Ver1 [in] First version number to compare. - @param Ver2 [in] Second version number to compare. - @return True if Ver1 > Ver2, False if not. - } - class function CompareLT(Ver1, Ver2: TVersionNumber): Boolean; - {Compares two version numbers to check if first is less than second. - @param Ver1 [in] First version number to compare. - @param Ver2 [in] Second version number to compare. - @return True if Ver1 < Ver2, False if not. - } - class function ProcessVerCompare(const Lines: IStringList; - var LineIdx: Integer; const CompareFn: TVerCompareMethod): IStringList; - {Processes a version comparison directive. - @param Lines [in] Lines of ini file. - @param LineIdx [in/out] In: index of current line before processing. - Out: index of last line processed. - @param CompareFn [in] Method to used to compare application version with - version number read from directive to determine if directive executes. - } - class function ProcessToEndIf(const Lines: IStringList; - var LineIdx: Integer; const RecordLines: Boolean): IStringList; - public - class function PreProcess(Lines: IStringList): IStringList; - {Performs pre-processing. - @param Lines [in] Lines of text to be pre-processed. - @return Lines after preprocessing. - } - end; - -{ TDatabaseIniFile } - -constructor TDatabaseIniFile.Create(const FileReader: TMainDBFileReader; - const FileName: string); -var - Files: IStringList; // List of associated file names -resourcestring - // Error message - sMissingCatFile = 'Neither category file "%s" nor its alternate exists.'; -begin - inherited Create(FileName); - fFileReader := FileReader; - // get list of associated files - Files := TDatabaseFileMapper.GetRelatedFiles(FileName); - if Files.Count = 0 then - raise EDatabaseIniFile.CreateFmt( - sMissingCatFile, [ExtractFileName(FileName)] - ); - // load ini file from concatenated contents of Files after running through - // pre-processor - SetStrings( - TDatabasePreprocessor.PreProcess( - LoadFiles(Files) - ) - ); -end; - -function TDatabaseIniFile.LoadFiles(const FileNames: IStringList): IStringList; -var - FileName: string; // each file name is list -begin - Result := TIStringList.Create; - for FileName in FileNames do - Result.Add(fFileReader.ReadAllStrings(FileName)); -end; - -function TDatabaseIniFile.ReadString(const Section, Ident, - Default: string): string; -begin - // Read string from ini - Result := inherited ReadString(Section, Ident, Default); - // Strip any leading and trailing quotes - if (Length(Result) > 1) and (Result[1] = DOUBLEQUOTE) - and (Result[Length(Result)] = DOUBLEQUOTE) then - Result := Copy(Result, 2, Length(Result) - 2); -end; - -procedure TDatabaseIniFile.SetStrings(const Strings: IStringList); -var - SL: TStringList; // string list use to call inherited method -begin - SL := TStringList.Create; - try - Strings.CopyTo(SL); - SetStrings(SL); - finally - FreeAndNil(SL); - end; -end; - -{ TDatabaseFileMapper } - -function RemoveFileExt(const FileName: string): string; - {Removes an extension from a file name. - @param FileName [in] File name from which extension is to be removed. - @return File name without extension. - } -begin - if StrContainsStr('.', FileName) then - Result := SysUtils.ChangeFileExt(FileName, '') - else - Result := FileName; -end; - -class function TDatabaseFileMapper.AlternateFileName( - const FileName, InnerExt: string): string; - {Creates an alternate file name for a specified file and an "inner" extension - that is inserted before the file's current extension. - @param FileName [in] File name to form basis of alternate name. - @param InnerExt [in] "Inner" extension that comes between file name and its - last extension. - @return Alternate file name. - } -var - BaseName: string; // base of file name without extension - Extension: string; // extension common to all names -begin - Extension := ExtractFileExt(FileName); - BaseName := RemoveFileExt(ExtractFileName(FileName)); - Result := ExtractFilePath(FileName) + BaseName + InnerExt + Extension; -end; - -class function TDatabaseFileMapper.GetRelatedFiles( - const FileName: string): IStringList; - {Builds a list of file names associated with a file name. - @param FileName [in] Original file name. - @return List of associated files, all of which exist. Original file name may - be omitted from the list if it doesn't exist. - } -var - AltFileName: string; // an alternate file name - InnerExt: string; // each inner extension -const - // "Inner" extensions to be interposed between filename and its extension - InnerExts: array[0..1] of string = ('.3', '.4'); -begin - Result := TIStringList.Create; - if FileExists(FileName) then - Result.Add(FileName); - for InnerExt in InnerExts do - begin - AltFileName := AlternateFileName(FileName, InnerExt); - if (AltFileName <> '') and FileExists(AltFileName) then - Result.Add(AltFileName); - end; -end; - -{ TDatabasePreprocessor } - -class function TDatabasePreprocessor.CompareEQ(Ver1, - Ver2: TVersionNumber): Boolean; - {Compares two version numbers to check if first is equal to second. - @param Ver1 [in] First version number to compare. - @param Ver2 [in] Second version number to compare. - @return True if Ver1 = Ver2, False if not. - } -begin - Result := Ver1 = Ver2; -end; - -class function TDatabasePreprocessor.CompareGT(Ver1, - Ver2: TVersionNumber): Boolean; - {Compares two version numbers to check if first is greater than second. - @param Ver1 [in] First version number to compare. - @param Ver2 [in] Second version number to compare. - @return True if Ver1 > Ver2, False if not. - } -begin - Result := Ver1 > Ver2; -end; - -class function TDatabasePreprocessor.CompareLT(Ver1, - Ver2: TVersionNumber): Boolean; - {Compares two version numbers to check if first is less than second. - @param Ver1 [in] First version number to compare. - @param Ver2 [in] Second version number to compare. - @return True if Ver1 < Ver2, False if not. - } -begin - Result := Ver1 < Ver2; -end; - -class function TDatabasePreprocessor.CompareNEQ(Ver1, - Ver2: TVersionNumber): Boolean; - {Compares two version numbers to check if first is not equal to second. - @param Ver1 [in] First version number to compare. - @param Ver2 [in] Second version number to compare. - @return True if Ver1 <> Ver2, False if not. - } -begin - Result := Ver1 <> Ver2; -end; - -class function TDatabasePreprocessor.PreProcess(Lines: IStringList): - IStringList; - {Performs pre-processing. - @param Lines [in] Lines of text to be pre-processed. - @return Lines after preprocessing. - } -var - LineIdx: Integer; // indexes each line - Line: string; // trimmed content of a line -begin - Result := TIStringList.Create; - LineIdx := 0; - while LineIdx < Lines.Count do - begin - Line := StrTrim(Lines[LineIdx]); - // Check for pre-processor instructions - if StrStartsStr(cIfVerLT, Line) then - Result.Add(ProcessVerLT(Lines, LineIdx)) - else if StrStartsStr(cIfVerGT, Line) then - Result.Add(ProcessVerGT(Lines, LineIdx)) - else if StrStartsStr(cIfVerInRange, Line) then - Result.Add(ProcessVerInRange(Lines, LineIdx)) - else if StrStartsStr(cIfVerEQ, Line) then - Result.Add(ProcessVerEQ(Lines, LineIdx)) - else if StrStartsStr(cIfVerNEQ, Line) then - Result.Add(ProcessVerNEQ(Lines, LineIdx)) - else if StrStartsStr(cPreProcPrefix, Line) then - // ignore unknown pre-proc dirs - else - // no pre-processor, just use trimmed line - Result.Add(Line); - Inc(LineIdx); - end; -end; - -class function TDatabasePreprocessor.ProcessToEndIf(const Lines: IStringList; - var LineIdx: Integer; const RecordLines: Boolean): IStringList; -begin - Inc(LineIdx); - Result := TIStringList.Create; - while (LineIdx < Lines.Count) and (StrTrim(Lines[LineIdx]) <> cEndIf) do - begin - if RecordLines then - Result.Add(Lines[LineIdx]); - Inc(LineIdx); - end; -end; - -class function TDatabasePreprocessor.ProcessVerCompare(const Lines: IStringList; - var LineIdx: Integer; const CompareFn: TVerCompareMethod): IStringList; - {Processes a version comparison directive. - @param Lines [in] Lines of ini file. - @param LineIdx [in/out] In: index of current line before processing. Out: - index of last line processed. - @param CompareFn [in] Method to used to compare application version with - version number read from directive to determine if directive executes. - } -var - InstParts: IStringList; // parts of the pre-processor instruction - Ver: TVersionNumber; // version number from directive -begin - // Get version number parameter - InstParts := TIStringList.Create(Lines[LineIdx], ' ', False, True); - if InstParts.Count >= 2 then - Ver := InstParts[1] // implicit conversion of string to TVersionNumber - else - Ver := TVersionNumber.Nul; // 0.0.0.0 - // Process lines up to endif - Result := ProcessToEndIf( - Lines, LineIdx, CompareFn(TVersionInfo.ProductVerNum, Ver) - ); -end; - -class function TDatabasePreprocessor.ProcessVerEQ(const Lines: IStringList; - var LineIdx: Integer): IStringList; - {Processes a ifvereq pre-processor directive. Includes lines before endif - directive only if condition is met, i.e. app version is equal to version - specified in directive. - @param Lines [in] Lines of ini file. - @param LineIdx [in/out] In: index of current line before processing. Out: - index of last line processed. - } -begin - Result := ProcessVerCompare(Lines, LineIdx, CompareEQ); -end; - -class function TDatabasePreprocessor.ProcessVerGT(const Lines: IStringList; - var LineIdx: Integer): IStringList; - {Processes a ifvergt pre-processor directive. Includes lines before endif - directive only if condition is met, i.e. app version is greater than - version specified in directive. - @param Lines [in] Lines of ini file. - @param LineIdx [in/out] In: index of current line before processing. Out: - index of last line processed. - } -begin - Result := ProcessVerCompare(Lines, LineIdx, CompareGT); -end; - -class function TDatabasePreprocessor.ProcessVerInRange(const Lines: IStringList; - var LineIdx: Integer): IStringList; - {Processes ifverinrange pre-processor directive. Includes lines before endif - directive only if condition is met, i.e. app version is in range of version - numbers specified in directive. - @param Lines [in] Lines of ini file. - @param LineIdx [in/out] In: index of current kine before processing. Out: - index of last line processed. - } -var - InstParts: IStringList; // parts of the pre-processor instruction - VerLo: TVersionNumber; // version number from directive - VerHi: TVersionNumber; // version number from directive - IncludeContents: Boolean; // flag true if enclosed lines to be included -begin - Result := TIStringList.Create; - // Get version number parameter - InstParts := TIStringList.Create(Lines[LineIdx], ' ', False, True); - if InstParts.Count < 3 then - IncludeContents := False - else - begin - VerLo := InstParts[1]; // implicit conversion of string to TVersionNumber - VerHi := InstParts[2]; // implicit conversion of string to TVersionNumber - IncludeContents := (TVersionInfo.ProductVerNum >= VerLo) and - (TVersionInfo.ProductVerNum <= VerHi); - end; - // Process lines up to endif - Result := ProcessToEndIf(Lines, LineIdx, IncludeContents); -end; - -class function TDatabasePreprocessor.ProcessVerLT(const Lines: IStringList; - var LineIdx: Integer): IStringList; - {Processes a ifverlt pre-processor directive. Includes lines before endif - directive only if condition is met, i.e. app version is less than version - specified in directive. - @param Lines [in] Lines of ini file. - @param LineIdx [in/out] In: index of current line before processing. Out: - index of last line processed. - } -begin - Result := ProcessVerCompare(Lines, LineIdx, CompareLT); -end; - -class function TDatabasePreprocessor.ProcessVerNEQ(const Lines: IStringList; - var LineIdx: Integer): IStringList; - {Processes a ifverneq pre-processor directive. Includes lines before endif - directive only if condition is met, i.e. app version is not equal to version - specified in directive. - @param Lines [in] Lines of ini file. - @param LineIdx [in/out] In: index of current line before processing. Out: - index of last line processed. - } -begin - Result := ProcessVerCompare(Lines, LineIdx, CompareNEQ); -end; - -end. - diff --git a/Src/UMainDBFileReader.pas b/Src/UMainDBFileReader.pas deleted file mode 100644 index d463babe8..000000000 --- a/Src/UMainDBFileReader.pas +++ /dev/null @@ -1,151 +0,0 @@ -{ - * This Source Code Form is subject to the terms of the Mozilla Public License, - * v. 2.0. If a copy of the MPL was not distributed with this file, You can - * obtain one at https://mozilla.org/MPL/2.0/ - * - * Copyright (C) 2005-2021, Peter Johnson (gravatar.com/delphidabbler). - * - * Implements class that can read files from main database using correct - * encoding. -} - - -unit UMainDBFileReader; - -interface - -uses - // Delphi - SysUtils, - // Project - UEncodings, UIStringList; - -type - /// - /// Loads files from main database, taking into account file encoding. - /// - /// - /// All files in database folder are assumed to have the same encoding. Only - /// one file is tested. - /// - TMainDBFileReader = class(TObject) - strict private - const - /// ANSI code page used for v4 and earlier database files. - /// - LegacyCodePage = TEncodingHelper.Windows1252CodePage; - var - /// Encoding to use when reading text files. - fEncoding: TEncoding; - /// - /// Detects encoding used by specified file. - /// - /// string [in] Name of file. - /// Required TEncoding instance. Callers should free this instance - /// if it not a standard encoding. - /// - /// Main database files created by CodeSnip v3 and earlier use the Default - /// encoding while those created by v4 use UTF-8 files that have the UTF-8 - /// preamble. - /// - function GetFileEncoding(const FileName: string): TEncoding; - public - /// - /// Object constructor. Sets up object to use encoding used for given - /// specimen file. - /// - constructor Create(const SpecimenFile: string); - /// - /// Object destructor. Tears down object. - /// - destructor Destroy; override; - /// - /// Reads all text from a text file using known encoding. - /// - /// string [in] Name of text file to read. - /// String containing contents of file. - function ReadAllText(const FileName: string): string; - /// - /// Reads all lines from a text file using known encoding. - /// - /// string [in] Name of text file to read. - /// IStringList object containing lines from file. - function ReadAllStrings(const FileName: string): IStringList; - end; - -implementation - - -uses - // Delphi - Classes, - // Project - UIOUtils; - - -{ TMainDBFileReader } - -constructor TMainDBFileReader.Create(const SpecimenFile: string); -begin - inherited Create; - fEncoding := GetFileEncoding(SpecimenFile); -end; - -destructor TMainDBFileReader.Destroy; -begin - TEncodingHelper.FreeEncoding(fEncoding); - inherited; -end; - -function TMainDBFileReader.GetFileEncoding(const FileName: string): TEncoding; - - /// Checks if two byte arrays are equal. - function BytesMatch(const BA1, BA2: TBytes): Boolean; - var - I: Integer; - begin - if Length(BA1) <> Length(BA2) then - Exit(False); - for I := 0 to Pred(Length(BA1)) do - if BA1[I] <> BA2[I] then - Exit(False); - Result := True; - end; - -var - FS: TFileStream; // stream onto file - Buffer: TBytes; // buffer containing first few bytes of file - UTF8Preamble: TBytes; // bytes of UTF-8 preamble -begin - UTF8Preamble := TEncoding.UTF8.GetPreamble; - Assert(Length(UTF8Preamble) > 0, - ClassName + '.GetFileEncoding: UTF-8 preamble has zero length'); - FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone); - try - if FS.Size >= Length(UTF8Preamble) then - begin - // read first few bytes of file to see if they match UTF-8 preamble - SetLength(Buffer, Length(UTF8Preamble)); - FS.ReadBuffer(Pointer(Buffer)^, Length(Buffer)); - if BytesMatch(Buffer, UTF8Preamble) then - Exit(TEncoding.UTF8); - end; - finally - FS.Free; - end; - Result := TEncodingHelper.GetEncoding(LegacyCodePage); -end; - -function TMainDBFileReader.ReadAllStrings(const FileName: string): IStringList; -begin - Result := TIStringList.Create( - TFileIO.ReadAllLines(FileName, fEncoding, True) - ); -end; - -function TMainDBFileReader.ReadAllText(const FileName: string): string; -begin - Result := TFileIO.ReadAllText(FileName, fEncoding, True); -end; - -end. diff --git a/Src/UMainDisplayMgr.pas b/Src/UMainDisplayMgr.pas index 15020fb34..578b68fc2 100644 --- a/Src/UMainDisplayMgr.pas +++ b/Src/UMainDisplayMgr.pas @@ -302,7 +302,9 @@ implementation // Delphi SysUtils, // Project - DB.UMain, UPreferences, UQuery; + DB.Main, + UPreferences, + UQuery; { TMainDisplayMgr } diff --git a/Src/UMarkdownSnippetDoc.pas b/Src/UMarkdownSnippetDoc.pas index aa931d2de..6c753221c 100644 --- a/Src/UMarkdownSnippetDoc.pas +++ b/Src/UMarkdownSnippetDoc.pas @@ -19,6 +19,7 @@ interface SysUtils, // Project ActiveText.UMain, + DB.Vaults, Hiliter.UGlobals, UEncodings, UIStringList, @@ -45,10 +46,12 @@ TMarkdownSnippetDoc = class sealed (TSnippetDoc) strict protected /// Initialises the Markdown document. procedure InitialiseDoc; override; - /// Adds the given heading (i.e. snippet name) to the document. - /// Can be user defined or from main database. - procedure RenderHeading(const Heading: string; const UserDefined: Boolean); - override; + /// Output given heading, i.e. snippet name for snippet from a + /// given vault. + /// Heading may be rendered differently depending on the snippet's + /// vault. + procedure RenderHeading(const Heading: string; + const AVaultID: TVaultID); override; /// Adds the given snippet description to the document. /// Active text formatting is observed and styled to suit the /// document. @@ -76,9 +79,8 @@ TMarkdownSnippetDoc = class sealed (TSnippetDoc) /// Active text formatting is observed and styled to suit the /// document. procedure RenderExtra(const ExtraText: IActiveText); override; - /// Adds the given information about a code snippets database to - /// the document. - procedure RenderDBInfo(const Text: string); override; + /// Output given information about a vault. + procedure RenderVaultInfo(const Text: string); override; /// Finalises the document and returns its content as encoded /// data. function FinaliseDoc: TEncodedData; override; @@ -156,13 +158,6 @@ procedure TMarkdownSnippetDoc.RenderCompilerInfo(const Heading: string; fDocument.AppendLine; end; -procedure TMarkdownSnippetDoc.RenderDBInfo(const Text: string); -begin - fDocument - .AppendLine(TMarkdown.WeakEmphasis(TMarkdown.EscapeText(Text))) - .AppendLine; -end; - procedure TMarkdownSnippetDoc.RenderDescription(const Desc: IActiveText); var DescStr: string; @@ -182,7 +177,7 @@ procedure TMarkdownSnippetDoc.RenderExtra(const ExtraText: IActiveText); end; procedure TMarkdownSnippetDoc.RenderHeading(const Heading: string; - const UserDefined: Boolean); + const AVaultID: TVaultID); begin fDocument .AppendLine(TMarkdown.Heading(TMarkdown.EscapeText(Heading), 1)) @@ -232,4 +227,11 @@ procedure TMarkdownSnippetDoc.RenderTitledText(const Title, Text: string); .AppendLine; end; +procedure TMarkdownSnippetDoc.RenderVaultInfo(const Text: string); +begin + fDocument + .AppendLine(TMarkdown.WeakEmphasis(TMarkdown.EscapeText(Text))) + .AppendLine; +end; + end. diff --git a/Src/UNotifier.pas b/Src/UNotifier.pas index fe3871df4..12cef6df1 100644 --- a/Src/UNotifier.pas +++ b/Src/UNotifier.pas @@ -19,7 +19,9 @@ interface // Delphi Classes, ActiveX, // Project - IntfNotifier, UView; + DB.Vaults, + IntfNotifier, + UView; type @@ -35,8 +37,6 @@ interface TNotifier = class(TInterfacedObject, INotifier, ISetActions) strict private var - /// Action that triggers a database update. - fUpdateDbaseAction: TBasicAction; /// Action that causes a named snippet to be displayed. /// fDisplaySnippetAction: TBasicAction; @@ -56,9 +56,6 @@ TNotifier = class(TInterfacedObject, INotifier, ISetActions) fEditSnippetAction: TBasicAction; /// Action that causes a category to be displayed. fDisplayCategoryAction: TBasicAction; - /// Action that causes the Snippets Editor to be opened ready to - /// create a new snippet. - fNewSnippetAction: TBasicAction; /// Action that causes news items from CodeSnip news feed to be /// displayed. fNewsAction: TBasicAction; @@ -67,20 +64,15 @@ TNotifier = class(TInterfacedObject, INotifier, ISetActions) public - /// Requests a database update. - /// Methods of INotifier. - procedure UpdateDbase; - /// Displays a snippet. - /// WideString [in] Name of required snippet. + /// WideString [in] Required snippet's key. /// - /// WordBool [in] Indicates whether snippet is - /// user defined. + /// TVaultID [in] ID of the snippet's + /// vault. /// WordBool [in] Whether to display snippet in a new /// detail pane tab. - /// Methods of INotifier. - procedure DisplaySnippet(const SnippetName: WideString; - UserDefined: WordBool; NewTab: WordBool); + procedure DisplaySnippet(const Key: WideString; AVaultID: TVaultID; + NewTab: WordBool); /// Displays a category. /// WideString [in] ID of required category. @@ -114,16 +106,11 @@ TNotifier = class(TInterfacedObject, INotifier, ISetActions) procedure ChangeDetailPane(const Pane: Integer); /// Edits a snippet in Snippets Editor. - /// WideString [in] Name of snippet. - /// - /// Snippet must be user defined. - /// Methods of INotifier. - /// - procedure EditSnippet(const SnippetName: WideString); - - /// Opens Snippets Editor ready to create a new snippet. - /// Methods of INotifier. - procedure NewSnippet; + /// WideString [in] Snippet's key. + /// TVaultID [in] ID of the snippet's + /// vault. + /// Method of INotifier. + procedure EditSnippet(const Key: WideString; const AVaultID: TVaultID); /// Displays news items from the CodeSnip news feed. /// Methods of INotifier. @@ -133,11 +120,6 @@ TNotifier = class(TInterfacedObject, INotifier, ISetActions) /// Methods of INotifier. procedure ShowAboutBox; - /// Sets action used to request a database update. - /// TBasicAction [in] Required action. - /// Methods of ISetActions. - procedure SetUpdateDbaseAction(const Action: TBasicAction); - /// Sets action used to display a snippet. /// TBasicAction [in] Required action. /// Methods of ISetActions. @@ -183,12 +165,6 @@ TNotifier = class(TInterfacedObject, INotifier, ISetActions) /// Methods of ISetActions. procedure SetDisplayCategoryAction(const Action: TBasicAction); - /// Sets action used to open snippets editor to create a new - /// snippet. - /// TBasicAction [in] Required action. - /// Methods of ISetActions. - procedure SetNewSnippetAction(const Action: TBasicAction); - /// Sets action used to display news items from the CodeSnip news /// feed. /// TBasicAction [in] Required action. @@ -211,6 +187,7 @@ implementation SysUtils, StdActns, // Project Compilers.UGlobals, + DB.SnippetIDs, UCategoryAction, UDetailTabAction, UEditSnippetAction, @@ -253,33 +230,30 @@ procedure TNotifier.DisplayCategory(const CatID: WideString; NewTab: WordBool); end; end; -procedure TNotifier.DisplaySnippet(const SnippetName: WideString; - UserDefined: WordBool; NewTab: WordBool); +procedure TNotifier.DisplaySnippet(const Key: WideString; AVaultID: TVaultID; + NewTab: WordBool); begin if Assigned(fDisplaySnippetAction) then begin - (fDisplaySnippetAction as TSnippetAction).SnippetName := SnippetName; - (fDisplaySnippetAction as TSnippetAction).UserDefined := UserDefined; + (fDisplaySnippetAction as TSnippetAction).Key := Key; + (fDisplaySnippetAction as TSnippetAction).VaultID := AVaultID; (fDisplaySnippetAction as TSnippetAction).NewTab := NewTab; fDisplaySnippetAction.Execute; end; end; -procedure TNotifier.EditSnippet(const SnippetName: WideString); +procedure TNotifier.EditSnippet(const Key: WideString; + const AVaultID: TVaultID); begin if Assigned(fEditSnippetAction) then begin - (fEditSnippetAction as TEditSnippetAction).SnippetName := SnippetName; + (fEditSnippetAction as TEditSnippetAction).ID := TSnippetID.Create( + Key, AVaultID + ); fEditSnippetAction.Execute; end; end; -procedure TNotifier.NewSnippet; -begin - if Assigned(fNewSnippetAction) then - fNewSnippetAction.Execute; -end; - procedure TNotifier.SetAboutBoxAction(const Action: TBasicAction); begin fAboutBoxAction := Action; @@ -330,11 +304,6 @@ procedure TNotifier.SetNewsAction(const Action: TBasicAction); fNewsAction := Action; end; -procedure TNotifier.SetNewSnippetAction(const Action: TBasicAction); -begin - fNewSnippetAction := Action; -end; - procedure TNotifier.SetOverviewStyleChangeActions( const Actions: array of TBasicAction); var @@ -350,12 +319,6 @@ procedure TNotifier.SetShowViewItemAction(const Action: TBasicAction); fShowViewItemAction := Action; end; -procedure TNotifier.SetUpdateDbaseAction( - const Action: TBasicAction); -begin - fUpdateDbaseAction := Action; -end; - procedure TNotifier.ShowAboutBox; begin if Assigned(fAboutBoxAction) then @@ -378,11 +341,5 @@ procedure TNotifier.ShowViewItem(ViewItem: IView; const NewTab: Boolean); end; end; -procedure TNotifier.UpdateDbase; -begin - if Assigned(fUpdateDbaseAction) then - fUpdateDbaseAction.Execute; -end; - end. diff --git a/Src/UOverviewTreeBuilder.pas b/Src/UOverviewTreeBuilder.pas index d9b61beb5..69f73e269 100644 --- a/Src/UOverviewTreeBuilder.pas +++ b/Src/UOverviewTreeBuilder.pas @@ -24,7 +24,10 @@ interface Generics.Collections, ComCtrls, // Project - DB.USnippet, UGroups, UView, UViewItemTreeNode; + DB.Snippets, + UGroups, + UView, + UViewItemTreeNode; type diff --git a/Src/UPreferences.pas b/Src/UPreferences.pas index 8bb265ec7..59eb7fba8 100644 --- a/Src/UPreferences.pas +++ b/Src/UPreferences.pas @@ -19,8 +19,15 @@ interface // Delphi Graphics, // Project - Hiliter.UGlobals, UIStringList, UMeasurement, UPrintInfo, - USnippetPageStructure, USourceFileInfo, USourceGen, UWarnings; + DB.Vaults, + Hiliter.UGlobals, + UIStringList, + UMeasurement, + UPrintInfo, + USnippetPageStructure, + USourceFileInfo, + USourceGen, + UWarnings; type @@ -147,44 +154,60 @@ interface property ShowNewSnippetsInNewTabs: Boolean read GetShowNewSnippetsInNewTabs write SetShowNewSnippetsInNewTabs; - /// Gets heading colour used for snippets from a specified - /// database. - /// Boolean [in] Required database: True for user - /// database and False for inline database. + /// Gets colour used for group heading / tree nodes. + /// TColor [in] Required colour. + function GetGroupHeadingColour: TColor; + /// Sets colour to be used for group heading / tree nodes. + /// + /// TColor [in] Colour to be used. + procedure SetGroupHeadingColour(const AColour: TColor); + /// Colour to be used for group headings / tree nodes. + property GroupHeadingColour: TColor + read GetGroupHeadingColour write SetGroupHeadingColour; + + /// Gets custom colours available for use for group headings / + /// tree nodes. + /// IStringList. List of hex representations of custom + /// colours. + function GetGroupHeadingCustomColours: IStringList; + /// Sets custom colours available for use for group headings / + /// tree nodes. + /// IStringList. List of hex representations + /// of custom colours. + procedure SetGroupHeadingCustomColours(const AColours: IStringList); + /// Custom colours available for use for group headings / + /// tree nodes. + property GroupHeadingCustomColours: IStringList + read GetGroupHeadingCustomColours write SetGroupHeadingCustomColours; + + /// Gets the heading / tree node colour used for snippets from a + /// specified vault. + /// TVaultID [in] ID of required vault. + /// /// TColor. Required colour. - function GetDBHeadingColour(UserDefined: Boolean): TColor; - /// Sets heading colour used for snippets from a specified - /// database. - /// Boolean [in] Required database: True for user - /// database and False for online database. - /// TColor [in] Required heading colour. - procedure SetDBHeadingColour(UserDefined: Boolean; + function GetSnippetHeadingColour(const AVaultID: TVaultID): TColor; + /// Sets heading / tree node colour used for snippets from a + /// specified vault. + /// TVaultID [in] ID of required vault. + /// + /// TColor. Required colour. + procedure SetSnippetHeadingColour(const AVaultID: TVaultID; const Value: TColor); - /// Records colour to be used for headings of items from either - /// online database (UserDefined = False) or user database (UserDefined = - /// True). - property DBHeadingColours[UserDefined: Boolean]: TColor - read GetDBHeadingColour write SetDBHeadingColour; - - /// Gets custom colours available for headings for specified - /// database. - /// Boolean [in] Required database: True for user - /// database and False for online database. - /// IStringList. String list containing custom colours. - function GetDBHeadingCustomColours(UserDefined: Boolean): IStringList; - /// Sets custom colours available for headings for specified - /// database. - /// Boolean [in] Required database: True for user - /// database and False for online database. - /// IStringList [in] String list containing custom - /// colours. - procedure SetDBHeadingCustomColours(UserDefined: Boolean; - Value: IStringList); - /// Records custom colours available for headings of items from - /// either online database (UserDefined = False) or user database - /// (UserDefined = True). - property DBHeadingCustomColours[UserDefined: Boolean]: IStringList - read GetDBHeadingCustomColours write SetDBHeadingCustomColours; + + /// Gets custom colours available for snippet headings / tree + /// nodes. + /// IStringList. String list containing custom colours. + /// + function GetSnippetHeadingCustomColours: IStringList; + /// Sets custom colours available for snippet headings / tree + /// nodes. + /// IStringList [in] String list containing + /// custom colours. + procedure SetSnippetHeadingCustomColours(const AColours: IStringList); + /// Custom colours available for snippet headings / tree nodes. + /// + property SnippetHeadingCustomColours: IStringList + read GetSnippetHeadingCustomColours write SetSnippetHeadingCustomColours; /// Gets size of font used in overview pane tree view. function GetOverviewFontSize: Integer; @@ -306,6 +329,8 @@ implementation uses // Delphi SysUtils, + Generics.Collections, + Generics.Defaults, // Project Hiliter.UAttrs, Hiliter.UPersist, IntfCommon, UExceptions, UColours, UFontHelper, USettings; @@ -350,17 +375,20 @@ TPreferences = class(TInterfacedObject, /// Indicates whether empty sections are displayed in overview /// pane. fShowEmptySections: Boolean; - /// Indicates whether new snippets and ca-tegories are displayed + /// Indicates whether new snippets and categories are displayed /// in new tabs in details pane. fShowNewSnippetsInNewTabs: Boolean; - /// Records colour to be used for headings of items from either - /// online database (UserDefined = False) or user database (UserDefined = - /// True). - fDBHeadingColours: array[Boolean] of TColor; - /// Records custom colours available for headings of items from - /// either online database (UserDefined = False) or user database - /// (UserDefined = True). - fDBHeadingCustomColours: array[Boolean] of IStringList; + /// Records colour to be used for group headings. + fGroupHeadingColour: TColor; + /// Records custom colours available for group headings. + /// + fGroupHeadingCustomColours: IStringList; + /// Records colour to be used for snippet headings and tree + /// nodes for each vault. + fSnippetHeadingColours: TDictionary; + /// Records custom colours available for snippet heading and + /// tree nodes. + fSnippetHeadingCustomColours: IStringList; /// Records size of font used in overview pane tree view. /// fOverviewFontSize: Integer; @@ -506,40 +534,67 @@ TPreferences = class(TInterfacedObject, /// Method of IPreferences. procedure SetShowNewSnippetsInNewTabs(const Value: Boolean); - /// Gets heading colour used for snippets from a specified - /// database. - /// Boolean [in] Required database: True for user - /// database and False for inline database. - /// TColor. Required colour. + /// Gets colour used for group heading / tree nodes. + /// TColor [in] Required colour. + /// Method of IPreferences. + function GetGroupHeadingColour: TColor; + + /// Sets colour to be used for group heading / tree nodes. + /// + /// TColor [in] Colour to be used. + /// Method of IPreferences. + procedure SetGroupHeadingColour(const AColour: TColor); + + /// Gets custom colours available for use for group headings / + /// tree nodes. + /// IStringList. List of hex representations of custom + /// colours. /// Method of IPreferences. - function GetDBHeadingColour(UserDefined: Boolean): TColor; + function GetGroupHeadingCustomColours: IStringList; - /// Sets heading colour used for snippets from a specified - /// database. - /// Boolean [in] Required database: True for user - /// database and False for online database. - /// TColor [in] Required heading colour. + /// Sets custom colours available for use for group headings / + /// tree nodes. + /// IStringList. List of hex representations + /// of custom colours. /// Method of IPreferences. - procedure SetDBHeadingColour(UserDefined: Boolean; + procedure SetGroupHeadingCustomColours(const AColours: IStringList); + + /// Gets the heading / tree node colour used for snippets from a + /// specified vault. + /// TVaultID [in] ID of required vault. + /// + /// TColor. Required colour. + /// Method of IPreferences. + function GetSnippetHeadingColour(const AVaultID: TVaultID): TColor; + + /// Sets heading / tree node colour used for snippets from a + /// specified vault. + /// TVaultID [in] ID of required vault. + /// + /// TColor. Required colour. + /// Method of IPreferences. + procedure SetSnippetHeadingColour(const AVaultID: TVaultID; const Value: TColor); - /// Gets custom colours available for headings for specified - /// database. - /// Boolean [in] Required database: True for user - /// database and False for online database. - /// IStringList. String list containing custom colours. - /// Method of IPreferences. - function GetDBHeadingCustomColours(UserDefined: Boolean): IStringList; - - /// Sets custom colours available for headings for specified - /// database. - /// Boolean [in] Required database: True for user - /// database and False for online database. - /// IStringList [in] String list containing custom - /// colours. - /// Method of IPreferences. - procedure SetDBHeadingCustomColours(UserDefined: Boolean; - Value: IStringList); + /// Gets custom colours available for snippet headings / tree + /// nodes. + /// IStringList. String list containing custom colours. + /// + /// + /// All vaults share this one custom colour list. + /// Method of IPreferences. + /// + function GetSnippetHeadingCustomColours: IStringList; + + /// Sets custom colours available for snippet headings / tree + /// nodes. + /// IStringList [in] String list containing + /// custom colours. + /// + /// All vaults share this one custom colour list. + /// Method of IPreferences. + /// + procedure SetSnippetHeadingCustomColours(const AColours: IStringList); /// Gets size of font used in overview pane tree view. /// Method of IPreferences. @@ -705,6 +760,7 @@ function Preferences: IPreferences; procedure TPreferences.Assign(const Src: IInterface); var SrcPref: IPreferences; // IPreferences interface of Src + Vault: TVault; begin // Get IPreferences interface of given object if not Supports(Src, IPreferences, SrcPref) then @@ -720,10 +776,13 @@ procedure TPreferences.Assign(const Src: IInterface); Self.fOverviewStartState := SrcPref.OverviewStartState; Self.fShowEmptySections := SrcPref.ShowEmptySections; Self.fShowNewSnippetsInNewTabs := SrcPref.ShowNewSnippetsInNewTabs; - Self.fDBHeadingColours[False] := SrcPref.DBHeadingColours[False]; - Self.fDBHeadingCustomColours[False] := SrcPref.DBHeadingCustomColours[False]; - Self.fDBHeadingColours[True] := SrcPref.DBHeadingColours[True]; - Self.fDBHeadingCustomColours[True] := SrcPref.DBHeadingCustomColours[True]; + Self.fGroupHeadingColour := SrcPref.GetGroupHeadingColour; + Self.fGroupHeadingCustomColours := SrcPref.GetGroupHeadingCustomColours; + for Vault in TVaults.Instance do + Self.SetSnippetHeadingColour( + Vault.UID, SrcPref.GetSnippetHeadingColour(Vault.UID) + ); + Self.fSnippetHeadingCustomColours := SrcPref.GetSnippetHeadingCustomColours; Self.fOverviewFontSize := SrcPref.OverviewFontSize; Self.fDetailFontSize := SrcPref.DetailFontSize; Self.fSourceCodeBGColour := SrcPref.SourceCodeBGColour; @@ -744,8 +803,9 @@ constructor TPreferences.Create; fNamedHiliteAttrs := THiliteAttrsFactory.CreateNamedAttrs; fHiliteCustomColours := TIStringList.Create; fWarnings := TWarnings.Create; - fDBHeadingCustomColours[False] := TIStringList.Create; - fDBHeadingCustomColours[True] := TIStringList.Create; + fSnippetHeadingColours := TDictionary.Create( + TVaultID.TComparer.Create + ); fPageStructures := TSnippetPageStructures.Create; TDefaultPageStructures.SetDefaults(fPageStructures); end; @@ -763,6 +823,7 @@ function TPreferences.DefaultOverviewFontSize: Integer; destructor TPreferences.Destroy; begin fPageStructures.Free; + fSnippetHeadingColours.Free; inherited; end; @@ -776,20 +837,19 @@ function TPreferences.GetCustomHiliteColours: IStringList; Result := fHiliteCustomColours; end; -function TPreferences.GetDBHeadingColour(UserDefined: Boolean): TColor; +function TPreferences.GetDetailFontSize: Integer; begin - Result := fDBHeadingColours[UserDefined]; + Result := fDetailFontSize; end; -function TPreferences.GetDBHeadingCustomColours( - UserDefined: Boolean): IStringList; +function TPreferences.GetGroupHeadingColour: TColor; begin - Result := fDBHeadingCustomColours[UserDefined]; + Result := fGroupHeadingColour; end; -function TPreferences.GetDetailFontSize: Integer; +function TPreferences.GetGroupHeadingCustomColours: IStringList; begin - Result := fDetailFontSize; + Result := fGroupHeadingCustomColours; end; function TPreferences.GetHiliteAttrs: IHiliteAttrs; @@ -847,6 +907,19 @@ function TPreferences.GetShowNewSnippetsInNewTabs: Boolean; Result := fShowNewSnippetsInNewTabs; end; +function TPreferences.GetSnippetHeadingColour(const AVaultID: TVaultID): TColor; +begin + if fSnippetHeadingColours.ContainsKey(AVaultID) then + Result := fSnippetHeadingColours[AVaultID] + else + Result := clDefSnippetHeading; +end; + +function TPreferences.GetSnippetHeadingCustomColours: IStringList; +begin + Result := fSnippetHeadingCustomColours; +end; + function TPreferences.GetSourceCodeBGColour: TColor; begin Result := fSourceCodeBGColour; @@ -892,24 +965,23 @@ procedure TPreferences.SetCustomHiliteColours(const Colours: IStringList); fHiliteCustomColours := Colours; end; -procedure TPreferences.SetDBHeadingColour(UserDefined: Boolean; - const Value: TColor); +procedure TPreferences.SetDetailFontSize(const Value: Integer); begin - fDBHeadingColours[UserDefined] := Value; + if TFontHelper.IsInCommonFontSizeRange(Value) then + fDetailFontSize := Value + else + fDetailFontSize := DefaultDetailFontSize; end; -procedure TPreferences.SetDBHeadingCustomColours(UserDefined: Boolean; - Value: IStringList); +procedure TPreferences.SetGroupHeadingColour(const AColour: TColor); begin - fDBHeadingCustomColours[UserDefined] := Value; + fGroupHeadingColour := AColour; end; -procedure TPreferences.SetDetailFontSize(const Value: Integer); +procedure TPreferences.SetGroupHeadingCustomColours( + const AColours: IStringList); begin - if TFontHelper.IsInCommonFontSizeRange(Value) then - fDetailFontSize := Value - else - fDetailFontSize := DefaultDetailFontSize; + fGroupHeadingCustomColours := AColours; end; procedure TPreferences.SetHiliteAttrs(const Attrs: IHiliteAttrs); @@ -971,6 +1043,18 @@ procedure TPreferences.SetShowNewSnippetsInNewTabs(const Value: Boolean); fShowNewSnippetsInNewTabs := Value; end; +procedure TPreferences.SetSnippetHeadingColour(const AVaultID: TVaultID; + const Value: TColor); +begin + fSnippetHeadingColours.AddOrSetValue(AVaultID, Value); +end; + +procedure TPreferences.SetSnippetHeadingCustomColours( + const AColours: IStringList); +begin + fSnippetHeadingCustomColours := AColours; +end; + procedure TPreferences.SetSourceCodeBGColour(const Value: TColor); begin fSourceCodeBGColour := Value; @@ -1011,6 +1095,7 @@ procedure TPreferences.SetWarnings(Warnings: IWarnings); function TPreferencesPersist.Clone: IInterface; var NewPref: IPreferences; // reference to new object's IPreferences interface + Vault: TVault; begin // Create new object Result := TPreferences.Create; @@ -1026,10 +1111,13 @@ function TPreferencesPersist.Clone: IInterface; NewPref.OverviewStartState := Self.fOverviewStartState; NewPref.ShowEmptySections := Self.fShowEmptySections; NewPref.ShowNewSnippetsInNewTabs := Self.fShowNewSnippetsInNewTabs; - NewPref.DBHeadingColours[False] := Self.fDBHeadingColours[False]; - NewPref.DBHeadingCustomColours[False] := Self.fDBHeadingCustomColours[False]; - NewPref.DBHeadingColours[True] := Self.fDBHeadingColours[True]; - NewPref.DBHeadingCustomColours[True] := Self.fDBHeadingCustomColours[True]; + NewPref.GroupHeadingColour := Self.fGroupHeadingColour; + NewPref.GroupHeadingCustomColours := Self.fGroupHeadingCustomColours; + for Vault in TVaults.Instance do + NewPref.SetSnippetHeadingColour( + Vault.UID, Self.GetSnippetHeadingColour(Vault.UID) + ); + NewPref.SnippetHeadingCustomColours := Self.fSnippetHeadingCustomColours; NewPref.OverviewFontSize := Self.fOverviewFontSize; NewPref.DetailFontSize := Self.fDetailFontSize; NewPref.SourceCodeBGColour := Self.fSourceCodeBGColour; @@ -1046,6 +1134,7 @@ function TPreferencesPersist.Clone: IInterface; constructor TPreferencesPersist.Create; var Storage: ISettingsSection; // object used to access persistent storage + Vault: TVault; const // Default margin size in millimeters cPrintPageMarginSizeMM = 25.0; @@ -1071,20 +1160,32 @@ constructor TPreferencesPersist.Create; fShowNewSnippetsInNewTabs := Storage.GetBoolean( 'ShowNewSnippetsInNewTabs', False ); - fDBHeadingColours[False] := TColor( - Storage.GetInteger('MainDBHeadingColour', clMainSnippet) - ); - fDBHeadingColours[True] := TColor( - Storage.GetInteger('UserDBHeadingColour', clUserSnippet) - ); fSourceCodeBGColour := TColor( Storage.GetInteger('SourceCodeBGColour', clSourceBg) ); - fDBHeadingCustomColours[False] := Storage.GetStrings( - 'MainDBHeadingCustomColourCount', 'MainDBHeadingCustomColour%d' + fGroupHeadingColour := TColor( + Storage.GetInteger('GroupHeadingColour', clDefGroupHeading) + ); + fGroupHeadingCustomColours := Storage.GetStrings( + 'GroupHeadingCustomColourCount', 'GroupHeadingCustomColour%d' ); - fDBHeadingCustomColours[True] := Storage.GetStrings( - 'UserDBHeadingCustomColourCount', 'UserDBHeadingCustomColour%d' + + fSnippetHeadingColours.Clear; + for Vault in TVaults.Instance do + begin + fSnippetHeadingColours.AddOrSetValue( + Vault.UID, + TColor( + Storage.GetInteger( + 'SnippetHeadingColour:' + Vault.UID.ToHexString, + clDefSnippetHeading + ) + ) + ); + end; + + fSnippetHeadingCustomColours := Storage.GetStrings( + 'SnippetHeadingCustomColourCount', 'SnippetHeadingCustomColour%d' ); fOverviewFontSize := Storage.GetInteger( 'OverviewFontSize', DefaultOverviewFontSize @@ -1145,6 +1246,7 @@ constructor TPreferencesPersist.Create; destructor TPreferencesPersist.Destroy; var Storage: ISettingsSection; // object used to access persistent storage + Vault: TVault; begin // Wreite meta section (no sub-section name) Storage := Settings.EmptySection(ssPreferences); @@ -1161,21 +1263,33 @@ destructor TPreferencesPersist.Destroy; Storage.SetInteger('OverviewStartState', Ord(fOverviewStartState)); Storage.SetBoolean('ShowEmptySections', fShowEmptySections); Storage.SetBoolean('ShowNewSnippetsInNewTabs', fShowNewSnippetsInNewTabs); - Storage.SetInteger('MainDBHeadingColour', fDBHeadingColours[False]); - Storage.SetInteger('UserDBHeadingColour', fDBHeadingColours[True]); - Storage.SetInteger('OverviewFontSize', fOverviewFontSize); - Storage.SetInteger('DetailFontSize', fDetailFontSize); - Storage.SetInteger('SourceCodeBGColour', fSourceCodeBGColour); + Storage.SetInteger('GroupHeadingColour', fGroupHeadingColour); Storage.SetStrings( - 'MainDBHeadingCustomColourCount', - 'MainDBHeadingCustomColour%d', - fDBHeadingCustomColours[False] + 'GroupHeadingCustomColourCount', + 'GroupHeadingCustomColour%d', + fGroupHeadingCustomColours ); + for Vault in TVaults.Instance do + begin + if fSnippetHeadingColours.ContainsKey(Vault.UID) then + Storage.SetInteger( + 'SnippetHeadingColour:' + Vault.UID.ToHexString, + fSnippetHeadingColours[Vault.UID] + ) + else + Storage.SetInteger( + 'SnippetHeadingColour:' + Vault.UID.ToHexString, + clDefSnippetHeading + ) + end; Storage.SetStrings( - 'UserDBHeadingCustomColourCount', - 'UserDBHeadingCustomColour%d', - fDBHeadingCustomColours[True] + 'SnippetHeadingCustomColourCount', + 'SnippetHeadingCustomColour%d', + fSnippetHeadingCustomColours ); + Storage.SetInteger('OverviewFontSize', fOverviewFontSize); + Storage.SetInteger('DetailFontSize', fDetailFontSize); + Storage.SetInteger('SourceCodeBGColour', fSourceCodeBGColour); Storage.SetStrings( 'SourceCodeBGCustomColourCount', 'SourceCodeBGCustomColour%d', diff --git a/Src/UPrintDocuments.pas b/Src/UPrintDocuments.pas index 51b6600a1..0f2e0fd00 100644 --- a/Src/UPrintDocuments.pas +++ b/Src/UPrintDocuments.pas @@ -20,7 +20,10 @@ interface // Delphi Classes, // Project - DB.UCategory, DB.USnippet, Hiliter.UGlobals, URTFUtils; + DB.Categories, + DB.Snippets, + Hiliter.UGlobals, + URTFUtils; type diff --git a/Src/UPrintMgr.pas b/Src/UPrintMgr.pas index 825753c5a..a1df2c851 100644 --- a/Src/UPrintMgr.pas +++ b/Src/UPrintMgr.pas @@ -20,7 +20,12 @@ interface // Delphi Classes, // Project - DB.USnippet, UBaseObjects, UPrintDocuments, UPrintInfo, URTFUtils, UView; + DB.Snippets, + UBaseObjects, + UPrintDocuments, + UPrintInfo, + URTFUtils, + UView; type diff --git a/Src/UQuery.pas b/Src/UQuery.pas index a3af9870d..49fca8d51 100644 --- a/Src/UQuery.pas +++ b/Src/UQuery.pas @@ -18,7 +18,9 @@ interface uses // Project - DB.UCategory, DB.USnippet, USearch; + DB.Categories, + DB.Snippets, + USearch; type @@ -90,9 +92,12 @@ implementation uses // Delphi - SysUtils, Generics.Collections, + SysUtils, + Generics.Collections, // Project - DB.UMain, UBaseObjects, USingleton; + DB.Main, + UBaseObjects, + USingleton; type diff --git a/Src/UREMLDataIO.pas b/Src/UREMLDataIO.pas index f96e95c65..5be7411f7 100644 --- a/Src/UREMLDataIO.pas +++ b/Src/UREMLDataIO.pas @@ -132,28 +132,45 @@ TREMLWriter = class(TNoPublicConstructObject) @param Text [in] Plain text to be converted. @return Converted text. } - function RenderTag(const TagElem: IActiveTextActionElem): string; - {Renders an active text action element as a REML tag. - @param TagElem [in] Active text action element to be rendered. - @return Required REML tag. - } - function RenderText(const TextElem: IActiveTextTextElem): string; - {Renders an active text text element. Illegal characters are converted to - REML character entities. - @param TextElem [in] Active text text element. - @return REML-safe text containing necessary character entities. - } + /// Renders an active text action element as a REML tag. + /// IActiveTextActionElem [in] Active text + /// action element to be rendered. + /// Boolean [in] Optional flag that + /// determines if tag is to be rendered formatted as multiple, indented + /// lines of REML code (True) or with no formatting (False). + /// string. Required REML tag. + function RenderTag(const TagElem: IActiveTextActionElem; + const Formatted: Boolean): string; + + /// Renders an active text text element. Illegal characters are + /// converted to REML character entities. + /// IActiveTextTextElem [in] Active text text + /// element to be rendered. + /// Boolean [in] Optional flag that + /// determines if text is to be rendered indented (True) or not (False). + /// + /// string. REML-safe text containing necessary character + /// entities. + function RenderText(const TextElem: IActiveTextTextElem; + const Indented: Boolean): string; + strict protected constructor InternalCreate; - {Internal class constructor. Sets up object to render active text document + {Internal constructor. Sets up object to render active text document as REML. } public - class function Render(const ActiveText: IActiveText): string; - {Renders REML representation of an active text object. - @param ActiveText [in] Active text to be rendered. - @return String containing REML markup. - } + /// Renders REML representation of an active text object. + /// + /// IActiveText [in] Active text to be + /// rendered. + /// Boolean [in] Optional flag that + /// determines if REML is to be rendered formatted as multiple lines of + /// indented text (True: the default) or as a single line of text with no + /// formatting (False). + /// string containing REML markup. + class function Render(const ActiveText: IActiveText; + const Formatted: Boolean = True): string; end; @@ -725,11 +742,8 @@ constructor TREMLWriter.InternalCreate; inherited InternalCreate; end; -class function TREMLWriter.Render(const ActiveText: IActiveText): string; - {Renders REML representation of an active text object. - @param ActiveText [in] Active text to be rendered. - @return String containing REML markup. - } +class function TREMLWriter.Render(const ActiveText: IActiveText; + const Formatted: Boolean): string; var Elem: IActiveTextElem; // each element in active text object TextElem: IActiveTextTextElem; // an active text text element @@ -750,30 +764,31 @@ class function TREMLWriter.Render(const ActiveText: IActiveText): string; for Elem in ActiveText do begin if Supports(Elem, IActiveTextTextElem, TextElem) then - Text := Text + RW.RenderText(TextElem) + Text := Text + RW.RenderText(TextElem, Formatted) else if Supports(Elem, IActiveTextActionElem, TagElem) then - Text := Text + RW.RenderTag(TagElem); + Text := Text + RW.RenderTag(TagElem, Formatted); end; - SrcLines := TIStringList.Create(Text, EOL, False); - DestLines := TIStringList.Create; - for SrcLine in SrcLines do + if Formatted then begin - DestLine := StrTrimRight(SrcLine); - if not StrIsEmpty(DestLine) then - DestLines.Add(DestLine); - end; - Result := DestLines.GetText(EOL, False); + SrcLines := TIStringList.Create(Text, EOL, False); + DestLines := TIStringList.Create; + for SrcLine in SrcLines do + begin + DestLine := StrTrimRight(SrcLine); + if not StrIsEmpty(DestLine) then + DestLines.Add(DestLine); + end; + Result := DestLines.GetText(EOL, False); + end + else + Result := StrTrim(Text); finally RW.Free; end; end; -function TREMLWriter.RenderTag( - const TagElem: IActiveTextActionElem): string; - {Renders an active text action element as a REML tag. - @param TagElem [in] Active text action element to be rendered. - @return Required REML tag. - } +function TREMLWriter.RenderTag(const TagElem: IActiveTextActionElem; + const Formatted: Boolean): string; var TagName: string; // name of tag ParamName: string; // name of any parameter @@ -791,7 +806,8 @@ function TREMLWriter.RenderTag( if TActiveTextElemCaps.DisplayStyleOf(TagElem.Kind) = dsBlock then begin Dec(fLevel); - Result := EOL + StrOfSpaces(IndentMult * fLevel) + Result + EOL; + if Formatted then + Result := EOL + StrOfSpaces(IndentMult * fLevel) + Result + EOL; fIsStartOfTextLine := True; end; end @@ -821,7 +837,8 @@ function TREMLWriter.RenderTag( ); if TActiveTextElemCaps.DisplayStyleOf(TagElem.Kind) = dsBlock then begin - Result := EOL + StrOfSpaces(IndentMult * fLevel) + Result + EOL; + if Formatted then + Result := EOL + StrOfSpaces(IndentMult * fLevel) + Result + EOL; Inc(fLevel); fIsStartOfTextLine := True; end @@ -829,7 +846,8 @@ function TREMLWriter.RenderTag( begin if fIsStartOfTextLine then begin - Result := StrOfSpaces(IndentMult * fLevel) + Result; + if Formatted then + Result := StrOfSpaces(IndentMult * fLevel) + Result; fIsStartOfTextLine := False; end; end; @@ -845,15 +863,10 @@ function TREMLWriter.RenderTag( end; end; -function TREMLWriter.RenderText( - const TextElem: IActiveTextTextElem): string; - {Renders an active text text element. Illegal characters are converted to - REML character entities. - @param TextElem [in] Active text text element. - @return REML-safe text containing necessary character entities. - } +function TREMLWriter.RenderText(const TextElem: IActiveTextTextElem; + const Indented: Boolean): string; begin - if fIsStartOfTextLine then + if fIsStartOfTextLine and Indented then begin Result := StrOfSpaces(IndentMult * fLevel); fIsStartOfTextLine := False; diff --git a/Src/URTFCategoryDoc.pas b/Src/URTFCategoryDoc.pas index c867c603a..192decb40 100644 --- a/Src/URTFCategoryDoc.pas +++ b/Src/URTFCategoryDoc.pas @@ -20,7 +20,11 @@ interface // Delphi Graphics, // Project - ActiveText.URTFRenderer, DB.UCategory, DB.USnippet, UEncodings, URTFBuilder, + ActiveText.URTFRenderer, + DB.Categories, + DB.Snippets, + UEncodings, + URTFBuilder, URTFStyles; @@ -90,12 +94,17 @@ implementation uses // Project - ActiveText.UMain, UColours, UPreferences; + ActiveText.UMain, + DB.Vaults, + UColours, + UPreferences; { TRTFCategoryDoc } constructor TRTFCategoryDoc.Create(const UseColour: Boolean); +var + Vault: TVault; begin inherited Create; fUseColour := UseColour; @@ -104,8 +113,11 @@ constructor TRTFCategoryDoc.Create(const UseColour: Boolean); fBuilder.FontTable.Add(MainFontName, rgfSwiss, 0); fBuilder.FontTable.Add(MonoFontName, rgfModern, 0); // Set up colour table - fBuilder.ColourTable.Add(Preferences.DBHeadingColours[False]); - fBuilder.ColourTable.Add(Preferences.DBHeadingColours[True]); + for Vault in TVaults.Instance do + fBuilder.ColourTable.Add( + Preferences.GetSnippetHeadingColour(Vault.UID) + ); + fBuilder.ColourTable.Add(Preferences.GroupHeadingColour); fBuilder.ColourTable.Add(clExternalLink); fDescStyles := TActiveTextRTFStyleMap.Create; InitStyles; @@ -214,7 +226,7 @@ procedure TRTFCategoryDoc.OutputCategoryHeading(const Category: TCategory); fBuilder.SetFont(MainFontName); fBuilder.SetFontSize(HeadingFontSize); fBuilder.SetFontStyle([fsBold]); - SetColour(Preferences.DBHeadingColours[Category.UserDefined]); + SetColour(Preferences.GroupHeadingColour); fBuilder.AddText(Category.Description); fBuilder.EndPara; fBuilder.EndGroup; @@ -227,7 +239,7 @@ procedure TRTFCategoryDoc.OutputSnippetSubHeading(const Snippet: TSnippet); fBuilder.SetFont(MainFontName); fBuilder.SetFontSize(SubHeadingFontSize); fBuilder.SetFontStyle([fsBold]); - SetColour(Preferences.DBHeadingColours[Snippet.UserDefined]); + SetColour(Preferences.GetSnippetHeadingColour(Snippet.VaultID)); fBuilder.AddText(Snippet.DisplayName); fBuilder.EndPara; fBuilder.EndGroup; diff --git a/Src/URTFSnippetDoc.pas b/Src/URTFSnippetDoc.pas index 4bb6399c1..f8d3bda86 100644 --- a/Src/URTFSnippetDoc.pas +++ b/Src/URTFSnippetDoc.pas @@ -18,8 +18,15 @@ interface uses // Project - ActiveText.UMain, ActiveText.URTFRenderer, Hiliter.UGlobals, UEncodings, - UIStringList, USnippetDoc, URTFBuilder, URTFStyles; + ActiveText.UMain, + ActiveText.URTFRenderer, + DB.Vaults, + Hiliter.UGlobals, + UEncodings, + UIStringList, + USnippetDoc, + URTFBuilder, + URTFStyles; type @@ -75,11 +82,11 @@ TRTFSnippetDoc = class(TSnippetDoc) strict protected /// Initialises rich text document. procedure InitialiseDoc; override; - /// Adds given heading (i.e. snippet name) to document. Can be - /// user defined or from main database. - /// Heading is coloured according to whether user defined or not. + /// Output given heading, i.e. snippet name for snippet from a + /// given vault. + /// Heading is coloured according the the snippet's vault. /// - procedure RenderHeading(const Heading: string; const UserDefined: Boolean); + procedure RenderHeading(const Heading: string; const AVaultID: TVaultID); override; /// Adds given snippet description to document. /// Active text formatting is observed and styled to suit @@ -106,9 +113,8 @@ TRTFSnippetDoc = class(TSnippetDoc) /// Active text formatting is observed and styled to suit /// document. procedure RenderExtra(const ExtraText: IActiveText); override; - /// Adds given information about code snippets database to - /// document. - procedure RenderDBInfo(const Text: string); override; + /// Output given information about a vault. + procedure RenderVaultInfo(const Text: string); override; /// Finalises document and returns content as encoded data. /// function FinaliseDoc: TEncodedData; override; @@ -162,6 +168,8 @@ function TRTFSnippetDoc.FinaliseDoc: TEncodedData; end; procedure TRTFSnippetDoc.InitialiseDoc; +var + Vault: TVault; begin // Create object used to build main rich text document fBuilder := TRTFBuilder.Create(0); // Use default code page @@ -172,8 +180,10 @@ procedure TRTFSnippetDoc.InitialiseDoc; fBuilder.ColourTable.Add(clWarningText); fBuilder.ColourTable.Add(clVarText); fBuilder.ColourTable.Add(clExternalLink); - fBuilder.ColourTable.Add(Preferences.DBHeadingColours[False]); - fBuilder.ColourTable.Add(Preferences.DBHeadingColours[True]); + for Vault in TVaults.Instance do + fBuilder.ColourTable.Add( + Preferences.GetSnippetHeadingColour(Vault.UID) + ); end; procedure TRTFSnippetDoc.InitStyles; @@ -371,17 +381,6 @@ procedure TRTFSnippetDoc.RenderCompilerInfo(const Heading: string; end; end; -procedure TRTFSnippetDoc.RenderDBInfo(const Text: string); -begin - fBuilder.SetParaSpacing(TRTFParaSpacing.Create(ParaSpacing, 0.0)); - fBuilder.SetFontSize(DBInfoFontSize); - fBuilder.SetFontStyle([fsItalic]); - fBuilder.AddText(Text); - fBuilder.EndPara; - fBuilder.ClearParaFormatting; - fBuilder.ResetCharStyle; -end; - procedure TRTFSnippetDoc.RenderDescription(const Desc: IActiveText); var RTFWriter: TActiveTextRTF; // Object that generates RTF from active text @@ -417,12 +416,12 @@ procedure TRTFSnippetDoc.RenderExtra(const ExtraText: IActiveText); end; procedure TRTFSnippetDoc.RenderHeading(const Heading: string; - const UserDefined: Boolean); + const AVaultID: TVaultID); begin fBuilder.SetFontStyle([fsBold]); fBuilder.SetFontSize(HeadingFontSize); if fUseColour then - fBuilder.SetColour(Preferences.DBHeadingColours[UserDefined]); + fBuilder.SetColour(Preferences.GetSnippetHeadingColour(AVaultID)); fBuilder.SetParaSpacing(TRTFParaSpacing.Create(0.0, ParaSpacing)); fBuilder.AddText(Heading); fBuilder.EndPara; @@ -486,5 +485,16 @@ procedure TRTFSnippetDoc.RenderTitledText(const Title, Text: string); fBuilder.EndPara; end; +procedure TRTFSnippetDoc.RenderVaultInfo(const Text: string); +begin + fBuilder.SetParaSpacing(TRTFParaSpacing.Create(ParaSpacing, 0.0)); + fBuilder.SetFontSize(DBInfoFontSize); + fBuilder.SetFontStyle([fsItalic]); + fBuilder.AddText(Text); + fBuilder.EndPara; + fBuilder.ClearParaFormatting; + fBuilder.ResetCharStyle; +end; + end. diff --git a/Src/UReservedCategories.pas b/Src/UReservedCategories.pas deleted file mode 100644 index dc8db26e4..000000000 --- a/Src/UReservedCategories.pas +++ /dev/null @@ -1,166 +0,0 @@ -{ - * This Source Code Form is subject to the terms of the Mozilla Public License, - * v. 2.0. If a copy of the MPL was not distributed with this file, You can - * obtain one at https://mozilla.org/MPL/2.0/ - * - * Copyright (C) 2009-2021, Peter Johnson (gravatar.com/delphidabbler). - * - * Implements a static class that provides information about reserved user - * defined categories. -} - - -unit UReservedCategories; - - -interface - - -uses - // Project - DB.UCategory, UBaseObjects; - - -type - - { - TReservedCategoryInfo: - Record that fully describes a category, i.e. contains all the required data. - } - TReservedCategoryInfo = record - Name: string; // Name (unique id) of category - Data: TCategoryData; // Category's properties - procedure Assign(const Src: TReservedCategoryInfo); - {Sets this record's fields to be same as another TReservedCategoryInfo - record. - @param Src [in] Record containing fields to be copied. - } - procedure Init; - {Initialises record to nul values. - } - end; - - { - TReservedCategories: - Static class that provides information about reserved user defined - categories. - } - TReservedCategories = class(TNoConstructObject) - strict private - class function IsReservedName(const CatID: string): Boolean; - {Checks if a category name is the id of a reserved category. - @param CatID [in] ID to be checked. - @return True if category is reserved, False if not. - } - public - const UserCatID = 'user'; // default category for user snippets - const ImportsCatID = 'imports'; // category for imported user snippets - const SWAGCatID = '_swag_'; // category for imported SWAG snippets - class function IsReserved(const Cat: TCategory): Boolean; - {Checks if a category is reserved. - @param Cat [in] Category to be checked. - @return True if category is reserved, False if not. - } - class function Info(Idx: Integer): TReservedCategoryInfo; - {Gets information about a reserved category. - @param Idx [in] Index of required category. - @return Record containing information about category. - } - class function Count: Integer; - {Gets number of reserved categories. - @return Number of reserved categories. - } - end; - - -implementation - - -uses - // Delphi - Windows {for inlining}, - // Project - UStrUtils; - - -resourcestring - // Default reserved category descriptions - sUserDesc = 'User Defined Snippets'; - sImportsDesc = 'Imported Snippets'; - sSWAGDesc = 'SWAG Imports'; - -const - // Maps reserved category ids onto info that describes category - cReservedCats: array[0..2] of TReservedCategoryInfo = ( - (Name: TReservedCategories.UserCatID; Data: (Desc: sUserDesc)), - (Name: TReservedCategories.ImportsCatID; Data: (Desc: sImportsDesc)), - (Name: TReservedCategories.SWAGCatID; Data: (Desc: sSWAGDesc)) - ); - -{ TReservedCategories } - -class function TReservedCategories.Count: Integer; - {Gets number of reserved categories. - @return Number of reserved categories. - } -begin - Result := Length(cReservedCats); -end; - -class function TReservedCategories.Info(Idx: Integer): TReservedCategoryInfo; - {Gets information about a reserved category. - @param Idx [in] Index of required category. - @return Record containing information about category. - } -begin - Result.Assign(cReservedCats[Idx]); -end; - -class function TReservedCategories.IsReserved(const Cat: TCategory): Boolean; - {Checks if a category is reserved. - @param Cat [in] Category to be checked. - @return True if category is reserved, False if not. - } -begin - Result := IsReservedName(Cat.ID); -end; - -class function TReservedCategories.IsReservedName( - const CatID: string): Boolean; - {Checks if a category name is the id of a reserved category. - @param CatID [in] ID to be checked. - @return True if category is reserved, False if not. - } -var - Idx: Integer; // loops thru all reserved categories -begin - Result := False; - for Idx := 0 to Pred(Count) do - if StrSameText(CatID, Info(Idx).Name) then - begin - Result := True; - Exit; - end; -end; - -{ TReservedCategoryInfo } - -procedure TReservedCategoryInfo.Assign(const Src: TReservedCategoryInfo); - {Sets this record's fields to be same as another TReservedCategoryInfo record. - @param Src [in] Record containing fields to be copied. - } -begin - Name := Src.Name; - Data.Assign(Src.Data); -end; - -procedure TReservedCategoryInfo.Init; - {Initialises record to nul values. - } -begin - Name := ''; - Data.Init; -end; - -end. - diff --git a/Src/USaveInfoMgr.pas b/Src/USaveInfoMgr.pas index 6f71937d1..9b9daf380 100644 --- a/Src/USaveInfoMgr.pas +++ b/Src/USaveInfoMgr.pas @@ -120,7 +120,7 @@ implementation SysUtils, Dialogs, // Project - DB.USnippetKind, + DB.SnippetKind, FmPreviewDlg, Hiliter.UAttrs, Hiliter.UFileHiliter, diff --git a/Src/USaveUnitMgr.pas b/Src/USaveUnitMgr.pas index e94a17757..908448b98 100644 --- a/Src/USaveUnitMgr.pas +++ b/Src/USaveUnitMgr.pas @@ -17,8 +17,15 @@ interface uses + // Delphi + Generics.Collections, // Project - DB.USnippet, UIStringList, USourceFileInfo, USaveSourceMgr, USourceGen; + DB.Snippets, + DB.Vaults, + UIStringList, + USourceFileInfo, + USaveSourceMgr, + USourceGen; type @@ -38,9 +45,9 @@ TSaveUnitMgr = class(TSaveSourceMgr) /// Name of generated unit. /// If empty string a default name is used. fUnitName: string; - /// Flag true if unit contains at least one snippet from main - /// database, False only if unit is completely user defined. - fContainsMainDBSnippets: Boolean; + /// List of vaults that have contributed snippets to the source + /// code being generated. + fVaults: TList; /// Gets name of unit to be used in generated code. function UnitName: string; /// Creates a string list containing comments to be written to @@ -96,8 +103,10 @@ implementation // Delphi SysUtils, // Project - DB.UMetaData, + DB.DataFormats, + DB.MetaData, UAppInfo, + UStrUtils, UConsts, UPreferences, UUrl, @@ -118,16 +127,10 @@ implementation // Error message sErrorMsg = 'Filename is not valid for a Pascal unit'; // Unit header comments - sLicense = 'The unit is copyright ' - + COPYRIGHT - + ' %0:s by %1:s and is licensed under the %2:s.'; - sMainDescription = 'This unit was generated automatically. It incorporates a ' - + 'selection of source code taken from the Code Snippets Database at %0:s.'; - sGenerated = 'Generated on : %0:s.'; - sGenerator = 'Generated by : %0:s %1:s.'; - sAdvert = 'The latest version of %0:s is available from the CodeSnip GitHub ' - + 'project at %1:s.'; - sUserDescription = 'This unit was generated automatically.'; + sMainGenerator = 'This unit snippet was generated by %0:s %1:s on %2:s.'; + sVault = 'The code was sourced from the %s vault.'; + sVaultList = 'The code was sourced from the following vaults:'; + sVaultCredit = 'Vault "%0:s" is licensed under the %1:s'; // Output document title sDocTitle = 'Pascal unit generated by %s'; @@ -148,54 +151,69 @@ procedure TSaveUnitMgr.CheckFileName(const FileName: string; end; function TSaveUnitMgr.CreateHeaderComments: IStringList; + + {TODO -cRefactoring: This code has a lot in common with header comment + generator code in USnippetSourceGen and in TSnippetDoc.VaultInfo + - extract common code.} + + function CreditsLine(const AVault: TVault): string; + var + MetaData: TMetaData; + begin + MetaData := AVault.MetaData; + Result := ''; + if TMetaDataCap.License in MetaData.Capabilities then + begin + Result := Result + StrMakeSentence(MetaData.LicenseInfo.NameWithURL); + end; + if TMetaDataCap.Copyright in MetaData.Capabilities then + begin + if not StrIsEmpty(Result) then + Result := Result + ' '; + Result := Result + StrMakeSentence(MetaData.CopyrightInfo.ToString); + end; + end; + var - DBMetaData: IDBMetaData; + Vault: TVault; + Credits: string; begin Result := TIStringList.Create; - if fContainsMainDBSnippets then - begin - // Result used for units that contain any snippet(s) from main database - Result.Add(Format(sMainDescription, [TURL.CodeSnippetsDBRepo])); - Result.Add(''); - DBMetaData := TMainDBMetaDataFactory.MainDBMetaDataInstance; - Result.Add( - Format( - sLicense, - [ - DBMetaData.GetCopyrightInfo.Date, - DBMetaData.GetCopyrightInfo.Holder, - DBMetaData.GetLicenseInfo.NameWithURL - ] - ) - ); - Result.Add(''); - Result.Add(Format(sGenerated, [RFC1123DateStamp])); - Result.Add( - Format( - sGenerator, [TAppInfo.FullProgramName, TAppInfo.ProgramReleaseInfo] - ) - ); - Result.Add(''); - Result.Add( - Format(sAdvert, [TAppInfo.ProgramName, TURL.CodeSnipRepo]) - ); - end + + Result.Add( + Format( + sMainGenerator, + [TAppInfo.FullProgramName, TAppInfo.ProgramReleaseInfo, RFC1123DateStamp] + ) + ); + + Result.Add(''); + if fVaults.Count = 1 then + Result.Add(Format(sVault, [fVaults[0].Name])) else begin - // Result used for units that contain only user defined snippets - Result.Add(sUserDescription); - Result.Add(''); - Result.Add(Format(sGenerated, [RFC1123DateStamp])); - Result.Add( - Format( - sGenerator, [TAppInfo.FullProgramName, TAppInfo.ProgramReleaseInfo] - ) - ); + Result.Add(sVaultList); + for Vault in fVaults do + begin + Result.Add(' - ' + Vault.Name); + end; + end; + + for Vault in fVaults do + begin + Credits := CreditsLine(Vault); + if Credits <> '' then + begin + Result.Add(''); + Result.Add(Format(sVaultCredit, [Vault.Name, Credits])); + end; end; + end; destructor TSaveUnitMgr.Destroy; begin + fVaults.Free; fSourceGen.Free; inherited; end; @@ -260,23 +278,23 @@ function TSaveUnitMgr.GetFileTypeDesc(const FileType: TSourceFileType): string; constructor TSaveUnitMgr.InternalCreate(const Snips: TSnippetList); var Snippet: TSnippet; // references each snippet in list + Vault: TVault; begin Assert(Assigned(Snips), ClassName + '.InternalCreate: Snips is nil'); inherited InternalCreate; + fVaults := TList.Create(TVault.TComparer.Create); + // Create source generator and initialize it with required snippets fSourceGen := TSourceGen.Create; fSourceGen.IncludeSnippets(Snips); - // Determine if snippet list contains at least one snippet from main database - fContainsMainDBSnippets := False; + // Count the number of vaults containing snippet in the list for Snippet in Snips do begin - if not Snippet.UserDefined then - begin - fContainsMainDBSnippets := True; - Break; - end; + Vault := TVaults.Instance.GetVault(Snippet.VaultID); + if not fVaults.Contains(Vault) then + fVaults.Add(Vault); end; end; diff --git a/Src/USearch.pas b/Src/USearch.pas index 2bb2889a8..f2ead4dd7 100644 --- a/Src/USearch.pas +++ b/Src/USearch.pas @@ -20,7 +20,10 @@ interface // Delphi Classes, Graphics, // Project - Compilers.UGlobals, DB.USnippet, UBaseObjects, USnippetIDs; + Compilers.UGlobals, + DB.SnippetIDs, + DB.Snippets, + UBaseObjects; type @@ -296,9 +299,13 @@ implementation uses // Delphi - SysUtils, Character, + SysUtils, + Character, // Project - DB.UMain, IntfCommon, UConsts, UStrUtils; + DB.Main, + IntfCommon, + UConsts, + UStrUtils; type @@ -1077,14 +1084,14 @@ procedure TXRefSearchFilter.ReferenceReverseRequired(const Snippet: TSnippet); begin if not (soRequiredReverse in fOptions) then Exit; - AddToXRefs((Database as IDatabaseEdit).GetDependents(Snippet)); + AddToXRefs(Database.GetDependents(Snippet)); end; procedure TXRefSearchFilter.ReferenceReverseSeeAlso(const Snippet: TSnippet); begin if not (soSeeAlsoReverse in fOptions) then Exit; - AddToXRefs((Database as IDatabaseEdit).GetReferrers(Snippet)); + AddToXRefs(Database.GetReferrers(Snippet)); end; procedure TXRefSearchFilter.ReferenceSeeAlso(const Snippet: TSnippet); diff --git a/Src/USelectionIOMgr.pas b/Src/USelectionIOMgr.pas index 90f1061c1..1a00bbd9e 100644 --- a/Src/USelectionIOMgr.pas +++ b/Src/USelectionIOMgr.pas @@ -43,15 +43,23 @@ implementation uses // Delphi - SysUtils, Dialogs, + SysUtils, + Dialogs, // Project - DB.USnippet, UConsts, UMessageBox, UOpenDialogEx, UOpenDialogHelper, - UQuery, USaveDialogEx, USnippetIDListIOHandler, USnippetIDs; + DB.SnippetIDs, + DB.Snippets, + UConsts, + UMessageBox, + UOpenDialogEx, + UOpenDialogHelper, + UQuery, + USaveDialogEx, + USnippetIDListIOHandler; const /// Watermark for selection files. Uses characters that will be /// interpreted wrongly if the file is not in UTF8 format. - SelectionFileWatermark = #$25BA + ' CodeSnip Selections v1 ' + #$25C4; + SelectionFileWatermark = #$25BA + ' CodeSnip Selections v2 ' + #$25C4; { TSelectionIOMgr } diff --git a/Src/USettings.pas b/Src/USettings.pas index 5e38e3227..f3f4427fd 100644 --- a/Src/USettings.pas +++ b/Src/USettings.pas @@ -119,6 +119,20 @@ interface /// regardless of locale. procedure SetDateTime(const Name: string; const Value: TDateTime); + /// Gets a named byte array from settings. + /// string [in] Name of value. + /// TBytes. The required array of bytes. + /// The value is stored as a comma separated sequence of decimal + /// values in the range 0..255. + function GetBytes(const Name: string): TBytes; + + /// Stores a named byte array in settings. + /// string [in] Name of value. + /// TBytes [in] Byte array to be recorded. + /// The bytes must be stored as comma separated decimal values. + /// + procedure SetBytes(const Name: string; const Value: TBytes); + /// Gets a list of related string values from the section. /// /// string [in] Name of an integer value that @@ -163,13 +177,14 @@ interface /// -ssFavourites - persistent settings from Favourites dlg /// -ssWindowState - info about the size and state of various /// windows - /// -ssDatabase - database customisation info /// -ssCompilers - info about all compilers + /// -ssVaults - info about all snippet vaults + /// -ssVault - info about a specific snippet vault /// TSettingsSectionId = ( - ssFindText, ssFindCompiler, ssFindXRefs, ssCompilerInfo, - ssPreferences, ssUnits, ssDuplicateSnippet, - ssFavourites, ssWindowState, ssDatabase, ssCompilers + ssFindText, ssFindCompiler, ssFindXRefs, ssCompilerInfo, ssPreferences, + ssUnits, ssDuplicateSnippet, ssFavourites, ssWindowState, ssCompilers, + ssVaults, ssVault ); type @@ -222,7 +237,8 @@ implementation UAppInfo, UHexUtils, UIOUtils, - UStrUtils; + UStrUtils, + UUtils; var @@ -442,7 +458,7 @@ TIniSettingsSection = class(TIniSettingsBase, ISettingsSection) /// Records a named date time value in settings. /// string [in] Name of value. - /// TDateTime [in] Value to be recored. + /// TDateTime [in] Value to be recorded. /// /// The value must be stored in YYYY-MM-DD hh:mm:ss format /// regardless of locale. @@ -450,6 +466,26 @@ TIniSettingsSection = class(TIniSettingsBase, ISettingsSection) /// procedure SetDateTime(const Name: string; const Value: TDateTime); + /// Gets a named byte array from settings. + /// string [in] Name of value. + /// TBytes. The required array of bytes. + /// + /// The value is stored as a comma separated sequence of decimal + /// values in the range 0..255. + /// Method of ISettingsSection. + /// + function GetBytes(const Name: string): TBytes; + + /// Stores a named byte array in settings. + /// string [in] Name of value. + /// TBytes [in] Byte array to be recorded. + /// + /// The bytes must be stored as comma separated decimal values. + /// + /// Method of ISettingsSection. + /// + procedure SetBytes(const Name: string; const Value: TBytes); + /// Gets a list of related string values from the section. /// /// string [in] Name of an integer value that @@ -475,6 +511,7 @@ TIniSettingsSection = class(TIniSettingsBase, ISettingsSection) /// Method of ISettingsSection. procedure SetStrings(const CountName, ItemFmt: string; Value: IStringList); + end; function Settings: ISettings; @@ -540,8 +577,9 @@ function TIniSettings.SectionName(const Id: TSettingsSectionId; 'DuplicateSnippet', // ssDuplicateSnippet 'Favourites', // ssFavourites 'WindowState', // ssWindowState - 'Database', // ssDatabase - 'Compilers' // ssCompilers + 'Compilers', // ssCompilers + 'Vaults', // ssVaults + 'Vault' // ssVault ); begin Result := cSectionNames[Id]; @@ -589,6 +627,35 @@ function TIniSettingsSection.GetBoolean(const Name: string; Result := not StrMatchText(ValStr, ['0', 'false', 'no', 'n']); end; +function TIniSettingsSection.GetBytes(const Name: string): TBytes; +var + ValStr: string; + ValSL: TStrings; + B: Byte; + Idx: Integer; +begin + ValStr := StrTrim(GetItemValue(Name)); + if ValStr = '' then + begin + SetLength(Result, 0); + Exit; + end; + ValSL := TStringList.Create; + try + StrExplode(ValStr, ',', ValSL, False, True); + SetLength(Result, ValSL.Count); + for Idx := 0 to Pred(ValSL.Count) do + begin + if TryStrToByte(ValSL[Idx], B) then + Result[Idx] := B + else + Result[Idx] := 0; + end; + finally + ValSL.Free; + end; +end; + function TIniSettingsSection.GetDateTime(const Name: string; const Default: TDateTime): TDateTime; var @@ -702,6 +769,24 @@ procedure TIniSettingsSection.SetBoolean(const Name: string; SetItemValue(Name, BoolStrs[Value]); end; +procedure TIniSettingsSection.SetBytes(const Name: string; + const Value: TBytes); +var + SL: TStrings; + B: Byte; +begin + SL := TStringList.Create; + try + for B in Value do + begin + SL.Add(IntToStr(B)); + end; + SetItemValue(Name, StrJoin(SL, ',')); + finally + SL.Free; + end; +end; + procedure TIniSettingsSection.SetDateTime(const Name: string; const Value: TDateTime); begin diff --git a/Src/USnippetAction.pas b/Src/USnippetAction.pas index 6c0cf81fe..1ff6f3299 100644 --- a/Src/USnippetAction.pas +++ b/Src/USnippetAction.pas @@ -5,7 +5,7 @@ * * Copyright (C) 2005-2021, Peter Johnson (gravatar.com/delphidabbler). * - * Custom action used to request display of a snippet by name. + * Custom action used to request display of a snippet by key and vault ID. } @@ -19,25 +19,28 @@ interface // Delphi Classes, // Project + DB.Vaults, IntfNotifier; +{TODO -cVault: Combine the two TSnippetAction properties into a single + TSnippetID property.} + type /// /// Custom action used to request display of a snippet. /// /// - /// Required snippet is uniquely identified by its name and whether it is - /// user defined or not. + /// Required snippet is uniquely identified by its key and vault ID. /// TSnippetAction = class(TBasicAction, ISetNotifier) strict private var - /// Value of SnippetName property. - fSnippetName: string; - /// Value of UserDefined property. - fUserDefined: Boolean; + /// Value of Key property. + fKey: string; + /// Value of VaultID property. + fVaultID: TVaultID; /// Value of NewTab property. fNewTab: Boolean; /// Reference to Notifier object. @@ -56,12 +59,12 @@ TSnippetAction = class(TBasicAction, ISetNotifier) /// Stores reference to given notifier object. /// Implements ISetNotifier.SetNotifier procedure SetNotifier(const Notifier: INotifier); - /// Name of snippet to be displayed. - property SnippetName: string read fSnippetName write fSnippetName; - /// Flag indicating whether snippet to be displayed is user - /// defined. - property UserDefined: Boolean read fUserDefined write fUserDefined; - /// Flag indicating if snippet is to be displayed in new detail + /// Key of snippet to be displayed. + property Key: string read fKey write fKey; + /// ID of the vault containing the snippet to be displayed. + /// + property VaultID: TVaultID read fVaultID write fVaultID; + /// Flag indicating if snippet is to be displayed in a new detail /// pane tab. property NewTab: Boolean read fNewTab write fNewTab; end; @@ -72,7 +75,9 @@ implementation uses // Project - DB.UMain, DB.USnippet, UView; + DB.Main, + DB.Snippets, + UView; { TSnippetAction } @@ -82,9 +87,11 @@ function TSnippetAction.Execute: Boolean; Snippet: TSnippet; // snippet to be displayed begin Assert(Assigned(fNotifier), ClassName + '.Execute: Notifier not set'); - Assert(SnippetName <> '', ClassName + '.Execute: SnippetName not provided'); - Snippet := Database.Snippets.Find(SnippetName, UserDefined); - Assert(Assigned(Snippet), ClassName + '.Execute: SnippetName not valid'); + Assert(Key <> '', ClassName + '.Execute: Key not provided'); + + Snippet := Database.Snippets.Find(Key, fVaultID); + Assert(Assigned(Snippet), ClassName + '.Execute: Key not valid'); + // Create a view item for snippet and get notifier to display it fNotifier.ShowViewItem(TViewFactory.CreateSnippetView(Snippet), NewTab); Result := False; diff --git a/Src/USnippetDoc.pas b/Src/USnippetDoc.pas index e11245322..0add0e284 100644 --- a/Src/USnippetDoc.pas +++ b/Src/USnippetDoc.pas @@ -21,7 +21,12 @@ interface // Delphi Classes, // Project - ActiveText.UMain, Compilers.UGlobals, DB.USnippet, UEncodings, UIStringList; + DB.Vaults, + ActiveText.UMain, + Compilers.UGlobals, + DB.Snippets, + UEncodings, + UIStringList; type @@ -53,19 +58,22 @@ TSnippetDoc = class(TObject) /// information for given snippet. function CompilerInfo(const Snippet: TSnippet): TCompileDocInfoArray; /// Generates and returns a string containing information about - /// the main database. - function MainDBInfo: string; + /// the given vault. + /// Information includes license and copyright information if + /// the vault's data format supports it. + function VaultInfo(const AVaultID: TVaultID): string; strict protected /// Initialise document. /// Does nothing. Descendant classes should perform any required /// initialisation here. procedure InitialiseDoc; virtual; - /// Output given heading, i.e. snippet name. Can be user defined - /// or from main database. - /// Heading may be rendered differently depending on whether user - /// defined or not. - procedure RenderHeading(const Heading: string; const UserDefined: Boolean); - virtual; abstract; + + /// Output given heading, i.e. snippet name for snippet from a + /// given vault. + /// Heading may be rendered differently depending on the snippet's + /// vault. + procedure RenderHeading(const Heading: string; + const AVaultID: TVaultID); virtual; abstract; /// Output given snippet description. procedure RenderDescription(const Desc: IActiveText); virtual; abstract; /// Output given source code. @@ -88,9 +96,8 @@ TSnippetDoc = class(TObject) /// Active text must be interpreted in a manner that makes sense /// for document format. procedure RenderExtra(const ExtraText: IActiveText); virtual; abstract; - /// Output given information about code snippets database. - /// - procedure RenderDBInfo(const Text: string); virtual; abstract; + /// Output given information about a vault. + procedure RenderVaultInfo(const Text: string); virtual; abstract; /// Finalise document and return content as encoded data. /// /// Descendant classes should perform any required finalisation @@ -116,9 +123,10 @@ implementation Generics.Collections, // Project Compilers.UCompilers, - DB.UMain, - DB.UMetaData, - DB.USnippetKind, + DB.DataFormats, + DB.Main, + DB.MetaData, + DB.SnippetKind, UStrUtils, UUrl; @@ -178,7 +186,7 @@ function TSnippetDoc.Generate(const Snippet: TSnippet): TEncodedData; Assert(Assigned(Snippet), ClassName + '.Create: Snippet is nil'); // generate document InitialiseDoc; - RenderHeading(Snippet.DisplayName, Snippet.UserDefined); + RenderHeading(Snippet.DisplayName, Snippet.VaultID); RenderDescription(Snippet.Description); RenderSourceCode(Snippet.SourceCode); RenderTitledText( @@ -200,9 +208,7 @@ function TSnippetDoc.Generate(const Snippet: TSnippet): TEncodedData; end; if Snippet.Extra.HasContent then RenderExtra(Snippet.Extra); - if not Snippet.UserDefined then - // database info written only if snippet is from main database - RenderDBInfo(MainDBInfo); + RenderVaultInfo(VaultInfo(Snippet.VaultID)); Result := FinaliseDoc; end; @@ -211,23 +217,6 @@ procedure TSnippetDoc.InitialiseDoc; // Do nothing end; -function TSnippetDoc.MainDBInfo: string; -resourcestring - sMainDBInfo = 'A snippet from the DelphiDabbler Code Snippets Database ' - + '(%0:s), licensed under the %1:s.'; -var - DBMetaData: IDBMetaData; -begin - DBMetaData := TMainDBMetaDataFactory.MainDBMetaDataInstance; - Result := Format( - sMainDBInfo, - [ - TURL.CodeSnipRepo, - DBMetaData.GetLicenseInfo.NameWithURL - ] - ); -end; - function TSnippetDoc.SnippetsToStrings(const SnippetList: TSnippetList): IStringList; var @@ -238,6 +227,27 @@ function TSnippetDoc.SnippetsToStrings(const SnippetList: TSnippetList): Result.Add(Snippet.DisplayName); end; +function TSnippetDoc.VaultInfo(const AVaultID: TVaultID): string; +resourcestring + {TODO -cBug: the following information is not included in output} + sVaultInfo = 'A snippet from the "%s" vault.'; +var + MetaData: TMetaData; + Vault: TVault; +begin + Vault := TVaults.Instance.GetVault(AVaultID); + MetaData := Vault.MetaData; + Result := ''; + if TMetaDataCap.License in MetaData.Capabilities then + Result := Result + StrMakeSentence(MetaData.LicenseInfo.NameWithURL); + if TMetaDataCap.Copyright in MetaData.Capabilities then + begin + if not StrIsEmpty(Result) then + Result := Result + ' '; + Result := Result + StrMakeSentence(MetaData.CopyrightInfo.ToString); + end; +end; + { TCompileDocInfo } constructor TCompileDocInfo.Create(const ACompiler: string; diff --git a/Src/USnippetHTML.pas b/Src/USnippetHTML.pas index 3f53d12fd..11dc54750 100644 --- a/Src/USnippetHTML.pas +++ b/Src/USnippetHTML.pas @@ -17,7 +17,9 @@ interface uses // Project - ActiveText.UMain, DB.UCategory, DB.USnippet; + ActiveText.UMain, + DB.Categories, + DB.Snippets; type @@ -96,9 +98,19 @@ implementation // Delphi SysUtils, // Project - ActiveText.UHTMLRenderer, DB.UMain, DB.USnippetKind, Hiliter.UAttrs, - Hiliter.UGlobals, Hiliter.UHiliters, UCompResHTML, UHTMLBuilder, - UHTMLUtils, UIStringList, UJavaScriptUtils, UResourceUtils, UStrUtils; + ActiveText.UHTMLRenderer, + DB.Main, + DB.SnippetKind, + Hiliter.UAttrs, + Hiliter.UGlobals, + Hiliter.UHiliters, + UCompResHTML, + UHTMLBuilder, + UHTMLUtils, + UIStringList, + UJavaScriptUtils, + UResourceUtils, + UStrUtils; { TSnippetHTML } @@ -204,10 +216,10 @@ function TSnippetHTML.SnippetName: string; class function TSnippetHTML.SnippetALink(const Snippet: TSnippet): string; begin - // Create javascript link enclosing snippet name + // Create javascript link enclosing snippet key Result := JSALink( TJavaScript.LiteralFunc( - 'displaySnippet', [Snippet.Name, Snippet.UserDefined] + 'displaySnippet', [Snippet.Key, Snippet.VaultID.ToHexString] ), 'snippet-link', Snippet.DisplayName @@ -250,7 +262,9 @@ function TSnippetHTML.TestingImage: string; resourcestring sTestingNone = 'Untested'#13#10'Use with care'; sTestingBasic = 'Passed simple tests'; - sTestingAdvanced = 'Passed advanced / unit testing'; + sTestingAdvanced = 'Passed unspecified advanced testing'; + sTestingUnitTests = 'Has unit tests'; + sTestingDemo = 'Has demo program'; const ImgWidth = 16; ImgHeight = 16; @@ -260,7 +274,11 @@ function TSnippetHTML.TestingImage: string; end =( (ResName: 'testing-none.png'; Title: sTestingNone), (ResName: 'testing-basic.png'; Title: sTestingBasic), - (ResName: 'testing-advanced.png'; Title: sTestingAdvanced) + (ResName: 'testing-advanced.png'; Title: sTestingAdvanced), + {TODO -cVault: Add new icons below for unit tests and demo code test info + to replace testing-advanced.png} + (ResName: 'testing-advanced.png'; Title: sTestingUnitTests), + (ResName: 'testing-advanced.png'; Title: sTestingDemo) ); var Attrs: IHTMLAttributes; // image's attributes diff --git a/Src/USnippetIDListIOHandler.pas b/Src/USnippetIDListIOHandler.pas index 4aed2f246..b28409751 100644 --- a/Src/USnippetIDListIOHandler.pas +++ b/Src/USnippetIDListIOHandler.pas @@ -16,8 +16,11 @@ interface uses + // Delphi SysUtils, - UExceptions, UIStringList, USnippetIDs; + // Project + DB.SnippetIDs, + UExceptions; type @@ -27,10 +30,7 @@ TSnippetIDListFileReader = class(TObject) var fWatermark: string; fSnippetIDs: ISnippetIDList; - /// Lines of text from file. - /// Must be stripped of blank lines. - fLines: IStringList; - procedure Parse; + procedure ParseLine(AFields: TArray); public constructor Create(const Watermark: string); function ReadFile(const FileName: string): ISnippetIDLIst; @@ -47,7 +47,6 @@ TSnippetIDListFileWriter = class(TObject) var fWatermark: string; fBuilder: TStringBuilder; - procedure CreateContent(const SnippetIDs: ISnippetIDList); public constructor Create(const Watermark: string); destructor Destroy; override; @@ -66,7 +65,9 @@ implementation // Delphi Classes, // Project - UConsts, UIOUtils, UStrUtils; + DB.Vaults, + UStrUtils, + UTabSeparatedFileIO; { TSnippetIDListFileReader } @@ -75,63 +76,48 @@ constructor TSnippetIDListFileReader.Create(const Watermark: string); begin inherited Create; fSnippetIDs := TSnippetIDList.Create; - fLines := TIStringList.Create; fWatermark := Watermark; end; -procedure TSnippetIDListFileReader.Parse; +procedure TSnippetIDListFileReader.ParseLine(AFields: TArray); resourcestring sBadFileFormat = 'Invalid snippet ID list file format'; - sMissingName = 'Snippet name missing on line' + EOL2 + '"%s"'; - sMissingUserDef = 'Snippet database specifier missing on line' - + EOL2 + '"%s"'; - sBadUserDef = 'Unknown snippet database specifier on line' - + EOL2 + '"%s"'; var - Line: string; // each line in fLines - Name: string; // name of each snippet - UserDefStr: string; // user defined value of each snippet as string - UserDefInt: Integer; // user defined value of each snippet as integer + Key: string; + VaultHex: string; + VaultID: TVaultID; begin - fSnippetIDs.Clear; - if (fLines.Count <= 1) or (fLines[0] <> fWatermark) then + Key := StrTrim(AFields[0]); + if Key = '' then raise ESnippetIDListFileReader.Create(sBadFileFormat); - fLines.Delete(0); - for Line in fLines do - begin - StrSplit(Line, TAB, Name, UserDefStr); - Name := StrTrim(Name); - UserDefStr := StrTrim(UserDefStr); - if Name = '' then - raise ESnippetIDListFileReader.CreateFmt(sMissingName, [Line]); - if UserDefStr = '' then - raise ESnippetIDListFileReader.CreateFmt(sMissingUserDef, [Line]); - if not TryStrToInt(UserDefStr, UserDefInt) - or not (UserDefInt in [0, 1]) then - raise ESnippetIDListFileReader.CreateFmt(sBadUserDef, [Line]); - fSnippetIDs.Add(TSnippetID.Create(Name, Boolean(UserDefInt))); - end; + VaultHex := StrTrim(AFields[1]); + if VaultHex = '' then + raise ESnippetIDListFileReader.Create(sBadFileFormat); + VaultID := TVaultID.CreateFromHexString(VaultHex); + fSnippetIDs.Add(TSnippetID.Create(Key, VaultID)); end; function TSnippetIDListFileReader.ReadFile(const FileName: string): ISnippetIDLIst; +var + TSVReader: TTabSeparatedReader; begin + fSnippetIDs.Clear; + TSVReader := TTabSeparatedReader.Create(FileName, fWatermark); try - fLines.SetText( - TFileIO.ReadAllText(FileName, TEncoding.UTF8, True), - CRLF, - False, - True - ); - except - on E: EStreamError do - raise ESnippetIDListFileReader.Create(E); - on E: EIOUtils do - raise ESnippetIDListFileReader.Create(E); - else - raise; + try + TSVReader.Read(ParseLine); + except + on E: ETabSeparatedReader do + raise ESnippetIDListFileReader.Create(E); + on E: EVaultID do + raise ESnippetIDListFileReader.Create(E); + else + raise; + end; + finally + TSVReader.Free; end; - Parse; Result := fSnippetIDs; end; @@ -140,28 +126,9 @@ function TSnippetIDListFileReader.ReadFile(const FileName: string): constructor TSnippetIDListFileWriter.Create(const Watermark: string); begin inherited Create; - fBuilder := TStringBuilder.Create; fWatermark := Watermark; end; -procedure TSnippetIDListFileWriter.CreateContent( - const SnippetIDs: ISnippetIDList); -var - SnippetID: TSnippetID; -begin - fBuilder.Clear; - fBuilder.AppendLine(fWatermark); - for SnippetID in SnippetIDs do - begin - fBuilder.Append(SnippetID.Name); - fBuilder.Append(TAB); - // NOTE: TStringBuilder.Append(Boolean) override not used here since ordinal - // value wanted instead of "True" or "False" or localised equivalent. - fBuilder.Append(Ord(SnippetID.UserDefined)); - fBuilder.AppendLine; - end; -end; - destructor TSnippetIDListFileWriter.Destroy; begin fBuilder.Free; @@ -170,10 +137,18 @@ destructor TSnippetIDListFileWriter.Destroy; procedure TSnippetIDListFileWriter.WriteFile(const FileName: string; SnippetIDs: ISnippetIDList); +var + TSVWriter: TTabSeparatedFileWriter; + SnippetID: TSnippetID; begin - CreateContent(SnippetIDs); + TSVWriter := TTabSeparatedFileWriter.Create(FileName, fWaterMark); try - TFileIO.WriteAllText(FileName, fBuilder.ToString, TEncoding.UTF8, True); + try + for SnippetID in SnippetIDs do + TSVWriter.WriteLine([SnippetID.Key, SnippetID.VaultID.ToHexString]); + finally + TSVWriter.Free; + end; except on E: EStreamError do raise ESnippetIDListFileWriter.Create(E); diff --git a/Src/USnippetPageHTML.pas b/Src/USnippetPageHTML.pas index 90715e256..75d2b3422 100644 --- a/Src/USnippetPageHTML.pas +++ b/Src/USnippetPageHTML.pas @@ -19,7 +19,9 @@ interface uses // Project - DB.USnippet, USnippetHTML, USnippetPageStructure; + DB.Snippets, + USnippetHTML, + USnippetPageStructure; type diff --git a/Src/USnippetPageStructure.pas b/Src/USnippetPageStructure.pas index a30989be0..6ee8ae576 100644 --- a/Src/USnippetPageStructure.pas +++ b/Src/USnippetPageStructure.pas @@ -16,7 +16,12 @@ interface uses Generics.Collections, - DB.USnippetKind, IntfCommon, UBaseObjects, UContainers, USettings, USingleton; + DB.SnippetKind, + IntfCommon, + UBaseObjects, + UContainers, + USettings, + USingleton; type diff --git a/Src/USnippetSourceGen.pas b/Src/USnippetSourceGen.pas index e7739df85..ef041f954 100644 --- a/Src/USnippetSourceGen.pas +++ b/Src/USnippetSourceGen.pas @@ -17,8 +17,15 @@ interface uses + // Delphi + Generics.Collections, // Project - UBaseObjects, UIStringList, USourceGen, UView; + DB.MetaData, + DB.Vaults, + UBaseObjects, + UIStringList, + USourceGen, + UView; type @@ -30,9 +37,9 @@ interface } TSnippetSourceGen = class sealed(TNoPublicConstructObject) strict private - fContainsMainDBSnippets: Boolean; - {Flag true if source code contains at least one snippet from main - database, False only if source code is completely user defined} + /// List of vaults that have contributed snippets to the source + /// code being generated. + fVaults: TList; fGenerator: TSourceGen; {Object used to generate the source code} procedure Initialize(View: IView); @@ -87,12 +94,13 @@ implementation // Delphi SysUtils, // Project - DB.UMetaData, - DB.USnippet, - DB.USnippetKind, + DB.DataFormats, + DB.SnippetKind, + DB.Snippets, UConsts, UAppInfo, UQuery, + UStrUtils, UUtils; @@ -103,60 +111,63 @@ function TSnippetSourceGen.BuildHeaderComments: IStringList; @return String list containing comments. } var - DBMetaData: IDBMetaData; + MetaData: TMetaData; + Vault: TVault; + Credits: string; resourcestring // Comment to be included at top of snippet // when snippets include those from main database - sMainDBGenerator = 'This code snippet was generated by %0:s %1:s on %2:s.'; - sMainDBLicense = 'It includes code taken from the DelphiDabbler Code ' - + 'Snippets database that is copyright ' - + COPYRIGHT - + ' %0:s by %1:s and is licensed under the %2:s.'; - // when snippets are all from user defined database - sUserGenerator = 'This user defined code snippet was generated by ' - + '%0:s %1:s on %2:s.'; + sMainGenerator = 'This code snippet was generated by %0:s %1:s on %2:s.'; + sVault = 'The code was sourced from the %s vault.'; + sVaultList = 'The code was sourced from the following vaults:'; + sVaultCredit = 'Vault "%0:s" is licensed under the %1:s'; + + function CreditsLine(const AVault: TVault): string; + begin + MetaData := AVault.MetaData; + Result := ''; + if TMetaDataCap.License in MetaData.Capabilities then + Result := Result + StrMakeSentence(MetaData.LicenseInfo.NameWithURL); + if TMetaDataCap.Copyright in MetaData.Capabilities then + begin + if not StrIsEmpty(Result) then + Result := Result + ' '; + Result := Result + StrMakeSentence(MetaData.CopyrightInfo.ToString); + end; + end; + begin - // Header depends on whether snippets contain any from main database or are - // all user defined Result := TIStringList.Create; - if fContainsMainDBSnippets then - begin - Result.Add( - Format( - sMainDBGenerator, - [ - TAppInfo.FullProgramName, - TAppInfo.ProgramReleaseInfo, - RFC1123DateStamp - ] - ) - ); - Result.Add(''); - DBMetaData := TMainDBMetaDataFactory.MainDBMetaDataInstance; - Result.Add( - Format( - sMainDBLicense, - [ - DBMetaData.GetCopyrightInfo.Date, - DBMetaData.GetCopyrightInfo.Holder, - DBMetaData.GetLicenseInfo.NameWithURL - ] - ) - ); - end + + Result.Add( + Format( + sMainGenerator, + [TAppInfo.FullProgramName, TAppInfo.ProgramReleaseInfo, RFC1123DateStamp] + ) + ); + + Result.Add(''); + if fVaults.Count = 1 then + Result.Add(Format(sVault, [fVaults[0].Name])) else begin - Result.Add( - Format( - sUserGenerator, - [ - TAppInfo.FullProgramName, - TAppInfo.ProgramReleaseInfo, - RFC1123DateStamp - ] - ) - ); + Result.Add(sVaultList); + for Vault in fVaults do + begin + Result.Add(' - ' + Vault.Name); + end; + end; + + for Vault in fVaults do + begin + Credits := CreditsLine(Vault); + if Credits <> '' then + begin + Result.Add(''); + Result.Add(Format(sVaultCredit, [Vault.Name, Credits])); + end; end; + end; class function TSnippetSourceGen.CanGenerate(View: IView): Boolean; @@ -189,6 +200,7 @@ destructor TSnippetSourceGen.Destroy; {Class destructor. Tears down object. } begin + fVaults.Free; fGenerator.Free; inherited; end; @@ -235,15 +247,15 @@ procedure TSnippetSourceGen.Initialize(View: IView); var Snips: TSnippetList; // list of snippets in a category to display Snippet: TSnippet; // a snippet in Snips list + Vault: TVault; begin - fContainsMainDBSnippets := False; // Record required snippet(s) if Supports(View, ISnippetView) then begin // view is single snippet: just record that Snippet := (View as ISnippetView).Snippet; fGenerator.IncludeSnippet(Snippet); - fContainsMainDBSnippets := not Snippet.UserDefined; + fVaults.Add(TVaults.Instance.GetVault(Snippet.VaultID)); end else begin @@ -254,11 +266,9 @@ procedure TSnippetSourceGen.Initialize(View: IView); fGenerator.IncludeSnippets(Snips); // ignores freeform snippets for Snippet in Snips do begin - if not Snippet.UserDefined then - begin - fContainsMainDBSnippets := True; - Break; - end; + Vault := TVaults.Instance.GetVault(Snippet.VaultID); + if not fVaults.Contains(Vault) then + fVaults.Add(Vault); end; finally Snips.Free; @@ -276,6 +286,7 @@ constructor TSnippetSourceGen.InternalCreate(View: IView); Assert(CanGenerate(View), ClassName + '.InternalCreate: View not supported'); inherited InternalCreate; fGenerator := TSourceGen.Create; + fVaults := TList.Create(TVault.TComparer.Create); Initialize(View); end; diff --git a/Src/USnippetValidator.pas b/Src/USnippetValidator.pas index 83de1adf3..0ead99a70 100644 --- a/Src/USnippetValidator.pas +++ b/Src/USnippetValidator.pas @@ -17,7 +17,12 @@ interface uses // Project - ActiveText.UMain, DB.USnippet, DB.USnippetKind, UBaseObjects, UStructs; + ActiveText.UMain, + DB.SnippetKind, + DB.Snippets, + DB.Vaults, + UBaseObjects, + UStructs; type @@ -31,6 +36,17 @@ TSnippetValidator = class(TNoConstructObject) cAllSnippetKinds: TSnippetKinds = // Set of all possible snippet kinds [skFreeform, skRoutine, skConstant, skTypeDef, skUnit, skClass]; public + + /// Validate a snippet display name. + /// string [in] Display name to be + /// checked. + /// string [out] Message that describes + /// error. Undefined if True returned. + /// Boolean. True if source code is valid or + /// False if not. + class function ValidateDisplayName(const DisplayName: string; + out ErrorMsg: string): Boolean; + class function ValidateDependsList(const Snippet: TSnippet; out ErrorMsg: string): Boolean; overload; {Recursively checks dependency list of a snippet for validity. @@ -39,17 +55,24 @@ TSnippetValidator = class(TNoConstructObject) returned. @return True if dependency list is valid or False if not. } - class function ValidateDependsList(const SnippetName: string; - const Data: TSnippetEditData; out ErrorMsg: string): Boolean; overload; - {Recursively checks dependency list of a snippet for validity. - @param SnippetName [in] Name of snippet for which dependencies are to be - checked. - @param Data [in] Data describing properties and references of snippet - for which dependencies are to be checked. - @param ErrorMsg [out] Message that describes error. Undefined if True - returned. - @return True if dependency list is valid or False if not. - } + + /// Recursively checks dependency list of a snippet for validity. + /// + /// string [in] Key of snippet for which + /// dependencies are to be checked. + /// TVaultID [in] ID of the vault to which + /// the snippet belongs. + /// TSnippetEditData [in] Data describing + /// properties and references of snippet for which dependencies are to be + /// checked. + /// string [out] Message that describes any + /// error. Undefined if True is returned. + /// Boolean. True if dependency list is valid or + /// False if not. + class function ValidateDependsList(const AKey: string; + const AVaultID: TVaultID; const AData: TSnippetEditData; + out AErrorMsg: string): Boolean; overload; + class function ValidateSourceCode(const Source: string; out ErrorMsg: string; out ErrorSel: TSelection): Boolean; {Validates a source code from a snippet. @@ -68,37 +91,6 @@ TSnippetValidator = class(TNoConstructObject) @param ErrorSel [out] Selection that can be used to highlight error. @return True if description is valid or False if not. } - class function ValidateName(const Name: string; - const CheckForUniqueness: Boolean): Boolean; overload; - {Validates a snippet's name. - @param Name [in] Snippet name to be checked. - @param CheckForUniqueness [in] Flag indicating whether a check should - be made to see if snippet name is already in user database. - @return True if name is valid or False if not. - } - class function ValidateName(const Name: string; - const CheckForUniqueness: Boolean; out ErrorMsg: string): Boolean; - overload; - {Validates a snippet's name. - @param Name [in] Snippet name to be checked. - @param CheckForUniqueness [in] Flag indicating whether a check should - be made to see if snippet name is already in user database. - @param ErrorMsg [out] Message that describes error. Undefined if True - returned. - @return True if name is valid or False if not. - } - class function ValidateName(const Name: string; - const CheckForUniqueness: Boolean; out ErrorMsg: string; - out ErrorSel: TSelection): Boolean; overload; - {Validates a snippet's name. - @param Name [in] Snippet name to be checked. - @param CheckForUniqueness [in] Flag indicating whether a check should - be made to see if snippet name is already in user database. - @param ErrorMsg [out] Message that describes error. Undefined if True - returned. - @param ErrorSel [out] Selection that can be used to highlight error. - @return True if name is valid or False if not. - } class function ValidateExtra(const Extra: IActiveText; out ErrorMsg: string): Boolean; {Validates a extra information from a snippet. @@ -140,7 +132,9 @@ implementation // Delphi SysUtils, // Project - ActiveText.UValidator, DB.UMain, UStrUtils; + ActiveText.UValidator, + DB.Main, + UStrUtils; { TSnippetValidator } @@ -169,8 +163,9 @@ class function TSnippetValidator.Validate(const Snippet: TSnippet; @return True if snippet valid or False if not. } begin - Result := ValidateName(Snippet.Name, False, ErrorMsg, ErrorSel) - and ValidateDescription(Snippet.Description.ToString, ErrorMsg, ErrorSel) + Result := + {TODO -cVault: Add validation of display name here} + ValidateDescription(Snippet.Description.ToString, ErrorMsg, ErrorSel) and ValidateSourceCode(Snippet.SourceCode, ErrorMsg, ErrorSel) and ValidateDependsList(Snippet, ErrorMsg) and ValidateExtra(Snippet.Extra, ErrorMsg); @@ -238,8 +233,8 @@ class function TSnippetValidator.ValidateDependsList(const Snippet: TSnippet; resourcestring // Error messages sInvalidKind = 'Invalid snippet kind "%0:s" in depends list for snippet ' - + 'named "%1:s"'; - sCircular = '%0:s Snippet named "%1:s" cannot depend on itself.'; + + 'with key "%1:s"'; + sCircular = '%0:s snippet with key "%1:s" cannot depend on itself.'; var DeniedDepends: TSnippetKinds; // snippet kinds that can't be in depends list begin @@ -252,7 +247,7 @@ class function TSnippetValidator.ValidateDependsList(const Snippet: TSnippet; ErrorMsg := Format( sCircular, [ TSnippetKindInfoList.Items[Snippet.Kind].DisplayName, - Snippet.Name + Snippet.Key ] ); Exit; @@ -267,30 +262,20 @@ class function TSnippetValidator.ValidateDependsList(const Snippet: TSnippet; sInvalidKind, [ TSnippetKindInfoList.Items[Snippet.Kind].DisplayName, - Snippet.Name + Snippet.Key ] ); end; -class function TSnippetValidator.ValidateDependsList(const SnippetName: string; - const Data: TSnippetEditData; out ErrorMsg: string): Boolean; - {Recursively checks dependency list of a snippet for validity. - @param SnippetName [in] Name of snippet for which dependencies are to be - checked. - @param Data [in] Data describing properties and references of snippet for - which dependencies are to be checked. - @param ErrorMsg [out] Message that describes error. Undefined if True - returned. - @return True if dependency list is valid or False if not. - } +class function TSnippetValidator.ValidateDependsList(const AKey: string; + const AVaultID: TVaultID; const AData: TSnippetEditData; + out AErrorMsg: string): Boolean; var TempSnippet: TSnippet; // temporary snippet that is checked for dependencies begin - TempSnippet := (Database as IDatabaseEdit).CreateTempSnippet( - SnippetName, Data - ); + TempSnippet := Database.CreateTempSnippet(AKey, AVaultID, AData); try - Result := ValidateDependsList(TempSnippet, ErrorMsg); + Result := ValidateDependsList(TempSnippet, AErrorMsg); finally TempSnippet.Free; end; @@ -329,6 +314,19 @@ class function TSnippetValidator.ValidateDescription(const Desc: string; Result := True; end; +class function TSnippetValidator.ValidateDisplayName(const DisplayName: string; + out ErrorMsg: string): Boolean; +var + TrimmedDisplayName: string; +resourcestring + sErrEmpty = 'A display name must be provided'; +begin + TrimmedDisplayName := StrTrim(DisplayName); + Result := TrimmedDisplayName <> ''; + if not Result then + ErrorMsg := sErrEmpty; +end; + class function TSnippetValidator.ValidateExtra(const Extra: IActiveText; out ErrorMsg: string): Boolean; {Validates a extra information from a snippet. @@ -345,69 +343,6 @@ class function TSnippetValidator.ValidateExtra(const Extra: IActiveText; ErrorMsg := ErrorInfo.Description; end; -class function TSnippetValidator.ValidateName(const Name: string; - const CheckForUniqueness: Boolean; out ErrorMsg: string): Boolean; - {Validates a snippet's name. - @param Name [in] Snippet name to be checked. - @param CheckForUniqueness [in] Flag indicating whether a check should be - made to see if snippet name is already in user database. - @param ErrorMsg [out] Message that describes error. Undefined if True - returned. - @return True if name is valid or False if not. - } -resourcestring - // Error messages - sErrNoName = 'A name must be provided'; - sErrDupName = '"%s" is already in the database. Please choose another name'; - sErrBadName = '"%s" is not a valid Pascal identifier'; -var - TrimmedName: string; // Name param trimmed of leading trailing spaces -begin - Result := False; - TrimmedName := StrTrim(Name); - if TrimmedName = '' then - ErrorMsg := sErrNoName - else if not IsValidIdent(TrimmedName) then - ErrorMsg := Format(sErrBadName, [TrimmedName]) - else if CheckForUniqueness and - (Database.Snippets.Find(TrimmedName, True) <> nil) then - ErrorMsg := Format(sErrDupName, [TrimmedName]) - else - Result := True; -end; - -class function TSnippetValidator.ValidateName(const Name: string; - const CheckForUniqueness: Boolean; out ErrorMsg: string; - out ErrorSel: TSelection): Boolean; - {Validates a snippet's name. - @param Name [in] Snippet name to be checked. - @param CheckForUniqueness [in] Flag indicating whether a check should be - made to see if snippet name is already in user database. - @param ErrorMsg [out] Message that describes error. Undefined if True - returned. - @param ErrorSel [out] Selection that can be used to highlight error. - @return True if name is valid or False if not. - } -begin - Result := ValidateName(Name, CheckForUniqueness, ErrorMsg); - if not Result then - ErrorSel := TSelection.Create(0, Length(Name)); -end; - -class function TSnippetValidator.ValidateName(const Name: string; - const CheckForUniqueness: Boolean): Boolean; - {Validates a snippet's name. - @param Name [in] Snippet name to be checked. - @param CheckForUniqueness [in] Flag indicating whether a check should be - made to see if snippet name is already in user database. - @return True if name is valid or False if not. - } -var - DummyErrMsg: string; -begin - Result := ValidateName(Name, CheckForUniqueness, DummyErrMsg); -end; - class function TSnippetValidator.ValidateSourceCode(const Source: string; out ErrorMsg: string; out ErrorSel: TSelection): Boolean; {Validates a source code from a snippet. diff --git a/Src/USnippetsChkListMgr.pas b/Src/USnippetsChkListMgr.pas index 71e5c0561..0c0ac195a 100644 --- a/Src/USnippetsChkListMgr.pas +++ b/Src/USnippetsChkListMgr.pas @@ -18,9 +18,12 @@ interface uses // Delphi - Controls, CheckLst, Windows, + Controls, + CheckLst, + Windows, // Project - DB.USnippet, USnippetIDs; + DB.SnippetIDs, + DB.Snippets; type @@ -100,9 +103,13 @@ implementation uses // Delphi - Graphics, StdCtrls, + Graphics, + StdCtrls, // Project - UColours, UGraphicUtils, UPreferences; + DB.Vaults, + UColours, + UGraphicUtils, + UPreferences; { TSnippetsChkListMgr } @@ -199,9 +206,9 @@ procedure TSnippetsChkListMgr.DrawItem(Control: TWinControl; Index: Integer; Assert(fCLB = Control, ClassName + '.DrawItem: Control <> fCLB'); Canvas := fCLB.Canvas; if not (odSelected in State) then - Canvas.Font.Color := Preferences.DBHeadingColours[ - (fCLB.Items.Objects[Index] as TSnippet).UserDefined - ]; + Canvas.Font.Color := Preferences.GetSnippetHeadingColour( + (fCLB.Items.Objects[Index] as TSnippet).VaultID + ); Canvas.TextRect( Rect, Rect.Left + 2, diff --git a/Src/USnippetsTVDraw.pas b/Src/USnippetsTVDraw.pas index be4c22bb4..abdb15fc7 100644 --- a/Src/USnippetsTVDraw.pas +++ b/Src/USnippetsTVDraw.pas @@ -18,7 +18,9 @@ interface uses // Delphi - ComCtrls; + ComCtrls, + // Project + DB.Vaults; type @@ -30,12 +32,14 @@ interface } TSnippetsTVDraw = class abstract(TObject) strict protected - function IsUserDefinedNode(const Node: TTreeNode): Boolean; + /// Gets the vault ID, if any, associated with a tree node. + /// + /// TTreeNode [in] Node to be checked. + /// TVaultID. Associated vault ID. If Node has no + /// associated vault then a null vault ID is returned. + function GetVaultID(const Node: TTreeNode): TVaultID; virtual; abstract; - {Checks if a node represents a user defined snippets object. - @param Node [in] Node to be checked. - @return True if node represents user defined object, False if not. - } + function IsSectionHeadNode(const Node: TTreeNode): Boolean; virtual; {Checks if a node represents a section header. @@ -70,7 +74,8 @@ implementation // Delphi Graphics, // Project - UColours, UPreferences; + UColours, + UPreferences; { TSnippetsTVDraw } @@ -116,9 +121,11 @@ procedure TSnippetsTVDraw.CustomDrawItem(Sender: TCustomTreeView; if IsErrorNode(Node) then // colour unselected error nodes differently TV.Canvas.Font.Color := clWarningText + else if IsSectionHeadNode(Node) then + TV.Canvas.Font.Color := Preferences.GroupHeadingColour else TV.Canvas.Font.Color := - Preferences.DBHeadingColours[IsUserDefinedNode(Node)]; + Preferences.GetSnippetHeadingColour(GetVaultID(Node)); TV.Canvas.Brush.Color := TV.Color; end; if IsSectionHeadNode(Node) then diff --git a/Src/USourceGen.pas b/Src/USourceGen.pas index 32597cf6e..7a9572300 100644 --- a/Src/USourceGen.pas +++ b/Src/USourceGen.pas @@ -22,7 +22,7 @@ interface Generics.Collections, // Project ActiveText.UMain, - DB.USnippet, + DB.Snippets, UBaseObjects, UIStringList, UWarnings; @@ -264,7 +264,7 @@ implementation Character, // Project ActiveText.UTextRenderer, - DB.USnippetKind, + DB.SnippetKind, UConsts, UExceptions, USnippetValidator, diff --git a/Src/UStatusBarMgr.pas b/Src/UStatusBarMgr.pas index dc501db74..239645380 100644 --- a/Src/UStatusBarMgr.pas +++ b/Src/UStatusBarMgr.pas @@ -118,9 +118,14 @@ implementation uses // Delphi - SysUtils, Forms, + SysUtils, + Forms, // Project - DB.UMain, UQuery, USearch, UStructs; + DB.Main, + DB.Vaults, + UQuery, + USearch, + UStructs; { TStatusBarMgr } @@ -345,28 +350,29 @@ procedure TStatusBarMgr.ShowSnippetsInfo; } var TotalSnippets: Integer; // number of snippets in database - TotalUserSnippets: Integer; // number of snippets in user database - TotalMainSnippets: Integer; // number of snippets in main database + TotalVaults: Integer; // number of vaults in database resourcestring // status bar message strings sSnippet = 'snippet'; sSnippets = 'snippets'; - sStats = '%0:d %1:s (%2:d main / %3:d user defined)'; + sVault = 'vault'; + sVaults = 'vaults'; + sStats = '%0:d %1:s in %2:d %3:s'; const SnippetsStr: array[Boolean] of string = (sSnippet, sSnippets); + VaultsStr: array[Boolean] of string = (sVault, sVaults); begin // Calculate database stats TotalSnippets := Database.Snippets.Count; - TotalUserSnippets := Database.Snippets.Count(True); - TotalMainSnippets := TotalSnippets - TotalUserSnippets; + TotalVaults := TVaults.Instance.Count; // Build display text and display it fStatusBar.Panels[cDBPanel].Text := Format( sStats, [ TotalSnippets, SnippetsStr[TotalSnippets <> 1], - TotalMainSnippets, - TotalUserSnippets + TotalVaults, + VaultsStr[TotalVaults <> 1] ] ); end; @@ -380,7 +386,7 @@ procedure TStatusBarMgr.ShowUserDBInfo; // status bar to draw the panel. // We hide message if database not updated - fUserDBInfoVisible := (Database as IDatabaseEdit).Updated; + fUserDBInfoVisible := Database.Updated; fStatusBar.Repaint; end; diff --git a/Src/UStrUtils.pas b/Src/UStrUtils.pas index 5e613eebc..390f8e49a 100644 --- a/Src/UStrUtils.pas +++ b/Src/UStrUtils.pas @@ -21,6 +21,7 @@ interface uses // Delphi + SysUtils, Classes, // Project UConsts; @@ -117,6 +118,12 @@ function StrStartsText(const SubStr, Str: UnicodeString): Boolean; function StrReplace(const Str, FindStr, ReplaceStr: UnicodeString): UnicodeString; +/// Replaces all occurences in Str of characters for which +/// predicate Condition returns True with character +/// ReplaceCh and returns the modified string. +function StrReplaceChar(const Str: string; const Condition: TPredicate; + const ReplaceCh: Char): string; + /// Trims leading and trailing white space characters from a string. /// /// White space is considered to be any character from #0..#32. @@ -289,6 +296,44 @@ function StrOfChar(const Ch: Char; const Count: Word): string; /// If Count is zero then an empty string is returned. function StrOfSpaces(const Count: Word): string; +/// Escapes specified characters in a string using C format escape +/// sequences. +/// string [in] String to be escaped. +/// string [in] String of characters to be +/// used in the escape sequence. +/// string [in] String of characters to be +/// escaped. +/// string. String with all characters from +/// EscapableChars replaced by a backslash followed by the character at +/// the same index in EscapeChars +/// +/// NOTE: The backslash symbol is always escaped regardless of whether it +/// is included in EscapeChars and EscapableChars. +/// EscapeChars and EscapableChars must be the same +/// length. +/// +function StrCEscapeStr(const S: string; EscapeChars, EscapableChars: string): + string; + +/// Un-escapes a string containing C format escape sequences. +/// +/// string [in] String to be un-escaped. +/// string [in] String of characters used in +/// the escape sequences. +/// string [in] String of characters to be +/// used to replace the escape sequences. +/// string. String with all escape sequences comprising a +/// backslash followed by a character from EscapeChars replaced by a +/// corresponding character from EscapableChars. +/// +/// NOTE: The backslash symbol is always unescaped regardless of whether +/// it is included in EscapeChars and EscapableChars. +/// EscapeChars and EscapableChars must be the same +/// length. +/// +function StrCUnEscapeStr(const S: string; EscapeChars, EscapableChars: string): + string; + /// Returns the length of the longest repeating sequence of a given /// character in a given string. /// Char [in] Character to search for. @@ -303,7 +348,8 @@ implementation uses // Delphi - SysUtils, StrUtils, Character; + StrUtils, + Character; { Internal helper routines } @@ -629,6 +675,19 @@ function StrReplace(const Str, FindStr, ReplaceStr: UnicodeString): Result := StrUtils.AnsiReplaceStr(Str, FindStr, ReplaceStr); end; +function StrReplaceChar(const Str: string; const Condition: TPredicate; + const ReplaceCh: Char): string; +var + Idx: Integer; +begin + SetLength(Result, Length(Str)); + for Idx := 1 to Length(Str) do + if Condition(Str[Idx]) then + Result[Idx] := ReplaceCh + else + Result[Idx] := Str[Idx]; +end; + function StrSameStr(const Left, Right: UnicodeString): Boolean; begin Result := SysUtils.AnsiSameStr(Left, Right); @@ -953,6 +1012,111 @@ function StrOfSpaces(const Count: Word): string; Result := StrOfChar(' ', Count); end; +function StrCEscapeStr(const S: string; EscapeChars, EscapableChars: string): + string; +const + cEscChar = '\'; // the C escape character +var + EscCount: Integer; // count of escaped characters in string + Idx: Integer; // loops thru string + PRes: PChar; // points to chars in result string + EscCharPos: Integer; // position of esc chars in EscapeChars & EscapableChars +begin + Assert(Length(EscapeChars) = Length(EscapableChars), + 'StrCEscapeStr: EscapeChars & EscapableChars are different lengths'); + // Ensure '\' get escaped + if StrPos(cEscChar, EscapeChars) = 0 then + EscapeChars := cEscChar + EscapeChars; + if StrPos(cEscChar, EscapableChars) = 0 then + EscapableChars := cEscChar + EscapableChars; + // Check for empty string and treat specially + // (empty string crashes main code) + if S = '' then + begin + Result := ''; + Exit; + end; + // Count escapable characters in string + EscCount := 0; + for Idx := 1 to Length(S) do + begin + if SysUtils.AnsiPos(S[Idx], EscapableChars) > 0 then + Inc(EscCount); + end; + // Set size of result string and get pointer to it + SetLength(Result, Length(S) + EscCount); + PRes := PChar(Result); + // Replace escapable chars with the escaped version + for Idx := 1 to Length(S) do + begin + EscCharPos := SysUtils.AnsiPos(S[Idx], EscapableChars); + if EscCharPos > 0 then + begin + PRes^ := cEscChar; + Inc(PRes); + PRes^ := EscapeChars[EscCharPos]; + end + else + PRes^ := S[Idx]; + Inc(PRes); + end; +end; + +function StrCUnEscapeStr(const S: string; EscapeChars, EscapableChars: string): + string; +const + cEscChar = '\'; // the C escape character +var + EscCount: Integer; // counts escaped characters in string + Idx: Integer; // loops thru source string + PRes: PChar; // points to chars in result string + EscCharPos: Integer; // position of esc chars in EscapeChars & EscapableChars +begin + Assert(Length(EscapeChars) = Length(EscapableChars), + 'StrCUnEscapeStr: EscapeChars & EscapableChars are different lengths'); + // Ensure '\' get unescaped + if StrPos(cEscChar, EscapeChars) = 0 then + EscapeChars := cEscChar + EscapeChars; + if StrPos(cEscChar, EscapableChars) = 0 then + EscapableChars := cEscChar + EscapableChars; + // Count escape sequences + EscCount := 0; + Idx := 1; + while Idx < Length(S) do // don't count '\' if last character + begin + if S[Idx] = cEscChar then + begin + Inc(EscCount); + Inc(Idx); + end; + Inc(Idx); + end; + // Set length of result string and get pointer to it + SetLength(Result, Length(S) - EscCount); + PRes := PChar(Result); + // Replace escaped chars with literal ones + Idx := 1; + while Idx <= Length(S) do + begin + // check for escape char (unless last char when treat literally) + if (S[Idx] = cEscChar) and (Idx <> Length(S)) then + begin + // we have an escape char + Inc(Idx); // skip over '\' + // get index of escaped char (0 if not valid) + EscCharPos := SysUtils.AnsiPos(S[Idx], EscapeChars); + if EscCharPos > 0 then + PRes^ := EscapableChars[EscCharPos] + else + PRes^ := S[Idx]; // invalid escape char: copy literally + end + else + PRes^ := S[Idx]; + Inc(Idx); + Inc(PRes); + end; +end; + function StrMaxSequenceLength(const Ch: Char; const S: UnicodeString): Cardinal; var StartPos: Integer; diff --git a/Src/UTabSeparatedFileIO.pas b/Src/UTabSeparatedFileIO.pas new file mode 100644 index 000000000..7028a3797 --- /dev/null +++ b/Src/UTabSeparatedFileIO.pas @@ -0,0 +1,250 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2024, Peter Johnson (gravatar.com/delphidabbler). + * + * Classes that can read and write UTF8 files containing a watermark line + * followed by lines of tabbed separated values. +} + +unit UTabSeparatedFileIO; + +interface + +uses + // Delphi + SysUtils, + // Project + UExceptions, + UIStringList; + +type + + /// Class that writes UTF8 files beginning with a watermark line + /// followed by and blank line then lines of tabbed separated values. + /// + TTabSeparatedFileWriter = class(TObject) + strict private + var + fFileName: string; + fBuilder: TStringBuilder; + /// Convert any characters in AValue that can't appear in a + /// field into C-style escape sequences. + function Escape(const AValue: string): string; + /// Outputs the watermark AWatermark on a line on its own. + /// + procedure WriteWatermark(const AWaterMark: string); + public + /// Creates object to write file AFileName with watermark + /// AWatermark. + constructor Create(const AFileName: string; const AWatermark: string); + /// Object destructor. + destructor Destroy; override; + /// Writes data to file just before the object is destroyed. + /// + procedure BeforeDestruction; override; + /// Writes a line of data with tabbed separated fields. + /// array of string [in] Fields to be written. + /// + procedure WriteLine(const AFields: array of string); + end; + + /// Class that reads UTF8 files beginning with a watermark line + /// followed by lines of tabbed separated values. + /// Any blank lines are ignored. + TTabSeparatedReader = class(TObject) + public + type + /// Type of callback trigged when each line is pardsed. + /// + /// TArray<string> [in] Fields defined + /// in the line. + TLineCallback = reference to procedure(AFields: TArray); + strict private + var + fFileName: string; + fWatermark: string; + fLines: IStringList; + /// Un-escapes any a C style escape sequences in AValue. + /// + function UnEscape(const AValue: string): string; + /// Reads file and splits into lines. + /// ETabSeparatedReader raised if file can't be read. + /// + procedure ReadFile; + /// Removes all blank lines from the data. + procedure PreProcess; + /// Parses the data. See the Read method for details of the + /// ALineCallback parameter. + procedure Parse(const ALineCallback: TLineCallback); + public + /// Creates object to read file AFileName which must begin + /// with watermark AWatermark. + constructor Create(const AFileName: string; const AWatermark: string); + /// Reads all data from the file. + /// TLineCallback [in] Callback called + /// for each line of data read. Passed an array of fields read from the + /// line. Caller must process the fields in this callback. + /// ETabSeparatedReader raised if file can't be read or + /// if watermark is not valid. + procedure Read(const ALineCallback: TLineCallback); + end; + + ETabSeparatedReader = class(ECodeSnip); + +implementation + +uses + // Delphi + Classes, + // Project + UConsts, + UIOUtils, + UStrUtils; + +const + EscapeableChars = TAB + CR + LF; + EscapedChars = 'trn'; + +{ TTabSeparatedFileWriter } + +procedure TTabSeparatedFileWriter.BeforeDestruction; +begin + inherited; + TFileIO.WriteAllText(fFileName, fBuilder.ToString, TEncoding.UTF8, True); +end; + +constructor TTabSeparatedFileWriter.Create(const AFileName, AWatermark: string); +begin + Assert(not StrIsEmpty(AFileName), ClassName + '.Create: AFileName is empty'); + Assert(not StrIsEmpty(AWatermark, True), + ClassName + '.Create: AWatermark is empty'); + + inherited Create; + fFileName := StrTrim(AFileName); + fBuilder := TStringBuilder.Create; + WriteWatermark(AWaterMark); +end; + +destructor TTabSeparatedFileWriter.Destroy; +begin + fBuilder.Free; + inherited; +end; + +function TTabSeparatedFileWriter.Escape(const AValue: string): string; +begin + // Perform character escaping per + // https://en.wikipedia.org/wiki/Tab-separated_values + Result := StrCEscapeStr(AValue, EscapedChars, EscapeableChars); +end; + +procedure TTabSeparatedFileWriter.WriteLine(const AFields: array of string); +var + Data: TStringList; + Item: string; +begin + Data := TStringList.Create; + try + // escape each data item in array + for Item in AFields do + Data.Add(Escape(Item)); + fBuilder.AppendLine(StrJoin(Data, TAB, True)); + finally + Data.Free; + end; +end; + +procedure TTabSeparatedFileWriter.WriteWatermark(const AWaterMark: string); +begin + if StrTrim(AWaterMark) <> '' then + begin + fBuilder.AppendLine(AWaterMark); + fBuilder.AppendLine; + end; +end; + +{ TTabSeparatedReader } + +constructor TTabSeparatedReader.Create(const AFileName, AWatermark: string); +begin + Assert(not StrIsEmpty(AFileName), ClassName + '.Create: AFileName is empty'); + Assert(not StrIsEmpty(AWatermark, True), + ClassName + '.Create: AWatermark is empty'); + + inherited Create; + fFileName := StrTrim(AFileName); + fWatermark := StrTrim(AWatermark); + fLines := TIStringList.Create; +end; + +procedure TTabSeparatedReader.Parse(const ALineCallback: TLineCallback); +resourcestring + sBadFileFormat = 'Invalid tab separated list file format'; +var + Line: string; + Fields: TStringList; + Idx: Integer; +begin + // check for watermark in 1st line + if (fLines.Count < 1) or (fLines[0] <> fWatermark) then + raise ETabSeparatedReader.Create(sBadFileFormat); + // delete watermark line + fLines.Delete(0); + for Line in fLines do + begin + Fields := TStringList.Create; + try + StrExplode(Line, TAB, Fields); + for Idx := 0 to Pred(Fields.Count) do + Fields[Idx] := UnEscape(Fields[Idx]); + ALineCallback(Fields.ToStringArray); + finally + Fields.Free; + end; + end; +end; + +procedure TTabSeparatedReader.PreProcess; +var + Idx: Integer; +begin + for Idx := Pred(fLines.Count) downto 0 do + if StrIsEmpty(fLines[Idx], True) then + fLines.Delete(Idx); +end; + +procedure TTabSeparatedReader.ReadFile; +begin + try + fLines.SetText( + TFileIO.ReadAllText(fFileName, TEncoding.UTF8, True), CRLF, False, True + ); + except + on E: EStreamError do + raise ETabSeparatedReader.Create(E); + on E: EIOUtils do + raise ETabSeparatedReader.Create(E); + else + raise; + end; +end; + +procedure TTabSeparatedReader.Read(const ALineCallback: TLineCallback); +begin + ReadFile; + Preprocess; + Parse(ALineCallback); +end; + +function TTabSeparatedReader.UnEscape(const AValue: string): string; +begin + // Perform character un-escaping per + // https://en.wikipedia.org/wiki/Tab-separated_values + Result := StrCUnEscapeStr(AValue, EscapedChars, EscapeableChars); +end; + +end. + diff --git a/Src/UTestCompile.pas b/Src/UTestCompile.pas index 210a74b6e..516882852 100644 --- a/Src/UTestCompile.pas +++ b/Src/UTestCompile.pas @@ -20,7 +20,9 @@ interface // Delphi Classes, // Project - Compilers.UGlobals, DB.USnippet, UBaseObjects; + Compilers.UGlobals, + DB.Snippets, + UBaseObjects; type diff --git a/Src/UTestCompileUI.pas b/Src/UTestCompileUI.pas index 8df82ec99..eb8fa14f0 100644 --- a/Src/UTestCompileUI.pas +++ b/Src/UTestCompileUI.pas @@ -21,7 +21,9 @@ interface // Delphi SysUtils, Classes, // Project - Compilers.UGlobals, DB.USnippet, UBaseObjects; + Compilers.UGlobals, + DB.Snippets, + UBaseObjects; type diff --git a/Src/UTestUnit.pas b/Src/UTestUnit.pas index c34262c8f..422e04983 100644 --- a/Src/UTestUnit.pas +++ b/Src/UTestUnit.pas @@ -18,7 +18,7 @@ interface uses // Project - DB.USnippet; + DB.Snippets; type @@ -65,7 +65,7 @@ implementation // Delphi SysUtils, // Project - DB.USnippetKind, + DB.SnippetKind, UEncodings, UIOUtils, UPreferences, @@ -142,8 +142,9 @@ function TTestUnit.UnitName: string; begin if fSnippet.Kind = skUnit then Exit(TUnitAnalyser.UnitName(fSnippet.SourceCode)); - // Unit name is same as Snippet being tested, but with prefix to make unique - Result := cUnitPrefix + fSnippet.Name; + // Unit name is same as key of Snippet being tested, but with prefix to make + // unique + Result := cUnitPrefix + fSnippet.Key; // We ensure only ASCII characters are used in unit name. Any unsuitable // characters are replaced by underscore. // This is done because unit name is also used as unit file name. If we took diff --git a/Src/UTestUnitDlgMgr.pas b/Src/UTestUnitDlgMgr.pas index 05025efe5..756873fd9 100644 --- a/Src/UTestUnitDlgMgr.pas +++ b/Src/UTestUnitDlgMgr.pas @@ -20,7 +20,8 @@ interface // Delphi Classes, // Project - DB.USnippet, UBaseObjects; + DB.Snippets, + UBaseObjects; type diff --git a/Src/UTextSnippetDoc.pas b/Src/UTextSnippetDoc.pas index 923637950..13a21459d 100644 --- a/Src/UTextSnippetDoc.pas +++ b/Src/UTextSnippetDoc.pas @@ -20,7 +20,11 @@ interface // Delphi Classes, // Project - ActiveText.UMain, UEncodings, UIStringList, USnippetDoc; + ActiveText.UMain, + DB.Vaults, + UEncodings, + UIStringList, + USnippetDoc; type @@ -44,11 +48,12 @@ TTextSnippetDoc = class(TSnippetDoc) strict protected /// Initialises plain text document. procedure InitialiseDoc; override; - /// Adds given heading (i.e. snippet name) to document. Can be - /// user defined or from main database. - /// Heading is output the same whether user defined or not, so - /// UserDefined parameter is ignored. - procedure RenderHeading(const Heading: string; const UserDefined: Boolean); + + /// Output given heading, i.e. snippet name for snippet from a + /// given vault. + /// Heading is output the same regardless of the snippet's vault. + /// + procedure RenderHeading(const Heading: string; const AVaultID: TVaultID); override; /// Interprets and adds given snippet description to document. /// @@ -76,9 +81,8 @@ TTextSnippetDoc = class(TSnippetDoc) /// Active text is converted to word-wrapped plain text /// paragraphs. procedure RenderExtra(const ExtraText: IActiveText); override; - /// Adds given information about code snippets database to - /// document. - procedure RenderDBInfo(const Text: string); override; + /// Output given information about a vault. + procedure RenderVaultInfo(const Text: string); override; /// Finalises document and returns content as encoded data. /// function FinaliseDoc: TEncodedData; override; @@ -144,12 +148,6 @@ procedure TTextSnippetDoc.RenderCompilerInfo(const Heading: string; ); end; -procedure TTextSnippetDoc.RenderDBInfo(const Text: string); -begin - fWriter.WriteLine; - fWriter.WriteLine(StrWrap(Text, cPageWidth, 0)); -end; - procedure TTextSnippetDoc.RenderDescription(const Desc: IActiveText); begin fWriter.WriteLine; @@ -165,7 +163,7 @@ procedure TTextSnippetDoc.RenderExtra(const ExtraText: IActiveText); end; procedure TTextSnippetDoc.RenderHeading(const Heading: string; - const UserDefined: Boolean); + const AVaultID: TVaultID); begin fWriter.WriteLine(Heading); end; @@ -198,5 +196,11 @@ procedure TTextSnippetDoc.RenderTitledText(const Title, Text: string); fWriter.WriteLine(StrWrap(Text, cPageWidth - cIndent, cIndent)); end; +procedure TTextSnippetDoc.RenderVaultInfo(const Text: string); +begin + fWriter.WriteLine; + fWriter.WriteLine(StrWrap(Text, cPageWidth, 0)); +end; + end. diff --git a/Src/UUniqueID.pas b/Src/UUniqueID.pas index cf18f058a..90bd9ef94 100644 --- a/Src/UUniqueID.pas +++ b/Src/UUniqueID.pas @@ -5,7 +5,7 @@ * * Copyright (C) 2009-2021, Peter Johnson (gravatar.com/delphidabbler). * - * Implements a static class that generates globally unique id strings. + * Implements a generator of globally unique ids. } @@ -16,22 +16,36 @@ interface uses - // Project - UBaseObjects; + // Delphi + SysUtils; type - { - TUniqueID: - Static class that generates globally unique id strings. - } - TUniqueID = class(TNoConstructObject) + /// Generator of globally unique ids. + TUniqueID = record + strict private + + /// Generates a new GUID and returns it as an array of bytes. + /// + class function NewUID: TBytes; static; + public - class function Generate: string; - {Generates a 32 digit globally unique id string of hex characters. - @return Required unique id. - } + + /// Generates a globally unique string of 32 hexadecimal + /// characters. + class function Generate: string; static; + {TODO -cClarity: Rename above method as GenerateHex} + + /// Generates a globally unique string of 32 alphabetical + /// characters. + /// + /// The returned string comprises the letters 'A' to 'S', omitting + /// 'I' and 'O'. + /// The string is a valid Pascal identifier. + /// + class function GenerateAlpha: string; static; + end; @@ -39,34 +53,51 @@ implementation uses - // Delphi - SysUtils; + // Project + UUtils; { TUniqueID } class function TUniqueID.Generate: string; - {Generates a 32 digit globally unique id string of hex characters. - @return Required unique id. - } +var + Bytes: TBytes; + B: Byte; +begin + Bytes := NewUID; + Result := ''; + for B in Bytes do + Result := Result + IntToHex(B, 2); +end; + +class function TUniqueID.GenerateAlpha: string; type - TGUIDFragment = LongWord; // part of a TGUID - TGUIDFragments = // array of TGUID parts - assume same size as TGUID - array[1..SizeOf(TGUID) div SizeOf(TGUIDFragment)] of TGUIDFragment; + TNybble = 0..15; +const + AlphaMap: array[TNybble] of Char = ( + 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', + 'J', 'K', 'L', 'M', 'P', 'Q', 'R', 'S' + ); var - GUID: TGUID; // generated GUID - Idx: Integer; // loops through parts of GUID as an array + Bytes: TBytes; + B: Byte; begin - Assert(SizeOf(TGUID) = SizeOf(TGUIDFragments), - ClassName + '.Generate: Size of TGUID <> size of TGUIDFragments'); - // get a GUID - CreateGUID(GUID); + Bytes := NewUID; Result := ''; - // crack GUID into parts and build result from hex representation of the parts - for Idx := Low(TGUIDFragments) to High(TGUIDFragments) do - Result := Result + IntToHex( - TGUIDFragments(GUID)[Idx], 2 * SizeOf(TGUIDFragment) - ); + for B in Bytes do + begin + Result := Result + + AlphaMap[TNybble(B shr 4)] + + AlphaMap[TNybble(B and $0F)]; + end; +end; + +class function TUniqueID.NewUID: TBytes; +var + GUID: TGUID; +begin + CreateGUID(GUID); + Result := GUIDToBytes(GUID); end; end. diff --git a/Src/UUserDBBackup.pas b/Src/UUserDBBackup.pas deleted file mode 100644 index 7c50ff22c..000000000 --- a/Src/UUserDBBackup.pas +++ /dev/null @@ -1,62 +0,0 @@ -{ - * This Source Code Form is subject to the terms of the Mozilla Public License, - * v. 2.0. If a copy of the MPL was not distributed with this file, You can - * obtain one at https://mozilla.org/MPL/2.0/ - * - * Copyright (C) 2008-2021, Peter Johnson (gravatar.com/delphidabbler). - * - * Implements a class that can create and restore backups of the user database. -} - - -unit UUserDBBackup; - - -interface - - -uses - // Project - UFolderBackup; - - -type - - { - TUserDBBackup: - Sealed class that can create and restore backups of the user database. - Backups are single files. See UFolderBackup for details of file format. - } - TUserDBBackup = class sealed(TFolderBackup) - strict private - const cFileID = SmallInt($DBAC); // User database backup file ID - public - constructor Create(const BackupFile: string); - {Class constructor. Sets up object to backup user database to a specified - file. - @param BackupFile [in] Name of backup file. - } - end; - - -implementation - - -uses - // Project - UAppInfo; - - -{ TUserDBBackup } - -constructor TUserDBBackup.Create(const BackupFile: string); - {Class constructor. Sets up object to backup user database to a specified - file. - @param BackupFile [in] Name of backup file. - } -begin - inherited Create(TAppInfo.UserDataDir, BackupFile, cFileID); -end; - -end. - diff --git a/Src/UUserDBMgr.pas b/Src/UUserDBMgr.pas index 48ce2ecd8..4df7cd68a 100644 --- a/Src/UUserDBMgr.pas +++ b/Src/UUserDBMgr.pas @@ -5,7 +5,7 @@ * * Copyright (C) 2008-2022, Peter Johnson (gravatar.com/delphidabbler). * - * Implements a static class that manages user's interaction with user database. + * Implements a static class that manages user's interaction with the database. } @@ -14,12 +14,17 @@ interface +{TODO -cRefactoring: Rename this unit/classes/methods: the names refer to the + CodeSnip 4 database structure but the code now works with vaults} uses // Delphi Classes, // Project - DB.UCategory, UBaseObjects, UView; + DB.Categories, + DB.SnippetIDs, + UBaseObjects, + UView; type @@ -27,36 +32,13 @@ interface /// Static class that manages user's interaction with user database /// and performs move and backup operations on it. TUserDBMgr = class(TNoConstructObject) - strict private - /// OnClose event handler for open dialogue box. Checks if - /// dialogue box can close. - /// TObject [in] Reference to dialogue box in - /// question. - /// Boolean [in/out] Set to True to permit dialogue - /// to close or False to inhibit closure. - class procedure CanOpenDialogClose(Sender: TObject; var CanClose: Boolean); - /// OnClose event handler for save dialogue box. Checks if - /// dialogue box can close. - /// TObject [in] Reference to dialogue box in - /// question. - /// Boolean [in/out] Set to True to permit dialogue - /// to close or False to inhibit closure. - class procedure CanSaveDialogClose(Sender: TObject; var CanClose: Boolean); - /// Creates a list of user defined categories. - /// Boolean [in] Flag indicating whether list - /// should include special, non-deletable, categories. - /// Required category list. - /// Caller must free the returned object. - class function CreateUserCatList( - const IncludeSpecial: Boolean): TCategoryList; public /// Enables user to adds a new user defined snippet to the /// database using the snippets editor. class procedure AddSnippet; - /// Enables user to edit the snippet with the given name using the + /// Enables user to edit the snippet with the given ID using the /// snippets editor. - /// The named snippet must be user defined. - class procedure EditSnippet(const SnippetName: string); + class procedure EditSnippet(const ASnippetID: TSnippetID); /// Duplicates the snippet specified by the given view as a user /// defined snippet with name specified by user. class procedure DuplicateSnippet(ViewItem: IView); @@ -96,7 +78,10 @@ TUserDBMgr = class(TNoConstructObject) /// Moves the user database to a new location specified by the /// user. class procedure MoveDatabase; - /// Deletes the user database, with permission. + /// Deletes all the snippets in a vault specified by the user. + /// + /// Boolean. True if the vault's data was deleted, + /// False otherwise. class function DeleteDatabase: Boolean; end; @@ -106,19 +91,32 @@ implementation uses // Delphi - SysUtils, Dialogs, Windows {for inlining}, IOUtils, + SysUtils, + Dialogs, + Windows {for inlining}, + IOUtils, // Project - DB.UMain, DB.USnippet, - FmAddCategoryDlg, FmDeleteCategoryDlg, FmDuplicateSnippetDlg, - FmRenameCategoryDlg, FmSnippetsEditorDlg, + DB.Main, + DB.Snippets, + DB.Vaults, + FmAddCategoryDlg, + UI.Forms.BackupVaultDlg, + FmDeleteCategoryDlg, + UI.Forms.DeleteVaultDlg, + FmDuplicateSnippetDlg, + FmRenameCategoryDlg, + FmSnippetsEditorDlg, {$IFNDEF PORTABLE} - FmUserDataPathDlg, + UI.Forms.MoveVaultDlg, {$ENDIF} - FmDeleteUserDBDlg, FmWaitDlg, + FmWaitDlg, UAppInfo, - UConsts, UExceptions, UIStringList, UMessageBox, UOpenDialogEx, - UOpenDialogHelper, UReservedCategories, USaveDialogEx, USnippetIDs, - UUserDBBackup, UWaitForThreadUI; + UConsts, + UExceptions, + UIStringList, + UMessageBox, + VaultBackup, + UWaitForThreadUI; type /// Base class for classes that execute a user database management @@ -182,24 +180,27 @@ TRestoreThread = class(TThread) var /// Name of backup file to be restored. fBakFileName: string; + + fVault: TVault; strict protected /// Restores the user database from a backup. procedure Execute; override; public /// Constructs a new, suspended, thread that can restore the - /// database from the given backup file. - constructor Create(const BakFileName: string); + /// given vault from the given backup file. + constructor Create(const BakFileName: string; const AVault: TVault); end; public - /// Performs a user database restoration operation from in a - /// background thread and displays a wait diaogue box if the operation - /// takes more than a given time to execute. Blocks until the thread - /// terminates. + /// Performs the restoration of a vault from a background thread + /// and displays a wait diaogue box if the operation takes more than a + /// given time to execute. Blocks until the thread terminates. /// TComponent [in] Component that owns the dialogue /// box, over which it is aligned. /// string [in] Name of backup file to be /// restored. - class procedure Execute(AOwner: TComponent; const BakFileName: string); + /// TVault Vault being restored. + class procedure Execute(AOwner: TComponent; const BakFileName: string; + const AVault: TVault); end; type @@ -214,23 +215,27 @@ TBackupThread = class(TThread) var /// Name of backup file to be created. fBakFileName: string; + + fVault: TVault; strict protected /// Backs up the user database. procedure Execute; override; public /// Constructs a new, suspended, thread that can backup the - /// database to the given backup file. - constructor Create(const BakFileName: string); + /// given vault to the given backup file. + constructor Create(const BakFileName: string; const AVault: TVault); end; public - /// Performs a user database backup operation from in a background - /// thread and displays a wait diaogue box if the operation takes more than - /// a given time to execute. Blocks until the thread terminates. + /// Performs a vault backup operation in a background thread and + /// displays a wait diaogue box if the operation takes more than a given + /// time to execute. Blocks until the thread terminates. /// TComponent [in] Component that owns the dialogue /// box, over which it is aligned. /// string [in] Name of backup file to be /// created. - class procedure Execute(AOwner: TComponent; const BakFileName: string); + /// TVault Vault being backed up. + class procedure Execute(AOwner: TComponent; const BakFileName: string; + const AVault: TVault); end; { TUserDBMgr } @@ -249,37 +254,30 @@ class procedure TUserDBMgr.AddSnippet; class procedure TUserDBMgr.BackupDatabase(ParentCtrl: TComponent); var - SaveDlg: TSaveDialogEx; // save dialog box used to name backup file + FileName: string; + Vault: TVault; resourcestring - // Dialog box caption - sCaption = 'Save Backup'; + sOverwritePrompt = '"%s" already exists. OK to overwrite?'; begin - // Get backup file name from user via standard save dialog box - SaveDlg := TSaveDialogEx.Create(nil); - try - SaveDlg.OnCanClose := CanSaveDialogClose; - SaveDlg.Title := sCaption; - SaveDlg.Options := [ofShowHelp, ofExtensionDifferent, ofPathMustExist, - ofNoTestFileCreate, ofEnableSizing]; - SaveDlg.HelpKeyword := 'SaveBackupDlg'; - if SaveDlg.Execute then - // Perform backup - TUserDBBackupUI.Execute(ParentCtrl, SaveDlg.FileName); - finally - SaveDlg.Free; + if TVaultBackupDlg.Execute(ParentCtrl, FileName, Vault) then + begin + if TFile.Exists(FileName) + and not TMessageBox.Confirm( + ParentCtrl, Format(sOverwritePrompt, [FileName]) + ) then + Exit; + TUserDBBackupUI.Execute(ParentCtrl, FileName, Vault); end; end; class function TUserDBMgr.CanDeleteACategory: Boolean; var - CatList: TCategoryList; // list of user deletable categories + Cat: TCategory; begin - CatList := CreateUserCatList(False); // builds list of deletable user cats - try - Result := CatList.Count > 0; - finally - CatList.Free; - end; + Result := False; + for Cat in Database.Categories do + if Cat.CanDelete then + Exit(True); end; class function TUserDBMgr.CanDuplicate(ViewItem: IView): Boolean; @@ -288,91 +286,32 @@ class function TUserDBMgr.CanDuplicate(ViewItem: IView): Boolean; end; class function TUserDBMgr.CanEdit(ViewItem: IView): Boolean; -var - SnippetView: ISnippetView; // ViewItem as snippet view if supported begin Assert(Assigned(ViewItem), ClassName + '.CanEdit: ViewItem is nil'); - Result := Assigned(ViewItem) - and Supports(ViewItem, ISnippetView, SnippetView) - and SnippetView.Snippet.UserDefined; -end; - -class procedure TUserDBMgr.CanOpenDialogClose(Sender: TObject; - var CanClose: Boolean); -var - FileName: string; // name of file entered in dialog box -resourcestring - // Error message - sFileDoesNotExist = '"%s" does not exist.'; -begin - CanClose := False; - FileName := FileOpenEditedFileName(Sender as TOpenDialogEx); - if not FileExists(FileName) then - begin - // Specified file doesn't exist: inhibit closure - TMessageBox.Error( - Sender as TOpenDialogEx, - Format(sFileDoesNotExist, [FileName]) - ); - Exit; - end; - // All OK: allow closure - CanClose := True; + Result := Supports(ViewItem, ISnippetView); end; class function TUserDBMgr.CanRenameACategory: Boolean; -var - CatList: TCategoryList; // list of user renamable categories begin - CatList := CreateUserCatList(True); // build list of all user categories - try - Result := CatList.Count > 0; - finally - CatList.Free; - end; + Result := True; end; class function TUserDBMgr.CanSave: Boolean; begin // We can save database if it's been changed - Result := (Database as IDatabaseEdit).Updated; -end; - -class procedure TUserDBMgr.CanSaveDialogClose(Sender: TObject; - var CanClose: Boolean); -var - FileName: string; // name of file entered in dialog box -resourcestring - // Error message - sOverwritePrompt = '"%s" already exists. OK to overwrite?'; -begin - FileName := FileOpenEditedFileName(Sender as TSaveDialogEx); - if FileExists(FileName) then - // File exists: allow closure if user permits file to be overwritten - CanClose := TMessageBox.Confirm( - Sender as TSaveDialogEx, - Format(sOverwritePrompt, [FileName]) - ); -end; - -class function TUserDBMgr.CreateUserCatList( - const IncludeSpecial: Boolean): TCategoryList; -var - Cat: TCategory; // references each category in snippets database -begin - Result := TCategoryList.Create; - for Cat in Database.Categories do - if Cat.UserDefined and - (IncludeSpecial or not TReservedCategories.IsReserved(Cat)) then - Result.Add(Cat); + Result := Database.Updated; end; class procedure TUserDBMgr.DeleteACategory; var CatList: TCategoryList; // list of deletable categories + Cat: TCategory; begin - CatList := CreateUserCatList(False); + CatList := TCategoryList.Create; try + for Cat in Database.Categories do + if Cat.CanDelete then + CatList.Add(Cat); // all work takes place in dialog box TDeleteCategoryDlg.Execute(nil, CatList) finally @@ -381,18 +320,22 @@ class procedure TUserDBMgr.DeleteACategory; end; class function TUserDBMgr.DeleteDatabase: Boolean; +var + VaultToDelete: TVault; begin - if not TDeleteUserDBDlg.Execute(nil) then + if not TDeleteVaultDlg.Execute(nil, VaultToDelete) then Exit(False); - if not TDirectory.Exists(TAppInfo.UserDataDir) then + if not TDirectory.Exists(VaultToDelete.Storage.Directory) then Exit(False); - TDirectory.Delete(TAppInfo.UserDataDir, True); + TDirectory.Delete(VaultToDelete.Storage.Directory, True); Result := True; end; class procedure TUserDBMgr.DeleteSnippet(ViewItem: IView); - // Builds a list of snippet names from a given snippet ID list. + {TODO -cVault: rename following inner method to SnippetDisplayNames for + clarity} + // Builds a list of snippet display names from a given snippet ID list. function SnippetNames(const IDList: ISnippetIDList): IStringList; var ID: TSnippetID; // loops through all IDs in list @@ -423,10 +366,8 @@ class procedure TUserDBMgr.DeleteSnippet(ViewItem: IView); Assert(Supports(ViewItem, ISnippetView), ClassName + '.Delete: Current view is not a snippet'); Snippet := (ViewItem as ISnippetView).Snippet; - Assert(Snippet.UserDefined, - ClassName + '.Delete: Snippet must be user defined'); // Check if snippet has dependents: don't allow deletion if so - Dependents := (Database as IDatabaseEdit).GetDependents(Snippet); + Dependents := Database.GetDependents(Snippet); if Dependents.Count > 0 then begin TMessageBox.Error( @@ -439,7 +380,7 @@ class procedure TUserDBMgr.DeleteSnippet(ViewItem: IView); Exit; end; // Get permission to delete. If snippet has dependents list them in prompt - Referrers := (Database as IDatabaseEdit).GetReferrers(Snippet); + Referrers := Database.GetReferrers(Snippet); if Referrers.Count = 0 then ConfirmMsg := Format(sConfirmDelete, [Snippet.DisplayName]) else @@ -451,7 +392,7 @@ class procedure TUserDBMgr.DeleteSnippet(ViewItem: IView); ] ); if TMessageBox.Confirm(nil, ConfirmMsg) then - (Database as IDatabaseEdit).DeleteSnippet(Snippet); + Database.DeleteSnippet(Snippet); end; class procedure TUserDBMgr.DuplicateSnippet(ViewItem: IView); @@ -461,13 +402,13 @@ class procedure TUserDBMgr.DuplicateSnippet(ViewItem: IView); TDuplicateSnippetDlg.Execute(nil, (ViewItem as ISnippetView).Snippet); end; -class procedure TUserDBMgr.EditSnippet(const SnippetName: string); +class procedure TUserDBMgr.EditSnippet(const ASnippetID: TSnippetID); var Snippet: TSnippet; // reference to snippet to be edited begin - Snippet := Database.Snippets.Find(SnippetName, True); + Snippet := Database.Snippets.Find(ASnippetID); if not Assigned(Snippet) then - raise EBug.Create(ClassName + '.EditSnippet: Snippet not in user database'); + raise EBug.Create(ClassName + '.EditSnippet: Snippet not found'); TSnippetsEditorDlg.EditSnippet(nil, Snippet); end; @@ -475,16 +416,19 @@ class procedure TUserDBMgr.MoveDatabase; begin // This dialogue box not available in portable edition {$IFNDEF PORTABLE} - TUserDataPathDlg.Execute(nil); + TMoveVaultDlg.Execute(nil); {$ENDIF} end; class procedure TUserDBMgr.RenameACategory; var + Cat: TCategory; CatList: TCategoryList; // list of user defined categories begin - CatList := CreateUserCatList(True); + CatList := TCategoryList.Create; try + for Cat in Database.Categories do + CatList.Add(Cat); // all work takes place in dialog box TRenameCategoryDlg.Execute(nil, CatList) finally @@ -494,24 +438,23 @@ class procedure TUserDBMgr.RenameACategory; class function TUserDBMgr.RestoreDatabase(ParentCtrl: TComponent): Boolean; var - Dlg: TOpenDialogEx; // open dialog box used to select backup file + FileName: string; + Vault: TVault; resourcestring - sCaption = 'Open Backup File'; // dialog box caption + sFileDoesNotExist = '"%s" does not exist.'; begin - // Get name of backup file from user via standard open dialog box - Dlg := TOpenDialogEx.Create(nil); - try - Dlg.OnCanClose := CanOpenDialogClose; - Dlg.Title := sCaption; - Dlg.Options := [ofShowHelp, ofPathMustExist, ofHideReadOnly, - ofEnableSizing]; - Dlg.HelpKeyword := 'RestoreBackupDlg'; - Result := Dlg.Execute; - if Result then - // Perform restoration - TUserDBRestoreUI.Execute(ParentCtrl, Dlg.FileName); - finally - Dlg.Free; + Result := TVaultBackupDlg.Execute(ParentCtrl, FileName, Vault); + if Result then + begin + if not TFile.Exists(FileName) then + begin + // Specified file doesn't exist: inhibit closure + TMessageBox.Error( + ParentCtrl, Format(sFileDoesNotExist, [FileName]) + ); + Exit; + end; + TUserDBRestoreUI.Execute(ParentCtrl, FileName, Vault); end; end; @@ -563,20 +506,20 @@ constructor TUserDBSaveUI.TSaveThread.Create; procedure TUserDBSaveUI.TSaveThread.Execute; begin - (Database as IDatabaseEdit).Save; + Database.Save; end; { TUserDBRestoreUI } class procedure TUserDBRestoreUI.Execute(AOwner: TComponent; - const BakFileName: string); + const BakFileName: string; const AVault: TVault); resourcestring // Caption for wait dialog - sWaitCaption = 'Restoring database files...'; + sWaitCaption = 'Restoring vault files...'; var Thread: TRestoreThread; // thread that performs restore operation begin - Thread := TRestoreThread.Create(BakFileName); + Thread := TRestoreThread.Create(BakFileName, AVault); try RunThreadWithWaitDlg(Thread, AOwner, sWaitCaption); finally @@ -586,17 +529,19 @@ class procedure TUserDBRestoreUI.Execute(AOwner: TComponent; { TUserDBRestoreUI.TRestoreThread } -constructor TUserDBRestoreUI.TRestoreThread.Create(const BakFileName: string); +constructor TUserDBRestoreUI.TRestoreThread.Create(const BakFileName: string; + const AVault: TVault); begin inherited Create(True); fBakFileName := BakFileName; + fVault := AVault; end; procedure TUserDBRestoreUI.TRestoreThread.Execute; var - UserDBBackup: TUserDBBackup; + UserDBBackup: TVaultBackup; begin - UserDBBackup := TUserDBBackup.Create(fBakFileName); + UserDBBackup := TVaultBackup.Create(fBakFileName, fVault); try UserDBBackup.Restore; finally @@ -607,14 +552,14 @@ procedure TUserDBRestoreUI.TRestoreThread.Execute; { TUserDBBackupUI } class procedure TUserDBBackupUI.Execute(AOwner: TComponent; - const BakFileName: string); + const BakFileName: string; const AVault: TVault); resourcestring // Caption for wait dialog - sWaitCaption = 'Backing up database...'; + sWaitCaption = 'Backing up vault...'; var Thread: TBackupThread; // thread that performs restore operation begin - Thread := TBackupThread.Create(BakFileName); + Thread := TBackupThread.Create(BakFileName, AVault); try RunThreadWithWaitDlg(Thread, AOwner, sWaitCaption); finally @@ -624,20 +569,22 @@ class procedure TUserDBBackupUI.Execute(AOwner: TComponent; { TUserDBBackupUI.TBackupThread } -constructor TUserDBBackupUI.TBackupThread.Create(const BakFileName: string); +constructor TUserDBBackupUI.TBackupThread.Create(const BakFileName: string; + const AVault: TVault); begin inherited Create(True); fBakFileName := BakFileName; + fVault := AVault; end; procedure TUserDBBackupUI.TBackupThread.Execute; var - UserDBBackup: TUserDBBackup; // object used to perform backup + UserDBBackup: TVaultBackup; resourcestring // Dialog box caption sCaption = 'Save Backup'; begin - UserDBBackup := TUserDBBackup.Create(fBakFileName); + UserDBBackup := TVaultBackup.Create(fBakFileName, fVault); try UserDBBackup.Backup; finally diff --git a/Src/UUtils.pas b/Src/UUtils.pas index 279d62080..285197f30 100644 --- a/Src/UUtils.pas +++ b/Src/UUtils.pas @@ -3,7 +3,7 @@ * v. 2.0. If a copy of the MPL was not distributed with this file, You can * obtain one at https://mozilla.org/MPL/2.0/ * - * Copyright (C) 2005-2021, Peter Johnson (gravatar.com/delphidabbler). + * Copyright (C) 2005-2024, Peter Johnson (gravatar.com/delphidabbler). * * General utility routines. } @@ -172,15 +172,51 @@ function IsEqualBytes(const BA1, BA2: TBytes; const Count: Cardinal): /// If both arrays are empty they are considered equal. function IsEqualBytes(const BA1, BA2: TBytes): Boolean; overload; +/// Converts a TGUID record into an array of bytes. +/// TGUID [in] GUID to be converted. +/// TBytes. Required byte array. +function GUIDToBytes(const AGUID: TGUID): TBytes; + /// Attempts to convert string S into a Word value. /// string [in] String to be converted. -/// Cardinal [out] Value of converted string. Undefined if +/// Word [out] Value of converted string. Undefined if /// conversion fails. /// Boolean. True if conversion succeeds, False if not. /// String must represent a non-negative integer that is representable /// as a Word. function TryStrToWord(const S: string; out W: Word): Boolean; +/// Attempts to convert string S into a Byye value. +/// string [in] String to be converted. +/// Byte [out] Value of converted string. Undefined if +/// conversion fails. +/// Boolean. True if conversion succeeds, False if not. +/// String must represent a non-negative integer that is representable +/// as a Byte. +function TryStrToByte(const S: string; out B: Byte): Boolean; + +/// Converts a byte array to a string that is a concatentation of the +/// hex representation of the bytes of the array. +/// TBytes [in] Byte array to convert. +/// string. String of hex digits or empty string if BA is empty. +/// +/// The returned string is twice the length of BA, since each byte +/// occupies two hex digits. +function BytesToHexString(const BA: TBytes): string; + +/// Attempts to convert a string of hex digits to an array of bytes. +/// +/// string [in] String of hex digits. Alphabetic +/// characters can be either upper or lower case. +/// TBytes [out] Array of bytes converted from string. +/// Undefined if conversion fails. +/// Boolean. True if conversion succeeds, False if not. +/// String must be composed of valid hex digits, with two characters +/// per byte. Therefore the string must have an even number of characters. +/// +function TryHexStringToBytes(const AHexStr: string; out ABytes: TBytes): + Boolean; + implementation @@ -461,6 +497,19 @@ function IsEqualBytes(const BA1, BA2: TBytes): Boolean; Result := True; end; +function GUIDToBytes(const AGUID: TGUID): TBytes; +type + TGUIDCracker = array[1..SizeOf(TGUID) div SizeOf(Byte)] of Byte; +var + Idx: Integer; +begin + Assert(SizeOf(TGUID) = SizeOf(TGUIDCracker), + 'GUIDToBytes: Size of TGUID <> size of TGUIDCracker'); + SetLength(Result, SizeOf(TGUIDCracker)); + for Idx := Low(TGUIDCracker) to High(TGUIDCracker) do + Result[Idx - Low(TGUIDCracker)] := TGUIDCracker(AGUID)[Idx]; +end; + function TryStrToWord(const S: string; out W: Word): Boolean; var I: Integer; @@ -473,5 +522,53 @@ function TryStrToWord(const S: string; out W: Word): Boolean; W := Word(I); end; +function TryStrToByte(const S: string; out B: Byte): Boolean; +var + I: Integer; +begin + Result := TryStrToInt(S, I); + if not Result then + Exit; + if (I < Low(Byte)) or (I > High(Byte)) then + Exit(False); + B := Byte(I); +end; + +function BytesToHexString(const BA: TBytes): string; +var + B: Byte; +begin + Result := ''; + for B in BA do + Result := Result + IntToHex(B, 2); +end; + +function TryHexStringToBytes(const AHexStr: string; out ABytes: TBytes): + Boolean; +const + HexByteStrLength = 2; +var + HexByteStart: Integer; + HexByteStr: string; + ResIdx: Integer; + ConvertedByte: Byte; +begin + Result := True; + if Length(AHexStr) mod HexByteStrLength <> 0 then + Exit(False); + SetLength(ABytes, Length(AHexStr) div HexByteStrLength); + ResIdx := 0; + HexByteStart := 1; + while HexByteStart < Length(AHexStr) do + begin + HexByteStr := Copy(AHexStr, HexByteStart, HexByteStrLength); + if not TryStrToByte('$' + HexByteStr, ConvertedByte) then + Exit(False); + ABytes[ResIdx] := ConvertedByte; + Inc(HexByteStart, HexByteStrLength); + Inc(ResIdx); + end; +end; + end. diff --git a/Src/UVersionInfo.pas b/Src/UVersionInfo.pas index c74fbdc01..9e6e33b98 100644 --- a/Src/UVersionInfo.pas +++ b/Src/UVersionInfo.pas @@ -49,6 +49,10 @@ TVersionNumber = record V2: Word; // Minor version number V3: Word; // Revision version number V4: Word; // Build number + + /// Creates an instance of the record with the given version + /// numbers. + constructor Create(const AV1, AV2, AV3, AV4: Word); /// Checks if this version number is Null. /// Boolean. True if null, False otherwise. function IsNull: Boolean; @@ -277,6 +281,14 @@ class function TVersionInfo.SpecialBuildStr: string; { TVersionNumber } +constructor TVersionNumber.Create(const AV1, AV2, AV3, AV4: Word); +begin + V1 := AV1; + V2 := AV2; + V3 := AV3; + V4 := AV4; +end; + class operator TVersionNumber.Equal(Ver1, Ver2: TVersionNumber): Boolean; {Operator overload that compares two version numbers to check for equality. @param Ver1 [in] First version number. diff --git a/Src/UView.pas b/Src/UView.pas index b3425318a..0002c6539 100644 --- a/Src/UView.pas +++ b/Src/UView.pas @@ -20,7 +20,11 @@ interface // Delphi Generics.Collections, // Project - DB.UCategory, DB.USnippet, DB.USnippetKind, UBaseObjects, UInitialLetter; + DB.Categories, + DB.SnippetKind, + DB.Snippets, + UBaseObjects, + UInitialLetter; type @@ -56,8 +60,6 @@ interface /// without having have an instance of any object wrapped by the view. /// function GetKey: IViewKey; - /// Checks if view is user-defined. - function IsUserDefined: Boolean; /// Checks if view is a grouping. /// A grouping is a view that groups views together. /// @@ -196,7 +198,10 @@ implementation // Delphi SysUtils, // Project - DB.UMain, UExceptions, USnippetIDs, UStrUtils; + DB.Main, + DB.SnippetIDs, + UExceptions, + UStrUtils; type /// @@ -230,9 +235,6 @@ TKey = class(TInterfacedObject, IViewKey) /// Gets object containing view's unique key. /// Method of IView. function GetKey: IViewKey; - /// Checks if view is user-defined. - /// Method of IView. - function IsUserDefined: Boolean; /// Checks if view is a grouping. /// Method of IView. function IsGrouping: Boolean; @@ -320,8 +322,6 @@ TKey = class(TInterfacedObject, IViewKey) /// Gets object containing view's unique key. /// Method of IView. function GetKey: IViewKey; - /// Checks if view is user-defined. - function IsUserDefined: Boolean; /// Checks if view is a grouping. /// Method of IView. function IsGrouping: Boolean; @@ -367,9 +367,6 @@ TKey = class(TInterfacedObject, IViewKey) /// Gets object containing view's unique key. /// Method of IView. function GetKey: IViewKey; - /// Checks if view is user-defined. - /// Method of IView. - function IsUserDefined: Boolean; /// Checks if view is a grouping. /// Method of IView. function IsGrouping: Boolean; @@ -417,9 +414,6 @@ TKey = class(TInterfacedObject, IViewKey) /// Gets object containing view's unique key. /// Method of IView. function GetKey: IViewKey; - /// Checks if view is user-defined. - /// Method of IView. - function IsUserDefined: Boolean; /// Checks if view is a grouping. /// Method of IView. function IsGrouping: Boolean; @@ -467,9 +461,6 @@ TKey = class(TInterfacedObject, IViewKey) /// Gets object containing view's unique key. /// Method of IView. function GetKey: IViewKey; - /// Checks if view is user-defined. - /// Method of IView. - function IsUserDefined: Boolean; /// Checks if view is a grouping. /// Method of IView. function IsGrouping: Boolean; @@ -495,11 +486,6 @@ function TSimpleView.IsGrouping: Boolean; Result := False; end; -function TSimpleView.IsUserDefined: Boolean; -begin - Result := False; -end; - { TSimpleView.TKey } constructor TSimpleView.TKey.Create(OwnerClass: TClass); @@ -586,11 +572,6 @@ function TSnippetView.IsGrouping: Boolean; Result := False; end; -function TSnippetView.IsUserDefined: Boolean; -begin - Result := GetSnippet.UserDefined; -end; - { TSnippetView.TKey } constructor TSnippetView.TKey.Create(const ID: TSnippetID); @@ -645,11 +626,6 @@ function TCategoryView.IsGrouping: Boolean; Result := True; end; -function TCategoryView.IsUserDefined: Boolean; -begin - Result := GetCategory.UserDefined; -end; - { TCategoryView.TKey } constructor TCategoryView.TKey.Create(const ID: string); @@ -702,11 +678,6 @@ function TSnippetKindView.IsGrouping: Boolean; Result := True; end; -function TSnippetKindView.IsUserDefined: Boolean; -begin - Result := False; -end; - { TSnippetKindView.TKey } constructor TSnippetKindView.TKey.Create(const ID: TSnippetKind); @@ -759,11 +730,6 @@ function TInitialLetterView.IsGrouping: Boolean; Result := True; end; -function TInitialLetterView.IsUserDefined: Boolean; -begin - Result := False; -end; - { TInitialLetterView.TKey } constructor TInitialLetterView.TKey.Create(const ID: TInitialLetter); diff --git a/Src/UWBExternal.pas b/Src/UWBExternal.pas index 46c5fb12d..735fb75a9 100644 --- a/Src/UWBExternal.pas +++ b/Src/UWBExternal.pas @@ -26,7 +26,7 @@ interface type - /// COM object that implements the methods of the IWBExternal14 + /// COM object that implements the methods of the IWBExternal15 /// interface that extend the browser control's 'external' object. /// /// This class enables application code to be called from JavaScript @@ -34,7 +34,7 @@ interface /// The methods a declared in the type library that is defined in /// External.idl. /// - TWBExternal = class(TAutoIntfObject, IWBExternal14, ISetNotifier) + TWBExternal = class(TAutoIntfObject, IWBExternal15, ISetNotifier) strict private var /// Object used to call application code in response to @@ -53,53 +53,44 @@ TWBExternal = class(TAutoIntfObject, IWBExternal14, ISetNotifier) /// library. constructor Create; - /// Updates database from internet. - /// Method of IWBExternal14. - procedure UpdateDbase; safecall; - - /// Displays a named snippet. - /// WideString [in] Name of snippet to be - /// displayed. - /// WordBool [in] Whether the snippet is user - /// defined. + /// Display snippet identified by key and vault ID. + /// WideString [in] Snippet's key. + /// WideString [in] Hex representation of + /// snippet's vault ID. /// WordBool [in] Whether to display snippet in a new /// tab. - /// Method of IWBExternal14. - procedure DisplaySnippet(const SnippetName: WideString; - UserDefined: WordBool; NewTab: WordBool); safecall; + /// Method of IWBExternal15. + procedure DisplaySnippet(const Key: WideString; + const VaultIDAsHex: WideString; NewTab: WordBool); safecall; /// Displays the Configure Compilers dialogue box. - /// Method of IWBExternal14. + /// Method of IWBExternal15. procedure ConfigCompilers; safecall; - /// Edits a named snippet. - /// WideString [in] Name of snippet to be edited. - /// - /// - /// The named snippet must be user defined. - /// Method of IWBExternal14. - /// - procedure EditSnippet(const SnippetName: WideString); safecall; + /// Edits the snippet identified by its key and vault ID. + /// + /// WideString [in] Snippet's key. + /// WideString [in] Hex representation of + /// snippet's vault ID. + /// Method of IWBExternal15. + procedure EditSnippet(const Key: WideString; + const VaultIDAsHex: WideString); safecall; /// Displays a named category. /// WideString [in] ID of category to be displayed. /// /// WordBool [in] Whether to display category in a new /// tab. - /// Method of IWBExternal14. + /// Method of IWBExternal15. procedure DisplayCategory(const CatID: WideString; NewTab: WordBool); safecall; - /// Opens Snippet Editor ready to create a new snippet. - /// Method of IWBExternal14. - procedure NewSnippet; safecall; - /// Shows latest news items from CodeSnip news feed. - /// Method of IWBExternal14. + /// Method of IWBExternal15. procedure ShowNews; safecall; /// Displays the program's About Box. - /// Method of IWBExternal14. + /// Method of IWBExternal15. procedure ShowAboutBox; safecall; /// Records the notifier object that is used to call application @@ -118,6 +109,7 @@ implementation // Delphi Forms, // Project + DB.Vaults, UAppInfo; @@ -142,7 +134,7 @@ constructor TWBExternal.Create; ExeName := TAppInfo.AppExeFilePath; OleCheck(LoadTypeLib(PWideChar(ExeName), TypeLib)); // Create the object using type library - inherited Create(TypeLib, IWBExternal14); + inherited Create(TypeLib, IWBExternal15); end; procedure TWBExternal.DisplayCategory(const CatID: WideString; @@ -156,22 +148,25 @@ procedure TWBExternal.DisplayCategory(const CatID: WideString; end; end; -procedure TWBExternal.DisplaySnippet(const SnippetName: WideString; - UserDefined: WordBool; NewTab: WordBool); +procedure TWBExternal.DisplaySnippet(const Key, VaultIDAsHex: WideString; + NewTab: WordBool); begin try if Assigned(fNotifier) then - fNotifier.DisplaySnippet(SnippetName, UserDefined, NewTab); + fNotifier.DisplaySnippet( + Key, TVaultID.CreateFromHexString(VaultIDAsHex), NewTab + ); except HandleException; end; end; -procedure TWBExternal.EditSnippet(const SnippetName: WideString); +procedure TWBExternal.EditSnippet(const Key: WideString; + const VaultIDAsHex: WideString); begin try if Assigned(fNotifier) then - fNotifier.EditSnippet(SnippetName); + fNotifier.EditSnippet(Key, TVaultID.CreateFromHexString(VaultIDAsHex)); except HandleException; end; @@ -182,16 +177,6 @@ procedure TWBExternal.HandleException; Application.HandleException(ExceptObject); end; -procedure TWBExternal.NewSnippet; -begin - try - if Assigned(fNotifier) then - fNotifier.NewSnippet; - except - HandleException; - end; -end; - procedure TWBExternal.SetNotifier(const Notifier: INotifier); begin fNotifier := Notifier; @@ -217,15 +202,5 @@ procedure TWBExternal.ShowNews; end; end; -procedure TWBExternal.UpdateDbase; -begin - try - if Assigned(fNotifier) then - fNotifier.UpdateDbase; - except - HandleException; - end; -end; - end. diff --git a/Src/UXMLDocConsts.pas b/Src/UXMLDocConsts.pas deleted file mode 100644 index 122d13322..000000000 --- a/Src/UXMLDocConsts.pas +++ /dev/null @@ -1,79 +0,0 @@ -{ - * This Source Code Form is subject to the terms of the Mozilla Public License, - * v. 2.0. If a copy of the MPL was not distributed with this file, You can - * obtain one at https://mozilla.org/MPL/2.0/ - * - * Copyright (C) 2008-2023, Peter Johnson (gravatar.com/delphidabbler). - * - * Constants defined node names and attributes used in the various XML documents - * used by CodeSnip. -} - - -unit UXMLDocConsts; - - -interface - - -uses - // Project - Compilers.UGlobals; - - -const - // XML processing instruction node with version - cXMLNode = 'xml'; - cXMLNodeText = 'version="1.0"'; - - // Document nodes and attribute names - // user-database XML only - cUserDataRootNode = 'codesnip-data'; - cCategoriesNode = 'categories'; - cCategoryNode = 'category'; - cCategoryIdAttr = 'id'; - cCatSnippetsNode = 'cat-routines'; - cSourceCodeFileNode = 'source-code'; - cXRefNode = 'xref'; - // export XML only - cExportRootNode = 'codesnip-export'; - cProgVersionNode = 'prog-version'; - cSourceCodeTextNode = 'source-code-text'; - // common to user-database and export XML - cRootVersionAttr = 'version'; - cRootWatermarkAttr = 'watermark'; - cPascalNameNode = 'pascal-name'; - cDisplayNameNode = 'display-name'; - cSnippetsNode = 'routines'; - cSnippetNode = 'routine'; - cSnippetNameAttr = 'name'; - cCatIdNode = 'cat-id'; - cDescriptionNode = 'description'; - cUnitsNode = 'units'; - cDependsNode = 'depends'; - cCommentsNode = 'comments'; - cCreditsNode = 'credits'; - cCreditsUrlNode = 'credits-url'; - cExtraNode = 'extra'; - cKindNode = 'kind'; - cHighlightSource = 'highlight-source'; - cStandardFormatNode = 'standard-format'; - cCompilerResultsNode = 'compiler-results'; - cCompilerResultNode = 'compiler-result'; - cCompilerResultIdAttr = 'id'; - - // ID values: common to user-database and export XML - cCompilerIDs: array[TCompilerID] of string = ( - 'd2', 'd3', 'd4', 'd5', 'd6', 'd7', - 'd2005', 'd2006', 'd2007', 'd2009', 'd2010', - 'dXE', 'dXE2', 'dXE3', 'dDX4' {error, but in use so can't fix}, - 'dXE5', 'dXE6', 'dXE7', 'dXE8', - 'd10s', 'd101b', 'd102t', 'd103r', 'd104s', 'd11a', 'd12y', - 'fpc' - ); - - -implementation - -end. - diff --git a/Src/UXMLDocHelper.pas b/Src/UXMLDocHelper.pas index fabe3f1ea..c2a4c7eb8 100644 --- a/Src/UXMLDocHelper.pas +++ b/Src/UXMLDocHelper.pas @@ -5,7 +5,7 @@ * * Copyright (C) 2008-2021, Peter Johnson (gravatar.com/delphidabbler). * - * Implements a static class that helps with input and output to CodeSnip XML + * Implements a static class that helps with input and output to any XML * documents. } @@ -20,19 +20,28 @@ interface // Delphi XMLIntf, // Project - Compilers.UGlobals, DB.USnippetKind, UExceptions, UIStringList, UStructs, + Compilers.UGlobals, + DB.SnippetKind, + UBaseObjects, + UExceptions, + UIStringList, + UStructs, UXMLDocumentEx; type - { - TXMLDocHelper: - Static class that helps with input and output to CodeSnip XML documents. - Provides functionality common to two or more XML read/write classes. - } - TXMLDocHelper = class(TObject) + /// Static class that helps with input and output to any XML + /// documents. + /// Do not contruct instances of this class. + TXMLDocHelper = class(TNoConstructObject) strict private + const + // XML processing instruction node + XMLNodeName = 'xml'; + // XML processing node version attribute + XMLNodeVersionAttr = 'version="1.0"'; + class function FindRootNodeType(const XMLDoc: IXMLDocumentEx; const ANodeType: TNodeType): IXMLNode; {Finds a specified type of root node. @@ -49,21 +58,6 @@ TXMLDocHelper = class(TObject) {Creates xml processing instruction in document. @param XMLDoc [in] Document in which processing instruction is inserted. } - class procedure CreateComment(const XMLDoc: IXMLDocumentEx; - const Comment: string); - {Creates a comment at the top level of an XML document. - @param XMLDoc [in] Document in which comment is inserted. - @param Comment [in] Comment to be inserted. - } - class function CreateRootNode(const XMLDoc: IXMLDocumentEx; - const NodeName, Watermark: string; const Version: Integer): IXMLNode; - {Creates a root in XML document. - @param XMLDoc [in] Document in which to insert root node. - @param NodeName [in] Name of root node. - @param Watermark [in] Value of root node's "watermark" attribute. - @param Version [in] Value of root node's "version" attribute. - @return Reference to new root node. - } class function GetSubTagText(const XMLDoc: IXMLDocumentEx; const ParentNode: IXMLNode; const SubTagName: string): string; {Gets text of subtag of a parent node in an XML document. @@ -73,84 +67,6 @@ TXMLDocHelper = class(TObject) @return Sub tag's text if sub tag exists and is a text node, '' otherwise. } - class procedure GetPascalNameList(const XMLDoc: IXMLDocumentEx; - const ListNode: IXMLNode; const NameList: IStringList); - {Gets a list of names in elements with a list. - @param XMLDoc [in] XML document containing name list. - @param ListNode [in] Node that contains list. - @param NameList [in] Receives text of all elements in - list. - } - class function GetCompilerResults(const XMLDoc: IXMLDocumentEx; - const SnippetNode: IXMLNode): TCompileResults; - {Gets compiler results for a snippet in an XML document. - @param XMLDoc [in] XML document containing snippet. - @param SnippetNode [in] Document node that contains compiler results - tag. - @return Array of compiler results. Provides defaults for missing - compilers. - } - class function GetStandardFormat(const XMLDoc: IXMLDocumentEx; - const SnippetNode: IXMLNode; const Default: Boolean): Boolean; - {Gets value of a node of a snippet in an XML document. - @param XMLDoc [in] XML document containing snippet. - @param SnippetNode [in] Snippet node that contains standard format tag. - @param Default [in] Value to use if node doesn't exist or has - non-standard value. - @return Value of node, or default value. - } - class function GetSnippetKind(const XMLDoc: IXMLDocumentEx; - const SnippetNode: IXMLNode; const Default: TSnippetKind): TSnippetKind; - {Gets value of node of a snippet in an XML document. - @param XMLDoc [in] XML document containing snippet. - @param SnippetNode [in] Snippet node that contains kind tag. - @param Default [in] Value to use if node doesn't exist or has - non-standard value. - @return Required snippet kind. - } - class function GetHiliteSource(const XMLDoc: IXMLDocumentEx; - const SnippetNode: IXMLNode; const Default: Boolean): Boolean; - {Gets value of a node of a snippet in an XML document. - @param XMLDoc [in] XML document containing snippet. - @param SnippetNode [in] Snippet node that contains highlight source tag. - @param Default [in] Value to use if node doesn't exist or has - non-standard value. - @return Value of node, or default value. - } - class procedure WriteCompilerResults(const XMLDoc: IXMLDocumentEx; - const SnippetNode: IXMLNode; const CompRes: TCompileResults); - {Writes compile results for a snippet to XML document. - @param XMLDoc [in] XML document to receive compile results. - @param SnippetNode [in] Node containing snippet that received compile - results. - @param CompRes [in] Array of compiler results. - } - class procedure WritePascalNameList(const XMLDoc: IXMLDocumentEx; - const Parent: IXMLNode; const ListName: string; const Names: IStringList); - {Writes a Pascal name list to an XML document. - @param XMLDoc [in] XML document to which list is written. - @param Parent [in] Parent node that is to contain name list. - @param ListName [in] Name of new list node that is parent of list. - @param Names [in] List of Pascal names. - } - class procedure WriteSnippetKind(const XMLDoc: IXMLDocumentEx; - const SnippetNode: IXMLNode; const Value: TSnippetKind); - {Writes a node to a an XML document. - @param XMLDoc [in] XML document to receive the node. - @param SnippetNode [in] Node containing snippet that receives kind node. - @param Value [in] Value of node. - } - class function ValidateRootNode(const XMLDoc: IXMLDocumentEx; - const ANodeName, AWatermark: string; const AVersions: TRange): Integer; - {Validates the root node of an XML document. - @param XMLDoc [in] XML document to be validated. - @param ANodeName [in] Name of root mode. - @param AWatermark [in] Required value of root node's "watermark" - attribute. - @param AVersions [in] Range of acceptable file version numbers. - @return Document version. - @except ECodeSnipXML raised on error. - } class procedure ValidateProcessingInstr(const XMLDoc: IXMLDocumentEx); {Checks that an XML document has a valid xml processing instruction. @param XMLDoc [in] Document to be checked. @@ -158,6 +74,7 @@ TXMLDocHelper = class(TObject) } end; + {TODO -cVault: Replace ECodeSnipXML with EDataIO} { ECodeSnipXML: Class of exception raised by TXMLDocHelper validation methods. @@ -172,37 +89,11 @@ implementation // Delphi Windows {for inlining}, // Project - UStrUtils, UXMLDocConsts; + UStrUtils; { TXMLDocHelper } -class procedure TXMLDocHelper.CreateComment(const XMLDoc: IXMLDocumentEx; - const Comment: string); - {Creates a comment at the top level of an XML document. - @param XMLDoc [in] Document in which comment is inserted. - @param Comment [in] Comment to be inserted. - } -begin - XMLDoc.ChildNodes.Add(XMLDoc.CreateNode(' ' + Comment + ' ', ntComment)); -end; - -class function TXMLDocHelper.CreateRootNode(const XMLDoc: IXMLDocumentEx; - const NodeName, Watermark: string; const Version: Integer): IXMLNode; - {Creates a root in XML document. - @param XMLDoc [in] Document in which to insert root node. - @param NodeName [in] Name of root node. - @param Watermark [in] Value of root node's "watermark" attribute. - @param Version [in] Value of root node's "version" attribute. - @return Reference to new root node. - } -begin - Result := XMLDoc.CreateNode(NodeName); - Result.SetAttribute(cRootWatermarkAttr, Watermark); - Result.SetAttribute(cRootVersionAttr, Version); - XMLDoc.ChildNodes.Add(Result); -end; - class function TXMLDocHelper.CreateXMLDoc: IXMLDocumentEx; {Creates a new XML document object with required properties. @return New XML document object. @@ -219,7 +110,7 @@ class procedure TXMLDocHelper.CreateXMLProcInst(const XMLDoc: IXMLDocumentEx); } begin XMLDoc.ChildNodes.Add( - XMLDoc.CreateNode(cXMLNode, ntProcessingInstr, cXMLNodeText) + XMLDoc.CreateNode(XMLNodeName, ntProcessingInstr, XMLNodeVersionAttr) ); end; @@ -244,174 +135,6 @@ class function TXMLDocHelper.FindRootNodeType(const XMLDoc: IXMLDocumentEx; end; end; -class function TXMLDocHelper.GetCompilerResults(const XMLDoc: IXMLDocumentEx; - const SnippetNode: IXMLNode): TCompileResults; - {Gets compiler results for a snippet in an XML document. - @param XMLDoc [in] XML document containing snippet. - @param SnippetNode [in] Document node that contains compiler results tag. - @return Array of compiler results. Provides defaults for missing compilers. - } - - // ------------------------------------------------------------------------- - function IDStrToCompID(IDStr: string; - out Match: TCompilerID): Boolean; - {Converts an identifier string to a compiler ID. - @param IDStr [in] Identifier string. - @param Match [out] Set to compiler ID that matches IDStr. Undefined if - IDStr not recognised. - @return True if IDStr is recognised, False if not. - } - var - CompID: TCompilerID; // loops thru all compiler IDs - begin - // 'dXE4' can be encountered when reading files written by CodeSnip 3, which - // uses correct 'dXE4' symbol for Delphi XE4 instead of 'dDX4' used - // (erroneously) by CodeSnip 4. So the following two lines convert the - // CodeSnip 3 value to the CodeSnip 4 value before testing. - if IDStr = 'dXE4' then - IDStr := cCompilerIDs[ciDXE4]; - Result := False; - for CompID := Low(TCompilerID) to High(TCompilerID) do - begin - if cCompilerIDs[CompID] = IDStr then - begin - Result := True; - Match := CompID; - Break; - end; - end; - end; - // ------------------------------------------------------------------------- - -var - ListNode: IXMLNode; // node that enclose compiler result nodes - ResultsNodes: IXMLSimpleNodeList; // list of compiler-result nodes - ResultNode: IXMLNode; // a compiler-result node - CompID: TCompilerID; // loops thru compiler IDs - CompResultStr: string; // compiler id string from result node -begin - // Initialise all results to unknown (query) - for CompID := Low(TCompilerID) to High(TCompilerID) do - Result[CompID] := crQuery; - - // Find enclosing node: valid if this is not present - ListNode := XMLDoc.FindFirstChildNode(SnippetNode, cCompilerResultsNode); - if not Assigned(ListNode) then - Exit; - - // Get list of compiler-result nodes contained in list and process each one - ResultsNodes := XMLDoc.FindChildNodes(ListNode, cCompilerResultNode); - for ResultNode in ResultsNodes do - begin - if ResultNode.IsTextElement then - begin - // get compile result identifier - CompResultStr := ResultNode.Text; - if CompResultStr = '' then - CompResultStr := '?'; - // add specified result function result - if IDStrToCompID( - ResultNode.Attributes[cCompilerResultIdAttr], CompID - ) then - begin - case CompResultStr[1] of - 'Y': Result[CompID] := crSuccess; - 'N': Result[CompID] := crError; - 'W': Result[CompiD] := crWarning; - else Result[CompID] := crQuery; - end; - end; - end; - end; -end; - -class function TXMLDocHelper.GetHiliteSource(const XMLDoc: IXMLDocumentEx; - const SnippetNode: IXMLNode; const Default: Boolean): Boolean; - {Gets value of a node of a snippet in an XML document. - @param XMLDoc [in] XML document containing snippet. - @param SnippetNode [in] Snippet node that contains highlight source tag. - @param Default [in] Value to use if node doesn't exist or has non-standard - value. - @return Value of node, or default value. - } -var - Value: string; // text value of HiliteSource node -begin - Value := GetSubTagText(XMLDoc, SnippetNode, cHighlightSource); - if Value <> '' then - Result := Value <> '0' - else - Result := Default; -end; - -class procedure TXMLDocHelper.GetPascalNameList(const XMLDoc: IXMLDocumentEx; - const ListNode: IXMLNode; const NameList: IStringList); - {Gets a list of names in elements with a list. - @param XMLDoc [in] XML document containing name list. - @param ListNode [in] Node that contains list. - @param NameList [in] Receives text of all elements in list. - } -var - NameNode: IXMLNode; // name of a node in the list - NodeList: IXMLSimpleNodeList; // list of matching child nodes if ListNode -begin - NameList.Clear; - if not Assigned(ListNode) then - Exit; // this is permitted since snippet lists can be empty or missing - NodeList := XMLDoc.FindChildNodes(ListNode, cPascalNameNode); - for NameNode in NodeList do - if NameNode.IsTextElement then - NameList.Add(NameNode.Text); -end; - -class function TXMLDocHelper.GetSnippetKind(const XMLDoc: IXMLDocumentEx; - const SnippetNode: IXMLNode; const Default: TSnippetKind): TSnippetKind; - {Gets value of node of a snippet in an XML document. - @param XMLDoc [in] XML document containing snippet. - @param SnippetNode [in] Snippet node that contains kind tag. - @param Default [in] Value to use if node doesn't exist or has non-standard - value. - @return Required snippet kind. - } -var - Value: string; // text value of Kind node -begin - Value := GetSubTagText(XMLDoc, SnippetNode, cKindNode); - if StrSameText(Value, 'freeform') then - Result := skFreeform - else if StrSameText(Value, 'routine') then - Result := skRoutine - else if StrSameText(Value, 'const') then - Result := skConstant - else if StrSameText(Value, 'type') then - Result := skTypeDef - else if StrSameText(Value, 'unit') then - Result := skUnit - else if StrSameText(Value, 'class') then - Result := skClass - else - Result := Default; -end; - -class function TXMLDocHelper.GetStandardFormat(const XMLDoc: IXMLDocumentEx; - const SnippetNode: IXMLNode; const Default: Boolean): Boolean; - {Gets value of a node of a snippet in an XML document. - @param XMLDoc [in] XML document containing snippet. - @param SnippetNode [in] Snippet node that contains standard format tag. - @param Default [in] Value to use if node doesn't exist or has non-standard - value. - @return Value of node, or default value. - } -var - Value: string; // text value of Kind node -begin - Value := GetSubTagText(XMLDoc, SnippetNode, cStandardFormatNode); - if Value <> '' then - Result := Value <> '0' - else - Result := Default; -end; - class function TXMLDocHelper.GetSubTagText(const XMLDoc: IXMLDocumentEx; const ParentNode: IXMLNode; const SubTagName: string): string; {Gets text of subtag of a parent node in an XML document. @@ -444,106 +167,10 @@ class procedure TXMLDocHelper.ValidateProcessingInstr( begin // Must have correct processing instruction () XMLNode := FindRootNodeType(XMLDoc, ntProcessingInstr); - if not Assigned(XMLNode) or (XMLNode.NodeName <> cXMLNode) + if not Assigned(XMLNode) or (XMLNode.NodeName <> XMLNodeName) or (XMLNode.NodeType <> ntProcessingInstr) then raise ECodeSnipXML.Create(sNoXMLProcInst); end; -class function TXMLDocHelper.ValidateRootNode(const XMLDoc: IXMLDocumentEx; - const ANodeName, AWatermark: string; const AVersions: TRange): Integer; - {Validates the root node of an XML document. - @param XMLDoc [in] XML document to be validated. - @param ANodeName [in] Name of root mode. - @param AWatermark [in] Required value of root node's "watermark" attribute. - @param AVersions [in] Range of acceptable file version numbers. - @return Document version. - @except ECodeSnipXML raised on error. - } -var - RootNode: IXMLNode; // document root node -resourcestring - // Error messages - sNoRootNode = 'Invalid document: no root element present'; - sBadRootName = 'Invalid document: root element must be named <%s>'; - sBadWatermark = 'Invalid document: watermark is incorrect'; - sBadVersion = 'Invalid document: unsupported document version %d'; -begin - RootNode := XMLDoc.DocumentElement; - // There must be a root node - if not Assigned(RootNode) then - raise ECodeSnipXML.Create(sNoRootNode); - // Correct root node must be present, with valid watermark and version - if RootNode.NodeName <> ANodeName then - raise ECodeSnipXML.CreateFmt(sBadRootName, [ANodeName]); - if RootNode.Attributes[cRootWatermarkAttr] <> AWatermark then - raise ECodeSnipXML.Create(sBadWatermark); - Result := RootNode.Attributes[cRootVersionAttr]; - if not AVersions.Contains(Result) then - raise ECodeSnipXML.CreateFmt(sBadVersion, [Result]); -end; - -class procedure TXMLDocHelper.WriteCompilerResults(const XMLDoc: IXMLDocumentEx; - const SnippetNode: IXMLNode; const CompRes: TCompileResults); - {Writes compile results for a snippet to XML document. - @param XMLDoc [in] XML document to receive compile results. - @param SnippetNode [in] Node containing snippet that received compile - results. - @param CompRes [in] Array of compiler results. - } -const - // map of compiler results onto character representation store in XML file. - cCompResMap: array[TCompileResult] of Char = ('Y', 'W', 'N', '?'); -var - CompResultsNode: IXMLNode; // node that stores all compiler results - CompResultNode: IXMLNode; // each compiler result node - CompID: TCompilerID; // loops thru all supported compilers -begin - // compiler results value: only write known results - CompResultsNode := XMLDoc.CreateElement(SnippetNode, cCompilerResultsNode); - for CompID := Low(TCompilerID) to High(TCompilerID) do - begin - if CompRes[CompID] <> crQuery then - begin - CompResultNode := XMLDoc.CreateElement( - CompResultsNode, cCompilerResultNode, - cCompResMap[CompRes[CompID]] - ); - CompResultNode.Attributes[cCompilerResultIdAttr] := cCompilerIDs[CompID]; - end; - end; -end; - -class procedure TXMLDocHelper.WritePascalNameList(const XMLDoc: IXMLDocumentEx; - const Parent: IXMLNode; const ListName: string; const Names: IStringList); - {Writes a Pascal name list to an XML document. - @param XMLDoc [in] XML document to which list is written. - @param Parent [in] Parent node that is to contain name list. - @param ListName [in] Name of new list node that is parent of list. - @param Names [in] List of Pascal names. - } -var - ListNode: IXMLNode; // reference to enclosing list node - Name: string; // a name item in list -begin - ListNode := XMLDoc.CreateElement(Parent, ListName); - for Name in Names do - XMLDoc.CreateElement(ListNode, cPascalNameNode, Name); -end; - -class procedure TXMLDocHelper.WriteSnippetKind(const XMLDoc: IXMLDocumentEx; - const SnippetNode: IXMLNode; const Value: TSnippetKind); - {Writes a node to a an XML document. - @param XMLDoc [in] XML document to receive the node. - @param SnippetNode [in] Node containing snippet that receives kind node. - @param Value [in] Value of node. - } -const - cValues: array[TSnippetKind] of string = ( - 'freeform', 'routine', 'const', 'type', 'unit', 'class' - ); -begin - XMLDoc.CreateElement(SnippetNode, cKindNode, cValues[Value]); -end; - end. diff --git a/Src/VaultBackup.pas b/Src/VaultBackup.pas new file mode 100644 index 000000000..e32f0fc98 --- /dev/null +++ b/Src/VaultBackup.pas @@ -0,0 +1,71 @@ +{ + * This Source Code Form is subject to the terms of the Mozilla Public License, + * v. 2.0. If a copy of the MPL was not distributed with this file, You can + * obtain one at https://mozilla.org/MPL/2.0/ + * + * Copyright (C) 2008-2021, Peter Johnson (gravatar.com/delphidabbler). + * + * Implements a class that can create and restore backups of vaults. +} + + +unit VaultBackup; + + +interface + + +uses + // Project + DB.Vaults, + UFolderBackup; + + +type + + {TODO -cVault: Rename TUserDBBackup class and UUserDBBackup unit.} + + /// Sealed class that can create and restore backups of vaults. + /// Backups are single files. + /// See UFolderBackup for details of the file format. + /// + TVaultBackup = class sealed(TFolderBackup) + strict private + class function MakeFileID(const AVault: TVault): SmallInt; + public + /// Object constructor. Sets up the object to backup the given + /// vault to the given backup file. + constructor Create(const BackupFile: string; const AVault: TVault); + end; + + +implementation + + +uses + // Delphi + SysUtils, + // Project + UAppInfo; + + +{ TVaultBackup } + +constructor TVaultBackup.Create(const BackupFile: string; + const AVault: TVault); +begin + inherited Create( + AVault.Storage.Directory, BackupFile, MakeFileID(AVault), AVault.UID.ToArray + ); +end; + +class function TVaultBackup.MakeFileID(const AVault: TVault): + SmallInt; +begin + // Backup file ID is $Fxxx where xxx is ordinal value of format kind. + // The $F indicates that the file is a backup of a vault data format. + Result := SmallInt($F000 or UInt16(Ord(AVault.Storage.Format))); +end; + +end. + diff --git a/Src/UUserDBMove.pas b/Src/VaultMover.pas similarity index 60% rename from Src/UUserDBMove.pas rename to Src/VaultMover.pas index 447594147..5665e087e 100644 --- a/Src/UUserDBMove.pas +++ b/Src/VaultMover.pas @@ -5,11 +5,11 @@ * * Copyright (C) 2013-2021, Peter Johnson (gravatar.com/delphidabbler). * - * Implements a class that moves the user defined database to a new location. + * Implements a class that moves a vault to a new location. } -unit UUserDBMove; +unit VaultMover; interface @@ -17,18 +17,18 @@ interface uses // Project + DB.Vaults, UDirectoryCopier; type - /// Class that moves the user defined database to a new location. - /// - TUserDBMove = class(TObject) + /// Class that moves a vault to a new location. + TVaultMover = class(TObject) public type - /// Type of event triggered by TUserDBMove to report progress - /// when moving the database files. - /// TObject [in] TUserDBMove instance that triggered + /// Type of event triggered to report progress when moving a + /// vault's data files. + /// TObject [in] TVaultMover instance that triggered /// the event. /// Byte [in] Percentage of operation that has been /// completed. @@ -40,39 +40,41 @@ TUserDBMove = class(TObject) fOnCopyFile: TProgress; /// Reference to event handler for OnDeleteFile event. fOnDeleteFile: TProgress; - /// Directory of existing user database. + /// Directory containg existing vault data. fSourceDir: string; - /// Required new database directory. + /// Required new vault data directory. fDestDir: string; + /// Vault to be moved. + fVault: TVault; /// Instance of class used to perform directory move. fDirCopier: TDirectoryCopier; /// Validates source and destination directories. - /// Raises EInOutError exception if either directory is not - /// valid. + /// Raises EInOutError exception if either directory is not + /// valid. procedure ValidateDirectories; - /// Handles TDirectoryCopier.OnAfterCopyDir event to update user - /// database location. - /// Database location is updated once the database has been copied - /// but before old database directory is deleted. + /// Handles TDirectoryCopier.OnAfterCopyDir event to update the + /// vault data directory. + /// Vault data location is updated once the vault's data has been + /// copied but before the old vault data directory is deleted. procedure SetNewDBDirectory(Sender: TObject); /// Handles TDirectoryCopier.OnCopyFileProgress event and passes - /// the given progress percentage on to this class' similar OnCopyFile + /// the given progress percentage on to this class' similar OnCopyFile /// event. procedure ReportCopyProgress(Sender: TObject; const Percent: Single); /// Handles TDirectoryCopier.OnDeleteFileProgress event and passes - /// the given progress percentage on to this class' similar - /// OnDeleteFile event. + /// the given progress percentage on to this class' similar OnDeleteFile + /// event. procedure ReportDeleteProgress(Sender: TObject; const Percent: Single); public /// Constructs and initialises new object instance. constructor Create; /// Destroys current object instance. destructor Destroy; override; - /// Moves user database from its current directory to the given - /// new directory. + /// Moves vault data from its current directory to the given new + /// directory. /// Raises EInOutError exceptions if an error occurs. /// - procedure MoveTo(const ADirectory: string); + procedure MoveTo(const AVault: TVault; const ADirectory: string); /// Event triggered just before file copying begins and once for /// each file copied. Reports progress towards completion of copy /// operation. @@ -91,12 +93,13 @@ implementation // Delphi SysUtils, IOUtils, // Project - UAppInfo, UStrUtils; + UAppInfo, + UStrUtils; -{ TUserDBMove } +{ TVaultMover } -constructor TUserDBMove.Create; +constructor TVaultMover.Create; begin inherited Create; fDirCopier := TDirectoryCopier.Create; @@ -105,50 +108,56 @@ constructor TUserDBMove.Create; fDirCopier.OnDeleteFileProgress := ReportDeleteProgress; end; -destructor TUserDBMove.Destroy; +destructor TVaultMover.Destroy; begin fDirCopier.Free; inherited; end; -procedure TUserDBMove.MoveTo(const ADirectory: string); +procedure TVaultMover.MoveTo(const AVault: TVault; const ADirectory: string); begin - fSourceDir := ExcludeTrailingPathDelimiter(TAppInfo.UserDataDir); + fVault := AVault; + fSourceDir := ExcludeTrailingPathDelimiter(AVault.Storage.Directory); fDestDir := ExcludeTrailingPathDelimiter(ADirectory); ValidateDirectories; fDirCopier.Move(fSourceDir, fDestDir); end; -procedure TUserDBMove.ReportCopyProgress(Sender: TObject; +procedure TVaultMover.ReportCopyProgress(Sender: TObject; const Percent: Single); begin if Assigned(fOnCopyFile) then fOnCopyFile(Self, Round(Percent)); end; -procedure TUserDBMove.ReportDeleteProgress(Sender: TObject; +procedure TVaultMover.ReportDeleteProgress(Sender: TObject; const Percent: Single); begin if Assigned(fOnDeleteFile) then fOnDeleteFile(Self, Round(Percent)); end; -procedure TUserDBMove.SetNewDBDirectory(Sender: TObject); +procedure TVaultMover.SetNewDBDirectory(Sender: TObject); +var + Vaults: TVaults; begin + Vaults := TVaults.Instance; // record new location BEFORE deleting old directory - TAppInfo.ChangeUserDataDir(fDestDir); + fVault.Storage.Directory := fDestDir; + Vaults.Update(fVault); + // Persist vaults immediately to save new directory ASAP to prevent directory + // change being lost following a program crash. + Vaults.Save; end; -procedure TUserDBMove.ValidateDirectories; +procedure TVaultMover.ValidateDirectories; resourcestring - sSameNames = 'The new database directory is the same as the current ' - + 'directory.'; - sSourceMissing = 'No user database found'; - sCantMoveToSubDir = 'Can''t move database into a sub-directory of the ' - + 'existing database directory'; - sDestMustBeRooted = 'A full path to the new database directory must be ' - + 'provided.'; - sDestMustBeEmpty = 'The new database directory must be empty'; + sSameNames = 'The new directory is the same as the current directory.'; + sSourceMissing = 'No vault data found'; + sCantMoveToSubDir = 'Can''t move the vault into a sub-directory of its ' + + 'existing data directory'; + sDestMustBeRooted = 'A full path to the new directory must be provided.'; + sDestMustBeEmpty = 'The new data directory must be empty'; begin if not TPath.IsPathRooted(fDestDir) then raise EInOutError.Create(sDestMustBeRooted); @@ -163,7 +172,7 @@ procedure TUserDBMove.ValidateDirectories; raise EInOutError.Create(sSameNames); if StrStartsText( - IncludeTrailingPathDelimiter(TAppInfo.UserDataDir), fDestDir + IncludeTrailingPathDelimiter(fVault.Storage.Directory), fDestDir ) then raise EInOutError.Create(sCantMoveToSubDir); end; diff --git a/Src/VersionInfo.vi-inc b/Src/VersionInfo.vi-inc index 82a6dfe24..c673ba417 100644 --- a/Src/VersionInfo.vi-inc +++ b/Src/VersionInfo.vi-inc @@ -1,12 +1,12 @@ # CodeSnip Version Information Macros for Including in .vi files # Version & build numbers -version=4.26.0 -build=276 +version=4.900.0 +build=1000 # String file information copyright=Copyright © P.D.Johnson, 2005-. description=Code Snippets Repository company=DelphiDabbler -name=CodeSnip +name=CodeSnip.Vault license=Released under the terms of the Mozilla Public License v2.0 (https://www.mozilla.org/MPL/2.0/) diff --git a/Tests/Src/DUnit/TestUUtils.pas b/Tests/Src/DUnit/TestUUtils.pas index f4c117554..845dbcb10 100644 --- a/Tests/Src/DUnit/TestUUtils.pas +++ b/Tests/Src/DUnit/TestUUtils.pas @@ -24,6 +24,10 @@ TTestUtilsRoutines = class(TTestCase) procedure TestIsValidDriveLetter; procedure TestURIBaseName; procedure TestTryStrToCardinal; + procedure TestIsEqualBytes_NoCount_overload; + procedure TestIsEqualBytes_Count_overload; + procedure TestBytesToHexString; + procedure TestTryHexStringToBytes; end; @@ -37,6 +41,22 @@ implementation { TTestUtilsRoutines } +procedure TTestUtilsRoutines.TestBytesToHexString; +const + B0Str = ''; + B1Str = 'FA'; + B2Str = '010EAA42B656'; +var + BA0, BA1, BA2: TBytes; +begin + BA0 := TBytes.Create(); + BA1 := TBytes.Create($fa); + BA2 := TBytes.Create($01, $0E, $AA, $42, $B6, $56); + CheckEquals(B0Str, BytesToHexString(BA0), 'BA0'); + CheckEquals(B1Str, BytesToHexString(BA1), 'BA1'); + CheckEquals(B2Str, BytesToHexString(BA2), 'BA2'); +end; + procedure TTestUtilsRoutines.TestFloatToInt; begin CheckEquals(42, FloatToInt(42.0), 'Test 1'); @@ -80,6 +100,50 @@ procedure TTestUtilsRoutines.TestIsBaseFileName; CheckFalse(IsBaseFileName(''), 'Test 9'); end; +procedure TTestUtilsRoutines.TestIsEqualBytes_Count_overload; +var + B0, B0a, B1, B1a, B2, B3, B4: TBytes; +begin + B0 := TBytes.Create(); + B0a := TBytes.Create(); + B1 := TBytes.Create(1,2,3,4,5,6,7,8,9,10); + B1a := TBytes.Create(1,2,3,4,5,6,7,8,9,10); + B2 := TBytes.Create(1,2,3,4,5,6,7,8,9,11); + B3 := TBytes.Create(1,2,3,4,5,6,7,8,9); + B4 := TBytes.Create(0,1,2,3,4,5,6,7,8,9,10); + CheckTrue(IsEqualBytes(B1, B1a, 10), 'B1 = B1a (10)'); + CheckTrue(IsEqualBytes(B1, B2, 9), 'B1 = B2 (9)'); + CheckFalse(IsEqualBytes(B1, B2, 10), 'B1 <> B2 (10)'); + CheckFalse(IsEqualBytes(B1, B1a, 15), 'B1 <> B1a (15)'); + CheckFalse(IsEqualBytes(B3, B4, 1), 'B3 <> B4 (1)'); + CheckTrue(IsEqualBytes(B2, B3, 1), 'B2 <> B3 (1)'); + CheckFalse(IsEqualBytes(B0, B0a, 1), 'B0 <> B0a (0)'); +end; + +procedure TTestUtilsRoutines.TestIsEqualBytes_NoCount_overload; +var + B0, B0a, B1, B1a, B2, B3, B4, B5, B5a, B6: TBytes; +begin + B0 := TBytes.Create(); + B0a := TBytes.Create(); + B1 := TBytes.Create(1,2,3,4,5,6,7,8,9,10); + B1a := TBytes.Create(1,2,3,4,5,6,7,8,9,10); + B2 := TBytes.Create(1,2,3,4,5,6,7,8,9,11); + B3 := TBytes.Create(1,2,3,4,5,6,7,8,9); + B4 := TBytes.Create(0,1,2,3,4,5,6,7,8,9,10); + B5 := TBytes.Create(7); + B5a := TBytes.Create(7); + B6 := TBytes.Create(6); + CheckTrue(IsEqualBytes(B1, B1a), 'B1 = B1a'); + CheckTrue(IsEqualBytes(B5, B5a), 'B5 = B5a'); + CheckTrue(IsEqualBytes(B0, B0a), 'B0 = B0a'); + CheckFalse(IsEqualBytes(B1, B2), 'B1 <> B2'); + CheckFalse(IsEqualBytes(B5, B6), 'B5 <> B6'); + CheckFalse(IsEqualBytes(B2, B4), 'B2 <> B4'); + CheckFalse(IsEqualBytes(B0, B4), 'B0 <> B4'); + CheckFalse(IsEqualBytes(B0, B6), 'B0 <> B6'); +end; + procedure TTestUtilsRoutines.TestIsHexDigit; const GoodChars = '1234567890ABCDEFabcdef'; @@ -106,6 +170,29 @@ procedure TTestUtilsRoutines.TestIsValidDriveLetter; CheckFalse(IsValidDriveLetter(BadChars[Idx]), 'Bad Test ' + IntToStr(Idx)); end; +procedure TTestUtilsRoutines.TestTryHexStringToBytes; +const + B0Str = ''; + B1Str = 'FA'; + B2Str = '010EAa42b656'; + Bad1Str = '3abc7'; + Bad2Str = '010EAbx2b656'; +var + BA0, BA1, BA2, Res: TBytes; +begin + BA0 := TBytes.Create(); + BA1 := TBytes.Create($fa); + BA2 := TBytes.Create($01, $0E, $AA, $42, $B6, $56); + CheckTrue(TryHexStringToBytes(B0Str, Res), '#1: Boolean'); + CheckTrue(IsEqualBytes(BA0, Res), '#1: Array'); + Checktrue(TryHexStringToBytes(B1Str, Res), '#2: Boolean'); + CheckTrue(IsEqualBytes(BA1, Res), '#2: Array'); + Checktrue(TryHexStringToBytes(B2Str, Res), '#3: Boolean'); + CheckTrue(IsEqualBytes(BA2, Res), '#3: Array'); + CheckFalse(TryHexStringToBytes(Bad1Str, Res), '#4: Bad length'); + CheckFalse(TryHexStringToBytes(Bad2Str, Res), '#4: Bad digits'); +end; + procedure TTestUtilsRoutines.TestTryStrToCardinal; var V: Cardinal;