├── GHF.Dic.pas ├── GHF.Obs.pas ├── GHF.Sys.pas ├── GHF.Design.res ├── GHF.Lang.pas ├── GHF.List.pas ├── GHF.ObjExt.pas ├── GHF.RTTI.pas ├── GHF.SysEx.pas ├── GHF.ObjList.pas ├── GHF.ClassList.pas ├── GHF.KeyRetrieve.pas ├── GHF.OpenXMLRels.pas ├── GHF.VCLObjList.pas ├── GHF.CustomEnumerator.pas ├── GHF.CustomRetrieve.pas ├── GHF.LatinScriptLang.pas ├── GHF.OwnedCollection.pas ├── GHF.PersistentList.pas ├── GHF.OpenXMLSpreadsheet.pas ├── GHF.Design.PersistentListItemProp.pas ├── License.txt ├── README.md ├── GHF.CustomAttr.pas ├── GHF.Component.pas ├── GHF.StrList.pas ├── GHF.InterfacedObj.pas ├── GHF.Design.PersistentListDesigner.pas ├── GHF.TypeListDic.pas ├── GHF.OpenXMLPart.pas ├── GHF.Design.pas ├── GHF.Design.PersistentListProp.pas ├── GHF.InterfacedSingleton.pas ├── GHF.Singleton.pas ├── GHF.Observer.pas ├── GHF.ObsEx.pas ├── GHF.FDConnection.pas ├── GHF.OpenXMLSpreadsheetStrs.pas ├── GHF.ListDic.pas ├── GHF.ENLang.pas ├── GHF.Design.PersistentListCountProp.pas ├── GHF.ControlledObserver.pas ├── GHF.MutableObjExt.pas ├── GHF.Persistent.pas ├── GHF.RTTIInstanceType.pas ├── GHF.SQL.pas ├── GHF.VCL.pas ├── GHF.Form.pas ├── GHF.XMLDoc.pas └── GHF.Win.pas /GHF.Dic.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.Dic.pas -------------------------------------------------------------------------------- /GHF.Obs.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.Obs.pas -------------------------------------------------------------------------------- /GHF.Sys.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.Sys.pas -------------------------------------------------------------------------------- /GHF.Design.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.Design.res -------------------------------------------------------------------------------- /GHF.Lang.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.Lang.pas -------------------------------------------------------------------------------- /GHF.List.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.List.pas -------------------------------------------------------------------------------- /GHF.ObjExt.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.ObjExt.pas -------------------------------------------------------------------------------- /GHF.RTTI.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.RTTI.pas -------------------------------------------------------------------------------- /GHF.SysEx.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.SysEx.pas -------------------------------------------------------------------------------- /GHF.ObjList.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.ObjList.pas -------------------------------------------------------------------------------- /GHF.ClassList.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.ClassList.pas -------------------------------------------------------------------------------- /GHF.KeyRetrieve.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.KeyRetrieve.pas -------------------------------------------------------------------------------- /GHF.OpenXMLRels.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.OpenXMLRels.pas -------------------------------------------------------------------------------- /GHF.VCLObjList.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.VCLObjList.pas -------------------------------------------------------------------------------- /GHF.CustomEnumerator.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.CustomEnumerator.pas -------------------------------------------------------------------------------- /GHF.CustomRetrieve.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.CustomRetrieve.pas -------------------------------------------------------------------------------- /GHF.LatinScriptLang.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.LatinScriptLang.pas -------------------------------------------------------------------------------- /GHF.OwnedCollection.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.OwnedCollection.pas -------------------------------------------------------------------------------- /GHF.PersistentList.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.PersistentList.pas -------------------------------------------------------------------------------- /GHF.OpenXMLSpreadsheet.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.OpenXMLSpreadsheet.pas -------------------------------------------------------------------------------- /GHF.Design.PersistentListItemProp.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/algonzalez74/GHFreebrary/HEAD/GHF.Design.PersistentListItemProp.pas -------------------------------------------------------------------------------- /License.txt: -------------------------------------------------------------------------------- 1 | GH Freebrary 2 | 3 | This software is distributed under the open source BSD license. 4 | 5 | Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions are met: 10 | 11 | - Redistributions of source code must retain the above copyright notice, 12 | this list of conditions and the following disclaimer. 13 | - Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | - Neither the name of Al Gonzalez nor the names of his contributors may 17 | be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 23 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE 24 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 25 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 26 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 27 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 28 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 29 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # GH Freebrary 2 | GH Freebrary is a general purpose class library for modern versions of Delphi. This is a beta release, all units compile in Delphi XE7. 3 | 4 | Compare the following two code blocks (the first one borrowed from stackoverflow.com). 5 | 6 | (1) A method to get a hypothetical DisplayLabel RTTI attribute of a given class, NOT using GH Freebrary: 7 | 
implementation
 8 | 
 9 | uses
10 |   Rtti;
11 | 
12 | class function TArtifactInspector.DisplayLabelFor(AClass: TClass): string;
13 | var
14 |   RttiContext: TRttiContext;
15 |   RttiType: TRttiType;
16 |   Attribute: TCustomAttribute;
17 | begin
18 |   RttiContext := TRttiContext.Create;
19 |   try
20 |     RttiType := RttiContext.GetType(AClass);
21 |     for Attribute in RttiType.GetAttributes do
22 |       if Attribute is DisplayLabelAttribute then
23 |         Exit(DisplayLabelAttribute(Attribute).Text);
24 |     Result := '';
25 |   finally
26 |     RttiContext.Free;
27 |   end;
28 | end;
29 | 30 | (2) Same method using GH Freebrary: 31 | 
implementation
32 | 
33 | uses
34 |   GHF.SysEx, GHF.RTTI;
35 | 
36 | class function TArtifactInspector.DisplayLabelFor(AClass: TClass): string;
37 | var
38 |   Attribute: DisplayLabelAttribute;
39 | begin
40 |   if AClass.ghClassInfo.ghGetAttr<DisplayLabelAttribute>(Attribute) then
41 |     Result := Attribute.Text
42 |   else
43 |     Result := '';
44 | end;
45 | 46 | When I was 16 years old, Professor De Lira revealed to me that in Turbo Pascal there was a file type called unit. Since then I write .pas code that aims to make life easier. And I still feel the same emotion when I see the results! 47 | 48 | Use GHF if you agree that most of the code written for a complex software solution should be located below the layer that such a solution represents, not inside it. 49 | 50 | Any suggestions or contributions will be greatly appreciated. 51 | 52 | Al Gonzalez. 53 | -------------------------------------------------------------------------------- /GHF.CustomAttr.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.CustomAttr.pas - TghCustomAttr class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.CustomAttr; { Custom Attribute } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Type 52 | { Custom Attribute class } 53 | TghCustomAttr = Class Abstract (TCustomAttribute) 54 | Public 55 | { Overridden instance methods } 56 | Procedure BeforeDestruction; Override; 57 | End; 58 | 59 | Implementation 60 | 61 | Uses 62 | GHF.SysEx; 63 | 64 | { TghCustomAttr } 65 | 66 | Procedure TghCustomAttr.BeforeDestruction; 67 | Begin 68 | ghPreDestroy; 69 | Inherited BeforeDestruction; 70 | End; 71 | 72 | End. 73 | 74 | -------------------------------------------------------------------------------- /GHF.Component.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.Component.pas - TghComponent class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.Component; { Component } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | System.Classes; 53 | 54 | Type 55 | { Component class } 56 | TghComponent = Class (TComponent) 57 | Public 58 | { Overridden instance methods } 59 | Procedure BeforeDestruction; Override; 60 | End; 61 | 62 | Implementation 63 | 64 | Uses 65 | GHF.Obs, GHF.Sys, GHF.SysEx; 66 | 67 | { TghComponent } 68 | 69 | Procedure TghComponent.BeforeDestruction; 70 | Begin 71 | ghPreDestroy; 72 | Inherited BeforeDestruction; 73 | End; 74 | 75 | End. 76 | 77 | -------------------------------------------------------------------------------- /GHF.StrList.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.StrList.pas - TghStrList class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.StrList; { String List } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | System.Classes; 53 | 54 | Type 55 | { String List class } 56 | TghStrList = Class (TStringList) 57 | Public 58 | { Overridden instance methods } 59 | Procedure BeforeDestruction; Override; 60 | End; 61 | 62 | Implementation 63 | 64 | Uses 65 | GHF.SysEx; 66 | 67 | { TghStrList } 68 | 69 | { Public overridden instance methods } 70 | 71 | Procedure TghStrList.BeforeDestruction; 72 | Begin 73 | ghPreDestroy; 74 | Inherited BeforeDestruction; 75 | End; 76 | 77 | End. 78 | 79 | -------------------------------------------------------------------------------- /GHF.InterfacedObj.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.InterfacedObj.pas - TghInterfacedObj class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.InterfacedObj; { Interfaced Object } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Type 52 | { Interfaced Object class } 53 | TghInterfacedObj = Class (TInterfacedObject) 54 | Public 55 | { Overridden instance methods } 56 | Procedure BeforeDestruction; Override; 57 | End; 58 | 59 | Implementation 60 | 61 | Uses 62 | GHF.SysEx; 63 | 64 | { TghInterfacedObj } 65 | 66 | { Public overridden instance methods } 67 | 68 | Procedure TghInterfacedObj.BeforeDestruction; 69 | Begin 70 | __MarkDestroying (Self); 71 | ghPreDestroy; 72 | Inherited BeforeDestruction; 73 | End; 74 | 75 | End. 76 | 77 | -------------------------------------------------------------------------------- /GHF.Design.PersistentListDesigner.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.Design.PersistentListDesigner.pas - TghPersistentListDesigner type } 6 | { unit. } 7 | { } 8 | { This software is distributed under the open source BSD license. } 9 | { } 10 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 11 | { All rights reserved. } 12 | { } 13 | { Redistribution and use in source and binary forms, with or without } 14 | { modification, are permitted provided that the following conditions are } 15 | { met: } 16 | { } 17 | { - Redistributions of source code must retain the above copyright } 18 | { notice, this list of conditions and the following disclaimer. } 19 | { - Redistributions in binary form must reproduce the above copyright } 20 | { notice, this list of conditions and the following disclaimer in the } 21 | { documentation and/or other materials provided with the } 22 | { distribution. } 23 | { - Neither the name of Al Gonzalez nor the names of his contributors } 24 | { may be used to endorse or promote products derived from this } 25 | { software without specific prior written permission. } 26 | { } 27 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 28 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 29 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 30 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 31 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 32 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 33 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 34 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 35 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 36 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 37 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 38 | {*************************************************************************} 39 | 40 | Unit GHF.Design.PersistentListDesigner; { Persistent List Designer } 41 | 42 | {$ScopedEnums On} 43 | 44 | Interface 45 | 46 | Uses 47 | GHF.Design, System.Classes; 48 | 49 | Type 50 | { Persistent List Designer type } 51 | TghPersistentListDesigner = Record 52 | Public 53 | { Static class methods } 54 | Class Procedure RegProp (Const ContainerClass :TClass = Nil; 55 | Const Name :String = ''); Static; 56 | End; 57 | 58 | Implementation 59 | 60 | Uses 61 | DesignIntf, GHF.PersistentList, GHF.Design.PersistentListProp; 62 | 63 | { TghPersistentListDesigner } 64 | 65 | { Public static class methods } 66 | 67 | Class Procedure TghPersistentListDesigner .RegProp ( 68 | Const ContainerClass :TClass = Nil; Const Name :String = ''); 69 | Begin 70 | RegisterPropertyEditor (TghPersistentList .ClassInfo, 71 | ContainerClass, Name, TghPersistentListProp ); 72 | End; 73 | 74 | End. 75 | 76 | -------------------------------------------------------------------------------- /GHF.TypeListDic.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.TypeListDic.pas - TghTypeListDic class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.TypeListDic; { Type List Dictionary } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | GHF.ListDic, System.TypInfo, System.RTTI; 53 | 54 | Type 55 | { Type List Dictionary class } 56 | TghTypeListDic = Class (TghListDic ) 57 | Protected 58 | { Overridden instance methods } 59 | Function VerifyFeedValue (Const Value :Pointer; 60 | Const Key :TTypeKind; Var AContinue :Boolean) :Boolean; Override; 61 | End; 62 | 63 | Implementation 64 | 65 | { TghTypeListDic } 66 | 67 | { Protected overridden instance methods } 68 | 69 | Function TghTypeListDic.VerifyFeedValue (Const Value :Pointer; 70 | Const Key :TTypeKind; Var AContinue :Boolean) :Boolean; 71 | Begin 72 | Result := TRTTIType (Value).Handle.Kind = Key; 73 | End; 74 | 75 | End. 76 | 77 | -------------------------------------------------------------------------------- /GHF.OpenXMLPart.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.OpenXMLPart.pas - TghOpenXMLPart class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.OpenXMLPart; { OpenXML Part } 40 | 41 | { NOTE: The only native unit scopes that should be unconditionally 42 | referenced, either directly or indirectly, from this code file are the 43 | System, WinAPI and XML unit scopes. The intention is that this unit to be 44 | part of a central base that can be compiled into any Windows project. } 45 | 46 | {$ScopedEnums On} 47 | 48 | Interface 49 | 50 | Uses 51 | GHF.XMLDoc, GHF.OpenXMLRels; 52 | 53 | Type 54 | { OpenXML Part class } 55 | TghOpenXMLPart = Class (TghXMLDoc) 56 | Protected 57 | { Instance fields } 58 | FRels :TghOpenXMLRels; 59 | 60 | { Regular instance methods } 61 | Function GetRels :TghOpenXMLRels; 62 | Public 63 | Destructor Destroy; Override; 64 | 65 | { Instance properties } 66 | Property Rels :TghOpenXMLRels Read GetRels; 67 | End; 68 | 69 | Implementation 70 | 71 | Uses 72 | System.SysUtils; 73 | 74 | { TghOpenXMLPart } 75 | 76 | Destructor TghOpenXMLPart.Destroy; 77 | Begin 78 | System.SysUtils.FreeAndNil (FRels); 79 | Inherited Destroy; 80 | End; 81 | 82 | { Protected regular instance methods } 83 | 84 | Function TghOpenXMLPart.GetRels :TghOpenXMLRels; 85 | Begin 86 | If FRels = Nil Then 87 | FRels := TghOpenXMLRels.CreateForPart (Path); 88 | 89 | Result := FRels; 90 | End; 91 | 92 | End. 93 | 94 | -------------------------------------------------------------------------------- /GHF.Design.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.Design.pas - TghDesign class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.Design; { Design } 40 | 41 | {$ScopedEnums On} 42 | 43 | {$R GHF.Design.res} // Component bitmaps and other resources 44 | 45 | Interface 46 | 47 | Uses 48 | GHF.Sys, DesignEditors, GHF.List, System.Classes, System.TypInfo, 49 | GHF.SysEx; 50 | 51 | Type 52 | { Design class } 53 | TghDesign = Class (TghZeroton) 54 | Public 55 | Type 56 | { TPropertyEditor helper } 57 | TPropertyEditorHelper = Class Helper (TghSys.TObjectHelper) For 58 | TPropertyEditor 59 | Public 60 | { Regular instance methods } 61 | Function ghList (Const Index :Integer = 0; 62 | Info :PPropInfo = Nil) :TghList ; Inline; 63 | Function ghObj (Const Index :Integer = 0; 64 | Info :PPropInfo = Nil) :T; 65 | End; 66 | End; 67 | 68 | Implementation 69 | 70 | { Inline routines } 71 | 72 | Function TghDesign.TPropertyEditorHelper.ghList ( 73 | Const Index :Integer = 0; Info :PPropInfo = Nil) :TghList ; 74 | Begin 75 | Result := ghObj > (Index, Info); 76 | End; 77 | 78 | { TghDesign } 79 | 80 | { TghDesign.TPropertyEditorHelper } 81 | 82 | Function TghDesign.TPropertyEditorHelper.ghObj ( 83 | Const Index :Integer = 0; Info :PPropInfo = Nil) :T; 84 | Begin 85 | If Info = Nil Then 86 | Info := GetPropInfo; 87 | 88 | Result := GetObjectProp (GetComponent (Index), Info) As T; 89 | End; 90 | 91 | End. 92 | 93 | -------------------------------------------------------------------------------- /GHF.Design.PersistentListProp.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.Design.PersistentListProp.pas - TghPersistentListProp class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.Design.PersistentListProp; { Persistent List Property } 40 | 41 | {$ScopedEnums On} 42 | 43 | Interface 44 | 45 | Uses 46 | GHF.Design, System.Classes, DesignEditors, DesignIntf; 47 | 48 | Type 49 | ///pendiente probar herencia visual (GetIsDefault) y paRevertable 50 | { Persistent List Property class } 51 | TghPersistentListProp = Class (TClassProperty) 52 | Protected 53 | { Overridden instance methods } 54 | Function GetIsDefault :Boolean; Override; 55 | Public 56 | { Overridden instance methods } 57 | Function GetAttributes :TPropertyAttributes; Override; 58 | Procedure GetProperties (Proc :TGetPropProc); Override; 59 | End; 60 | 61 | Implementation 62 | 63 | Uses 64 | GHF.Design.PersistentListCountProp, GHF.Design.PersistentListItemProp; 65 | 66 | { TghPersistentListProp } 67 | 68 | { Protected overridden instance methods } 69 | 70 | Function TghPersistentListProp .GetIsDefault :Boolean; 71 | Begin 72 | Result := System.False; 73 | End; 74 | 75 | { Public overridden instance methods } 76 | 77 | Function TghPersistentListProp .GetAttributes :TPropertyAttributes; 78 | Begin 79 | Result := Inherited GetAttributes + [DesignIntf.paVolatileSubProperties]; 80 | End; 81 | 82 | Procedure TghPersistentListProp .GetProperties (Proc :TGetPropProc); 83 | Var 84 | I :Integer; 85 | Begin 86 | Inherited GetProperties (Proc); 87 | Proc (TghPersistentListCountProp .Create (Self)); 88 | 89 | If PropCount = 1 Then{}//revisar con paMultiSelect 90 | For I := 0 To ghList .Count - 1 Do 91 | Proc (TghPersistentListItemProp .Create (Self, I)); 92 | End; 93 | 94 | End. 95 | 96 | -------------------------------------------------------------------------------- /GHF.InterfacedSingleton.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.InterfacedSingleton.pas - TghInterfacedSingleton class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.InterfacedSingleton; { Interfaced Singleton } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | GHF.InterfacedObj, GHF.Sys; 53 | 54 | Type 55 | { Interfaced Singleton class } 56 | TghInterfacedSingleton = Class (TghInterfacedObj) 57 | Protected 58 | { Virtual class methods } 59 | Class Function InstanceRef :TghSys.PObject; Virtual; Abstract; 60 | Public 61 | { Overridden instance methods } 62 | Procedure FreeInstance; Override; 63 | 64 | { Overridden class methods } 65 | Class Function NewInstance :TObject; Override; 66 | End; 67 | 68 | Implementation 69 | 70 | Uses 71 | GHF.SysEx; 72 | 73 | { TghInterfacedSingleton } 74 | 75 | { Public overridden instance methods } 76 | 77 | Procedure TghInterfacedSingleton.FreeInstance; 78 | Begin 79 | InstanceRef^ := Nil; 80 | Inherited FreeInstance; 81 | End; 82 | 83 | { Public overridden class methods } 84 | 85 | Class Function TghInterfacedSingleton.NewInstance :TObject; 86 | Begin 87 | { NOTE: This form is not supported by the compiler due to use of 88 | "Inherited" (E2010 Incompatible types). } 89 | // Result := TghSys.NewSingleton (InstanceRef, Inherited NewInstance); 90 | 91 | Result := TghSys.NewSingleton (InstanceRef, 92 | Function :TObject 93 | Begin 94 | Result := Inherited NewInstance; 95 | End); 96 | End; 97 | 98 | End. 99 | 100 | -------------------------------------------------------------------------------- /GHF.Singleton.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.Singleton.pas - TghSingleton class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.Singleton; { Singleton } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | GHF.Sys; 53 | 54 | Type 55 | { Singleton class } 56 | TghSingleton = Class Abstract 57 | Protected 58 | { Virtual class methods } 59 | Class Function InstanceRef :TghSys.PObject; Virtual; Abstract; 60 | Public 61 | { Overridden class methods } 62 | Class Function NewInstance :TObject; Override; 63 | 64 | { Overridden instance methods } 65 | Procedure BeforeDestruction; Override; 66 | Procedure FreeInstance; Override; 67 | End; 68 | 69 | Implementation 70 | 71 | Uses 72 | GHF.SysEx; 73 | 74 | { TghSingleton } 75 | 76 | { Public overridden class methods } 77 | 78 | Class Function TghSingleton.NewInstance :TObject; 79 | Begin 80 | { NOTE: This form is not supported by the compiler due to use of 81 | "Inherited" (E2010 Incompatible types). } 82 | // Result := TghSys.NewSingleton (InstanceRef, Inherited NewInstance); 83 | 84 | Result := TghSys.NewSingleton (InstanceRef, 85 | Function :TObject 86 | Begin 87 | Result := Inherited NewInstance; 88 | End); 89 | End; 90 | 91 | { Public overridden instance methods } 92 | 93 | Procedure TghSingleton.BeforeDestruction; 94 | Begin 95 | ghPreDestroy; 96 | Inherited BeforeDestruction; 97 | End; 98 | 99 | Procedure TghSingleton.FreeInstance; 100 | Begin 101 | InstanceRef^ := Nil; 102 | Inherited FreeInstance; 103 | End; 104 | 105 | End. 106 | -------------------------------------------------------------------------------- /GHF.Observer.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.Observer.pas - TghObserver class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.Observer; { Observer } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | GHF.InterfacedObj, GHF.Obs, GHF.Sys; 53 | 54 | Type 55 | { Observer class } 56 | TghObserver = Class (TghInterfacedObj, IghObserver) 57 | Protected 58 | { Instance fields } 59 | Handler :TghSys.TAnyKindMethod; 60 | Protected 61 | { IghObserver } 62 | Procedure HandleEvent (AObj :TObject; AEventID :Integer); Virtual; 63 | Public 64 | Constructor Create (AHandler :TghObs.TObsEvent); Overload; Virtual; 65 | Constructor Create (Const AHandler :TghObs.TObsEventRef); Overload; 66 | Virtual; 67 | Destructor Destroy; Override; 68 | End; 69 | 70 | Implementation 71 | 72 | Uses 73 | GHF.SysEx; 74 | 75 | { TghObserver } 76 | 77 | { Constructors and destructors } 78 | 79 | Constructor TghObserver.Create (AHandler :TghObs.TObsEvent); 80 | Begin 81 | Inherited Create; 82 | Handler.Normal := @@AHandler;{}//probar 83 | End; 84 | 85 | Constructor TghObserver.Create (Const AHandler :TghObs.TObsEventRef); 86 | Begin 87 | Inherited Create; 88 | Handler.Ref := PPointer (@AHandler)^; 89 | End; 90 | 91 | Destructor TghObserver.Destroy; 92 | Begin 93 | Inherited Destroy; 94 | Handler.ClearRef; 95 | End; 96 | 97 | { IghObserver } 98 | 99 | Procedure TghObserver.HandleEvent (AObj :TObject; AEventID :Integer); 100 | Begin 101 | If Handler.IsRef Then 102 | TghObs.TObsEventRef (Handler.Ref) (Self, AObj, AEventID) 103 | Else 104 | If Not Handler.IsEmpty Then 105 | TghObs.TObsEvent (Handler.Normal^) (Self, AObj, AEventID); 106 | End; 107 | 108 | End. 109 | 110 | -------------------------------------------------------------------------------- /GHF.ObsEx.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.ObsEx.pas - TghObsEx helper unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.ObsEx; { Observation Extended } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | GHF.Sys, GHF.SysEx, GHF.Obs, GHF.Dic; 53 | 54 | Type 55 | { Observation class Extended helper. Complement of the TghObs partial 56 | class. } 57 | TghObsEx = Class Helper (TghSys.TObjectHelper) For TghObs 58 | Protected 59 | Type 60 | TItemInfos = Class (TghDic ) 61 | Protected 62 | { Overridden instance methods } 63 | Procedure InitValue (Var AValue :PItemInfo; 64 | Const AKey :Pointer); Override; 65 | Procedure OwnedValueDeleted (Const AValue :PItemInfo); 66 | Override; 67 | End; 68 | Class Var 69 | ItemInfos :TItemInfos; 70 | 71 | Class Function GetItemInfos :TItemInfos; Static; 72 | End; 73 | 74 | Implementation 75 | 76 | Uses 77 | System.Generics.Collections; 78 | 79 | { TghObsEx } 80 | 81 | { TghObsEx.TItemInfos } 82 | 83 | Procedure TghObsEx.TItemInfos.InitValue (Var AValue :PItemInfo; 84 | Const AKey :Pointer); 85 | Begin 86 | AValue.FFlags := itfNotifyEvents; // Used for objects 87 | End; 88 | 89 | Procedure TghObsEx.TItemInfos.OwnedValueDeleted ( 90 | Const AValue :PItemInfo); 91 | Begin 92 | AValue.Finalize; 93 | Inherited OwnedValueDeleted (AValue); 94 | End; 95 | 96 | { Protected static class methods } 97 | 98 | Class Function TghObsEx.GetItemInfos :TItemInfos; 99 | Begin 100 | If ItemInfos = Nil Then 101 | ItemInfos := TItemInfos.Create ( 102 | [System.Generics.Collections.doOwnsValues]); 103 | 104 | Result := ItemInfos; 105 | End; 106 | 107 | End. 108 | 109 | -------------------------------------------------------------------------------- /GHF.FDConnection.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.FDConnection.pas - TghFDConnection class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.FDConnection; { FireDAC Connection } 40 | 41 | { NOTE: The only native unit scopes that should be unconditionally 42 | referenced, either directly or indirectly, from this code file are the 43 | System, Data and FireDAC unit scopes, except the System.Win and Data.Win 44 | sub-scopes. The intention is that this unit to be part of a central base 45 | that can be compiled into any project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | FireDAC.Comp.Client; 53 | 54 | Type 55 | { FireDAC Connection class } 56 | TghFDConnection = Class (TFDConnection) 57 | Public 58 | { Regular instance methods } 59 | Procedure PrepareLogin ( 60 | Const AServer, ADatabase, AUser, APassword :String); 61 | Function Query (Const AStatement :String; 62 | Const AParams :Array Of Variant) :TFDQuery; 63 | 64 | { Overridden instance methods } 65 | Procedure BeforeDestruction; Override; 66 | End; 67 | 68 | Implementation 69 | 70 | Uses 71 | GHF.SysEx; 72 | 73 | { TghFDConnection } 74 | 75 | Procedure TghFDConnection.BeforeDestruction; 76 | Begin 77 | ghPreDestroy; 78 | Inherited BeforeDestruction; 79 | End; 80 | 81 | Procedure TghFDConnection.PrepareLogin ( 82 | Const AServer, ADatabase, AUser, APassword :String); 83 | Begin 84 | Params.Values ['Server'] := AServer; 85 | Params.Values ['Database'] := ADatabase; 86 | Params.Values ['User_Name'] := AUser; 87 | Params.Values ['Password'] := APassword; 88 | End; 89 | 90 | Function TghFDConnection.Query (Const AStatement :String; 91 | Const AParams :Array Of Variant) :TFDQuery; 92 | Var 93 | I :Integer; 94 | Begin 95 | Result := TFDQuery.Create (Self); 96 | 97 | Try 98 | Result.Connection := Self; 99 | Result.SQL.Text := AStatement; 100 | 101 | For I := 0 To Result.ParamCount - 1 Do 102 | Result.Params [I].Value := AParams [I]; 103 | 104 | Result.Open; 105 | Except 106 | Result.Free; 107 | Raise; 108 | End; 109 | End; 110 | 111 | End. 112 | 113 | -------------------------------------------------------------------------------- /GHF.OpenXMLSpreadsheetStrs.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.OpenXMLSpreadsheetStrs.pas - TghOpenXMLSpreadsheetStrs class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.OpenXMLSpreadsheetStrs; 40 | 41 | { NOTE: The only native unit scopes that should be unconditionally 42 | referenced, either directly or indirectly, from this code file are the 43 | System, WinAPI and XML unit scopes. The intention is that this unit to be 44 | part of a central base that can be compiled into any Windows project. } 45 | 46 | {$ScopedEnums On} 47 | 48 | Interface 49 | 50 | Uses 51 | GHF.OpenXMLPart; 52 | 53 | Type 54 | { OpenXML Spreadsheet Strings class } 55 | TghOpenXMLSpreadsheetStrs = Class (TghOpenXMLPart) 56 | Protected 57 | { Regular instance methods } 58 | Function Element (Const Index :Integer) :OLEVariant; 59 | Function GetValue (Const Index :Integer) :String; 60 | Procedure SetValue (Const Index :Integer; Const Value :String); 61 | Public 62 | Constructor CreateFromDir (Const APath :String); Virtual; 63 | 64 | { Static class methods } 65 | Class Function CalcPath (Const DirPath :String) :String; Static; 66 | 67 | { Instance properties } 68 | Property Values [Const Index :Integer] :String Read GetValue 69 | Write SetValue; Default; 70 | End; 71 | 72 | Implementation 73 | 74 | Uses 75 | GHF.Sys, GHF.Win; 76 | 77 | { TghOpenXMLSpreadsheetStrs } 78 | 79 | Constructor TghOpenXMLSpreadsheetStrs.CreateFromDir ( 80 | Const APath :String); 81 | Begin 82 | Create (CalcPath (APath)); 83 | End; 84 | 85 | { Protected regular instance methods } 86 | 87 | Function TghOpenXMLSpreadsheetStrs.Element (Const Index :Integer) 88 | :OLEVariant; 89 | Begin 90 | Result := FindNode ('/_:sst/_:si[%d]', [Index + 1]); 91 | End; 92 | 93 | Function TghOpenXMLSpreadsheetStrs.GetValue (Const Index :Integer) 94 | :String; 95 | Begin 96 | Result := Element (Index).Text; 97 | End; 98 | 99 | Procedure TghOpenXMLSpreadsheetStrs.SetValue (Const Index :Integer; 100 | Const Value :String); 101 | Begin 102 | WorkNode := Element (Index); 103 | Nodes ('*').RemoveAll; 104 | CreateElement ('t', Value) 105 | End; 106 | 107 | { Public static class methods } 108 | 109 | Class Function TghOpenXMLSpreadsheetStrs.CalcPath (Const DirPath :String) 110 | :String; 111 | Begin 112 | If DirPath <> '' Then 113 | Result := TghSys.ConcatFilePaths (DirPath, TghWin.oxmSharedStrs) 114 | Else 115 | Result := ''; 116 | End; 117 | 118 | End. 119 | -------------------------------------------------------------------------------- /GHF.ListDic.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.ListDic.pas - TghListDic class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.ListDic; { List Dictionary } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | GHF.Dic, GHF.List; 53 | 54 | Type 55 | {}//problema ya no presente en XE7, refactorizar 56 | { NOTE: We avoid using generic object parameters with default value in 57 | methods of generic classes, because these cause Internal Error 58 | URW1154 when those classes are referenced from another unit (quality 59 | report #129713). } 60 | 61 | { List Dictionary class } 62 | TghListDic = Class (TghDic >) 63 | Protected 64 | { Virtual instance methods } 65 | Function FeedItem (Const Value :Pointer) :ATItem; Virtual; 66 | 67 | { Overridden instance methods } 68 | Procedure HandleAbsentKey (Const Key :TKey); Override; 69 | Public 70 | { Overridden instance methods } 71 | Procedure AfterConstruction; Override; 72 | End; 73 | 74 | Implementation 75 | 76 | Uses 77 | GHF.Sys, GHF.SysEx, System.TypInfo; 78 | 79 | { TghListDic } 80 | 81 | { Protected virtual instance methods } 82 | 83 | Function TghListDic .FeedItem (Const Value :Pointer) 84 | :ATItem; 85 | Begin 86 | Result := TghSys.RawCast (Value); 87 | End; 88 | 89 | { Protected overridden instance methods } 90 | 91 | 92 | Procedure TghListDic .HandleAbsentKey (Const Key :TKey); 93 | Var 94 | NewList :TghList ; 95 | Begin 96 | NewList := Nil; 97 | FFeedValues.Extract (Key, VerifyFeedValue, 98 | 99 | Procedure (Const Value :Pointer; Const Key :TKey) 100 | Begin 101 | If NewList = Nil Then 102 | Begin 103 | NewList := TghList .Create; 104 | ghHold (NewList); 105 | Add (Key, NewList); 106 | End; 107 | 108 | NewList.Add (FeedItem (Value)); 109 | End); 110 | End; 111 | 112 | { Public overridden instance methods } 113 | 114 | Procedure TghListDic .AfterConstruction; 115 | Begin 116 | Inherited AfterConstruction; 117 | FeedValuesDirect := System.False; 118 | End; 119 | 120 | End. 121 | 122 | 123 | 124 | -------------------------------------------------------------------------------- /GHF.ENLang.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.ENLang.pas - TghENLang class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.ENLang; { English Language } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | GHF.LatinScriptLang; 53 | 54 | Type 55 | { English Language class } 56 | TghENLang = Class (TghLatinScriptLang) 57 | Public 58 | Const 59 | { Letters } 60 | 61 | lttLowers = ['a'..'z']; // Lower case 62 | lttUppers = ['A'..'Z']; // Upper case 63 | lttAll = lttLowers + lttUppers; 64 | 65 | // Vowels 66 | lttLowerVowels = ['a', 'e', 'i', 'o', 'u']; // Lower case 67 | lttUpperVowels = ['A', 'E', 'I', 'O', 'U']; // Upper case 68 | lttVowels = lttLowerVowels + lttUpperVowels; 69 | 70 | // Consonants 71 | lttLowerConsonants = lttLowers - lttLowerVowels; // Lower case 72 | lttUpperConsonants = lttUppers - lttUpperVowels; // Upper case 73 | lttConsonants = lttLowerConsonants + lttUpperConsonants; 74 | 75 | { Overridden class methods } 76 | Class Function LowerChr (AValue :Char) :Char; Override; 77 | Class Function LowerStr (Const AValue :String) :String; Override; 78 | Class Function UpperChr (AValue :Char) :Char; Override; 79 | Class Function UpperStr (Const AValue :String) :String; Override; 80 | End; 81 | 82 | Implementation 83 | 84 | Uses 85 | GHF.Sys, System.SysUtils; 86 | 87 | { Inline routines }{} 88 | 89 | { TghENLang } 90 | 91 | { Public overridden class methods } 92 | 93 | {}//probar 94 | Class Function TghENLang.LowerChr (AValue :Char) :Char; 95 | Begin 96 | Case AValue Of 97 | 'A'..'Z' : Result := TghSys.ChrPlus (AValue, DefaultChrCaseDelta); 98 | Else 99 | Result := AValue; 100 | End; 101 | End; 102 | 103 | Class Function TghENLang.LowerStr (Const AValue :String) :String; 104 | Begin 105 | Result := System.SysUtils.LowerCase (AValue); 106 | End; 107 | 108 | Class Function TghENLang.UpperChr (AValue :Char) :Char; 109 | Begin 110 | Result := System.UpCase (AValue); 111 | End; 112 | 113 | Class Function TghENLang.UpperStr (Const AValue :String) :String; 114 | Begin 115 | Result := System.SysUtils.UpperCase (AValue); 116 | End; 117 | 118 | End. 119 | 120 | -------------------------------------------------------------------------------- /GHF.Design.PersistentListCountProp.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.Design.PersistentListCountProp.pas - TghPersistentListCountProp } 6 | { class unit. } 7 | { } 8 | { This software is distributed under the open source BSD license. } 9 | { } 10 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 11 | { All rights reserved. } 12 | { } 13 | { Redistribution and use in source and binary forms, with or without } 14 | { modification, are permitted provided that the following conditions are } 15 | { met: } 16 | { } 17 | { - Redistributions of source code must retain the above copyright } 18 | { notice, this list of conditions and the following disclaimer. } 19 | { - Redistributions in binary form must reproduce the above copyright } 20 | { notice, this list of conditions and the following disclaimer in the } 21 | { documentation and/or other materials provided with the } 22 | { distribution. } 23 | { - Neither the name of Al Gonzalez nor the names of his contributors } 24 | { may be used to endorse or promote products derived from this } 25 | { software without specific prior written permission. } 26 | { } 27 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 28 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 29 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 30 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 31 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 32 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 33 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 34 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 35 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 36 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 37 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 38 | {*************************************************************************} 39 | 40 | { Persistent List Count Property } 41 | Unit GHF.Design.PersistentListCountProp; 42 | 43 | {$ScopedEnums On} 44 | 45 | Interface 46 | 47 | Uses 48 | GHF.Design, System.Classes, DesignEditors, DesignIntf, System.TypInfo; 49 | 50 | Type 51 | { Persistent List Count Property class } 52 | {$TypeInfo On} 53 | TghPersistentListCountProp = Class ( 54 | TNestedProperty) 55 | Protected 56 | { Regular instance methods } 57 | Procedure SetCount (Const AValue :Integer); 58 | Public 59 | { Overridden instance methods } 60 | Function AllEqual :Boolean; Override; 61 | Function GetAttributes :TPropertyAttributes; Override; 62 | Function GetName :String; Override; 63 | Function GetPropInfo :PPropInfo; Override; 64 | Function GetValue :String; Override; 65 | Procedure SetValue (Const Value :String); Override; 66 | Published 67 | { Instance properties } 68 | Property Count :Integer Write SetCount; 69 | End; 70 | {$TypeInfo Off} 71 | 72 | Implementation 73 | 74 | Uses 75 | System.SysUtils, System.SysConst; 76 | 77 | { TghPersistentListCountProp } 78 | 79 | { Protected regular instance methods } 80 | 81 | Procedure TghPersistentListCountProp .SetCount (Const AValue :Integer); 82 | Var 83 | I :Integer; 84 | Begin 85 | For I := 0 To PropCount - 1 Do 86 | ghList (I, Inherited GetPropInfo).Count := AValue; 87 | 88 | Modified; 89 | End; 90 | 91 | { Public overridden instance methods } 92 | 93 | Function TghPersistentListCountProp .AllEqual :Boolean; 94 | Var 95 | AValue, I :Integer; 96 | Begin 97 | If PropCount > 1 Then 98 | Begin 99 | AValue := ghList (0, Inherited GetPropInfo).Count; 100 | 101 | For I := 1 To PropCount - 1 Do 102 | If ghList (I, Inherited GetPropInfo).Count <> AVAlue Then 103 | System.Exit (System.False); 104 | End; 105 | 106 | Result := System.True; 107 | End; 108 | 109 | Function TghPersistentListCountProp .GetAttributes :TPropertyAttributes; 110 | Begin 111 | Result := [DesignIntf.paMultiSelect, DesignIntf.paRevertable{}{probar}]; 112 | End; 113 | 114 | Function TghPersistentListCountProp .GetName :String; 115 | Begin 116 | Result := 'Count'; 117 | End; 118 | 119 | Function TghPersistentListCountProp .GetPropInfo :PPropInfo; 120 | Begin 121 | { NOTE: To allow the modification of Count in the object inspector, we 122 | need information of a writable and published property } 123 | Result := System.TypInfo.GetPropInfo (Self, 'Count'); 124 | End; 125 | 126 | Function TghPersistentListCountProp .GetValue :String; 127 | Begin 128 | Result := ghList (0, Inherited GetPropInfo).Count.ToString; 129 | End; 130 | 131 | Procedure TghPersistentListCountProp .SetValue (Const Value :String); 132 | Var 133 | AValue :Integer; 134 | Begin 135 | If TryStrToInt (Value, AValue) then 136 | Count := AValue 137 | Else 138 | Raise EDesignPropertyError.CreateResFmt (@SInvalidInteger, [Value]); 139 | End; 140 | 141 | End. 142 | 143 | -------------------------------------------------------------------------------- /GHF.ControlledObserver.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.ControlledObserver.pas - TghControlledObserver class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.ControlledObserver; { Controlled Observer } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | GHF.Observer, GHF.Obs; 53 | 54 | Type 55 | { Controlled Observer class } 56 | TghControlledObserver = Class (TghObserver, IghControlledObserver) 57 | Protected 58 | Const 59 | { Flags } 60 | osfEnabled = $10000000; 61 | 62 | Var 63 | FlagsEventIDs :Integer; // Flags and Events IDs (osfXXX, oeiXXX) 64 | 65 | { IghObserver } 66 | Procedure HandleEvent (AObj :TObject; AEventID :Integer); Override; 67 | 68 | { IghControlledObserver } 69 | Function GetEnabled :Boolean; 70 | Function GetEventIDs :Integer; 71 | Procedure SetEnabled (Value :Boolean); 72 | Procedure SetEventIDs (Value :Integer); 73 | Public 74 | Constructor Create (AHandler :TghObs.TObsEvent; 75 | AEventIDs :Integer = TghObs.oeiAllObjChanged); Overload; Virtual; 76 | Constructor Create (Const AHandler :TghObs.TObsEventRef; 77 | AEventIDs :Integer = TghObs.oeiAllObjChanged); Overload; Virtual; 78 | 79 | { Instance properties } 80 | Property Enabled :Boolean Read GetEnabled Write SetEnabled; 81 | Property EventIDs :Integer Read GetEventIDs Write SetEventIDs; 82 | End; 83 | 84 | Implementation 85 | 86 | Uses 87 | GHF.Sys; 88 | 89 | { TghControlledObserver } 90 | 91 | Constructor TghControlledObserver.Create (AHandler :TghObs.TObsEvent; 92 | AEventIDs :Integer = TghObs.oeiAllObjChanged); 93 | Begin 94 | Inherited Create (AHandler); 95 | FlagsEventIDs := osfEnabled Or AEventIDs; 96 | End; 97 | 98 | Constructor TghControlledObserver.Create ( 99 | Const AHandler :TghObs.TObsEventRef; 100 | AEventIDs :Integer = TghObs.oeiAllObjChanged); 101 | Begin 102 | Inherited Create (AHandler); 103 | FlagsEventIDs := osfEnabled Or AEventIDs; 104 | End; 105 | 106 | { IghObserver } 107 | 108 | Procedure TghControlledObserver.HandleEvent (AObj :TObject; 109 | AEventID :Integer); 110 | Begin 111 | If Enabled And TghSys.HasBitsOn (EventIDs, AEventID) Then 112 | Inherited HandleEvent (AObj, AEventID); 113 | End; 114 | 115 | { IghControlledObserver } 116 | 117 | Function TghControlledObserver.GetEnabled :Boolean; 118 | Begin 119 | Result := TghSys.HasBitOn (FlagsEventIDs, osfEnabled); 120 | End; 121 | 122 | Function TghControlledObserver.GetEventIDs :Integer; 123 | Begin 124 | Result := FlagsEventIDs And TghObs.oeiAll; 125 | End; 126 | 127 | Procedure TghControlledObserver.SetEnabled (Value :Boolean); 128 | Begin 129 | If Value = Enabled Then 130 | System.Exit; 131 | 132 | FlagsEventIDs := TghSys.TurnBits (FlagsEventIDs, osfEnabled, Value); 133 | End; 134 | 135 | Procedure TghControlledObserver.SetEventIDs (Value :Integer); 136 | Begin 137 | FlagsEventIDs := TghSys.SwitchBits ( 138 | FlagsEventIDs, TghObs.oeiAll, Value); 139 | End; 140 | 141 | End. 142 | 143 | -------------------------------------------------------------------------------- /GHF.MutableObjExt.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.MutableObjExt.pas - TghMutableObjExt class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.MutableObjExt; { Mutable Object Extension } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | GHF.ObjExt; 53 | 54 | Type 55 | { Mutable Object Extension class } 56 | TghMutableObjExt = Class Abstract (TghObjExt ) 57 | Protected 58 | { Fields } 59 | LockWriteCount :Cardinal; 60 | 61 | { Regular instance methods } 62 | Procedure CheckWriteUnlocked; 63 | Function GetWriteLocked :Boolean; 64 | 65 | { Virtual instance methods } 66 | Procedure OwnerChanged (AEventID :Integer); Virtual; 67 | Procedure OwnerChanging (AEventID :Integer); Virtual; 68 | 69 | { IghObserver } 70 | Procedure HandleEvent (AObj :TObject; AEventID :Integer); Override; 71 | Public 72 | { Regular instance methods } 73 | Procedure LockWrite; 74 | Procedure UnlockWrite; 75 | 76 | { Overridden instance methods } 77 | Procedure BeforeDestruction; Override; 78 | Procedure UpdateOwner; Virtual; Abstract; 79 | 80 | { Properties } 81 | Property WriteLocked :Boolean Read GetWriteLocked; 82 | End; 83 | 84 | Implementation 85 | 86 | Uses 87 | GHF.SysEx, System.SysUtils, GHF.Sys, GHF.Obs; 88 | 89 | { TghMutableObjExt } 90 | 91 | { Protected regular instance methods } 92 | 93 | Procedure TghMutableObjExt .CheckWriteUnlocked; 94 | Begin 95 | If WriteLocked Then 96 | EInvalidOpException.ghRaise ( 97 | TghSys.ermLockedForWriting, [T.ClassName + ' object']); 98 | End; 99 | 100 | Function TghMutableObjExt .GetWriteLocked :Boolean; 101 | Begin 102 | Result := LockWriteCount > 0; 103 | End; 104 | 105 | { Protected virtual instance methods } 106 | 107 | Procedure TghMutableObjExt .OwnerChanged (AEventID :Integer); 108 | Begin 109 | CheckWriteUnlocked; 110 | End; 111 | 112 | Procedure TghMutableObjExt .OwnerChanging (AEventID :Integer); 113 | Begin 114 | CheckWriteUnlocked; 115 | End; 116 | 117 | { Public regular instance methods } 118 | 119 | Procedure TghMutableObjExt .LockWrite; 120 | Begin 121 | System.Inc (LockWriteCount); 122 | End; 123 | 124 | Procedure TghMutableObjExt .UnlockWrite; 125 | Begin 126 | TghSys.CheckInc (LockWriteCount, -1); 127 | End; 128 | 129 | { Public overridden instance methods } 130 | 131 | Procedure TghMutableObjExt .BeforeDestruction; 132 | Begin 133 | CheckWriteUnlocked; 134 | Inherited BeforeDestruction; 135 | End; 136 | 137 | { IghObserver } 138 | 139 | Procedure TghMutableObjExt .HandleEvent (AObj :TObject; 140 | AEventID :Integer); 141 | Begin 142 | { Compiler bug "E2015 Operator not applicable to this operand type" 143 | (XE7) } 144 | //If AObj = Owner Then 145 | 146 | If AObj = Owner.ghAsPtr Then 147 | If TghSys.HasBitOn (AEventID, TghObs.oeiObjChanging) Then 148 | OwnerChanging (AEventID) 149 | Else 150 | If TghSys.HasBitOn (AEventID, TghObs.oeiObjChanged) Then 151 | OwnerChanged (AEventID); 152 | End; 153 | 154 | End. 155 | 156 | -------------------------------------------------------------------------------- /GHF.Persistent.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.Persistent.pas - TghPersistent class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.Persistent; { Persistent } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | System.Classes, System.SysUtils; 53 | 54 | Type 55 | { Persistent class } 56 | TghPersistent = Class Abstract (TPersistent) 57 | Protected 58 | { Virtual instance methods } 59 | Function GetAsVar :Variant; Virtual; 60 | Function GetSerialized :TBytes; Virtual; 61 | Procedure SetSerialized (Const AValue :TBytes); Virtual; 62 | 63 | { Overridden instance methods } 64 | Function GetOwner :TPersistent; Override; 65 | Public 66 | Constructor Create (Const AHolder :TObject = Nil); Overload; 67 | Virtual; 68 | 69 | { Virtual instance methods } 70 | Procedure Changed; Virtual; 71 | Procedure Changing; Virtual; 72 | Procedure Deserialize (Const AStream :TStream); Virtual; 73 | Procedure Serialize (Const AStream :TStream); Virtual; 74 | 75 | { Overridden instance methods } 76 | Procedure BeforeDestruction; Override; 77 | 78 | { Instance properties } 79 | Property AsVar :Variant Read GetAsVar; 80 | Property Serialized :TBytes Read GetSerialized Write SetSerialized; 81 | End; 82 | 83 | Implementation 84 | 85 | Uses 86 | GHF.Obs, GHF.RTTI, GHF.Sys, GHF.Observer, GHF.SysEx, System.Variants; 87 | 88 | { TghPersistent } 89 | 90 | Constructor TghPersistent.Create (Const AHolder :TObject = Nil); 91 | Begin 92 | Inherited Create; 93 | 94 | If AHolder <> Nil Then 95 | AHolder.ghHold (Self); 96 | End; 97 | 98 | Procedure TghPersistent.BeforeDestruction; 99 | Begin 100 | ghPreDestroy; 101 | Inherited BeforeDestruction; 102 | End; 103 | 104 | Procedure TghPersistent.Changed; 105 | Begin 106 | ghNotifyChanged; 107 | End; 108 | 109 | Procedure TghPersistent.Changing; 110 | Begin 111 | ghNotifyChanging; 112 | End; 113 | 114 | Procedure TghPersistent.Deserialize (Const AStream :TStream); 115 | Begin 116 | {}//mecanismo DFM 117 | End; 118 | 119 | Function TghPersistent.GetAsVar :Variant; 120 | Begin 121 | Result := System.Variants.Null; 122 | End; 123 | 124 | {}//probar 125 | Function TghPersistent.GetOwner :TPersistent; 126 | Begin 127 | Result := ghHolder.ghAsOrNil ; 128 | End; 129 | 130 | Function TghPersistent.GetSerialized :TBytes; 131 | Var 132 | LStream :TBytesStream; 133 | Begin 134 | LStream := TBytesStream.Create; 135 | 136 | Try 137 | Serialize (LStream); 138 | Result := LStream.Bytes; 139 | Finally 140 | LStream.Free; 141 | End; 142 | End; 143 | 144 | Procedure TghPersistent.Serialize (Const AStream :TStream); 145 | Begin 146 | {}//mecanismo DFM 147 | End; 148 | 149 | Procedure TghPersistent.SetSerialized (Const AValue :TBytes); 150 | Var 151 | LStream :TBytesStream; 152 | Begin 153 | LStream := TBytesStream.Create (AValue); 154 | 155 | Try 156 | Deserialize (LStream); 157 | Finally 158 | LStream.Free; 159 | End; 160 | End; 161 | 162 | End. 163 | 164 | -------------------------------------------------------------------------------- /GHF.RTTIInstanceType.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.RTTIInstanceType.pas - TghRTTIInstanceType class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.RTTIInstanceType; { RTTI Instance Type } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | GHF.ClassList, GHF.KeyRetrieve, System.RTTI; 53 | 54 | Type 55 | { RTTI Instance Type class. NOTE: This class should not declare new 56 | instance fields, because its purpose is to replace the class of live 57 | TRTTIInstanceType objects. } 58 | TghRTTIInstanceType = Class (TRTTIInstanceType) 59 | Protected 60 | Type 61 | TExData = Class (TghKeyRetrieve) 62 | Protected 63 | { Instance fields } 64 | FChildren :TghClassList ; 65 | FDescendants :TghClassList ; 66 | End; 67 | 68 | { Regular instance methods } 69 | Function GetChildren :TghClassList ; 70 | Function GetDescendants :TghClassList ; 71 | Public 72 | { Regular instance methods } 73 | Function CheckSimpleConstructor ( 74 | Const ASafe :Boolean = System.True) :TRTTIMethod; 75 | 76 | { Virtual instance methods } 77 | Function CreateObj (AConstructor :TRTTIMethod) :TObject; Overload; 78 | Virtual; 79 | Function CreateObj :TObject; Overload; Virtual; 80 | Function SimpleConstructor (ASafe :Boolean = System.True) 81 | :TRTTIMethod; Virtual; 82 | 83 | { Overridden instance methods } 84 | Procedure BeforeDestruction; Override; 85 | 86 | { Instance properties } 87 | Property Children :TghClassList Read GetChildren; 88 | Property Descendants :TghClassList Read GetDescendants; 89 | End; 90 | 91 | Implementation 92 | 93 | Uses 94 | GHF.RTTI, GHF.Obs, System.TypInfo, GHF.Sys, System.SysUtils, GHF.SysEx; 95 | 96 | { TghRTTIInstanceType } 97 | 98 | { Protected regular instance methods } 99 | 100 | Function TghRTTIInstanceType.GetChildren :TghClassList ; 101 | Var 102 | ExData :TExData; 103 | Begin 104 | ExData := TExData.Get (Self); 105 | 106 | If ExData.FChildren = Nil Then 107 | Begin 108 | ExData.ghHoldSet (ExData.FChildren, TghClassList .Create); 109 | TghRTTI.InitChildren (Self); 110 | End; 111 | 112 | Result := ExData.FChildren; 113 | End; 114 | 115 | Function TghRTTIInstanceType.GetDescendants :TghClassList ; 116 | Var 117 | ExData :TExData; 118 | 119 | Procedure AddChildren (AClass :TClass); 120 | Begin 121 | For AClass In AClass.ghClassInfo.ghInstanceType.Children Do 122 | Begin 123 | ExData.FDescendants.Add (AClass); 124 | AddChildren (AClass); 125 | End; 126 | End; 127 | Begin 128 | ExData := TExData.Get (Self); 129 | 130 | If ExData.FDescendants = Nil Then 131 | Begin 132 | ExData.ghHoldSet (ExData.FDescendants, TghClassList .Create); 133 | AddChildren (MetaclassType); 134 | End; 135 | 136 | Result := ExData.FDescendants; 137 | End; 138 | 139 | { Public regular instance methods } 140 | 141 | Function TghRTTIInstanceType.CheckSimpleConstructor ( 142 | Const ASafe :Boolean = System.True) :TRTTIMethod; 143 | Begin 144 | If SimpleConstructor (ASafe).ghSetBlankTo (Result) Then 145 | EInvalidOpException.ghRaise (TghRTTI.ermNoSingleConstructor, [Name]); 146 | End; 147 | 148 | { Public virtual instance methods } 149 | 150 | Function TghRTTIInstanceType.CreateObj (AConstructor :TRTTIMethod) 151 | :TObject; 152 | Begin 153 | Result := AConstructor.Invoke (MetaclassType, []).AsObject; 154 | End; 155 | 156 | Function TghRTTIInstanceType.CreateObj :TObject; 157 | Begin 158 | Result := CheckSimpleConstructor.Invoke (MetaclassType, []).AsObject; 159 | End; 160 | 161 | Function TghRTTIInstanceType.SimpleConstructor ( 162 | ASafe :Boolean = System.True) :TRTTIMethod; 163 | Var 164 | LParamConstructor :TRTTIMethod; 165 | Begin 166 | LParamConstructor := Nil; 167 | 168 | For Result In GetMethods Do 169 | If Result.ghIsPublicConstructor And Not Result.ghIsAbstract Then 170 | If Result.ghParamCount = 0 Then 171 | If ASafe And (LParamConstructor <> Nil) And 172 | (Result.Parent <> LParamConstructor.Parent) Then 173 | System.Break // Exit in "Result := Nil;" 174 | Else 175 | System.Exit // A simple one found (at least TObject.Create) 176 | Else 177 | Result.ghReplaceNil (LParamConstructor); 178 | 179 | Result := Nil; 180 | End; 181 | 182 | { Public overridden instance methods } 183 | 184 | Procedure TghRTTIInstanceType.BeforeDestruction; 185 | Begin 186 | ghPreDestroy; 187 | Inherited BeforeDestruction; 188 | End; 189 | 190 | End. 191 | 192 | -------------------------------------------------------------------------------- /GHF.SQL.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.SQL.pas - TghSQL class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.SQL; { SQL } 40 | 41 | { NOTE: The only native unit scope that should be unconditionally 42 | referenced, either directly or indirectly, from this code file is the 43 | System unit scope, except the System.Win sub-scope. The intention is that 44 | this unit to be part of a central base that can be compiled into any 45 | project. } 46 | 47 | {$ScopedEnums On} 48 | 49 | Interface 50 | 51 | Uses 52 | GHF.Sys, System.Types; 53 | 54 | Type 55 | { SQL class } 56 | TghSQL = Class (TghZeroton) 57 | Public 58 | Type 59 | { Class reference type } 60 | TClassRef = Class Of TghSQL; 61 | 62 | { Regular class methods } 63 | Class Function ConcatLiteralValues ( 64 | Const AValues :Array Of Variant; Const ASeparator :String = ', ') 65 | :String; Overload; 66 | Class Function ConcatLiteralValues (Const AValues :Variant; 67 | Const ASeparator :String = ', ') :String; Overload; 68 | Class Function LiteralDate (Const AValue :TDateTime) :String; 69 | Overload; 70 | Class Function LiteralDate :String; Overload; 71 | Class Function LiteralDateTime (Const AValue :TDateTime) :String; 72 | Overload; 73 | Class Function LiteralDateTime :String; Overload; 74 | Class Function LiteralTime (Const AValue :TDateTime) :String; 75 | Overload; 76 | Class Function LiteralTime :String; Overload; 77 | Class Function LiteralValues (Const AValues :Array Of Variant) 78 | :TArray ; Overload; 79 | Class Function LiteralValues (Const AValues :Variant) 80 | :TArray ; Overload; 81 | 82 | { Virtual class methods } 83 | Class Function LiteralDateFormat :String; Virtual; 84 | Class Function LiteralDateTimeFormat :String; Virtual; 85 | Class Function LiteralTimeFormat :String; Virtual; 86 | Class Function LiteralValue (Const AValue :Variant) :String; 87 | Virtual; 88 | End; 89 | 90 | Implementation 91 | 92 | Uses 93 | System.SysUtils, GHF.SysEx; 94 | 95 | { TghSQL } 96 | 97 | { Public regular class methods } 98 | 99 | Class Function TghSQL.ConcatLiteralValues ( 100 | Const AValues :Array Of Variant; Const ASeparator :String = ', ') 101 | :String; 102 | Begin 103 | Result := String.Join (ASeparator, LiteralValues (AValues)); 104 | End; 105 | 106 | Class Function TghSQL.ConcatLiteralValues (Const AValues :Variant; 107 | Const ASeparator :String = ', ') :String; 108 | Begin 109 | Result := String.Join (ASeparator, LiteralValues (AValues)); 110 | End; 111 | 112 | Class Function TghSQL.LiteralDate (Const AValue :TDateTime) :String; 113 | Begin 114 | Result := System.SysUtils.FormatDateTime (LiteralDateFormat, AValue); 115 | End; 116 | 117 | Class Function TghSQL.LiteralDate :String; 118 | Begin 119 | Result := LiteralDate (System.SysUtils.Date); 120 | End; 121 | 122 | Class Function TghSQL.LiteralDateTime (Const AValue :TDateTime) :String; 123 | Begin 124 | Result := System.SysUtils.FormatDateTime ( 125 | LiteralDateTimeFormat, AValue); 126 | End; 127 | 128 | Class Function TghSQL.LiteralDateTime :String; 129 | Begin 130 | Result := LiteralDateTime (System.SysUtils.Now); 131 | End; 132 | 133 | Class Function TghSQL.LiteralTime (Const AValue :TDateTime) :String; 134 | Begin 135 | Result := System.SysUtils.FormatDateTime (LiteralTimeFormat, AValue); 136 | End; 137 | 138 | Class Function TghSQL.LiteralTime :String; 139 | Begin 140 | Result := LiteralTime (System.SysUtils.Time); 141 | End; 142 | 143 | Class Function TghSQL.LiteralValues (Const AValues :Array Of Variant) 144 | :TArray ; 145 | Var 146 | I :Integer; 147 | Begin 148 | For I := 0 To 149 | TghSys.SetHigh (Result, System.High (AValues)) Do 150 | Result [I] := LiteralValue (AValues [I]); 151 | End; 152 | 153 | {}//probar 154 | Class Function TghSQL.LiteralValues (Const AValues :Variant) 155 | :TArray ; 156 | Var 157 | I :Integer; 158 | Begin 159 | If AValues.ghIsArr Then 160 | For I := 0 To TghSys.SetHigh (Result, AValues.ghHigh) Do 161 | Result [I] := LiteralValue (AValues [I]) 162 | Else 163 | Result [TghSys.SetHigh (Result, 0)] := 164 | LiteralValue (AValues); 165 | End; 166 | 167 | { Public virtual class methods } 168 | 169 | Class Function TghSQL.LiteralDateFormat :String; 170 | Begin 171 | Result := TghSys.QuotedFormat (TghSys.fmtISODate); 172 | End; 173 | 174 | Class Function TghSQL.LiteralDateTimeFormat :String; 175 | Begin 176 | Result := TghSys.QuotedFormat (TghSys.fmtStdDateTime); 177 | End; 178 | 179 | Class Function TghSQL.LiteralTimeFormat :String; 180 | Begin 181 | Result := TghSys.QuotedFormat (TghSys.fmtISOTime); 182 | End; 183 | 184 | Class Function TghSQL.LiteralValue (Const AValue :Variant) :String; 185 | Begin 186 | If AValue.ghIsSolid Then 187 | If AValue.ghIsStr Then 188 | Result := System.SysUtils.QuotedStr (AValue) 189 | Else 190 | If AValue.ghFindData.VType = varDate Then 191 | If System.Frac (AValue) = 0 Then 192 | Result := LiteralDate (AValue) 193 | Else 194 | Result := LiteralDateTime (AValue) 195 | Else 196 | Result := AValue 197 | Else 198 | Result := 'Null' // varEmpty or varNull 199 | End; 200 | 201 | End. 202 | 203 | -------------------------------------------------------------------------------- /GHF.VCL.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.VCL.pas - TghVCL class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.VCL; { VCL } 40 | 41 | { NOTE: In order to avoid circular unit references, the public parts of 42 | this unit should not depend on other Windows or VCL GH Freebrary units. 43 | Moreover, the only native unit scopes that should be unconditionally 44 | referenced, either directly or indirectly, from this code file are the 45 | System, WinAPI and VCL unit scopes. The intention is that this unit to be 46 | part of a central base that can be compiled into any VCL project. } 47 | 48 | {$ScopedEnums On} 49 | 50 | Interface 51 | 52 | Uses 53 | GHF.Sys, VCL.Forms, VCL.Controls, WinAPI.Windows, GHF.SysEx; 54 | 55 | Type 56 | { VCL class } 57 | TghVCL = Class (TghZeroton) 58 | Private 59 | Class Constructor Create; 60 | Class Destructor Destroy; 61 | Public 62 | Type 63 | { Pointer types for data types declared in native units } 64 | PCustomForm = ^TCustomForm; 65 | 66 | { TWinControl helper } 67 | TWinControlHelper = Class Helper (TghSys.TComponentHelper) For 68 | TWinControl 69 | Public 70 | { Regular instance methods } 71 | Function ghFirstFocusableControl ( 72 | Const ATabStop :Boolean = System.True) :TWinControl; 73 | Function ghMsgPending (Const AMinID, AMaxID :Integer) 74 | :Boolean; Overload; 75 | Function ghMsgPending (Const AID :Integer = 0) :Boolean; 76 | Overload; 77 | Function ghPeekMsg (Out AMsg :TMsg; 78 | Const AMinID, AMaxID :Integer; 79 | Const ARemove :Boolean = System.False) :Boolean; Overload; 80 | Function ghPeekMsg (Out AMsg :TMsg; Const AID :Integer = 0; 81 | Const ARemove :Boolean = System.False) :Boolean; Overload; 82 | Function ghReleasePending :Boolean; 83 | End; 84 | 85 | { TForm helper } 86 | TFormHelper = Class Helper (TWinControlHelper) For TForm 87 | Public 88 | { Regular class methods } 89 | Class Function ghDefaultInstance :TForm; 90 | 91 | { Regular instance methods } 92 | Function ghFocusFirstControl ( 93 | Const ATabStop :Boolean = System.True) :Boolean; 94 | Function ghHasFocus :Boolean; Overload; 95 | Function ghHasFocus (Const AControl :TWinControl) :Boolean; 96 | Overload; 97 | Procedure ghRefocusControl; 98 | Function ghRefocusFirstControl ( 99 | Const ATabStop :Boolean = System.True) :Boolean; 100 | End; 101 | 102 | { Record type for TghWin.msgCloseModal Windows message } 103 | TMsgCloseModal = Packed Record 104 | ID :Cardinal; 105 | ModalResult :TModalResult; 106 | Unused :LongInt; 107 | Result :LongInt; 108 | End; 109 | 110 | { Virtual class. Overridable functionality, accessible via the 111 | Virtual class property. } 112 | TVirtual = Class 113 | Public 114 | Type 115 | { Class reference type } 116 | TClassRef = Class Of TVirtual; 117 | End; 118 | Protected 119 | Class Var 120 | FVirtual :TVirtual.TClassRef; 121 | 122 | { Static class methods } 123 | Class Procedure SetVirtual (Const AValue :TVirtual.TClassRef); 124 | Static; 125 | Public 126 | { Class properties } 127 | Class Property Virtual :TVirtual.TClassRef Read FVirtual 128 | Write SetVirtual; 129 | End; 130 | 131 | Implementation 132 | 133 | Uses 134 | GHF.Win; 135 | 136 | { TghVCL } 137 | 138 | { TghVCL.TFormHelper } 139 | 140 | Class Function TghVCL.TFormHelper.ghDefaultInstance :TForm; 141 | Begin 142 | Result := VCL.Forms.Application.ghFirstComponent (Self).ghAsPtr; 143 | End; 144 | 145 | Function TghVCL.TFormHelper.ghFocusFirstControl ( 146 | Const ATabStop :Boolean = System.True) :Boolean; 147 | Begin 148 | ActiveControl := ghFirstFocusableControl (ATabStop); 149 | Result := ActiveControl <> Nil; 150 | End; 151 | 152 | Function TghVCL.TFormHelper.ghHasFocus :Boolean; 153 | Begin 154 | Result := VCL.Forms.Screen.ActiveForm = Self; 155 | End; 156 | 157 | Function TghVCL.TFormHelper.ghHasFocus (Const AControl :TWinControl) 158 | :Boolean; 159 | Begin 160 | Result := ghHasFocus And AControl.ContainsControl (ActiveControl); 161 | End; 162 | 163 | Procedure TghVCL.TFormHelper.ghRefocusControl; 164 | Var 165 | LControl :TWinControl; 166 | Begin 167 | If ActiveControl = Nil Then 168 | System.Exit; 169 | 170 | LControl := ActiveControl; 171 | ActiveControl := Nil; 172 | 173 | If LControl.CanFocus Then 174 | ActiveControl := LControl; 175 | End; 176 | 177 | Function TghVCL.TFormHelper.ghRefocusFirstControl ( 178 | Const ATabStop :Boolean = System.True) :Boolean; 179 | Begin 180 | ActiveControl := Nil; 181 | Result := ghFocusFirstControl (ATabStop); 182 | End; 183 | 184 | { TghVCL.TWinControlHelper } 185 | 186 | Function TghVCL.TWinControlHelper.ghFirstFocusableControl ( 187 | Const ATabStop :Boolean = System.True) :TWinControl; 188 | Begin 189 | Result := FindNextControl (Nil, System.True, ATabStop, System.False); 190 | End; 191 | 192 | Function TghVCL.TWinControlHelper.ghMsgPending ( 193 | Const AMinID, AMaxID :Integer) :Boolean; 194 | Begin 195 | Result := TghWin.MsgPending (Handle, AMinID, AMaxID); 196 | End; 197 | 198 | Function TghVCL.TWinControlHelper.ghMsgPending (Const AID :Integer = 0) 199 | :Boolean; 200 | Begin 201 | Result := TghWin.MsgPending (Handle, AID); 202 | End; 203 | 204 | Function TghVCL.TWinControlHelper.ghPeekMsg (Out AMsg :TMsg; 205 | Const AMinID, AMaxID :Integer; Const ARemove :Boolean = System.False) 206 | :Boolean; 207 | Begin 208 | Result := TghWin.PeekMsg (AMsg, Handle, AMinID, AMaxID, ARemove); 209 | End; 210 | 211 | Function TghVCL.TWinControlHelper.ghPeekMsg (Out AMsg :TMsg; 212 | Const AID :Integer = 0; Const ARemove :Boolean = System.False) 213 | :Boolean; 214 | Begin 215 | Result := TghWin.PeekMsg (AMsg, Handle, AID, ARemove); 216 | End; 217 | 218 | Function TghVCL.TWinControlHelper.ghReleasePending :Boolean; 219 | Begin 220 | Result := ghMsgPending (VCL.Controls.cm_Release); 221 | End; 222 | 223 | { Constructors and destructors } 224 | 225 | Class Constructor TghVCL.Create; 226 | Begin 227 | TVirtual.ghInitVirtualClass (FVirtual); 228 | End; 229 | 230 | Class Destructor TghVCL.Destroy; 231 | Begin 232 | TVirtual.ghFinalizeVirtualClass; 233 | End; 234 | 235 | { Protected static class methods } 236 | 237 | Class Procedure TghVCL.SetVirtual (Const AValue :TVirtual.TClassRef); 238 | Begin 239 | TVirtual.ghSetVirtualClass (AValue); 240 | End; 241 | 242 | End. 243 | 244 | -------------------------------------------------------------------------------- /GHF.Form.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.Form.pas - TghForm class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.Form; { Form } 40 | 41 | { NOTE: The only native unit scopes that should be unconditionally 42 | referenced, either directly or indirectly, from this code file are the 43 | System, WinAPI and VCL unit scopes. The intention is that this unit to be 44 | part of a central base that can be compiled into any VCL project. } 45 | 46 | {$ScopedEnums On} 47 | 48 | Interface 49 | 50 | Uses 51 | VCL.Forms, VCL.Controls, System.Classes, GHF.VCL, GHF.Win; 52 | 53 | Type 54 | {}//considerar en derivada capacidades para TDataSource quitadas 55 | { Form class } 56 | TghForm = Class (TForm) 57 | Protected 58 | { Instance fields } 59 | AutoModalResult :TModalResult; 60 | FActiveReader :TReader; 61 | FInOnCreate :Boolean; 62 | FOpenParams :PVariant; 63 | 64 | { Regular class methods } 65 | Class Function InternalExecute (Const AParams :PVariant; 66 | Const AAutoModalResult :TModalResult = VCL.Controls.mrNone) 67 | :TModalResult; 68 | Class Function InternalOpen (Const AParams :PVariant) :TghForm; 69 | Class Function PrepareOpen (Const AParams :PVariant = Nil) :TghForm; 70 | 71 | { Regular instance methods } 72 | Function GetOpenParam (Const AIndex :Integer) :Variant; 73 | Function GetOpenParamCount :Integer; 74 | 75 | { Virtual instance methods } 76 | Function DoExecute :TModalResult; Virtual; 77 | Procedure DoOpen; Virtual; 78 | Procedure GetControlStates (AControl :TControl; 79 | Var AVisible, AEnabled :Boolean); Virtual; 80 | Procedure UpdateControl (AControl :TControl); Virtual; 81 | 82 | { Overridden instance methods } 83 | Procedure DoClose (Var Action :TCloseAction); Override; 84 | Procedure DoCreate; Override; 85 | Procedure ReadState (Reader :TReader); Override; 86 | 87 | { Message methods } 88 | Procedure MsgCloseModal (Var AMsg :TghVCL.TMsgCloseModal); 89 | Message TghWin.msgCloseModal; 90 | Public 91 | Constructor Create; Reintroduce; Overload; Virtual; 92 | 93 | { Regular class methods } 94 | Class Function Execute (Const AParams :Variant; 95 | Const AAutoModalResult :TModalResult = VCL.Controls.mrNone) 96 | :TModalResult; Overload; 97 | Class Function Execute (Const AParams :Array Of Const; 98 | Const AAutoModalResult :TModalResult = VCL.Controls.mrNone) 99 | :TModalResult; Overload; 100 | Class Function Execute (Const AParam :Pointer; 101 | Const AAutoModalResult :TModalResult = VCL.Controls.mrNone) 102 | :TModalResult; Overload; 103 | Class Function Execute :TModalResult; Overload; 104 | Class Function Open (Const AParams :Variant) :TghForm; Overload; 105 | Class Function Open (Const AParams :Array Of Const) :TghForm; 106 | Overload; 107 | Class Function Open (Const AParam :Pointer) :TghForm; Overload; 108 | Class Function Open :TghForm; Overload; 109 | 110 | { Regular instance methods } 111 | Procedure UpdateControls (Const AParent :TWinControl; 112 | Const AIncludeParent :Boolean = System.False); Overload; 113 | Procedure UpdateControls ( 114 | Const AIncludeForm :Boolean = System.False); Overload; 115 | Procedure UpdateControls (Const AParents :Array Of TWinControl; 116 | Const AIncludeParents :Boolean = System.False); Overload; 117 | 118 | { Overridden instance methods } 119 | Procedure BeforeDestruction; Override; 120 | 121 | { Instance properties } 122 | Property InOnCreate :Boolean Read FInOnCreate; 123 | Property OpenParams [Const AIndex :Integer] :Variant 124 | Read GetOpenParam; 125 | Property OpenParamCount :Integer Read GetOpenParamCount; 126 | Property ActiveReader :TReader Read FActiveReader; 127 | End; 128 | 129 | { TghForm Class type } 130 | TghFormClass = Class Of TghForm; 131 | 132 | Implementation 133 | 134 | Uses 135 | System.Variants, WinAPI.Windows, VCL.StdCtrls, GHF.VCLObjList, 136 | GHF.ObjList, GHF.Obs, System.Contnrs, GHF.Sys; 137 | 138 | { TghForm } 139 | 140 | Constructor TghForm.Create; 141 | Begin 142 | Create (Application); 143 | End; 144 | 145 | { Protected regular class methods } 146 | 147 | Class Function TghForm.InternalExecute (Const AParams :PVariant; 148 | Const AAutoModalResult :TModalResult = VCL.Controls.mrNone) 149 | :TModalResult; 150 | Begin 151 | With PrepareOpen (AParams) Do{}//dejar de usar With 152 | Try 153 | If AAutoModalResult <> VCL.Controls.mrNone Then 154 | Begin 155 | AutoModalResult := AAutoModalResult; 156 | PostMessage (Handle, TghWin.msgCloseModal, AutoModalResult, 0); 157 | End; 158 | 159 | Result := DoExecute; 160 | Finally 161 | FOpenParams := Nil; 162 | AutoModalResult := VCL.Controls.mrNone; 163 | End; 164 | End; 165 | 166 | Class Function TghForm.InternalOpen (Const AParams :PVariant) :TghForm; 167 | Begin 168 | Result := PrepareOpen (AParams); 169 | 170 | Try 171 | Result.DoOpen; 172 | Finally 173 | Result.FOpenParams := Nil; 174 | End; 175 | End; 176 | 177 | Class Function TghForm.PrepareOpen (Const AParams :PVariant = Nil) 178 | :TghForm; 179 | Begin 180 | Result := ghDefaultInstance.ghAsPtr; 181 | 182 | If (Result = Nil) Or (VCL.Forms.fsModal In Result.FormState) Or 183 | Result.ghReleasePending Then 184 | Begin 185 | Result := TghForm (NewInstance); 186 | Result.FOpenParams := AParams; 187 | Result.Create; 188 | End 189 | Else 190 | Result.FOpenParams := AParams; 191 | End; 192 | 193 | { Protected regular instance methods } 194 | 195 | Function TghForm.GetOpenParam (Const AIndex :Integer) :Variant; 196 | Begin 197 | If TghSys.CheckIndex (AIndex) >= OpenParamCount Then 198 | Result := Unassigned // Default value of "optional" parameter 199 | Else 200 | Result := FOpenParams^.ghElement (AIndex); 201 | End; 202 | 203 | Function TghForm.GetOpenParamCount :Integer; 204 | Begin 205 | If FOpenParams = Nil Then 206 | Result := 0 207 | Else 208 | Result := FOpenParams^.ghLength; 209 | End; 210 | 211 | { Protected virtual instance methods } 212 | 213 | Function TghForm.DoExecute :TModalResult; 214 | Begin 215 | Hide; 216 | Result := ShowModal; 217 | End; 218 | 219 | Procedure TghForm.DoOpen; 220 | Begin 221 | Show; 222 | End; 223 | 224 | Procedure TghForm.GetControlStates (AControl :TControl; 225 | Var AVisible, AEnabled :Boolean); 226 | Begin 227 | End; 228 | 229 | Procedure TghForm.UpdateControl (AControl :TControl); 230 | Var 231 | AEnabled, AVisible :Boolean; 232 | Method :TMethod; 233 | Begin 234 | TghSys.TValueVarVarMethod (Method) := 235 | GetControlStates; 236 | 237 | // We check if the GetControlStates method was overridden 238 | If Method.Code = @TghForm.GetControlStates Then 239 | System.Exit; 240 | 241 | AVisible := AControl.Visible; 242 | AEnabled := AControl.Enabled; 243 | GetControlStates (AControl, AVisible, AEnabled); 244 | AControl.Visible := AVisible; 245 | AControl.Enabled := AEnabled; 246 | End; 247 | 248 | { Protected overridden instance methods } 249 | 250 | Procedure TghForm.DoClose (Var Action :TCloseAction); 251 | Begin 252 | If Action = VCL.Forms.caHide Then 253 | Action := VCL.Forms.caFree; 254 | 255 | Inherited DoClose (Action); 256 | End; 257 | 258 | Procedure TghForm.DoCreate; 259 | Begin 260 | FInOnCreate := System.True; 261 | 262 | Try 263 | Inherited DoCreate; 264 | Finally 265 | FInOnCreate := System.False; 266 | End; 267 | End; 268 | 269 | Procedure TghForm.ReadState (Reader :TReader); 270 | Begin 271 | FActiveReader := Reader; 272 | 273 | Try 274 | Inherited ReadState (Reader); 275 | Finally 276 | FActiveReader := Nil; 277 | End; 278 | End; 279 | 280 | { Protected message methods } 281 | 282 | {}//probar 283 | Procedure TghForm.MsgCloseModal (Var AMsg :TghVCL.TMsgCloseModal); 284 | Var 285 | LModalResult :TModalResult; 286 | Begin 287 | LModalResult := AMsg.ModalResult; 288 | 289 | If ghEnumComponents ( 290 | Procedure (Const AButton :TButton; Var Continue :Boolean) 291 | Begin 292 | If AButton.Enabled And (AButton.ModalResult = LModalResult) Then 293 | Begin 294 | AButton.Click; 295 | Continue := System.False; 296 | End; 297 | End, System.True) = Nil Then 298 | ModalResult := LModalResult; 299 | End; 300 | 301 | { Public regular class methods } 302 | 303 | Class Function TghForm.Execute (Const AParams :Variant; 304 | Const AAutoModalResult :TModalResult = VCL.Controls.mrNone) 305 | :TModalResult; 306 | Begin 307 | Result := InternalExecute (@AParams, AAutoModalResult); 308 | End; 309 | 310 | Class Function TghForm.Execute (Const AParams :Array Of Const; 311 | Const AAutoModalResult :TModalResult = VCL.Controls.mrNone) 312 | :TModalResult; 313 | Begin 314 | Result := Execute (TghSys.TVarRecsVar (AParams), AAutoModalResult); 315 | End; 316 | 317 | Class Function TghForm.Execute (Const AParam :Pointer; 318 | Const AAutoModalResult :TModalResult = VCL.Controls.mrNone) 319 | :TModalResult; 320 | Begin 321 | Result := Execute (TghSys.PtrVar (AParam), AAutoModalResult); 322 | End; 323 | 324 | Class Function TghForm.Execute :TModalResult; 325 | Begin 326 | Result := InternalExecute (Nil); 327 | End; 328 | 329 | Class Function TghForm.Open (Const AParams :Variant) :TghForm; 330 | Begin 331 | Result := InternalOpen (@AParams); 332 | End; 333 | 334 | Class Function TghForm.Open (Const AParams :Array Of Const) :TghForm; 335 | Begin 336 | Result := Open (TghSys.TVarRecsVar (AParams)); 337 | End; 338 | 339 | Class Function TghForm.Open (Const AParam :Pointer) :TghForm; 340 | Begin 341 | Result := Open (AParam.ghAsVar); 342 | End; 343 | 344 | Class Function TghForm.Open :TghForm; 345 | Begin 346 | Result := InternalOpen (Nil); 347 | End; 348 | 349 | { Public regular instance methods } 350 | 351 | Procedure TghForm.UpdateControls (Const AParent :TWinControl; 352 | Const AIncludeParent :Boolean = System.False); 353 | Var 354 | LList :TghVCLObjList; 355 | Begin 356 | LList := TghVCLObjList.Create (System.False); 357 | 358 | Try 359 | If AIncludeParent Then 360 | LList.Add (Parent); 361 | 362 | LList.AddControls (Parent, System.True); 363 | LList.Enum ( 364 | Procedure (Const AControl :TObject; Var AContinue :Boolean) 365 | Begin 366 | UpdateControl (TControl (AControl)); 367 | End); 368 | Finally 369 | LList.Free; 370 | End; 371 | End; 372 | 373 | Procedure TghForm.UpdateControls ( 374 | Const AIncludeForm :Boolean = System.False); 375 | Begin 376 | UpdateControls (Self, AIncludeForm); 377 | End; 378 | 379 | Procedure TghForm.UpdateControls (Const AParents :Array Of TWinControl; 380 | Const AIncludeParents :Boolean = System.False); 381 | Var 382 | I :Integer; 383 | Begin 384 | For I := 0 To System.High (AParents) Do 385 | UpdateControls (AParents [I], AIncludeParents); 386 | End; 387 | 388 | { Public overridden instance methods } 389 | 390 | Procedure TghForm.BeforeDestruction; 391 | Begin 392 | ghPreDestroy; 393 | Inherited BeforeDestruction; 394 | End; 395 | 396 | End. 397 | 398 | -------------------------------------------------------------------------------- /GHF.XMLDoc.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.XMLDoc.pas - TghXMLDoc class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.XMLDoc; { XML Document } 40 | 41 | { NOTE: The only native unit scopes that should be unconditionally 42 | referenced, either directly or indirectly, from this code file are the 43 | System, WinAPI and XML unit scopes. The intention is that this unit to be 44 | part of a central base that can be compiled into any Windows project. } 45 | 46 | {$ScopedEnums On} 47 | 48 | Interface 49 | 50 | Uses 51 | GHF.Sys; 52 | 53 | Type 54 | { XML Document class } 55 | TghXMLDoc = Class 56 | Protected 57 | { Instance fields } 58 | FClassID :TGUID; 59 | FContent :OLEVariant; 60 | FPath :String; 61 | FValidationError :OLEVariant; 62 | FWorkNode :OLEVariant; 63 | 64 | { Regular instance methods } 65 | Function GetVersion :String; 66 | Function GetWorkLevel :Integer; 67 | Function GetWorkNode :OLEVariant; 68 | Procedure RaiseNodeNotFound (Const AExpr :String); 69 | Procedure SetWorkLevel (Value :Integer); 70 | Procedure SetWorkNode (Const Value :OLEVariant); 71 | Public 72 | Constructor Create (Const ClassIDs :Array Of TGUID; 73 | Const AContent :String = ''); Overload; Virtual; 74 | Constructor Create (Const AContent :String = ''); Overload; 75 | Virtual; 76 | 77 | { Regular instance methods } 78 | Procedure AddSchema (Const NameSpace :String; 79 | Const Schema :OLEVariant; 80 | Const ValidateContent :Boolean = System.False); Overload; 81 | Procedure AddSchema (Const Schema :OLEVariant; 82 | Const ValidateContent :Boolean = System.False); Overload; 83 | Function CreateElement (Name :String; Const Text :String = '') 84 | :OLEVariant; Overload; 85 | Function CreateElement (Const Name, Attr :String; 86 | Const AttrValue :OLEVariant) :OLEVariant; Overload; 87 | Function CreateElement (Const Name, Text :String; 88 | Const Attrs :Array Of Const) :OLEVariant; Overload; 89 | Function CreateElement (Const Name :String; 90 | Const Attrs :Array Of Const) :OLEVariant; Overload; 91 | Function CreateElement (Const ParentLevel :Integer; 92 | Const Name :String; Const Text :String = '') :OLEVariant; 93 | Overload; 94 | Function CreateElement (Const ParentLevel :Integer; 95 | Const Name, Attr :String; Const AttrValue :OLEVariant) 96 | :OLEVariant; Overload; 97 | Function CreateElement (Const ParentLevel :Integer; 98 | Const Name, Text :String; Const Attrs :Array Of Const) 99 | :OLEVariant; Overload; 100 | Function CreateElement (Const ParentLevel :Integer; 101 | Const Name :String; Const Attrs :Array Of Const) 102 | :OLEVariant; Overload; 103 | Function FindNode (Const Expr :String) :OLEVariant; Overload; 104 | Function FindNode (Const Expr :String; 105 | Const Params :Array Of Const) :OLEVariant; Overload; 106 | Function FindNodes (Const Expr :String) :OLEVariant; Overload; 107 | Function FindNodes (Const Expr :String; 108 | Const Params :Array Of Const) :OLEVariant; Overload; 109 | Function FormatContent :String; 110 | Function LocateNode (Const Expr :String; 111 | Const ARaiseError :Boolean = System.False) :Boolean; 112 | Function Node (Const Expr :String; Const Params :Array Of Const) 113 | :OLEVariant; Overload; 114 | Function Nodes (Const Expr :String; Const Params :Array Of Const) 115 | :OLEVariant; Overload; 116 | Function Validate :OLEVariant; 117 | 118 | { Virtual instance methods } 119 | Function DefaultClassIDs :TArray ; 120 | Function Load (Const AContent :String) :Boolean; Virtual; 121 | Function Node (Const Expr :String) :OLEVariant; Overload; Virtual; 122 | Function Nodes (Const Expr :String) :OLEVariant; Overload; Virtual; 123 | Procedure Save (Const APath :String = ''); Virtual; 124 | 125 | { Overridden instance methods } 126 | Procedure BeforeDestruction; Override; 127 | 128 | { Instance properties } 129 | Property ClassID :TGUID Read FClassID; 130 | Property Content :OLEVariant Read FContent; 131 | Property Path :String Read FPath; 132 | Property ValidationError :OLEVariant Read FValidationError; 133 | Property Version :String Read GetVersion; 134 | Property WorkLevel :Integer Read GetWorkLevel Write SetWorkLevel; 135 | Property WorkNode :OLEVariant Read GetWorkNode Write SetWorkNode; 136 | End; 137 | 138 | Implementation 139 | 140 | Uses 141 | System.Variants, System.SysUtils, WinAPI.MSXML, XML.XMLDoc, GHF.Obs, 142 | GHF.Win, GHF.SysEx; 143 | 144 | { TghXMLDoc } 145 | 146 | Constructor TghXMLDoc.Create (Const ClassIDs :Array Of TGUID; 147 | Const AContent :String = ''); 148 | Begin 149 | TghWin.CheckMSXMLDocClassIDs (ClassIDs); 150 | 151 | { After calling TghWin.COMDispatch, FClassID is the class ID that this 152 | function used to create the FContent COM object (a DOMDocument). 153 | NOTE: With some versions of MSXML, it is not reliable to use 154 | IProvideClassInfo or IPersistStream.GetClassID to get the class ID of 155 | a DOMDocument instance (do not use them for that purpose). } 156 | FContent := TghWin.COMDispatch (ClassIDs, @FClassID); 157 | Content.Async := System.False; 158 | 159 | If (AContent <> '') And Not Load (AContent) Then 160 | EArgumentException.ghRaise ( 161 | TghSys.ermInvalidContentOrFile, ['XML document']); 162 | End; 163 | 164 | Constructor TghXMLDoc.Create (Const AContent :String = ''); 165 | Begin 166 | Create (DefaultClassIDs, AContent); 167 | End; 168 | 169 | { Protected regular instance methods } 170 | 171 | Function TghXMLDoc.GetVersion :String; 172 | Begin 173 | Result := TghWin.Virtual.MSXMLVersion (ClassID); 174 | End; 175 | 176 | Function TghXMLDoc.GetWorkLevel :Integer; 177 | Var 178 | ANode :OLEVariant; 179 | Begin 180 | ANode := WorkNode; 181 | Result := 0; 182 | 183 | While Not System.Variants.VarIsClear (ANode.ParentNode) Do 184 | Begin 185 | ANode := ANode.ParentNode; 186 | Inc (Result); 187 | End; 188 | End; 189 | 190 | Function TghXMLDoc.GetWorkNode :OLEVariant; 191 | Begin 192 | If System.Variants.VarIsClear (FWorkNode) Then 193 | If System.Variants.VarIsClear (Content.DocumentElement) Then 194 | FWorkNode := Content 195 | Else 196 | FWorkNode := Content.DocumentElement; 197 | 198 | Result := FWorkNode; 199 | End; 200 | 201 | Procedure TghXMLDoc.RaiseNodeNotFound (Const AExpr :String); 202 | Begin 203 | Exception.ghRaise ( 204 | TghSys.ermNotFoundStr, ['XML document node(s)', AExpr]); 205 | End; 206 | 207 | Procedure TghXMLDoc.SetWorkLevel (Value :Integer); 208 | Begin 209 | If Value = WorkLevel Then 210 | System.Exit; 211 | 212 | Case Value Of 213 | 0 : WorkNode := Content; 214 | 1 : WorkNode := Content.DocumentElement; 215 | Else 216 | If Value > 0 Then 217 | If Value > WorkLevel Then 218 | {}//probar 219 | Exception.ghRaise (TghSys.ermCannotStrWhenStr, 220 | ['point out a work level greater than 1', Value.ToString, 221 | 'current level is less than it', WorkLevel.ToString]) 222 | Else 223 | WorkLevel := Value - WorkLevel 224 | Else 225 | While (Value < 0) And (WorkLevel > 0) Do 226 | Begin 227 | WorkNode := WorkNode.ParentNode; 228 | Inc (Value); 229 | End; 230 | End; 231 | End; 232 | 233 | Procedure TghXMLDoc.SetWorkNode (Const Value :OLEVariant); 234 | Begin 235 | If System.Variants.VarIsStr (Value) Then // Node by expression 236 | FWorkNode := FindNode (Value) 237 | Else // Node by automation object 238 | FWorkNode := IDispatch (Value); 239 | End; 240 | 241 | { Public regular instance methods } 242 | 243 | Procedure TghXMLDoc.AddSchema (Const NameSpace :String; 244 | Const Schema :OLEVariant; 245 | Const ValidateContent :Boolean = System.False); 246 | Begin 247 | { NOTE: This call to VarIsNull is correct here, instead of the typical 248 | VarIsClear (automation/MSXML bug?). } 249 | If System.Variants.VarIsNull (Content.Schemas) Then 250 | Content.Schemas := TghWin.MSXMLSchemaCache (ClassID); 251 | 252 | Content.Schemas.Add (NameSpace, Schema); 253 | 254 | If ValidateContent Then 255 | Validate; 256 | End; 257 | 258 | Procedure TghXMLDoc.AddSchema (Const Schema :OLEVariant; 259 | Const ValidateContent :Boolean = System.False); 260 | Begin 261 | AddSchema ('', Schema, ValidateContent); 262 | End; 263 | 264 | Function TghXMLDoc.CreateElement (Name :String; Const Text :String = '') 265 | :OLEVariant; 266 | Var 267 | NameSpace :String; 268 | Begin 269 | If Content.ChildNodes.Length = 0 Then 270 | Content.AppendChild (Content.CreateProcessingInstruction ('xml', 271 | 'version="1.0" encoding="UTF-8"')); 272 | 273 | If TghSys.ChrIndex (Name, ' ') > 0 Then // Name and name space 274 | With TghSys.LeftRightOfOptional (Name, ' ') Do {}//LeftRightOf, ya no With 275 | Begin 276 | Name := Value1; 277 | NameSpace := Value2; 278 | End 279 | Else // Name only, we use the document name space (if any) 280 | If Not System.Variants.VarIsClear (Content.DocumentElement) Then 281 | NameSpace := Content.DocumentElement.NameSpaceURI; 282 | 283 | Result := Content.CreateNode ( 284 | WinAPI.MSXML.Node_Element, Name, NameSpace); 285 | 286 | If Text <> '' Then 287 | Result.Text := Text; 288 | 289 | WorkNode.AppendChild (Result); 290 | WorkNode := Result; 291 | End; 292 | 293 | Function TghXMLDoc.CreateElement (Const Name, Attr :String; 294 | Const AttrValue :OLEVariant) :OLEVariant; 295 | Begin 296 | Result := CreateElement (Name); 297 | Result.SetAttribute (Attr, AttrValue); 298 | End; 299 | 300 | Function TghXMLDoc.CreateElement (Const Name, Text :String; 301 | Const Attrs :Array Of Const) :OLEVariant; 302 | Var 303 | I :Integer; 304 | Begin 305 | Result := CreateElement (Name, Text); 306 | 307 | For I := 0 To System.High (Attrs) Div 2 Do 308 | Result.SetAttribute ( 309 | Attrs [I * 2].ghAsOLEVar, Attrs [(I * 2) + 1].ghAsOLEVar);{}//probar (helper) 310 | End; 311 | 312 | Function TghXMLDoc.CreateElement (Const Name :String; 313 | Const Attrs :Array Of Const) :OLEVariant; 314 | Begin 315 | Result := CreateElement (Name, '', Attrs); 316 | End; 317 | 318 | Function TghXMLDoc.CreateElement (Const ParentLevel :Integer; 319 | Const Name :String; Const Text :String = '') :OLEVariant; 320 | Begin 321 | WorkLevel := ParentLevel; 322 | Result := CreateElement (Name, Text); 323 | End; 324 | 325 | Function TghXMLDoc.CreateElement (Const ParentLevel :Integer; 326 | Const Name, Attr :String; Const AttrValue :OLEVariant) :OLEVariant; 327 | Begin 328 | WorkLevel := ParentLevel; 329 | Result := CreateElement (Name, Attr, AttrValue); 330 | End; 331 | 332 | Function TghXMLDoc.CreateElement (Const ParentLevel :Integer; 333 | Const Name, Text :String; Const Attrs :Array Of Const) 334 | :OLEVariant; 335 | Begin 336 | WorkLevel := ParentLevel; 337 | Result := CreateElement (Name, Text, Attrs); 338 | End; 339 | 340 | Function TghXMLDoc.CreateElement (Const ParentLevel :Integer; 341 | Const Name :String; Const Attrs :Array Of Const) :OLEVariant; 342 | Begin 343 | WorkLevel := ParentLevel; 344 | Result := CreateElement (Name, Attrs); 345 | End; 346 | 347 | Function TghXMLDoc.FindNode (Const Expr :String) :OLEVariant; 348 | Begin 349 | Result := Node (Expr); 350 | 351 | If System.Variants.VarIsClear (Result) Then 352 | RaiseNodeNotFound (Expr); 353 | End; 354 | 355 | Function TghXMLDoc.FindNode (Const Expr :String; 356 | Const Params :Array Of Const) :OLEVariant; 357 | Begin 358 | Result := FindNode (System.SysUtils.Format (Expr, Params)); 359 | End; 360 | 361 | Function TghXMLDoc.FindNodes (Const Expr :String) :OLEVariant; 362 | Begin 363 | Result := Nodes (Expr); 364 | 365 | If Result.Length = 0 Then 366 | RaiseNodeNotFound (Expr); 367 | End; 368 | 369 | Function TghXMLDoc.FindNodes (Const Expr :String; 370 | Const Params :Array Of Const) :OLEVariant; 371 | Begin 372 | Result := FindNodes (System.SysUtils.Format (Expr, Params)); 373 | End; 374 | 375 | Function TghXMLDoc.FormatContent :String; 376 | Begin 377 | Result := XML.XMLDoc.FormatXMLData (Content.XML); 378 | End; 379 | 380 | {$Warn No_RetVal Off} 381 | Function TghXMLDoc.LocateNode (Const Expr :String; 382 | Const ARaiseError :Boolean = System.False) :Boolean; 383 | Var 384 | ANode :OLEVariant; 385 | Begin 386 | ANode := Node (Expr); 387 | 388 | If System.Variants.VarIsClear (ANode) Then 389 | If ARaiseError Then 390 | RaiseNodeNotFound (Expr) 391 | Else 392 | Result := System.False 393 | Else 394 | Begin 395 | WorkNode := ANode; 396 | Result := System.True; 397 | End; 398 | End; 399 | {$Warn No_RetVal On} 400 | 401 | Function TghXMLDoc.Node (Const Expr :String; 402 | Const Params :Array Of Const) :OLEVariant; 403 | Begin 404 | Result := Node (System.SysUtils.Format (Expr, Params)); 405 | End; 406 | 407 | Function TghXMLDoc.Nodes (Const Expr :String; 408 | Const Params :Array Of Const) :OLEVariant; 409 | Begin 410 | Result := Nodes (System.SysUtils.Format (Expr, Params)); 411 | End; 412 | 413 | Function TghXMLDoc.Validate :OLEVariant; 414 | Begin 415 | FValidationError := Content.Validate; 416 | Result := FValidationError; 417 | End; 418 | 419 | { Public virtual instance methods } 420 | 421 | Function TghXMLDoc.DefaultClassIDs :TArray ; 422 | Begin 423 | { Preferred class IDs of MSXML DOMDocument. NOTE: 424 | MSXML2.DOMDocument.5.0 (TghWin.cliMSXMLDoc50) is part of Microsoft 425 | Office and not a formal Windows standard. } 426 | Result := [TghWin.cliMSXMLDoc60, TghWin.cliMSXMLDoc40, 427 | TghWin.cliMSXMLDoc30]; 428 | End; 429 | 430 | Function TghXMLDoc.Load (Const AContent :String) :Boolean; 431 | Var 432 | Prefix :String; 433 | Begin 434 | If (AContent = '') Or (AContent [1] = '<') Then 435 | Begin 436 | Result := Content.LoadXML (AContent); // XML text 437 | FPath := ''; 438 | End 439 | Else // File path 440 | Begin 441 | FPath := TghWin.CheckSearchFilePath (AContent); 442 | Result := Content.Load (FPath); 443 | 444 | If Not Result Then 445 | FPath := ''; 446 | End; 447 | 448 | FWorkNode := System.Variants.Unassigned; 449 | 450 | If Result And (Content.DocumentElement.NameSpaceURI <> '') Then 451 | Begin 452 | Prefix := Content.DocumentElement.Prefix; 453 | 454 | If Prefix = '' Then 455 | { NOTE: The SelectNodes and SelectSingleNode methods of MSXML need 456 | that every name space in SelectionNamespaces has a prefix. We 457 | use the "_" alias when the document element has no prefix. } 458 | Prefix := '_'; 459 | 460 | Content.SetProperty ('SelectionNamespaces', System.SysUtils.Format ( 461 | 'xmlns:%s="%s"', [Prefix, Content.DocumentElement.NameSpaceURI])); 462 | End; 463 | End; 464 | 465 | Function TghXMLDoc.Node (Const Expr :String) :OLEVariant; 466 | Begin 467 | { We search from the current work node by using the given XPath 468 | expression. NOTE: Expr can be a relative or absolute path. } 469 | Result := WorkNode.SelectSingleNode (Expr); 470 | End; 471 | 472 | Function TghXMLDoc.Nodes (Const Expr :String) :OLEVariant; 473 | Begin 474 | { We search from the current work node by using the given XPath 475 | expression. NOTE: Expr can be a relative or absolute path. } 476 | Result := WorkNode.SelectNodes (Expr); 477 | End; 478 | 479 | Procedure TghXMLDoc.Save (Const APath :String = ''); 480 | Var 481 | ExpandedPath :String; 482 | Begin 483 | If APath = '' Then 484 | Content.Save (Path) 485 | Else 486 | Begin 487 | ExpandedPath := ExpandFileName (APath); 488 | Content.Save (ExpandedPath); // Exception if the Save method fails 489 | FPath := ExpandedPath; 490 | End; 491 | End; 492 | 493 | { Public overridden instance methods } 494 | 495 | Procedure TghXMLDoc.BeforeDestruction; 496 | Begin 497 | ghPreDestroy; 498 | Inherited BeforeDestruction; 499 | End; 500 | 501 | End. 502 | 503 | -------------------------------------------------------------------------------- /GHF.Win.pas: -------------------------------------------------------------------------------- 1 | {}//Unit under construction, the author shall check the Uses clauses and Inline routines before removing this line. 2 | {*************************************************************************} 3 | { GH Freebrary } 4 | { } 5 | { GHF.Win.pas - TghWin class unit. } 6 | { } 7 | { This software is distributed under the open source BSD license. } 8 | { } 9 | { Copyright (c) 2002-2016, Al Gonzalez (@algonzalez74) } 10 | { All rights reserved. } 11 | { } 12 | { Redistribution and use in source and binary forms, with or without } 13 | { modification, are permitted provided that the following conditions are } 14 | { met: } 15 | { } 16 | { - Redistributions of source code must retain the above copyright } 17 | { notice, this list of conditions and the following disclaimer. } 18 | { - Redistributions in binary form must reproduce the above copyright } 19 | { notice, this list of conditions and the following disclaimer in the } 20 | { documentation and/or other materials provided with the } 21 | { distribution. } 22 | { - Neither the name of Al Gonzalez nor the names of his contributors } 23 | { may be used to endorse or promote products derived from this } 24 | { software without specific prior written permission. } 25 | { } 26 | { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS } 27 | { IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED } 28 | { TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } 29 | { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT } 30 | { HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, } 31 | { SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT } 32 | { LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, } 33 | { DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY } 34 | { THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT } 35 | { (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE } 36 | { OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } 37 | {*************************************************************************} 38 | 39 | Unit GHF.Win; { Windows } 40 | 41 | { NOTE: In order to avoid circular unit references, the public parts of 42 | this unit should not depend on other Windows GH Freebrary units. 43 | Moreover, the only native unit scopes that should be unconditionally 44 | referenced, either directly or indirectly, from this code file are the 45 | System and WinAPI unit scopes. The intention is that this unit to be part 46 | of a central base that can be compiled into any Windows project. } 47 | 48 | {$ScopedEnums On} 49 | 50 | Interface 51 | 52 | Uses 53 | WinAPI.Messages, WinAPI.Windows, GHF.Sys; 54 | 55 | Type 56 | { Windows class } 57 | TghWin = Class (TghZeroton) 58 | Private 59 | Class Constructor Create; 60 | Class Destructor Destroy; 61 | Public 62 | Const 63 | { Class IDs } 64 | 65 | // MSXML. NOTE: Versions 2.6 and earlier are obsolete. 66 | 67 | // MSXML2.DOMDocument.3.0 68 | cliMSXMLDoc30 :TGUID = '{F5078F32-C551-11D3-89B9-0000F81FE221}'; 69 | 70 | // MSXML2.DOMDocument.4.0 71 | cliMSXMLDoc40 :TGUID = '{88D969C0-F192-11D4-A65F-0040963251E5}'; 72 | 73 | // MSXML2.DOMDocument.5.0 74 | cliMSXMLDoc50 :TGUID = '{88D969E5-F192-11D4-A65F-0040963251E5}'; 75 | 76 | // MSXML2.DOMDocument.6.0 77 | cliMSXMLDoc60 :TGUID = '{88D96A05-F192-11D4-A65F-0040963251E5}'; 78 | 79 | { Messages } 80 | 81 | { Range from wm_User + $400 up to wm_User + $5FF (512 values 82 | reserved by GH Freebrary) } 83 | msgMin = wm_User + $400; // Minimum 84 | msgCloseModal = msgMin; 85 | msgMax = msgMin + $1FF; // Maximum 86 | 87 | { MSXML Document Class IDs } 88 | MSXMLDocClassIDs :Array [0..3] Of TGUID = ( 89 | // MSXML2.DOMDocument.3.0 90 | '{F5078F32-C551-11D3-89B9-0000F81FE221}', 91 | 92 | // MSXML2.DOMDocument.4.0 93 | '{88D969C0-F192-11D4-A65F-0040963251E5}', 94 | 95 | // MSXML2.DOMDocument.5.0 96 | '{88D969E5-F192-11D4-A65F-0040963251E5}', 97 | 98 | // MSXML2.DOMDocument.6.0 99 | '{88D96A05-F192-11D4-A65F-0040963251E5}'); 100 | 101 | { MSXML Schema Cache Class IDs } 102 | MSXMLSchemaCacheClassIDs :Array [0..3] Of TGUID = ( 103 | // MSXML2.XMLSchemaCache.3.0 104 | '{F5078F34-C551-11D3-89B9-0000F81FE221}', 105 | 106 | // MSXML2.XMLSchemaCache.4.0 107 | '{88D969C2-F192-11D4-A65F-0040963251E5}', 108 | 109 | // MSXML2.XMLSchemaCache.5.0 110 | '{88D969E7-F192-11D4-A65F-0040963251E5}', 111 | 112 | // MSXML2.XMLSchemaCache.6.0 113 | '{88D96A07-F192-11D4-A65F-0040963251E5}'); 114 | 115 | { MSXML Versions } 116 | MSXMLVersions :Array [0..3] Of String = 117 | ('3.0', '4.0', '5.0', '6.0'); 118 | 119 | { OpenXML } 120 | oxmSharedStrs :String = 'sharedStrings.xml'; 121 | 122 | { Programmatic IDs } 123 | 124 | // MSXML 125 | priMSXMLSchemaCache :String = 'MSXML2.XMLSchemaCache'; 126 | 127 | Type 128 | { Virtual class. Overridable functionality, accessible via the 129 | Virtual class property. } 130 | TVirtual = Class 131 | Public 132 | Type 133 | { Class reference type } 134 | TClassRef = Class Of TVirtual; 135 | 136 | { Virtual class methods } 137 | Class Function InternalParentFilePath (Const APath :String; 138 | AUpLevels :Integer) :String; Virtual; 139 | Class Function InternalSearchFilePath (Const APath :String; 140 | Out AFullPath :String) :Cardinal; Virtual; 141 | Class Function MSXMLDocClassIDsValid ( 142 | Const AValues :Array Of TGUID) :Boolean; Virtual; 143 | Class Function MSXMLSchemaCacheClassID ( 144 | Const AVersionID :TGUID) :TGUID; Virtual; 145 | Class Function MSXMLVersion (Const AClassID :TGUID) :String; 146 | Virtual; 147 | Class Function ProgIDVersion (Const AClassID :TGUID) :String; 148 | Virtual; 149 | Class Function VersionedClassID ( 150 | Const AProgIDBase, AVersion :String) :TGUID; Overload; 151 | Virtual; 152 | Class Function VersionedClassID (Const AProgIDBase :String; 153 | Const AVersionID :TGUID) :TGUID; Overload; Virtual; 154 | End; 155 | 156 | { Static class methods } 157 | Class Procedure CheckMSXMLDocClassIDs ( 158 | Const AValues :Array Of TGUID); Static; 159 | Class Function CheckSearchFilePath (Const APath :String) :String; 160 | Static; 161 | Class Function ClassID (Const AProgID :String) :TGUID; Overload; 162 | Static; 163 | Class Function COMDispatch (Const AClassID :TGUID) :IDispatch; 164 | Overload; Static; 165 | Class Function COMDispatch (Const AClassIDs :Array Of TGUID; 166 | Const AUsedClassID :PGUID = Nil) :IDispatch; Overload; Static; 167 | Class Function COMObj (Const AClassID, AIntfID :TGUID) :IUnknown; 168 | Overload; Static; 169 | Class Function COMObj (Const AClassIDs :Array Of TGUID; 170 | Const AIntfID :TGUID; Const AUsedClassID :PGUID = Nil) :IUnknown; 171 | Overload; Static; 172 | Class Function COMObj (Const AClassIDs :Array Of TGUID; 173 | Const AUsedClassID :PGUID = Nil) :IUnknown; Overload; Static; 174 | Class Function CreateCOMObj (Const AClassID, AIntfID :TGUID; 175 | Out AIntf) :Integer; Overload; Static; 176 | Class Function CreateCOMObj (Const AClassID :TGUID; Out AIntf) 177 | :Integer; Overload; Static; 178 | Class Function ExeDrive :String; Static; 179 | Class Function ExeRootPath (Const ASubPath :String) :String; 180 | Static; 181 | Class Function GetClassID (Const AProgID :String; Out AID :TGUID) 182 | :Integer; Overload; Static; 183 | Class Function GetProgID (Const AClassID :TGUID; 184 | Out AProgID :String) :Integer; Static; 185 | Class Function MsgPending (Const AWindow :THandle; 186 | Const AMinID, AMaxID :Integer) :Boolean; Overload; Static; 187 | Class Function MsgPending (Const AWindow :THandle = 0; 188 | Const AID :Integer = 0) :Boolean; Overload; Static; 189 | Class Function MSXMLSchemaCache (Const AVersionClassID :TGUID) 190 | :IDispatch; Static; 191 | Class Function ParentFilePath (Const APath :String; 192 | Const AUpLevels :Integer = 1) :String; Static; 193 | Class Function PathHintsDrive (Const AValue :String) :Boolean; 194 | Static; 195 | Class Function PeekMsg (Out AMsg :TMsg; Const AWindow :THandle; 196 | Const AMinID, AMaxID :Integer; 197 | Const ARemove :Boolean = System.False) :Boolean; Overload; 198 | Static; 199 | Class Function PeekMsg (Out AMsg :TMsg; Const AWindow :THandle = 0; 200 | Const AID :Integer = 0; Const ARemove :Boolean = System.False) 201 | :Boolean; Overload; Static; 202 | Class Function ProgID (Const AClassID :TGUID) :String; Static; 203 | Class Function SearchFilePath (Const APath :String) :String; 204 | Static; 205 | Protected 206 | Class Var 207 | FVirtual :TVirtual.TClassRef; 208 | 209 | { Static class methods } 210 | Class Procedure SetVirtual (Const AValue :TVirtual.TClassRef); 211 | Static; 212 | Public 213 | { Class properties } 214 | Class Property Virtual :TVirtual.TClassRef Read FVirtual 215 | Write SetVirtual; 216 | End; 217 | 218 | Implementation 219 | 220 | Uses 221 | System.SysUtils, System.Win.COMObj, WinAPI.ActiveX, GHF.SysEx; 222 | 223 | { Inline routines }{} 224 | 225 | { TghWin } 226 | 227 | { TghWin.TVirtual } 228 | 229 | {}//probar 230 | Class Function TghWin.TVirtual.InternalParentFilePath ( 231 | Const APath :String; AUpLevels :Integer) :String; 232 | Var 233 | LDrive :String; 234 | Begin 235 | LDrive := System.SysUtils.ExtractFileDrive (APath); 236 | 237 | If TghSys.SetSolid (Result, TghSys.ParentPath (System.Copy ( 238 | APath, LDrive.Length + 1), AUpLevels, System.SysUtils.PathDelim)) Then 239 | Result := LDrive + Result; 240 | End; 241 | 242 | {}//probar 243 | Class Function TghWin.TVirtual.InternalSearchFilePath (Const APath :String; 244 | Out AFullPath :String) :Cardinal; 245 | Var 246 | LFullPath :Array [0..WinAPI.Windows.Max_Path] Of Char; 247 | Begin 248 | Result := WinAPI.Windows.SearchPath (Nil, PChar (APath), Nil, 249 | WinAPI.Windows.Max_Path + 1, LFullPath, TghSys.DummyChrPtr); 250 | 251 | If Result.ToBoolean Then 252 | AFullPath := LFullPath; 253 | End; 254 | 255 | Class Function TghWin.TVirtual.MSXMLDocClassIDsValid ( 256 | Const AValues :Array Of TGUID) :Boolean; 257 | Begin 258 | Result := TghSys.GUIDsIn (AValues, MSXMLDocClassIDs); 259 | End; 260 | 261 | Class Function TghWin.TVirtual.MSXMLSchemaCacheClassID ( 262 | Const AVersionID :TGUID) :TGUID; 263 | Var 264 | I :Integer Absolute Result; 265 | Begin 266 | I := TghSys.GUIDPos (MSXMLDocClassIDs, AVersionID); 267 | 268 | If I > -1 Then 269 | Result := MSXMLSchemaCacheClassIDs [I] 270 | Else 271 | Result := VersionedClassID (priMSXMLSchemaCache, AVersionID); 272 | End; 273 | 274 | Class Function TghWin.TVirtual.MSXMLVersion (Const AClassID :TGUID) 275 | :String; 276 | Var 277 | I :Integer; 278 | Begin 279 | I := TghSys.GUIDPos (MSXMLDocClassIDs, AClassID); 280 | 281 | If I = -1 Then 282 | I := TghSys.GUIDPos (MSXMLSchemaCacheClassIDs, AClassID); 283 | 284 | If I > -1 Then 285 | Result := MSXMLVersions [I] 286 | Else 287 | Result := ProgIDVersion (AClassID); 288 | End; 289 | 290 | Class Function TghWin.TVirtual.ProgIDVersion (Const AClassID :TGUID) 291 | :String; 292 | Begin 293 | Result := TghSys.Virtual.RightVersion (ProgID (AClassID)); 294 | End; 295 | 296 | Class Function TghWin.TVirtual.VersionedClassID ( 297 | Const AProgIDBase, AVersion :String) :TGUID; 298 | Begin 299 | Result := ClassID (AProgIDBase + '.' + AVersion); 300 | End; 301 | 302 | Class Function TghWin.TVirtual.VersionedClassID ( 303 | Const AProgIDBase :String; Const AVersionID :TGUID) :TGUID; 304 | Begin 305 | Result := VersionedClassID (AProgIDBase, ProgIDVersion (AVersionID)); 306 | End; 307 | 308 | { Constructors and destructors } 309 | 310 | Class Constructor TghWin.Create; 311 | Begin 312 | TVirtual.ghInitVirtualClass (FVirtual); 313 | End; 314 | 315 | Class Destructor TghWin.Destroy; 316 | Begin 317 | TVirtual.ghFinalizeVirtualClass; 318 | End; 319 | 320 | { Protected static class methods } 321 | 322 | Class Procedure TghWin.SetVirtual (Const AValue :TVirtual.TClassRef); 323 | Begin 324 | TVirtual.ghSetVirtualClass (AValue); 325 | End; 326 | 327 | { Public static class methods } 328 | 329 | Class Procedure TghWin.CheckMSXMLDocClassIDs ( 330 | Const AValues :Array Of TGUID); 331 | Begin 332 | If Not Virtual.MSXMLDocClassIDsValid (AValues) Then 333 | Exception.ghRaise (TghSys.ermInvalidClassIDs, ['XML document']); 334 | End; 335 | 336 | {}//probar 337 | Class Function TghWin.CheckSearchFilePath (Const APath :String) :String; 338 | Begin 339 | If Not Virtual.InternalSearchFilePath (APath, Result).ToBoolean Then 340 | {}//simplificar en TghSys obviando GetLastError 341 | System.SysUtils.RaiseLastOSError (System.GetLastError, 342 | sLineBreak + 'Searched path: "' + APath + '".') 343 | End; 344 | 345 | Class Function TghWin.ClassID (Const AProgID :String) :TGUID; 346 | Begin 347 | GetClassID (AProgID, Result); 348 | End; 349 | 350 | Class Function TghWin.COMDispatch (Const AClassID :TGUID) :IDispatch; 351 | Begin 352 | Result := IDispatch (COMObj (AClassID, IDispatch)); 353 | End; 354 | 355 | Class Function TghWin.COMDispatch (Const AClassIDs :Array Of TGUID; 356 | Const AUsedClassID :PGUID = Nil) :IDispatch; 357 | Begin 358 | Result := IDispatch (COMObj (AClassIDs, IDispatch, AUsedClassID)); 359 | End; 360 | 361 | Class Function TghWin.COMObj (Const AClassID, AIntfID :TGUID) :IUnknown; 362 | Begin 363 | System.Win.COMObj.OLECheck (CreateCOMObj (AClassID, AIntfID, Result)); 364 | End; 365 | 366 | Class Function TghWin.COMObj (Const AClassIDs :Array Of TGUID; 367 | Const AIntfID :TGUID; Const AUsedClassID :PGUID = Nil) :IUnknown; 368 | Var 369 | LError :Integer; 370 | LID :TGUID; 371 | Begin 372 | LError := WinAPI.Windows.E_InvalidArg; // If AClassIDs is empty 373 | 374 | For LID In AClassIDs Do 375 | Begin 376 | LError := CreateCOMObj (LID, AIntfID, Result); 377 | 378 | If LError = WinAPI.Windows.S_OK Then 379 | Begin 380 | TghSys.SetGUIDRef (AUsedClassID, LID); 381 | System.Exit; 382 | End; 383 | End; 384 | 385 | OLEError (LError); 386 | End; 387 | 388 | Class Function TghWin.COMObj (Const AClassIDs :Array Of TGUID; 389 | Const AUsedClassID :PGUID = Nil) :IUnknown; 390 | Begin 391 | Result := COMObj (AClassIDs, IUnknown, AUsedClassID); 392 | End; 393 | 394 | Class Function TghWin.CreateCOMObj (Const AClassID, AIntfID :TGUID; 395 | Out AIntf) :Integer; 396 | Begin 397 | Result := WinAPI.ActiveX.CoCreateInstance (AClassID, Nil, 398 | ClsCtx_InProc_Server Or ClsCtx_Local_Server, AIntfID, AIntf); 399 | End; 400 | 401 | Class Function TghWin.CreateCOMObj (Const AClassID :TGUID; Out AIntf) 402 | :Integer; 403 | Begin 404 | Result := CreateCOMObj (AClassID, IUnknown, AIntf); 405 | End; 406 | 407 | Class Function TghWin.ExeDrive :String; 408 | Begin 409 | Result := System.SysUtils.ExtractFileDrive (TghSys.ExePath); 410 | End; 411 | 412 | Class Function TghWin.ExeRootPath (Const ASubPath :String) :String; 413 | Begin 414 | Result := TghSys.ConcatFilePaths (ExeDrive, ASubPath); 415 | End; 416 | 417 | {}//asegurar que AID regrese en ceros si CLSIDFromProgID retorna error 418 | Class Function TghWin.GetClassID (Const AProgID :String; Out AID :TGUID) 419 | :Integer; 420 | Begin 421 | Result := WinAPI.ActiveX.CLSIDFromProgID (PChar (AProgID), AID); 422 | End; 423 | 424 | Class Function TghWin.GetProgID (Const AClassID :TGUID; 425 | Out AProgID :String) :Integer; 426 | Var 427 | LProgID :POLEStr; 428 | Begin 429 | Result := WinAPI.ActiveX.ProgIDFromCLSID (AClassID, LProgID); 430 | 431 | If Result = WinAPI.Windows.S_OK Then 432 | Begin 433 | AProgID := LProgID; 434 | CoTaskMemFree (LProgID); 435 | End; 436 | End; 437 | 438 | Class Function TghWin.MsgPending (Const AWindow :THandle; 439 | Const AMinID, AMaxID :Integer) :Boolean; 440 | Var 441 | LMsg :TMsg; 442 | Begin 443 | Result := PeekMsg (LMsg, AWindow, AMinID, AMaxID); 444 | End; 445 | 446 | Class Function TghWin.MsgPending (Const AWindow :THandle = 0; 447 | Const AID :Integer = 0) :Boolean; 448 | Begin 449 | Result := MsgPending (AWindow, AID, AID); 450 | End; 451 | 452 | Class Function TghWin.MSXMLSchemaCache (Const AVersionClassID :TGUID) 453 | :IDispatch; 454 | Begin 455 | Result := COMDispatch ( 456 | Virtual.MSXMLSchemaCacheClassID (AVersionClassID)); 457 | End; 458 | 459 | {}//probar 460 | Class Function TghWin.ParentFilePath (Const APath :String; 461 | Const AUpLevels :Integer = 1) :String; 462 | Begin 463 | If TghSys.Keep (Result, APath <> '') Then 464 | Result := Virtual.InternalParentFilePath (APath, AUpLevels); 465 | End; 466 | 467 | Class Function TghWin.PathHintsDrive (Const AValue :String) :Boolean; 468 | Begin 469 | Result := (AValue.Length > 1) And 470 | ((AValue [2] = System.SysUtils.DriveDelim) Or 471 | TghSys.StartsDupChr (AValue, System.SysUtils.PathDelim)); 472 | End; 473 | 474 | Class Function TghWin.PeekMsg (Out AMsg :TMsg; Const AWindow :THandle; 475 | Const AMinID, AMaxID :Integer; Const ARemove :Boolean = System.False) 476 | :Boolean; 477 | Begin 478 | Result := WinAPI.Windows.PeekMessage ( 479 | AMsg, AWindow, AMinID, AMaxID, System.Ord (ARemove)); 480 | End; 481 | 482 | Class Function TghWin.PeekMsg (Out AMsg :TMsg; 483 | Const AWindow :THandle = 0; Const AID :Integer = 0; 484 | Const ARemove :Boolean = System.False) :Boolean; 485 | Begin 486 | Result := PeekMsg (AMsg, AWindow, AID, AID, ARemove); 487 | End; 488 | 489 | Class Function TghWin.ProgID (Const AClassID :TGUID) :String; 490 | Begin 491 | GetProgID (AClassID, Result); 492 | End; 493 | 494 | Class Function TghWin.SearchFilePath (Const APath :String) :String; 495 | Begin 496 | Virtual.InternalSearchFilePath (APath, Result); 497 | End; 498 | 499 | End. 500 | 501 | --------------------------------------------------------------------------------