Browse Source

* implementer IutlStored

* implemented some usefull custom variant types
* fixed memleak in uutlGenerics
master
bergmann 7 years ago
parent
commit
66515e3fc6
19 changed files with 2257 additions and 336 deletions
  1. +21
    -1
      bitSpaceUtils.lpk
  2. +2
    -1
      bitSpaceUtils.pas
  3. +9
    -1
      tests/tests.lpi
  4. +3
    -3
      tests/tests.lpr
  5. +327
    -214
      tests/tests.lps
  6. +11
    -11
      tests/uutlSetHelperTests.pas
  7. +94
    -0
      tests/uutlVariantEnumTest.pas
  8. +48
    -0
      tests/uutlVariantSetTest.pas
  9. +2
    -1
      uutlArrayContainer.pas
  10. +6
    -2
      uutlCommon.pas
  11. +13
    -0
      uutlEnumVariant.pas
  12. +428
    -98
      uutlGenerics.pas
  13. +496
    -0
      uutlStored.pas
  14. +105
    -0
      uutlTypeInfo.pas
  15. +206
    -0
      uutlVariantEnum.pas
  16. +149
    -0
      uutlVariantObject.pas
  17. +157
    -0
      uutlVariantProperty.pas
  18. +172
    -0
      uutlVariantSet.pas
  19. +8
    -4
      uutlXmlHelper.pas

+ 21
- 1
bitSpaceUtils.lpk View File

@@ -11,7 +11,7 @@
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Files Count="26">
<Files Count="31">
<Item1>
<Filename Value="uutlAlgorithm.pas"/>
<UnitName Value="uutlAlgorithm"/>
@@ -116,6 +116,26 @@
<Filename Value="uutlXmlHelper.pas"/>
<UnitName Value="uutlXmlHelper"/>
</Item26>
<Item27>
<Filename Value="uutlStored.pas"/>
<UnitName Value="uutlStored"/>
</Item27>
<Item28>
<Filename Value="uutlVariantObject.pas"/>
<UnitName Value="uutlVariantObject"/>
</Item28>
<Item29>
<Filename Value="uutlVariantProperty.pas"/>
<UnitName Value="uutlVariantProperty"/>
</Item29>
<Item30>
<Filename Value="uutlVariantEnum.pas"/>
<UnitName Value="uutlVariantEnum"/>
</Item30>
<Item31>
<Filename Value="uutlVariantSet.pas"/>
<UnitName Value="uutlVariantSet"/>
</Item31>
</Files>
<RequiredPkgs Count="2">
<Item1>


+ 2
- 1
bitSpaceUtils.pas View File

@@ -11,7 +11,8 @@ uses
uutlAlgorithm, uutlArrayContainer, uutlCommon, uutlComparer, uutlCompression, uutlEmbeddedProfiler, uutlEnumerator,
uutlEvent, uutlEventManager, uutlFilter, uutlGenerics, uutlInterfaces, uutlKeyCodes, uutlLinq, uutlListBase,
uutlLogger, uutlMCF, uutlObservable, uutlSScanf, uutlStreamHelper, uutlSyncObjs, uutlThreads, uutlTypes,
uutlXmlHelper, LazarusPackageIntf;
uutlXmlHelper, uutlStored, uutlVariantObject, uutlVariantProperty, uutlVariantEnum, uutlVariantSet,
LazarusPackageIntf;

implementation



+ 9
- 1
tests/tests.lpi View File

@@ -33,7 +33,7 @@
<PackageName Value="FCL"/>
</Item3>
</RequiredPackages>
<Units Count="38">
<Units Count="40">
<Unit0>
<Filename Value="tests.lpr"/>
<IsPartOfProject Value="True"/>
@@ -186,6 +186,14 @@
<Filename Value="uutlSetHelperTests.pas"/>
<IsPartOfProject Value="True"/>
</Unit37>
<Unit38>
<Filename Value="uutlVariantEnumTest.pas"/>
<IsPartOfProject Value="True"/>
</Unit38>
<Unit39>
<Filename Value="uutlVariantSetTest.pas"/>
<IsPartOfProject Value="True"/>
</Unit39>
</Units>
</ProjectOptions>
<CompilerOptions>


+ 3
- 3
tests/tests.lpr View File

@@ -15,9 +15,9 @@ uses
uTestHelper,

// units unter test
uutlAlgorithm, uutlArrayContainer, uutlCommon, uutlComparer, uutlEnumerator,
uutlFilter, uutlGenerics, uutlInterfaces, uutlLinq, uutlListBase, uutlLogger,
uutlStreamHelper, uutlSyncObjs, uutlTypes, uutlXmlHelper, uutlObservable, uutlSetHelperTests;
uutlAlgorithm, uutlArrayContainer, uutlCommon, uutlComparer, uutlEnumerator, uutlFilter, uutlGenerics, uutlInterfaces,
uutlLinq, uutlListBase, uutlLogger, uutlStreamHelper, uutlSyncObjs, uutlTypes, uutlXmlHelper, uutlObservable,
uutlSetHelperTests, uutlVariantEnumTest, uutlVariantSetTest;

{$R *.res}



+ 327
- 214
tests/tests.lps View File

@@ -4,21 +4,29 @@
<PathDelim Value="\"/>
<Version Value="10"/>
<BuildModes Active="Default"/>
<Units Count="68">
<Units Count="82">
<Unit0>
<Filename Value="tests.lpr"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<CursorPos X="54" Y="12"/>
<UsageCount Value="81"/>
<EditorIndex Value="10"/>
<CursorPos Y="5"/>
<UsageCount Value="92"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="..\uutlGenerics.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="7"/>
<TopLine Value="1003"/>
<CursorPos Y="1021"/>
<UsageCount Value="81"/>
<TopLine Value="1897"/>
<CursorPos X="3" Y="1900"/>
<ExtraEditorCount Value="1"/>
<ExtraEditor1>
<EditorIndex Value="2"/>
<WindowIndex Value="1"/>
<TopLine Value="2008"/>
<CursorPos Y="2043"/>
</ExtraEditor1>
<UsageCount Value="92"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
@@ -26,32 +34,32 @@
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<CursorPos X="11" Y="13"/>
<UsageCount Value="81"/>
<UsageCount Value="92"/>
</Unit2>
<Unit3>
<Filename Value="..\uutlCommon.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<TopLine Value="206"/>
<CursorPos X="10" Y="225"/>
<UsageCount Value="81"/>
<EditorIndex Value="8"/>
<TopLine Value="264"/>
<CursorPos X="29" Y="283"/>
<UsageCount Value="92"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="..\uutlListBase.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<TopLine Value="100"/>
<CursorPos X="72" Y="113"/>
<UsageCount Value="81"/>
<Loaded Value="True"/>
<UsageCount Value="92"/>
</Unit4>
<Unit5>
<Filename Value="uutlListTest.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="3"/>
<TopLine Value="573"/>
<CursorPos Y="588"/>
<UsageCount Value="81"/>
<Loaded Value="True"/>
<EditorIndex Value="-1"/>
<TopLine Value="50"/>
<CursorPos X="3" Y="65"/>
<UsageCount Value="92"/>
</Unit5>
<Unit6>
<Filename Value="uutlQueueTests.pas"/>
@@ -59,7 +67,7 @@
<EditorIndex Value="-1"/>
<TopLine Value="250"/>
<CursorPos X="49" Y="260"/>
<UsageCount Value="81"/>
<UsageCount Value="92"/>
</Unit6>
<Unit7>
<Filename Value="uutlStackTests.pas"/>
@@ -67,22 +75,23 @@
<EditorIndex Value="-1"/>
<TopLine Value="246"/>
<CursorPos X="24" Y="263"/>
<UsageCount Value="81"/>
<UsageCount Value="92"/>
</Unit7>
<Unit8>
<Filename Value="uTestHelper.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="4"/>
<EditorIndex Value="-1"/>
<CursorPos X="3" Y="12"/>
<UsageCount Value="81"/>
<Loaded Value="True"/>
<UsageCount Value="92"/>
</Unit8>
<Unit9>
<Filename Value="..\uutlComparer.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<CursorPos X="90" Y="6"/>
<UsageCount Value="71"/>
<EditorIndex Value="9"/>
<TopLine Value="174"/>
<CursorPos X="10" Y="190"/>
<UsageCount Value="82"/>
<Loaded Value="True"/>
</Unit9>
<Unit10>
<Filename Value="..\uutlAlgorithm.pas"/>
@@ -90,14 +99,14 @@
<EditorIndex Value="-1"/>
<TopLine Value="138"/>
<CursorPos Y="153"/>
<UsageCount Value="81"/>
<UsageCount Value="92"/>
</Unit10>
<Unit11>
<Filename Value="uutlHashSetTests.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<CursorPos X="32" Y="13"/>
<UsageCount Value="81"/>
<UsageCount Value="92"/>
</Unit11>
<Unit12>
<Filename Value="uutlAlgorithmTests.pas"/>
@@ -105,7 +114,7 @@
<EditorIndex Value="-1"/>
<TopLine Value="72"/>
<CursorPos X="43" Y="87"/>
<UsageCount Value="80"/>
<UsageCount Value="91"/>
</Unit12>
<Unit13>
<Filename Value="uutlMapTests.pas"/>
@@ -113,15 +122,15 @@
<EditorIndex Value="-1"/>
<TopLine Value="206"/>
<CursorPos X="66" Y="221"/>
<UsageCount Value="79"/>
<UsageCount Value="90"/>
</Unit13>
<Unit14>
<Filename Value="..\uutlEnumerator.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="1"/>
<TopLine Value="90"/>
<CursorPos X="5" Y="105"/>
<UsageCount Value="78"/>
<EditorIndex Value="12"/>
<TopLine Value="325"/>
<CursorPos X="42" Y="341"/>
<UsageCount Value="89"/>
<Loaded Value="True"/>
</Unit14>
<Unit15>
@@ -130,7 +139,7 @@
<EditorIndex Value="-1"/>
<TopLine Value="615"/>
<CursorPos X="34" Y="631"/>
<UsageCount Value="78"/>
<UsageCount Value="89"/>
</Unit15>
<Unit16>
<Filename Value="..\uutlFilter.pas"/>
@@ -138,16 +147,15 @@
<EditorIndex Value="-1"/>
<TopLine Value="17"/>
<CursorPos X="13" Y="159"/>
<UsageCount Value="74"/>
<UsageCount Value="85"/>
</Unit16>
<Unit17>
<Filename Value="..\uutlInterfaces.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="2"/>
<EditorIndex Value="-1"/>
<TopLine Value="34"/>
<CursorPos X="5" Y="40"/>
<UsageCount Value="74"/>
<Loaded Value="True"/>
<UsageCount Value="85"/>
</Unit17>
<Unit18>
<Filename Value="..\uutlLinq.pas"/>
@@ -155,7 +163,7 @@
<EditorIndex Value="-1"/>
<TopLine Value="391"/>
<CursorPos X="31" Y="417"/>
<UsageCount Value="65"/>
<UsageCount Value="76"/>
</Unit18>
<Unit19>
<Filename Value="uutlLinqTests.pas"/>
@@ -163,13 +171,13 @@
<EditorIndex Value="-1"/>
<TopLine Value="622"/>
<CursorPos X="23" Y="650"/>
<UsageCount Value="65"/>
<UsageCount Value="76"/>
</Unit19>
<Unit20>
<Filename Value="..\uutlTypes.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<UsageCount Value="65"/>
<UsageCount Value="76"/>
</Unit20>
<Unit21>
<Filename Value="..\uutlSyncObjs.pas"/>
@@ -177,7 +185,7 @@
<EditorIndex Value="-1"/>
<TopLine Value="241"/>
<CursorPos X="20" Y="263"/>
<UsageCount Value="59"/>
<UsageCount Value="70"/>
</Unit21>
<Unit22>
<Filename Value="..\uutlLogger.pas"/>
@@ -185,7 +193,7 @@
<EditorIndex Value="-1"/>
<TopLine Value="419"/>
<CursorPos X="55" Y="434"/>
<UsageCount Value="57"/>
<UsageCount Value="68"/>
</Unit22>
<Unit23>
<Filename Value="..\uutlXmlHelper.pas"/>
@@ -193,7 +201,7 @@
<EditorIndex Value="-1"/>
<TopLine Value="188"/>
<CursorPos X="26" Y="203"/>
<UsageCount Value="58"/>
<UsageCount Value="69"/>
</Unit23>
<Unit24>
<Filename Value="..\uutlStreamHelper.pas"/>
@@ -201,7 +209,7 @@
<EditorIndex Value="-1"/>
<TopLine Value="216"/>
<CursorPos X="10" Y="241"/>
<UsageCount Value="57"/>
<UsageCount Value="68"/>
</Unit24>
<Unit25>
<Filename Value="..\uutlCompression.pas"/>
@@ -210,7 +218,7 @@
<WindowIndex Value="-1"/>
<TopLine Value="-1"/>
<CursorPos X="-1" Y="-1"/>
<UsageCount Value="57"/>
<UsageCount Value="68"/>
</Unit25>
<Unit26>
<Filename Value="..\uutlEmbeddedProfiler.pas"/>
@@ -219,7 +227,7 @@
<WindowIndex Value="-1"/>
<TopLine Value="-1"/>
<CursorPos X="-1" Y="-1"/>
<UsageCount Value="57"/>
<UsageCount Value="68"/>
</Unit26>
<Unit27>
<Filename Value="..\uutlKeyCodes.pas"/>
@@ -228,7 +236,7 @@
<WindowIndex Value="-1"/>
<TopLine Value="-1"/>
<CursorPos X="-1" Y="-1"/>
<UsageCount Value="57"/>
<UsageCount Value="68"/>
</Unit27>
<Unit28>
<Filename Value="..\uutlMCF.pas"/>
@@ -237,7 +245,7 @@
<WindowIndex Value="-1"/>
<TopLine Value="-1"/>
<CursorPos X="-1" Y="-1"/>
<UsageCount Value="57"/>
<UsageCount Value="68"/>
</Unit28>
<Unit29>
<Filename Value="..\uutlSScanf.pas"/>
@@ -246,7 +254,7 @@
<WindowIndex Value="-1"/>
<TopLine Value="-1"/>
<CursorPos X="-1" Y="-1"/>
<UsageCount Value="57"/>
<UsageCount Value="68"/>
</Unit29>
<Unit30>
<Filename Value="..\uutlThreads.pas"/>
@@ -255,14 +263,14 @@
<WindowIndex Value="-1"/>
<TopLine Value="-1"/>
<CursorPos X="-1" Y="-1"/>
<UsageCount Value="57"/>
<UsageCount Value="68"/>
</Unit30>
<Unit31>
<Filename Value="..\uutlEvent.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<CursorPos X="11" Y="35"/>
<UsageCount Value="56"/>
<UsageCount Value="67"/>
</Unit31>
<Unit32>
<Filename Value="..\uutlEventManager.pas"/>
@@ -270,7 +278,7 @@
<EditorIndex Value="-1"/>
<TopLine Value="246"/>
<CursorPos X="39" Y="264"/>
<UsageCount Value="56"/>
<UsageCount Value="67"/>
</Unit32>
<Unit33>
<Filename Value="..\uutlObservable.pas"/>
@@ -278,7 +286,7 @@
<EditorIndex Value="-1"/>
<TopLine Value="556"/>
<CursorPos X="45" Y="572"/>
<UsageCount Value="56"/>
<UsageCount Value="67"/>
</Unit33>
<Unit34>
<Filename Value="uutlObservableListTests.pas"/>
@@ -286,7 +294,7 @@
<EditorIndex Value="-1"/>
<TopLine Value="36"/>
<CursorPos X="53" Y="52"/>
<UsageCount Value="48"/>
<UsageCount Value="59"/>
</Unit34>
<Unit35>
<Filename Value="uutlObservableHashSetTests.pas"/>
@@ -294,7 +302,7 @@
<EditorIndex Value="-1"/>
<TopLine Value="46"/>
<CursorPos X="25" Y="62"/>
<UsageCount Value="28"/>
<UsageCount Value="39"/>
</Unit35>
<Unit36>
<Filename Value="uutlObservableMapTests.pas"/>
@@ -302,360 +310,462 @@
<EditorIndex Value="-1"/>
<TopLine Value="46"/>
<CursorPos X="22" Y="51"/>
<UsageCount Value="27"/>
<UsageCount Value="38"/>
</Unit36>
<Unit37>
<Filename Value="uutlSetHelperTests.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<TopLine Value="44"/>
<CursorPos X="64" Y="54"/>
<UsageCount Value="24"/>
<EditorIndex Value="11"/>
<TopLine Value="45"/>
<CursorPos Y="67"/>
<UsageCount Value="35"/>
<Loaded Value="True"/>
</Unit37>
<Unit38>
<Filename Value="uutlVariantEnumTest.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="3"/>
<WindowIndex Value="1"/>
<TopLine Value="30"/>
<CursorPos X="62" Y="34"/>
<UsageCount Value="31"/>
<Loaded Value="True"/>
</Unit38>
<Unit39>
<Filename Value="..\uutlExceptions.pas"/>
<EditorIndex Value="-1"/>
<CursorPos X="21" Y="3"/>
<UsageCount Value="32"/>
</Unit38>
<Unit39>
</Unit39>
<Unit40>
<Filename Value="_uutlInterfaces.pas"/>
<EditorIndex Value="-1"/>
<CursorPos X="42" Y="6"/>
<UsageCount Value="33"/>
</Unit39>
<Unit40>
</Unit40>
<Unit41>
<Filename Value="uutlArrayTests.pas"/>
<EditorIndex Value="-1"/>
<TopLine Value="9"/>
<CursorPos X="25" Y="38"/>
<UsageCount Value="32"/>
</Unit40>
<Unit41>
</Unit41>
<Unit42>
<Filename Value="..\uutlGenerics2.pas"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="-1"/>
<TopLine Value="1902"/>
<CursorPos Y="1905"/>
<UsageCount Value="7"/>
</Unit41>
<Unit42>
</Unit42>
<Unit43>
<Filename Value="..\uutlCommon2.pas"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="1"/>
<TopLine Value="9"/>
<CursorPos X="15" Y="26"/>
<UsageCount Value="7"/>
</Unit42>
<Unit43>
</Unit43>
<Unit44>
<Filename Value="uutlInterfaces2.pas"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="1"/>
<TopLine Value="49"/>
<CursorPos X="35" Y="60"/>
<UsageCount Value="7"/>
</Unit43>
<Unit44>
</Unit44>
<Unit45>
<Filename Value="..\uutlAlgorithm2.pas"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="1"/>
<TopLine Value="66"/>
<CursorPos X="5" Y="93"/>
<UsageCount Value="7"/>
</Unit44>
<Unit45>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\3.1.1\source\rtl\objpas\objpas.pp"/>
</Unit45>
<Unit46>
<Filename Value="..\..\..\fpc\3.1.1\source\rtl\objpas\objpas.pp"/>
<EditorIndex Value="-1"/>
<TopLine Value="63"/>
<CursorPos X="20" Y="75"/>
<UsageCount Value="15"/>
</Unit45>
<Unit46>
</Unit46>
<Unit47>
<Filename Value="G:\Eigene Datein\Projekte\_Active Projekte\TotoStarRedesign\utils\uutlAlgorithm.pas"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="1"/>
<TopLine Value="48"/>
<CursorPos X="45" Y="56"/>
<UsageCount Value="7"/>
</Unit46>
<Unit47>
</Unit47>
<Unit48>
<Filename Value="..\uutlEnumerator2.pas"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="1"/>
<TopLine Value="126"/>
<CursorPos X="22" Y="128"/>
<UsageCount Value="6"/>
</Unit47>
<Unit48>
<Filename Value="C:\Zusatzprogramme\Lazarus\components\fptest\src\FPCUnitCompatibleInterface.inc"/>
</Unit48>
<Unit49>
<Filename Value="..\..\..\components\fptest\src\FPCUnitCompatibleInterface.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="54"/>
<CursorPos Y="69"/>
<UsageCount Value="16"/>
</Unit48>
<Unit49>
<Filename Value="C:\Zusatzprogramme\Lazarus\components\fptest\src\TestFramework.pas"/>
</Unit49>
<Unit50>
<Filename Value="..\..\..\components\fptest\src\TestFramework.pas"/>
<EditorIndex Value="-1"/>
<TopLine Value="2243"/>
<CursorPos Y="2258"/>
<UsageCount Value="10"/>
</Unit49>
<Unit50>
</Unit50>
<Unit51>
<Filename Value="..\internal_uutlInterfaces.pas"/>
<EditorIndex Value="-1"/>
<CursorPos Y="11"/>
<UsageCount Value="6"/>
</Unit50>
<Unit51>
</Unit51>
<Unit52>
<Filename Value="..\uutlUtils.inc"/>
<EditorIndex Value="-1"/>
<CursorPos X="46" Y="3"/>
<UsageCount Value="7"/>
</Unit51>
<Unit52>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\3.1.1\source\rtl\objpas\classes\classesh.inc"/>
</Unit52>
<Unit53>
<Filename Value="..\..\..\fpc\3.1.1\source\rtl\objpas\classes\classesh.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="118"/>
<CursorPos X="3" Y="143"/>
<UsageCount Value="13"/>
</Unit52>
<Unit53>
</Unit53>
<Unit54>
<Filename Value="G:\Eigene Datein\Projekte\_Active Projekte\TotoStarRedesign\utils\uutlCommon.pas"/>
<EditorIndex Value="-1"/>
<TopLine Value="474"/>
<CursorPos X="16" Y="500"/>
<UsageCount Value="9"/>
</Unit53>
<Unit54>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\3.1.1\source\rtl\win\wininc\ascdef.inc"/>
</Unit54>
<Unit55>
<Filename Value="..\..\..\fpc\3.1.1\source\rtl\win\wininc\ascdef.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="202"/>
<CursorPos X="10" Y="217"/>
<UsageCount Value="8"/>
</Unit54>
<Unit55>
</Unit55>
<Unit56>
<Filename Value="G:\Eigene Datein\Projekte\_Active Projekte\TotoStarRedesign\utils\uutlSyncObjs.pas"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="1"/>
<TopLine Value="64"/>
<CursorPos X="13" Y="76"/>
<UsageCount Value="14"/>
</Unit55>
<Unit56>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\3.1.1\source\rtl\objpas\sysutils\sysutilh.inc"/>
</Unit56>
<Unit57>
<Filename Value="..\..\..\fpc\3.1.1\source\rtl\objpas\sysutils\sysutilh.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="83"/>
<CursorPos X="4" Y="98"/>
<UsageCount Value="14"/>
</Unit56>
<Unit57>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\3.1.1\source\rtl\win\wininc\func.inc"/>
</Unit57>
<Unit58>
<Filename Value="..\..\..\fpc\3.1.1\source\rtl\win\wininc\func.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="244"/>
<CursorPos X="10" Y="259"/>
<UsageCount Value="9"/>
</Unit57>
<Unit58>
</Unit58>
<Unit59>
<Filename Value="G:\Eigene Datein\Projekte\_Active Projekte\TotoStarRedesign\utils\uutlXmlHelper.pas"/>
<EditorIndex Value="-1"/>
<CursorPos X="29" Y="30"/>
<UsageCount Value="8"/>
</Unit58>
<Unit59>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\3.1.1\source\packages\fcl-base\src\contnrs.pp"/>
</Unit59>
<Unit60>
<Filename Value="..\..\..\fpc\3.1.1\source\packages\fcl-base\src\contnrs.pp"/>
<EditorIndex Value="-1"/>
<TopLine Value="136"/>
<CursorPos X="3" Y="151"/>
<UsageCount Value="9"/>
</Unit59>
<Unit60>
</Unit60>
<Unit61>
<Filename Value="..\uutlEmbeddedProfiler.inc"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="-1"/>
<TopLine Value="-1"/>
<CursorPos X="-1" Y="-1"/>
<UsageCount Value="19"/>
</Unit60>
<Unit61>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\3.1.1\source\rtl\inc\objpash.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="190"/>
<CursorPos X="23" Y="205"/>
<UsageCount Value="14"/>
</Unit61>
<Unit62>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\3.1.1\source\rtl\objpas\sysutils\osutilsh.inc"/>
<Filename Value="..\..\..\fpc\3.1.1\source\rtl\inc\objpash.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="248"/>
<CursorPos X="8" Y="264"/>
<UsageCount Value="15"/>
</Unit62>
<Unit63>
<Filename Value="..\..\..\fpc\3.1.1\source\rtl\objpas\sysutils\osutilsh.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="40"/>
<CursorPos X="3" Y="62"/>
<UsageCount Value="12"/>
</Unit62>
<Unit63>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\3.1.1\source\rtl\win\wininc\struct.inc"/>
</Unit63>
<Unit64>
<Filename Value="..\..\..\fpc\3.1.1\source\rtl\win\wininc\struct.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="5662"/>
<CursorPos X="8" Y="5677"/>
<UsageCount Value="11"/>
</Unit63>
<Unit64>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\3.1.1\source\rtl\win\wininc\base.inc"/>
</Unit64>
<Unit65>
<Filename Value="..\..\..\fpc\3.1.1\source\rtl\win\wininc\base.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="448"/>
<CursorPos X="12" Y="463"/>
<UsageCount Value="11"/>
</Unit64>
<Unit65>
<Filename Value="C:\Zusatzprogramme\Lazarus\components_extra\fptest\src\FPCUnitCompatibleInterface.inc"/>
<EditorIndex Value="5"/>
<TopLine Value="158"/>
<CursorPos Y="185"/>
<UsageCount Value="11"/>
<Loaded Value="True"/>
</Unit65>
<Unit66>
<Filename Value="C:\Zusatzprogramme\Lazarus\components_extra\fptest\src\TestFramework.pas"/>
<IsVisibleTab Value="True"/>
<EditorIndex Value="8"/>
<TopLine Value="3311"/>
<CursorPos X="30" Y="3325"/>
<UsageCount Value="11"/>
<Loaded Value="True"/>
<Filename Value="..\..\fptest\src\FPCUnitCompatibleInterface.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="53"/>
<CursorPos X="35" Y="66"/>
<UsageCount Value="12"/>
</Unit66>
<Unit67>
<Filename Value="C:\Zusatzprogramme\Lazarus\components_extra\fptest\src\TestFrameworkIfaces.pas"/>
<EditorIndex Value="6"/>
<Filename Value="..\..\fptest\src\TestFramework.pas"/>
<EditorIndex Value="1"/>
<WindowIndex Value="1"/>
<TopLine Value="2786"/>
<CursorPos Y="2808"/>
<UsageCount Value="14"/>
<Loaded Value="True"/>
</Unit67>
<Unit68>
<Filename Value="..\..\fptest\src\TestFrameworkIfaces.pas"/>
<EditorIndex Value="-1"/>
<TopLine Value="35"/>
<CursorPos X="3" Y="51"/>
<UsageCount Value="10"/>
</Unit68>
<Unit69>
<Filename Value="..\uutlVariantEnum.pas"/>
<WindowIndex Value="1"/>
<TopLine Value="81"/>
<CursorPos X="34" Y="105"/>
<UsageCount Value="16"/>
<Loaded Value="True"/>
</Unit67>
</Unit69>
<Unit70>
<Filename Value="..\..\..\fpc\3.1.1\source\packages\rtl-objpas\src\inc\variants.pp"/>
<EditorIndex Value="5"/>
<UsageCount Value="14"/>
<Loaded Value="True"/>
</Unit70>
<Unit71>
<Filename Value="..\..\..\fpc\3.1.1\source\rtl\inc\varianth.inc"/>
<EditorIndex Value="6"/>
<TopLine Value="114"/>
<CursorPos X="27" Y="136"/>
<UsageCount Value="13"/>
<Loaded Value="True"/>
</Unit71>
<Unit72>
<Filename Value="..\..\..\fpc\3.1.1\source\rtl\inc\variant.inc"/>
<EditorIndex Value="-1"/>
<UsageCount Value="11"/>
</Unit72>
<Unit73>
<Filename Value="..\..\..\fpc\3.1.1\source\rtl\objpas\sysconst.pp"/>
<EditorIndex Value="-1"/>
<TopLine Value="107"/>
<CursorPos X="3" Y="123"/>
<UsageCount Value="11"/>
</Unit73>
<Unit74>
<Filename Value="..\..\..\fpc\3.1.1\source\packages\rtl-objpas\src\inc\varutilh.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="43"/>
<CursorPos X="10" Y="59"/>
<UsageCount Value="11"/>
</Unit74>
<Unit75>
<Filename Value="..\..\..\fpc\3.1.1\source\packages\rtl-objpas\src\inc\cvarutil.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="258"/>
<CursorPos X="41" Y="272"/>
<UsageCount Value="11"/>
</Unit75>
<Unit76>
<Filename Value="..\..\..\fpc\3.1.1\source\packages\rtl-objpas\src\inc\varerror.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="2"/>
<CursorPos X="3" Y="23"/>
<UsageCount Value="11"/>
</Unit76>
<Unit77>
<Filename Value="..\uutlVariantSet.pas"/>
<TopLine Value="80"/>
<CursorPos X="36" Y="95"/>
<UsageCount Value="14"/>
<Loaded Value="True"/>
</Unit77>
<Unit78>
<Filename Value="..\uutlVariantObject.pas"/>
<EditorIndex Value="1"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit78>
<Unit79>
<Filename Value="..\uutlVariantProperty.pas"/>
<EditorIndex Value="4"/>
<TopLine Value="24"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit79>
<Unit80>
<Filename Value="uutlVariantSetTest.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="2"/>
<TopLine Value="17"/>
<CursorPos Y="43"/>
<UsageCount Value="22"/>
<Loaded Value="True"/>
</Unit80>
<Unit81>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<IsVisibleTab Value="True"/>
<EditorIndex Value="3"/>
<TopLine Value="1726"/>
<CursorPos X="16" Y="1749"/>
<ExtraEditorCount Value="1"/>
<ExtraEditor1>
<IsVisibleTab Value="True"/>
<EditorIndex Value="4"/>
<WindowIndex Value="1"/>
<TopLine Value="1480"/>
<CursorPos X="85" Y="1507"/>
</ExtraEditor1>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit81>
</Units>
<OtherDefines Count="3">
<Define0 Value="UTL_ADVANCED_ENUMERATORS"/>
<Define1 Value="UTL_NESTED_PROCVARS"/>
<Define2 Value="UTL_ENUMERATORS"/>
</OtherDefines>
<JumpHistory Count="30" HistoryIndex="29">
<JumpHistory Count="28" HistoryIndex="27">
<Position1>
<Filename Value="..\uutlListBase.pas"/>
<Caret Line="139" TopLine="119"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="1433" Column="6" TopLine="1416"/>
</Position1>
<Position2>
<Filename Value="..\uutlListBase.pas"/>
<Caret Line="143" TopLine="119"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="395" Column="20" TopLine="368"/>
</Position2>
<Position3>
<Filename Value="..\uutlListBase.pas"/>
<Caret Line="135" Column="35" TopLine="119"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="1732" Column="18" TopLine="1723"/>
</Position3>
<Position4>
<Filename Value="uutlListTest.pas"/>
<Caret Line="612" Column="42" TopLine="594"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="1733" Column="32" TopLine="1723"/>
</Position4>
<Position5>
<Filename Value="..\uutlListBase.pas"/>
<Caret Line="105" TopLine="89"/>
<Filename Value="..\uutlVariantSet.pas"/>
<Caret Line="16" Column="73"/>
</Position5>
<Position6>
<Filename Value="uutlListTest.pas"/>
<Caret Line="625" TopLine="610"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="1733" Column="32" TopLine="1723"/>
</Position6>
<Position7>
<Filename Value="C:\Zusatzprogramme\Lazarus\components_extra\fptest\src\FPCUnitCompatibleInterface.inc"/>
<Caret Line="184" TopLine="158"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="1727" Column="33" TopLine="1723"/>
</Position7>
<Position8>
<Filename Value="C:\Zusatzprogramme\Lazarus\components_extra\fptest\src\TestFramework.pas"/>
<Caret Line="3327" TopLine="3306"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="620" Column="31" TopLine="605"/>
</Position8>
<Position9>
<Filename Value="C:\Zusatzprogramme\Lazarus\components_extra\fptest\src\TestFramework.pas"/>
<Caret Line="3329" TopLine="3306"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="549" Column="57" TopLine="533"/>
</Position9>
<Position10>
<Filename Value="C:\Zusatzprogramme\Lazarus\components_extra\fptest\src\TestFramework.pas"/>
<Caret Line="3332" TopLine="3306"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="584" Column="50" TopLine="563"/>
</Position10>
<Position11>
<Filename Value="C:\Zusatzprogramme\Lazarus\components_extra\fptest\src\TestFramework.pas"/>
<Caret Line="3333" TopLine="3307"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="561" Column="36" TopLine="546"/>
</Position11>
<Position12>
<Filename Value="C:\Zusatzprogramme\Lazarus\components_extra\fptest\src\TestFramework.pas"/>
<Caret Line="3335" TopLine="3309"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="2044" Column="12" TopLine="2023"/>
</Position12>
<Position13>
<Filename Value="C:\Zusatzprogramme\Lazarus\components_extra\fptest\src\TestFramework.pas"/>
<Caret Line="3337" TopLine="3311"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="629" Column="23" TopLine="597"/>
</Position13>
<Position14>
<Filename Value="C:\Zusatzprogramme\Lazarus\components_extra\fptest\src\FPCUnitCompatibleInterface.inc"/>
<Caret Line="185" TopLine="158"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="1917" Column="12" TopLine="1901"/>
</Position14>
<Position15>
<Filename Value="uutlListTest.pas"/>
<Caret Line="626" TopLine="610"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="1926" Column="27" TopLine="1899"/>
</Position15>
<Position16>
<Filename Value="..\uutlEnumerator.pas"/>
<Caret Line="396" TopLine="380"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="1917" Column="17" TopLine="1901"/>
</Position16>
<Position17>
<Filename Value="..\uutlEnumerator.pas"/>
<Caret Line="397" TopLine="380"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="2000" Column="3" TopLine="1997"/>
</Position17>
<Position18>
<Filename Value="..\uutlEnumerator.pas"/>
<Caret Line="398" TopLine="380"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="1971" Column="27" TopLine="1949"/>
</Position18>
<Position19>
<Filename Value="..\uutlEnumerator.pas"/>
<Caret Line="402" TopLine="380"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="1989" Column="13" TopLine="1968"/>
</Position19>
<Position20>
<Filename Value="..\uutlEnumerator.pas"/>
<Caret Line="403" TopLine="380"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="561" Column="11" TopLine="553"/>
</Position20>
<Position21>
<Filename Value="..\uutlEnumerator.pas"/>
<Caret Line="405" TopLine="380"/>
<Filename Value="..\uutlGenerics.pas"/>
<Caret Line="1900" Column="3" TopLine="1897"/>
</Position21>
<Position22>
<Filename Value="..\uutlEnumerator.pas"/>
<Caret Line="407" TopLine="381"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="1730" Column="2" TopLine="1723"/>
</Position22>
<Position23>
<Filename Value="uutlListTest.pas"/>
<Caret Line="627" TopLine="610"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="1769" Column="17" TopLine="1758"/>
</Position23>
<Position24>
<Filename Value="..\uutlListBase.pas"/>
<Caret Line="103" TopLine="89"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="1426" Column="25" TopLine="1410"/>
</Position24>
<Position25>
<Filename Value="..\uutlListBase.pas"/>
<Caret Line="104" TopLine="89"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="1774" Column="4" TopLine="1752"/>
</Position25>
<Position26>
<Filename Value="..\uutlEnumerator.pas"/>
<Caret Line="400" Column="28" TopLine="381"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="398" Column="15" TopLine="373"/>
</Position26>
<Position27>
<Filename Value="..\uutlEnumerator.pas"/>
<Caret Line="105" Column="24" TopLine="89"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="281" Column="34" TopLine="256"/>
</Position27>
<Position28>
<Filename Value="..\uutlListBase.pas"/>
<Caret Line="110" Column="29" TopLine="100"/>
<Filename Value="..\..\bitSpaceControls\uPropertyTree.pas"/>
<Caret Line="273" Column="21" TopLine="261"/>
</Position28>
<Position29>
<Filename Value="..\uutlListBase.pas"/>
<Caret Line="106" TopLine="100"/>
</Position29>
<Position30>
<Filename Value="..\uutlListBase.pas"/>
<Caret Line="113" Column="72" TopLine="100"/>
</Position30>
</JumpHistory>
</ProjectSession>
<Debugging>
@@ -665,10 +775,13 @@
<InitialEnabled Value="False"/>
</Item1>
</BreakPointGroups>
<Watches Count="1">
<Watches Count="2">
<Item1>
<Expression Value="fCurrent"/>
<Expression Value="TEnumVarData(v)"/>
</Item1>
<Item2>
<Expression Value="TTestEnum(aSet)"/>
</Item2>
</Watches>
</Debugging>
</CONFIG>

+ 11
- 11
tests/uutlSetHelperTests.pas View File

@@ -22,7 +22,7 @@ uses
uutlGenerics;

type
TTestEnum = (
TSetHelperTestEnum = (
teTest0 = 0,
teTest1 = 1,
teTest2 = 2,
@@ -32,8 +32,8 @@ type
teTest8 = 8,
teTest9 = 9
);
TTestSet = set of TTestEnum;
TTestSetH = specialize TutlSetHelper<TTestEnum, TTestSet>;
TSetHelperTestSet = set of TSetHelperTestEnum;
TSetHelperTestSetH = specialize TutlSetHelper<TSetHelperTestEnum, TSetHelperTestSet>;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlSetHelperTests////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
@@ -42,31 +42,31 @@ procedure TutlSetHelperTests.proc_ToString;
var
str: String;
begin
str := TTestSetH.ToString([teTest0, teTest1, teTest2, teTest3, teTest4, teTest8]);
str := TSetHelperTestSetH.ToString([teTest0, teTest1, teTest2, teTest3, teTest4, teTest8]);
AssertEquals('teTest0, teTest1, teTest2, teTest3, teTest4, teTest8', str);

str := TTestSetH.ToString([teTest0, teTest1, teTest2, teTest3, teTest4, teTest8], '_');
str := TSetHelperTestSetH.ToString([teTest0, teTest1, teTest2, teTest3, teTest4, teTest8], '_');
AssertEquals('teTest0_teTest1_teTest2_teTest3_teTest4_teTest8', str);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlSetHelperTests.proc_TryToSet;
var
s: TTestSet;
s: TSetHelperTestSet;
begin
AssertTrue(TTestSetH.TryToSet('teTest0, teTest1, teTest2, teTest3, teTest8, teTest9', s));
AssertTrue(TSetHelperTestSetH.TryToSet('teTest0, teTest1, teTest2, teTest3, teTest8, teTest9', s));
AssertTrue([teTest0, teTest1, teTest2, teTest3, teTest8, teTest9] = s);

AssertTrue(TTestSetH.TryToSet('teTest0_asd_teTest1_asd_teTest2_asd_teTest3_asd_teTest8_asd_teTest9', '_asd_', s));
AssertTrue(TSetHelperTestSetH.TryToSet('teTest0_asd_teTest1_asd_teTest2_asd_teTest3_asd_teTest8_asd_teTest9', '_asd_', s));
AssertTrue([teTest0, teTest1, teTest2, teTest3, teTest8, teTest9] = s);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlSetHelperTests.proc_Compare;
begin
AssertEquals( 0, TTestSetH.Compare([teTest0, teTest1, teTest2], [teTest0, teTest1, teTest2]));
AssertEquals(-1, TTestSetH.Compare([ teTest1, teTest2], [teTest0, teTest1, teTest2]));
AssertEquals( 1, TTestSetH.Compare([teTest0, teTest1, teTest2], [teTest0, teTest2]));
AssertEquals( 0, TSetHelperTestSetH.Compare([teTest0, teTest1, teTest2], [teTest0, teTest1, teTest2]));
AssertEquals(-1, TSetHelperTestSetH.Compare([ teTest1, teTest2], [teTest0, teTest1, teTest2]));
AssertEquals( 1, TSetHelperTestSetH.Compare([teTest0, teTest1, teTest2], [teTest0, teTest2]));
end;

initialization


+ 94
- 0
tests/uutlVariantEnumTest.pas View File

@@ -0,0 +1,94 @@
unit uutlVariantEnumTest;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, TestFramework,
uutlVariantEnum;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlVariantEnumTest = class(TTestCase)
published
procedure VariantToString;
procedure VariantToEnum;
procedure VariantToInt;
end;

implementation

uses
uutlGenerics;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TTestEnum = (
teTest2 = 2,
teTest3 = 3,
teTest5 = 5,
teTest9 = 9
);
TTestEnumH = specialize TutlEnumHelper<TTestEnum>;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVariantEnumTest///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantEnumTest.VariantToString;
begin
AssertEquals('2', String(VarMakeEnum(Ord(teTest2))));
AssertEquals('3', String(VarMakeEnum(Ord(teTest3))));
AssertEquals('5', String(VarMakeEnum(Ord(teTest5))));
AssertEquals('9', String(VarMakeEnum(Ord(teTest9))));

AssertEquals('teTest2', String(VarMakeEnum(Ord(teTest2), TTestEnumH)));
AssertEquals('teTest3', String(VarMakeEnum(Ord(teTest3), TTestEnumH)));
AssertEquals('teTest5', String(VarMakeEnum(Ord(teTest5), TTestEnumH)));
AssertEquals('teTest9', String(VarMakeEnum(Ord(teTest9), TTestEnumH)));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantEnumTest.VariantToEnum;
var
e: TTestEnum;
begin
AssertTrue (TTestEnumH.TryToEnum(VarMakeEnum(Ord(teTest2)), e, true));
AssertEquals(Integer(teTest2), Integer(e));
AssertTrue (TTestEnumH.TryToEnum(VarMakeEnum(Ord(teTest3)), e, true));
AssertEquals(Integer(teTest3), Integer(e));
AssertTrue (TTestEnumH.TryToEnum(VarMakeEnum(Ord(teTest5)), e, true));
AssertEquals(Integer(teTest5), Integer(e));
AssertTrue (TTestEnumH.TryToEnum(VarMakeEnum(Ord(teTest9)), e, true));
AssertEquals(Integer(teTest9), Integer(e));

AssertTrue (TTestEnumH.TryToEnum(VarMakeEnum(Ord(teTest2), TTestEnumH), e, true));
AssertEquals(Integer(teTest2), Integer(e));
AssertTrue (TTestEnumH.TryToEnum(VarMakeEnum(Ord(teTest3), TTestEnumH), e, true));
AssertEquals(Integer(teTest3), Integer(e));
AssertTrue (TTestEnumH.TryToEnum(VarMakeEnum(Ord(teTest5), TTestEnumH), e, true));
AssertEquals(Integer(teTest5), Integer(e));
AssertTrue (TTestEnumH.TryToEnum(VarMakeEnum(Ord(teTest9), TTestEnumH), e, true));
AssertEquals(Integer(teTest9), Integer(e));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantEnumTest.VariantToInt;
begin
// cause of a bug in FPC this test will always fail with a invalid cast exception

AssertEquals(2, Integer(VarMakeEnum(Ord(teTest2))));
AssertEquals(3, Integer(VarMakeEnum(Ord(teTest3))));
AssertEquals(5, Integer(VarMakeEnum(Ord(teTest5))));
AssertEquals(9, Integer(VarMakeEnum(Ord(teTest9))));

AssertEquals(2, Integer(VarMakeEnum(Ord(teTest2), TTestEnumH)));
AssertEquals(3, Integer(VarMakeEnum(Ord(teTest3), TTestEnumH)));
AssertEquals(5, Integer(VarMakeEnum(Ord(teTest5), TTestEnumH)));
AssertEquals(9, Integer(VarMakeEnum(Ord(teTest9), TTestEnumH)));
end;

initialization
RegisterTest(TutlVariantEnumTest.Suite);
end.


+ 48
- 0
tests/uutlVariantSetTest.pas View File

@@ -0,0 +1,48 @@
unit uutlVariantSetTest;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, TestFramework,
uutlVariantSet;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlVariantSetTest = class(TTestCase)
published
procedure VariantToString;
end;

implementation

uses
uutlGenerics;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TTestEnum = (
teTest2 = 2,
teTest3 = 3,
teTest5 = 5,
teTest9 = 9
);
TTestSet = set of TTestEnum;
TTestSetH = specialize TutlSetHelper<TTestEnum, TTestSet>;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVariantSetTest////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantSetTest.VariantToString;
begin
AssertEquals('teTest2, teTest3, teTest5, teTest9', String(VarMakeSet(TTestSet([teTest2, teTest3, teTest5, teTest9]), SizeOf(TTestSet), TTestSetH)));
AssertEquals('teTest2, teTest5', String(VarMakeSet(TTestSet([teTest2, teTest5]), SizeOf(TTestSet), TTestSetH)));
AssertEquals('teTest3', String(VarMakeSet(TTestSet([teTest3]), SizeOf(TTestSet), TTestSetH)));
end;

initialization
RegisterTest(TutlVariantSetTest.Suite);

end.


+ 2
- 1
uutlArrayContainer.pas View File

@@ -80,7 +80,8 @@ end;
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlArrayContainer.Release(var aItem: T; const aFreeItem: Boolean);
begin
utlFinalizeObject(aItem, TypeInfo(aItem), fOwnsItems and aFreeItem);
if not utlFinalizeObject(aItem, TypeInfo(aItem), fOwnsItems and aFreeItem) then
Finalize(aItem);
FillByte(aItem, SizeOf(aItem), 0);
end;



+ 6
- 2
uutlCommon.pas View File

@@ -90,7 +90,7 @@ function GetMicroTime (): QWord;
function GetPlatformIdentitfier(): String;

function utlRateLimited (const Reference: QWord; const Interval: QWord): boolean;
procedure utlFinalizeObject (var obj; const aTypeInfo: PTypeInfo; const aFreeObject: Boolean);
function utlFinalizeObject (var obj; const aTypeInfo: PTypeInfo; const aFreeObject: Boolean): Boolean;
function utlFilterBuilder (): IutlFilterBuilder;

implementation
@@ -261,10 +261,11 @@ begin
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure utlFinalizeObject(var obj; const aTypeInfo: PTypeInfo; const aFreeObject: Boolean);
function utlFinalizeObject(var obj; const aTypeInfo: PTypeInfo; const aFreeObject: Boolean): Boolean;
var
o: TObject;
begin
result := true;
case aTypeInfo^.Kind of
tkClass: begin
if (aFreeObject) then begin
@@ -290,6 +291,9 @@ begin
tkString: begin
String(Obj) := '';
end;

else
result := false;
end;
end;



+ 13
- 0
uutlEnumVariant.pas View File

@@ -0,0 +1,13 @@
unit uutlEnumVariant;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils;

implementation

end.


+ 428
- 98
uutlGenerics.pas View File

@@ -453,6 +453,7 @@ type
function TryGetValue (constref aKey: TKey; out aValue: TValue): Boolean;
function IndexOf (constref aKey: TKey): Integer;
function Contains (constref aKey: TKey): Boolean;
function Remove (constref aKey: TKey): Boolean;
procedure Delete (constref aKey: TKey);
procedure DeleteAt (const aIndex: Integer);
procedure Clear;
@@ -482,49 +483,153 @@ type
constructor Create(const aValue, aExpectedType: String);
end;

generic TutlEnumHelper<T> = class
TutlEnumHelperBaseClass = class of TutlEnumHelperBase;
TutlEnumHelperBase = class
public type
TIntArray = array of Integer;
TStringArray = array of String;

private type
TValuesMap = specialize TutlMap<string, TIntArray>;
TNamesMap = specialize TutlMap<string, TStringArray>;

private class var
fValuesMap: TValuesMap;
fNamesMap: TNamesMap;

protected
class procedure RegisterType (const aValues: TIntArray; const aNames: TStringArray);
class procedure UnregisterType();

public
class function ToString (const aValue: Integer; const aAllowOrd: Boolean = false): String; reintroduce;
class function TryToEnum (const aStr: String; out aValue: Integer; const aAllowOrd: Boolean = false): Boolean;
class function ToEnum (const aStr: String; const aAllowOrd: Boolean = false): Integer; overload;
class function ToEnum (const aStr: String; const aDefault: Integer; const aAllowOrd: Boolean = false): Integer; overload;

class function IntValues: TIntArray;
class function Names: TStringArray;

public
class constructor Initialize;
class destructor Finalize;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
generic TutlEnumHelper<T> = class(TutlEnumHelperBase)
public type
TEnumType = T;
TValueArray = array of T;
TStringArray = array of String;

private class var
fTypeInfo: PTypeInfo;
fValues: TValueArray;
fNames: TStringArray;
fIntValues: TIntArray;
fTypeInfo: PTypeInfo;

public
class function ToString (aValue: T): String; reintroduce;
class function TryToEnum (aStr: String; out aValue: T): Boolean;
class function ToEnum (aStr: String): T; overload;
class function ToEnum (aStr: String; const aDefault: T): T; overload;
class function ToString (const aValue: T; const aAllowOrd: Boolean = false): String; reintroduce;
class function TryToEnum (const aStr: String; out aValue: T; const aAllowOrd: Boolean = false): Boolean;
class function ToEnum (const aStr: String; const aAllowOrd: Boolean = false): T; overload;
class function ToEnum (const aStr: String; const aDefault: T; const aAllowOrd: Boolean = false): T; overload;

class function Values: TValueArray; inline;
class function IntValues: TIntArray; inline;
class function Names: TStringArray; inline;
class function TypeInfo: PTypeInfo; inline;

class constructor Initialize;
class destructor Finalize;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlSetHelperBase = class
private type
TEnumHelperMap = specialize TutlMap<string, TutlEnumHelperBaseClass>;

private class var
fEnumHelpers: TEnumHelperMap;

private
class function IsSet (const aSet; const aSize: Integer; const aValue: Integer): Boolean;
class procedure SetValue (var aSet; const aSize: Integer; const aValue: Integer);
class procedure ClearValue(var aSet; const aSize: Integer; const aValue: Integer);

protected
class procedure RegisterEnumHelper(const aHelper: TutlEnumHelperBaseClass);
class procedure UnregisterEnumHelper;

public
class function ToString(
const aSet;
const aSize: Integer;
const aSeparator: String = ', ';
const aAllowOrd: Boolean = false): String; reintroduce;

class function TryToSet(
const aStr: String;
out aSet;
const aSize: Integer;
const aAllowOrd: Boolean = false): Boolean;

class function TryToSet(
const aStr: String;
const aSeparator: String;
out aSet;
const aSize: Integer;
const aAllowOrd: Boolean = false): Boolean;

class function Compare(
const aSet1;
const aSet2;
const aSize: Integer): Integer;

class function EnumHelper: TutlEnumHelperBaseClass;

class constructor Initialize;
class destructor Finalize;
end;
TutlSetHelperBaseClass = class of TutlSetHelperBase;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
generic TutlSetHelper<TEnum, TSet> = class
generic TutlSetHelper<TEnum, TSet> = class(TutlSetHelperBase)
public type
TEnumHelper = specialize TutlEnumHelper<TEnum>;
TEnumType = TEnum;
TSetType = TSet;

private
class function IsSet (constref aSet: TSet; aEnum: TEnum): Boolean;
class procedure SetValue (var aSet: TSet; aEnum: TEnum);
class procedure ClearValue(var aSet: TSet; aEnum: TEnum);

public
class function ToString (const aValue: TSet; const aSeperator: String = ', '): String; reintroduce;
class function TryToSet (const aStr: String; out aValue: TSet): Boolean; overload;
class function TryToSet (const aStr: String; const aSeperator: String; out aValue: TSet): Boolean; overload;
class function ToSet (const aStr: String; const aDefault: TSet): TSet; overload;
class function ToSet (const aStr: String): TSet; overload;
class function Compare (const aSet1, aSet2: TSet): Integer;
class function ToString(
const aValue: TSet;
const aSeparator: String = ', ';
const aAllowOrd: Boolean = false): String; overload;

class function TryToSet(
const aStr: String;
out aValue: TSet;
const aAllowOrd: Boolean = false): Boolean; overload;

class function TryToSet(
const aStr: String;
const aSeparator: String;
out aValue: TSet;
const aAllowOrd: Boolean = false): Boolean; overload;

class function ToSet(
const aStr: String;
const aDefault: TSet;
const aAllowOrd: Boolean = false): TSet; overload;

class function ToSet(
const aStr: String;
const aAllowOrd: Boolean = false): TSet; overload;

class function Compare(
const aSet1, aSet2: TSet): Integer; overload;

class constructor Initialize;
class destructor Finalize;
end;

implementation
@@ -1129,8 +1234,10 @@ end;
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlCustomMap.THashSet.Release(var aItem: TKeyValuePair; const aFreeItem: Boolean);
begin
utlFinalizeObject(aItem.Key, TypeInfo(aItem.Key), fOwner.OwnsKeys and aFreeItem);
utlFinalizeObject(aItem.Value, TypeInfo(aItem.Value), fOwner.OwnsValues and aFreeItem);
if not utlFinalizeObject(aItem.Key, TypeInfo(aItem.Key), fOwner.OwnsKeys and aFreeItem) then
Finalize(aItem.Key);
if not utlFinalizeObject(aItem.Value, TypeInfo(aItem.Value), fOwner.OwnsValues and aFreeItem) then
Finalize(aItem.Key);
inherited Release(aItem, aFreeItem);
end;

@@ -1448,12 +1555,18 @@ begin
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlCustomMap.Delete(constref aKey: TKey);
function TutlCustomMap.Remove(constref aKey: TKey): Boolean;
var
kvp: TKeyValuePair;
begin
kvp.Key := aKey;
if not fHashSetRef.Remove(kvp) then
result := fHashSetRef.Remove(kvp);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlCustomMap.Delete(constref aKey: TKey);
begin
if not Remove(aKey) then
raise EInvalidOperation.Create('key not found');
end;

@@ -1523,10 +1636,107 @@ begin
inherited Create(Format('%s is not a %s', [aValue, aExpectedType]));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEnumHelperBase////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class procedure TutlEnumHelperBase.RegisterType(const aValues: TIntArray; const aNames: TStringArray);
begin
fValuesMap.Add(ClassName, aValues);
fNamesMap.Add (ClassName, aNames);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class procedure TutlEnumHelperBase.UnregisterType;
begin
fValuesMap.Remove(ClassName);
fNamesMap.Remove(ClassName);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEnumHelperBase.ToString(const aValue: Integer; const aAllowOrd: Boolean = false): String;
var
i: Integer;
iArr: TIntArray;
sArr: TStringArray;
begin
iArr := fValuesMap[ClassName];
sArr := fNamesMap[ClassName];
for i := low(iArr) to high(iArr) do begin
if (iArr[i] = aValue) then begin
result := sArr[i];
exit;
end;
end;
if aAllowOrd
then result := IntToStr(aValue)
else result := '';
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEnumHelperBase.TryToEnum(const aStr: String; out aValue: Integer; const aAllowOrd: Boolean = false): Boolean;
var
i: Integer;
iArr: TIntArray;
sArr: TStringArray;
begin
iArr := fValuesMap[ClassName];
sArr := fNamesMap[ClassName];
for i := low(sArr) to high(sArr) do begin
if (sArr[i] = aStr) then begin
result := true;
aValue := iArr[i];
exit;
end;
end;
if aAllowOrd
then result := TryStrToInt(aStr, aValue)
else result := false;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEnumHelperBase.ToEnum(const aStr: String; const aAllowOrd: Boolean): Integer;
begin
if not TryToEnum(aStr, result, aAllowOrd) then
raise EConvertError.Create(aStr + ' is an unknown enum value');
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEnumHelperBase.ToEnum(const aStr: String; const aDefault: Integer; const aAllowOrd: Boolean): Integer;
begin
if not TryToEnum(aStr, result, aAllowOrd) then
result := aDefault;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEnumHelperBase.IntValues: TIntArray;
begin
result := fValuesMap[ClassName];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEnumHelperBase.Names: TStringArray;
begin
result := fNamesMap[ClassName];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class constructor TutlEnumHelperBase.Initialize;
begin
fNamesMap := TNamesMap.Create(true, true);
fValuesMap := TValuesMap.Create(true, true);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class destructor TutlEnumHelperBase.Finalize;
begin
FreeAndNil(fNamesMap);
FreeAndNil(fValuesMap);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEnumHelper////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEnumHelper.ToString(aValue: T): String;
class function TutlEnumHelper.ToString(const aValue: T; const aAllowOrd: Boolean): String;
begin
{$Push}
{$IOChecks OFF}
@@ -1537,9 +1747,10 @@ begin
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEnumHelper.TryToEnum(aStr: String; out aValue: T): Boolean;
class function TutlEnumHelper.TryToEnum(const aStr: String; out aValue: T; const aAllowOrd: Boolean): Boolean;
var
a: T;
i: Integer;
begin
a := T(0);
Result := false;
@@ -1552,20 +1763,25 @@ begin
Result := IOResult <> 106;
{$Pop}
if Result then
aValue := a;
aValue := a
else if aAllowOrd then begin
result := TryStrToInt(aStr, i);
if result then
aValue := T(i);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEnumHelper.ToEnum(aStr: String): T;
class function TutlEnumHelper.ToEnum(const aStr: String; const aAllowOrd: Boolean): T;
begin
if not TryToEnum(aStr, result) then
if not TryToEnum(aStr, result, aAllowOrd) then
raise EEnumConvertException.Create(aStr, TypeInfo^.Name);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEnumHelper.ToEnum(aStr: String; const aDefault: T): T;
class function TutlEnumHelper.ToEnum(const aStr: String; const aDefault: T; const aAllowOrd: Boolean): T;
begin
if not TryToEnum(aStr, result) then
if not TryToEnum(aStr, result, aAllowOrd) then
result := aDefault;
end;

@@ -1575,6 +1791,12 @@ begin
result := fValues;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEnumHelper.IntValues: TIntArray;
begin
result := fIntValues;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlEnumHelper.Names: TStringArray;
begin
@@ -1595,6 +1817,7 @@ var
PName: PShortString;
i: integer;
en: T;
sl: TStringList;
begin
{
See FPC Bug http://bugs.freepascal.org/view.php?id=27622
@@ -1613,97 +1836,142 @@ begin
}
tdEnum := GetTypeData(FTypeInfo);
PName := @tdEnum^.NameList;
SetLength(fValues, 0);
SetLength(fNames, 0);
i:= 0;
while Length(PName^) > 0 do begin
SetLength(fValues, i+1);
SetLength(fNames, i+1);
{
Memory layout for TTypeData has the declaring EnumUnitName after the last NameList entry.
This can normally not be the same as a valid enum value, because it is in the same identifier
namespace. However, with scoped enums we might have the same name for module and element, because
the full identifier for the element would be TypeName.ElementName.
In either case, the next PShortString will point to a zero-length string, and the loop is left
with the last element being invalid (either empty or whatever value the unit-named element has).
}
fNames[i] := PName^;
if TryToEnum(PName^, en) then
fValues[i]:= en;
sl := TStringList.Create;
try
while Length(PName^) > 0 do begin
{
Memory layout for TTypeData has the declaring EnumUnitName after the last NameList entry.
This can normally not be the same as a valid enum value, because it is in the same identifier
namespace. However, with scoped enums we might have the same name for module and element, because
the full identifier for the element would be TypeName.ElementName.
In either case, the next PShortString will point to a zero-length string, and the loop is left
with the last element being invalid (either empty or whatever value the unit-named element has).
}
sl.Add(PName^);
if TryToEnum(PName^, en) then
sl.Objects[sl.Count-1] := TObject({%H-}Pointer(PtrUInt(en)));
inc(PByte(PName), Length(PName^) + 1);
end;

inc(i);
inc(PByte(PName), Length(PName^) + 1);
sl.Delete(sl.Count-1); // remove the EnumUnitName item
SetLength(fValues, sl.Count);
SetLength(fIntValues, sl.Count);
SetLength(fNames, sl.Count);
for i := 0 to sl.Count-1 do begin
fNames[i] := sl[i];
fValues[i] := T(PtrUInt(sl.Objects[i]));
fIntValues[i] := Integer(fValues[i]);
end;

finally
FreeAndNil(sl);
end;
// remove the EnumUnitName item
SetLength(fValues, High(fValues));
SetLength(fNames, High(fNames));

RegisterType(fIntValues, fNames);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlSetHelper/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class destructor TutlEnumHelper.Finalize;
begin
Finalize(fNames);
Finalize(fValues);
Finalize(fIntValues);
UnregisterType;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelper.IsSet(constref aSet: TSet; aEnum: TEnum): Boolean;
//TutlSetHelperBase/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelperBase.IsSet(const aSet; const aSize: Integer; const aValue: Integer): Boolean;
begin
if (aValue >= 8*aSize) then
raise EOutOfRangeException.Create(aValue, 0, 8*aSize-1);
result := ((PByte(@aSet)[aValue shr 3] and (1 shl (aValue and 7))) <> 0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class procedure TutlSetHelperBase.SetValue(var aSet; const aSize: Integer; const aValue: Integer);
begin
result := ((PByte(@aSet)[Integer(aEnum) shr 3] and (1 shl (Integer(aEnum) and 7))) <> 0);
if (aValue >= 8*aSize) then
raise EOutOfRangeException.Create(aValue, 0, 8*aSize-1);
PByte(@aSet)[aValue shr 3] := PByte(@aSet)[aValue shr 3] or (1 shl (aValue and 7));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class procedure TutlSetHelper.SetValue(var aSet: TSet; aEnum: TEnum);
class procedure TutlSetHelperBase.ClearValue(var aSet; const aSize: Integer; const aValue: Integer);
begin
PByte(@aSet)[Integer(aEnum) shr 3] := PByte(@aSet)[Integer(aEnum) shr 3] or (1 shl (Integer(aEnum) and 7));
if (aValue >= 8*aSize) then
raise EOutOfRangeException.Create(aValue, 0, 8*aSize-1);
PByte(@aSet)[aValue shr 3] := PByte(@aSet)[aValue shr 3] and not (1 shl (aValue and 7));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class procedure TutlSetHelper.ClearValue(var aSet: TSet; aEnum: TEnum);
class procedure TutlSetHelperBase.RegisterEnumHelper(const aHelper: TutlEnumHelperBaseClass);
begin
PByte(@aSet)[Integer(aEnum) shr 3] := PByte(@aSet)[Integer(aEnum) shr 3] and not (1 shl (Integer(aEnum) and 7));
fEnumHelpers.Add(ClassName, aHelper);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelper.ToString(const aValue: TSet; const aSeperator: String): String;
class procedure TutlSetHelperBase.UnregisterEnumHelper;
begin
fEnumHelpers.Remove(ClassName);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelperBase.ToString(const aSet; const aSize: Integer; const aSeparator: String;
const aAllowOrd: Boolean): String;
var
e: TEnum;
i: Integer;
h: TutlEnumHelperBaseClass;
arr: TutlEnumHelperBase.TIntArray;
begin
h := EnumHelper;
if not Assigned(h) then
raise EInvalidOperation.Create('enum helper class is not set');
result := '';
for e in TEnumHelper.Values do begin
if IsSet(aValue, e) then begin
arr := h.IntValues;
for i in arr do begin
if IsSet(aSet, aSize, i) then begin
if result > '' then
result := result + aSeperator;
result := result + TEnumHelper.ToString(e);
result := result + aSeparator;
result := result + h.ToString(i, aAllowOrd);
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelper.TryToSet(const aStr: String; out aValue: TSet): Boolean;
class function TutlSetHelperBase.TryToSet(const aStr: String; out aSet; const aSize: Integer; const aAllowOrd: Boolean): Boolean;
begin
result := TryToSet(aStr, ',', aValue);
result := TryToSet(aStr, ',', aSet, aSize, aAllowOrd);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelper.TryToSet(const aStr: String; const aSeperator: String; out aValue: TSet): Boolean;
class function TutlSetHelperBase.TryToSet(const aStr: String; const aSeparator: String; out aSet; const aSize: Integer; const aAllowOrd: Boolean): Boolean;
var
i, j: Integer;
i, j, e: Integer;
s: String;
e: TEnum;
h: TutlEnumHelperBaseClass;
begin
if (aSeperator = '') then
raise EArgumentException.Create('''aSeperator'' can not be empty');
if (aSeparator = '') then
raise EArgumentException.Create('''aSeparator'' can not be empty');
h := EnumHelper;
if not Assigned(h) then
raise EInvalidOperation.Create('enum helper class is not set');

result := true;
aValue := [];
i := 1;
j := 1;
i := 1;
j := 1;

FillByte(aSet{%H-}, aSize, 0);
while (i <= Length(aStr)) do begin
if (Copy(aStr, i, Length(aSeperator)) = aSeperator) then begin
if (Copy(aStr, i, Length(aSeparator)) = aSeparator) then begin
s := Trim(copy(aStr, j, i - j));
if (s <> '') then begin
result := result and TEnumHelper.TryToEnum(s, e);
result := result and h.TryToEnum(s, e);
if not result then
exit;
SetValue(aValue, e);
j := i + Length(aSeperator);
SetValue(aSet, aSize, e);
j := i + Length(aSeparator);
end;
end;
inc(i);
@@ -1711,42 +1979,104 @@ begin

s := Trim(copy(aStr, j, i - j));
if (s <> '') then begin
result := result and TEnumHelper.TryToEnum(s, e);
result := result and h.TryToEnum(s, e);
if not result then
exit;
SetValue(aValue, e);
end
SetValue(aSet, aSize, e);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelperBase.Compare(const aSet1; const aSet2; const aSize: Integer): Integer;
var
e: Integer;
h: TutlEnumHelperBaseClass;
begin
h := EnumHelper;
if not Assigned(h) then
raise EInvalidOperation.Create('enum helper class is not set');

result := 0;
for e in h.IntValues do begin
if IsSet(aSet1, aSize, e) and not IsSet(aSet2, aSize, e) then begin
result := 1;
break;
end else
if not IsSet(aSet1, aSize, e) and IsSet(aSet2, aSize, e) then begin
result := -1;
break;
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelperBase.EnumHelper: TutlEnumHelperBaseClass;
begin
result := fEnumHelpers[ClassName];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class constructor TutlSetHelperBase.Initialize;
begin
fEnumHelpers := TEnumHelperMap.Create(true, true);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class destructor TutlSetHelperBase.Finalize;
begin
FreeAndNil(fEnumHelpers);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlSetHelper/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelper.ToString(const aValue: TSet; const aSeparator: String; const aAllowOrd: Boolean): String;
begin
result := ToString(aValue, SizeOf(aValue), aSeparator, aAllowOrd);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelper.TryToSet(const aStr: String; out aValue: TSet; const aAllowOrd: Boolean): Boolean;
begin
result := TryToSet(aStr, ',', aValue, SizeOf(aValue), aAllowOrd);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelper.TryToSet(const aStr: String; const aSeparator: String; out aValue: TSet; const aAllowOrd: Boolean): Boolean;
begin
result := TryToSet(aStr, aSeparator, aValue, SizeOf(aValue), aAllowOrd);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelper.ToSet(const aStr: String; const aDefault: TSet): TSet;
class function TutlSetHelper.ToSet(const aStr: String; const aDefault: TSet; const aAllowOrd: Boolean): TSet;
begin
if not TryToSet(aStr, result) then
if not TryToSet(aStr, ',', result, SizeOf(result), aAllowOrd) then
result := aDefault;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelper.ToSet(const aStr: String): TSet;
class function TutlSetHelper.ToSet(const aStr: String; const aAllowOrd: Boolean): TSet;
begin
if not TryToSet(aStr, result) then
if not TryToSet(aStr, ',', result, SizeOf(result), aAllowOrd) then
raise EEnumConvertException.CreateFmt('"%s" is an invalid value', [aStr]);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlSetHelper.Compare(const aSet1, aSet2: TSet): Integer;
var
e: TEnum;
begin
result := 0;
for e in TEnumHelper.Values do begin
if IsSet(aSet1, e) and not IsSet(aSet2, e) then begin
result := 1;
break;
end else if not IsSet(aSet1, e) and IsSet(aSet2, e) then begin
result := -1;
break;
end;
end;
result := Compare(aSet1, aSet2, SizeOf(aSet1));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class constructor TutlSetHelper.Initialize;
begin
RegisterEnumHelper(TEnumHelper);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class destructor TutlSetHelper.Finalize;
begin
UnregisterEnumHelper();
end;

end.


+ 496
- 0
uutlStored.pas View File

@@ -0,0 +1,496 @@
unit uutlStored;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils,
DOM,
uutlMCF;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
IutlStored = interface(IUnknown)
['{1AAA369A-B938-4430-AFAA-E4B5FD9D5A8D}']
function GetStoredCount(): Integer; // returns the number of stored values
function GetStoredName (const aIndex: Integer): String; // returns the name of the stored value
function GetStoredValue(const aIndex: Integer): Variant; // returns the stored value as string
procedure SetStoredValue(const aIndex: Integer; const aValue: Variant); // set the stored value
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
IutlStoredWriter = interface(IUnknown)
['{AE592B18-DDC2-408A-BB26-DAA24E2A7C34}']
procedure Write(constref aObj: IutlStored; const aStream: TStream);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
IutlStoredReader = interface(IUnknown)
['{B596DCD9-5F34-45F9-82C7-790F5407E1E8}']
function Read(constref aObj: IutlStored; const aStream: TStream): Boolean;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStoredWriter = class(
TInterfacedObject
, IutlStoredWriter)

public { IutlStoredWriter }
procedure Write(constref aObj: IutlStored; const aStream: TStream); virtual;
constructor Create; virtual;

public
class function CreateWriter: IutlStoredWriter;
end;
TutlStoredWriterClass = class of TutlStoredWriter;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStoredReader = class(
TInterfacedObject
, IutlStoredReader)

public { IutlStoredReader }
function Read(constref aObj: IutlStored; const aStream: TStream): Boolean; virtual;
constructor Create; virtual;

public
class function CreateReader: IutlStoredReader;
end;
TutlStoredReaderClass = class of TutlStoredReader;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStoredXmlWriter = class(TutlStoredWriter)
private
fRootName: String;

protected
property RootName: String read fRootName write fRootName;

procedure Write(constref aObj: IutlStored; const aElement: TDOMElement); virtual;

public
procedure Write(constref aObj: IutlStored; const aStream: TStream); override;
constructor Create; override;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStoredXmlReader = class(TutlStoredReader)
protected
function CreateObject(constref aOwner: IutlStored; const aElement: TDOMElement): IutlStored; virtual;
procedure Read (constref aObj: IutlStored; const aElement: TDOMElement); virtual;

public
function Read(constref aObj: IutlStored; const aStream: TStream): Boolean; override;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStoredMcfWriter = class(TutlStoredWriter)
protected
procedure Write(constref aObj: IutlStored; const aName: String; const aParent: TutlMCFSection); virtual;
procedure Write(constref aObj: IutlStored; const aSection: TutlMCFSection); virtual;

public
procedure Write(constref aObj: IutlStored; const aStream: TStream); override;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlStoredMcfReader = class(TutlStoredReader)
private
function TryFindStoredName(const aObj: IutlStored; const aName: String; out aIndex: Integer): Boolean;

protected
function CreateObject(constref aOwner: IutlStored; const aName: String; const aParent: TutlMCFSection): IutlStored; virtual;
function ReadValue (constref aOwner: IutlStored; const aName: String; const aParent: TutlMCFSection): Variant; virtual;
procedure ReadSection (constref aObj: IutlStored; const aSection: TutlMCFSection); virtual;

public
function Read(constref aObj: IutlStored; const aStream: TStream): Boolean; override;
end;

implementation

uses
XMLWrite, XMLRead, variants,
uutlXmlHelper, uutlSyncObjs;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStoredWriter//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredWriter.Write(constref aObj: IutlStored; const aStream: TStream);
begin
// DUMMY
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlStoredWriter.Create;
begin
inherited Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlStoredWriter.CreateWriter: IutlStoredWriter;
begin
result := TutlStoredWriterClass(ClassType).Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStoredReader//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredReader.Read(constref aObj: IutlStored; const aStream: TStream): Boolean;
begin
result := false;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlStoredReader.Create;
begin
inherited Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlStoredReader.CreateReader: IutlStoredReader;
begin
result := TutlStoredReaderClass(ClassType).Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStoredXmlWriter///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredXmlWriter.Write(constref aObj: IutlStored; const aElement: TDOMElement);
var
i, c: Integer;
s: DOMString;
v: Variant;
vt: TVarType;
intf: IUnknown;
lock: IutlLockable;
stored: IutlStored;
begin
if not Supports(aObj, IutlLockable, lock) then
lock := nil;
if Assigned(lock) then
lock.Lock;
try
with TutlXmlHelper.Create(aElement) do begin
c := aObj.GetStoredCount;
for i := 0 to c-1 do begin
s := DOMString(aObj.GetStoredName(i));
v := aObj.GetStoredValue(i);
vt := VarType(v);
case vt of
varunknown: begin
intf := IUnknown(v);
if Supports(intf, IutlStored, stored) then
Write(stored, AppendNode(s));
end;
else
SetAttribString(s, String(v));
end;
end;
end;
finally
if Assigned(lock) then
lock.Unlock;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredXmlWriter.Write(constref aObj: IutlStored; const aStream: TStream);
var
doc: TXMLDocument;
root: TDOMElement;
begin
doc := TXMLDocument.Create;
try
root := doc.CreateElement(DOMString(fRootName));
doc.AppendChild(root);
Write(aObj, root);
WriteXMLFile(doc, aStream);
finally
FreeAndNil(doc);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlStoredXmlWriter.Create;
begin
inherited Create;
fRootName := 'root';
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStoredXmlReader///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredXmlReader.CreateObject(constref aOwner: IutlStored; const aElement: TDOMElement): IutlStored;
begin
result := nil;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredXmlReader.Read(constref aObj: IutlStored; const aElement: TDOMElement);
var
i, j: Integer;
s: DOMString;
v: Variant;
vt: TVarType;
intf: IUnknown;
stored: IutlStored;
attribs: TDOMNamedNodeMap;
attrib: TDOMNode;
el: TDOMElement;

function TryFindStoredName(const aName: String; out aIndex: Integer): Boolean;
var
c, i: Integer;
begin
result := true;
c := aObj.GetStoredCount;
for i := 0 to c-1 do begin
aIndex := i;
if (aObj.GetStoredName(aIndex) = aName) then
exit;
end;
aIndex := -1;
result := false;
end;

begin
with TutlXmlHelper.Create(aElement) do begin
attribs := aElement.Attributes;
for i := 0 to attribs.Length-1 do begin
attrib := attribs.Item[i];
s := attrib.NodeName;
v := attrib.TextContent;
if not TryFindStoredName(String(s), j) then
continue;
aObj.SetStoredValue(j, v);
end;

for el in Nodes('') do begin
s := el.NodeName;
v := Unassigned;
stored := nil;
if TryFindStoredName(String(s), j) then begin
v := aObj.GetStoredValue(j);
vt := VarType(v);
case vt of
varunknown: begin
intf := v;
if not Supports(intf, IutlStored, stored) then
stored := nil;
end;
else
raise EInvalidOperation.Create('expected ' + String(s) + ' to be an stored object');
end;
end else
j := -1;
if not Assigned(stored) then
stored := CreateObject(aObj, el);
if not Assigned(stored) then
continue;
Read(stored, el);
aObj.SetStoredValue(j, stored);
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredXmlReader.Read(constref aObj: IutlStored; const aStream: TStream): Boolean;
var
doc: TXMLDocument;
p: Int64;
begin
p := aStream.Position;
doc := TXMLDocument.Create;
try try
result := true;
ReadXMLFile(doc, aStream);
Read(aObj, (doc.FirstChild as TDOMElement));
except
result := false;
aStream.Position := p;
end;
finally
FreeAndNil(doc);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStoredMcfWriter///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredMcfWriter.Write(constref aObj: IutlStored; const aName: String; const aParent: TutlMCFSection);
begin
Write(aObj, aParent.Section(aName));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredMcfWriter.Write(constref aObj: IutlStored; const aSection: TutlMCFSection);
var
lock: IutlLockable;
i, c: Integer;
s: String;
v: Variant;
vt: TVarType;
intf: IUnknown;
stored: IutlStored;
begin
if not Supports(aObj, IutlLockable, lock) then
lock := nil;
if Assigned(lock) then
lock.Lock;
try
c := aObj.GetStoredCount;
for i := 0 to c-1 do begin
s := aObj.GetStoredName (i);
v := aObj.GetStoredValue(i);
vt := VarType(v);
case vt of
varunknown: begin
intf := IUnknown(v);
if Supports(intf, IutlStored, stored) then
Write(stored, s, aSection);
end;

varboolean:
aSection.SetBool(s, v);

{$IFNDEF FPUNONE}
varsingle,
vardouble:
aSection.SetFloat(s, v);
{$ENDIF}

vardecimal,
varshortint,
varbyte,
varword,
varlongword,
varint64,
varqword,
varsmallint,
varinteger:
aSection.SetInt(s, v);
else
aSection.SetString(s, String(v));
end;
end;
finally
if Assigned(lock) then
lock.Unlock;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredMcfWriter.Write(constref aObj: IutlStored; const aStream: TStream);
var
mcf: TutlMCFFile;
begin
mcf := TutlMCFFile.Create(nil);
try
Write(aObj, mcf);
mcf.SaveToStream(aStream);
finally
FreeAndNil(mcf);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStoredMcfReader///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredMcfReader.TryFindStoredName(const aObj: IutlStored; const aName: String; out aIndex: Integer): Boolean;
var
c, i: Integer;
begin
result := true;
c := aObj.GetStoredCount;
for i := 0 to c-1 do begin
aIndex := i;
if (aObj.GetStoredName(aIndex) = aName) then
exit;
end;
aIndex := -1;
result := false;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredMcfReader.CreateObject(constref aOwner: IutlStored; const aName: String; const aParent: TutlMCFSection): IutlStored;
begin
result := nil;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredMcfReader.ReadValue(constref aOwner: IutlStored; const aName: String; const aParent: TutlMCFSection): Variant;
begin
result := aParent.GetString(aName);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStoredMcfReader.ReadSection(constref aObj: IutlStored; const aSection: TutlMCFSection);
var
i, j, c: Integer;
s: String;
v: Variant;
vt: TVarType;
intf: IUnknown;
stored: IutlStored;
begin
c := aSection.ValueCount;
for i := 0 to c-1 do begin
s := aSection.ValueNameAt[i];
v := ReadValue(aObj, s, aSection);
if (VarType(v) <> varempty) and TryFindStoredName(aObj, s, j) then
aObj.SetStoredValue(j, v);
end;

c := aSection.SectionCount;
for i := 0 to c-1 do begin
s := aSection.SectionNameAt[i];
v := Unassigned;
stored := nil;
if TryFindStoredName(aObj, s, j) then begin
v := aObj.GetStoredValue(j);
vt := VarType(v);
case vt of
varunknown: begin
intf := v;
if not Supports(intf, IutlStored, stored) then
stored := nil;
end;
else
raise EInvalidOperation.Create('expected ' + s + ' to be an stored object');
end;
end else
j := -1;
if not Assigned(stored) then
stored := CreateObject(aObj, s, aSection);
if not Assigned(stored) then
continue;
ReadSection(stored, aSection.Section(s));
aObj.SetStoredValue(j, stored);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStoredMcfReader.Read(constref aObj: IutlStored; const aStream: TStream): Boolean;
var
p: Int64;
mcf: TutlMCFFile;
begin
p := aStream.Position;
mcf := TutlMCFFile.Create(nil);
try try
result := true;
mcf.LoadFromStream(aStream);
ReadSection(aObj, mcf);
except
result := false;
aStream.Position := p;
end;
finally
FreeAndNil(mcf);
end;
end;

end.


+ 105
- 0
uutlTypeInfo.pas View File

@@ -0,0 +1,105 @@
unit uutlTypeInfo;

{$mode objfpc}{$H+}
{$ModeSwitch advancedrecords}

interface

uses
Classes, SysUtils, variants;

type
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlVariantType = (
vtNull,

// boolean
vtBool,
vtByteBool,
vtWordBool,
vtLongBool,

// signed
vtShortInt,
vtSmallInt,
vtLongInt,
vtInt64,

// unsigned
vtByte,
vtWord,
vtLongWord,
vtQuadWord,

// floating point
vtSingle,
vtDouble,
vtExtended,

// characters
vtAnsiChar,
vtWideChar,

// strings
vtShortString,
vtAnsiString,
vtWideString,
vtUnicodeString,
vtUTF8String
);

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlVariant = packed record
private
function GetVarType: TutlVariantType;

public
property VarType: TutlVariantType read GetVarType;

private
case fType: TutlVariantType of
vtNull: ();

// boolean
vtBool: (fBool: Boolean);
vtByteBool: (fByteBool: ByteBool);
vtWordBool: (fWordBool: WordBool);
vtLongBool: (fLongBool: LongBool);

// signed
vtShortInt: (fShortInt: ShortInt);
vtSmallInt: (fSmallInt: SmallInt);
vtLongInt: (fLongInt: LongInt);
vtInt64: (fInt64: Int64);

// unsigned
vtByte: (fByte: Byte);
vtWord: (fWord: Word);
vtLongWord: (fLongWord: LongWord);
vtQuadWord: (fQuadWord: QWord);

// floating point
vtSingle: (fFloat: Single);
vtDouble: (fDouble: Double);
vtExtended: (fExtended: Extended);

// characters
vtAnsiChar: (fAnsiChar: AnsiChar);
vtWideChar: (fWideChar: WideChar);

// strings
vtShortString: (fShortString: ShortString);
end;

implementation

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVariant////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlVariant.GetVarType: TutlVariantType;
begin
result := fType;
end;

end.


+ 206
- 0
uutlVariantEnum.pas View File

@@ -0,0 +1,206 @@
unit uutlVariantEnum;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, variants,
uutlGenerics;

function VarEnum: TVarType; inline;
function VarIsEnum(const aValue: Variant): Boolean; inline;
function VarAsEnum(const aValue: Variant): Variant; inline;
function VarMakeEnum(const aValue: Integer): Variant;
function VarMakeEnum(const aValue: Integer; const aHelper: TutlEnumHelperBaseClass): Variant;
function VarGetEnumHelper(const aValue: Variant): TutlEnumHelperBaseClass;

implementation

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
PEnumVarData = ^TEnumVarData;
TEnumVarData = packed record
vType: TVarType;
case Integer of
0: (
vValue: Integer;
vHelper: TutlEnumHelperBaseClass;
);
1: (vBytes : array[0..13] of byte);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlVariantEnum = class(TCustomVariantType)
public
procedure Cast (var Dest: TVarData; const Source: TVarData); override;
procedure CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); override;
procedure Copy (var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;
procedure Clear (var V: TVarData); override;
end;

var
VariantEnum: TutlVariantEnum;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarEnum: TVarType;
begin
result := VariantEnum.VarType;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarIsEnum(const aValue: Variant): Boolean;
begin
result := (VarType(aValue) = VariantEnum.VarType);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarAsEnum(const aValue: Variant): Variant;
begin
if not VarIsEnum(aValue)
then VarCast(result, aValue, VarEnum)
else result := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarMakeEnum(const aValue: Integer): Variant;
begin
result := VarMakeEnum(aValue, nil);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarMakeEnum(const aValue: Integer; const aHelper: TutlEnumHelperBaseClass): Variant;
begin
with PEnumVarData(@TVarData(result))^ do begin
vType := VariantEnum.VarType;
vValue := aValue;
vHelper := aHelper;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarGetEnumHelper(const aValue: Variant): TutlEnumHelperBaseClass;
begin
if not VarIsEnum(aValue) then
VarBadTypeError;
result := PEnumVarData(@TVarData(aValue))^.vHelper;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVariantEnum///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantEnum.Cast(var Dest: TVarData; const Source: TVarData);

function CheckValue(const aValue: Integer): Boolean;
var
i: Integer;
begin
with PEnumVarData(@Dest)^ do begin
result := true;
if not Assigned(vHelper) then
exit;
for i in vHelper.IntValues do
if (i = aValue) then
exit;
result := false;
end;
end;

var
LSource: TVarData;
begin
if (Dest.vtype <> VariantEnum.VarType) then
RaiseCastError;
VarDataInit(LSource{%H-});
try
VarDataCopyNoInd(LSource, Source);
case LSource.vtype of
varsmallint,
varinteger,
vardecimal,
varshortint,
varbyte,
varword,
varlongword,
varint64,
varqword: with PEnumVarData(@Dest)^ do begin
if not CheckValue(Variant(LSource)) then
RaiseCastError;
vValue := Variant(Source);
end;
else
with PEnumVarData(@Dest)^ do begin
if not Assigned(vHelper) then
RaiseCastError;
if not vHelper.TryToEnum(Variant(LSource), vValue, true) then
RaiseCastError;
end;
end;
finally
VarDataClear(LSource);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantEnum.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
var
tmp: TVarData;
begin
if (Source.vtype <> VarType) then
RaiseCastError;
with PEnumVarData(@Source)^ do begin
case aVarType of
varolestr:
if Assigned(vHelper) then begin
VarDataFromOleStr(Dest, WideString(vHelper.ToString(vValue, true)));
exit;
end;
varstring:
if Assigned(vHelper) then begin
VarDataFromStr(Dest, vHelper.ToString(vValue, true));
exit;
end;
end;
VarDataInit(tmp{%H-});
try
tmp.vtype := varinteger;
tmp.vinteger := vValue;
VarDataCastTo(Dest, tmp, aVarType);
finally
VarDataClear(tmp);
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantEnum.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
var
src, dst: PEnumVarData;
begin
if (Dest.vtype <> varempty) and (Dest.vtype <> Source.vtype) then
RaiseInvalidOp;
src := PEnumVarData(@Source);
dst := PEnumVarData(@Dest);
dst^.vType := src^.vType;
dst^.vHelper := src^.vHelper;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantEnum.Clear(var V: TVarData);
begin
// DUMMY
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
initialization
VariantEnum := TutlVariantEnum.Create;

finalization
FreeAndNil(VariantEnum);

end.


+ 149
- 0
uutlVariantObject.pas View File

@@ -0,0 +1,149 @@
unit uutlVariantObject;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, variants;

function VarObject: TVarType; inline;
function VarIsObject(const aValue: Variant): Boolean; inline;
function VarAsObject(const aValue: Variant): Variant; inline;

operator :=(const aValue: TObject): Variant; inline;
operator :=(const aValue: Variant): TObject; inline;

implementation

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlVariantObject = class(TCustomVariantType)
public
function IsClear (const V: TVarData): Boolean; override;
procedure Cast (var Dest: TVarData; const Source: TVarData); override;
procedure CastTo (var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); override;
procedure Clear (var V: TVarData); override;
procedure Copy (var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;

public
class function FromObject(const aObj: TObject): Variant;
class function ToObject (const aVar: Variant): TObject;
end;

var
VariantObject: TutlVariantObject;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarObject: TVarType;
begin
result := VariantObject.VarType;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarIsObject(const aValue: Variant): Boolean;
begin
result := (TVarData(aValue).vtype = VarObject);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarAsObject(const aValue: Variant): Variant;
begin
if not VarIsObject(aValue)
then VarCast(result, aValue, VarObject)
else result := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
operator := (const aValue: TObject): Variant;
begin
result := TutlVariantObject.FromObject(aValue);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
operator := (const aValue: Variant): TObject;
begin
result := TutlVariantObject.ToObject(aValue);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVariantObject/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlVariantObject.IsClear(const V: TVarData): Boolean;
begin
result := (V.vpointer = nil);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantObject.Cast(var Dest: TVarData; const Source: TVarData);
begin
RaiseCastError;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantObject.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
var
tmp: TVarData;
begin
if (Source.vtype <> VarType) then
RaiseCastError;
case aVarType of
varolestr:
VarDataFromOleStr(Dest, WideString(Format('$%p', [Source.vpointer])));
varstring:
VarDataFromStr(Dest, Format('$%p', [Source.vpointer]));
else
VarDataInit(tmp{%H-});
try
tmp.vtype := varqword;
tmp.vqword := QWord(Source.vpointer);
VarDataCastTo(Dest, tmp, aVarType);
finally
VarDataClear(tmp);
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantObject.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
begin
if (Dest.vtype <> varempty) and (Dest.vtype <> Source.vtype) then
RaiseInvalidOp;
Dest := Source;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantObject.Clear(var V: TVarData);
begin
V.vpointer := nil;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlVariantObject.FromObject(const aObj: TObject): Variant;
begin
TVarData(result).vtype := VarObject;
TVarData(result).vpointer := aObj;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlVariantObject.ToObject(const aVar: Variant): TObject;
var
v: Variant;
begin
v := VarAsObject(aVar);
result := TObject(TVarData(v).vpointer);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
initialization
VariantObject := TutlVariantObject.Create;

finalization
FreeAndNil(VariantObject);

end.


+ 157
- 0
uutlVariantProperty.pas View File

@@ -0,0 +1,157 @@
unit uutlVariantProperty;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, variants, typinfo;

function VarProperty: TVarType; inline;
function VarIsProperty(const aValue: Variant): Boolean; inline;
function VarAsProperty(const aValue: Variant): Variant; inline;

operator :=(const aValue: PPropInfo): Variant;
operator :=(const aValue: Variant): PPropInfo;

implementation

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlVariantPropInfo = class(TCustomVariantType)
public
function IsClear (const V: TVarData): Boolean; override;
procedure Cast (var Dest: TVarData; const Source: TVarData); override;
procedure CastTo (var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); override;
procedure Clear (var V: TVarData); override;
procedure Copy (var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;

public
class function FromPropInfo(const aPropInfo: PPropInfo): Variant;
class function ToPropInfo (const aValue: Variant): PPropInfo;
end;

var
VariantProperty: TutlVariantPropInfo;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarProperty: TVarType;
begin
result := VariantProperty.VarType;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarIsProperty(const aValue: Variant): Boolean;
begin
result := (VarType(aValue) = VarProperty);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarAsProperty(const aValue: Variant): Variant;
begin
if not VarIsProperty(aValue)
then VarCast(result, aValue, VarProperty)
else result := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
operator := (const aValue: PPropInfo): Variant;
begin
result := TutlVariantPropInfo.FromPropInfo(aValue);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
operator := (const aValue: Variant): PPropInfo;
begin
result := TutlVariantPropInfo.ToPropInfo(aValue);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVariantProperty///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlVariantPropInfo.IsClear(const V: TVarData): Boolean;
begin
result := not Assigned(V.vpointer);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantPropInfo.Cast(var Dest: TVarData; const Source: TVarData);
begin
RaiseCastError;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantPropInfo.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
begin
if (Source.vtype <> VarType) then
RaiseCastError;
case aVarType of
varolestr:
if IsClear(Source)
then VarDataFromOleStr(Dest, '')
else VarDataFromOleStr(Dest, WideString(PPropInfo(Source.vpointer)^.Name));
varstring:
if IsClear(Source)
then VarDataFromStr(Dest, '')
else VarDataFromStr(Dest, PPropInfo(Source.vpointer)^.Name);
else
RaiseCastError;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantPropInfo.Clear(var V: TVarData);
begin
if Assigned(V.vpointer) then begin
Dispose(PPropInfo(V.vpointer));
V.vpointer := nil;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantPropInfo.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
begin
if (Dest.vtype <> varempty) and (Dest.vtype <> Source.vtype) then
RaiseInvalidOp;
Dest.vtype := Source.vtype;
if Assigned(Source.vpointer) then begin
if not Assigned(Dest.vpointer) then
Dest.vpointer := New(PPropInfo);
PPropInfo(Dest.vpointer)^ := PPropInfo(Source.vpointer)^;
end else if Assigned(Dest.vpointer) then begin
Dispose(PPropInfo(Dest.vpointer));
Dest.vpointer := nil;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlVariantPropInfo.FromPropInfo(const aPropInfo: PPropInfo): Variant;
begin
with TVarData(result) do begin
vPointer := new(PPropInfo);
vType := VarProperty;
PPropInfo(vPointer)^ := aPropInfo^;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlVariantPropInfo.ToPropInfo(const aValue: Variant): PPropInfo;
begin
with TVarData(aValue) do begin
result := PPropInfo(vpointer);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
initialization
VariantProperty := TutlVariantPropInfo.Create;

finalization
FreeAndNil(VariantProperty);

end.


+ 172
- 0
uutlVariantSet.pas View File

@@ -0,0 +1,172 @@
unit uutlVariantSet;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, variants,
uutlGenerics;

function VarSet: TVarType; inline;
function VarIsSet(const aValue: Variant): Boolean; inline;
function VarAsSet(const aValue: Variant): Variant; inline;
function VarMakeSet(const aValue; const aSize: Integer): Variant;
function VarMakeSet(const aValue; const aSize: Integer; const aHelper: TutlSetHelperBaseClass): Variant;
function VarGetSetHelper(const aValue: Variant): TutlSetHelperBaseClass;

implementation

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
PSetData = ^TSetData;
TSetData = packed record
Data: array[0..31] of Byte;
Size: Integer;
Helper: TutlSetHelperBaseClass;
end;

PSetVarData = ^TSetVarData;
TSetVarData = packed record
vType: TVarType;
case Integer of
0: (vData: PSetData);
1: (vBytes: array[0..13] of Byte);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TutlVariantSet = class(TCustomVariantType)
public
procedure Cast (var Dest: TVarData; const Source: TVarData); override;
procedure CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); override;
procedure Copy (var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;
procedure Clear (var V: TVarData); override;
end;

var
VariantSet: TutlVariantSet;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarSet: TVarType;
begin
result := VariantSet.VarType;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarIsSet(const aValue: Variant): Boolean;
begin
result := (VarType(aValue) = VarSet);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarAsSet(const aValue: Variant): Variant;
begin
if not VarIsSet(aValue)
then VarCast(result, aValue, VarSet)
else result := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarMakeSet(const aValue; const aSize: Integer): Variant;
begin
result := VarMakeSet(aValue, aSize, nil);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarMakeSet(const aValue; const aSize: Integer; const aHelper: TutlSetHelperBaseClass): Variant;
begin
with PSetVarData(@TVarData(result))^ do begin
New (vData);
FillByte(vData^.Data, SizeOf(vData^.Data), 0);
Move (aValue, vData^.Data, aSize);
vType := VarSet;
vData^.Size := aSize;
vData^.Helper := aHelper;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarGetSetHelper(const aValue: Variant): TutlSetHelperBaseClass;
begin
if not VarIsSet(aValue) then
VarBadTypeError;
with PSetVarData(@TVarData(aValue))^ do begin
if not Assigned(vData) then
VarInvalidOp;
result := vData^.Helper;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVariantSet////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantSet.Cast(var Dest: TVarData; const Source: TVarData);
begin
if (Dest.vType <> VariantSet.VarType) then
RaiseCastError;
with PSetVarData(@Dest)^ do begin
if not Assigned(vData^.Helper) then
RaiseCastError;
if not vData^.Helper.TryToSet(Variant(Source), vData^.Data, vData^.Size) then
RaiseCastError;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantSet.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
begin
if (Source.vtype <> VarType) then
RaiseCastError;
with PSetVarData(@Source)^ do begin
if not Assigned(vData^.Helper) then
RaiseCastError;
case aVarType of
varolestr:
VarDataFromOleStr(Dest, WideString(vData^.Helper.ToString(vData^.Data, vData^.Size)));
varstring:
VarDataFromStr(Dest, vData^.Helper.ToString(vData^.Data, vData^.Size));
else
RaiseCastError;
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantSet.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
var
src, dst: PSetVarData;
begin
if (Dest.vtype <> varempty) and (Dest.vtype <> Source.vtype) then
RaiseInvalidOp;
src := PSetVarData(@Source);
dst := PSetVarData(@Dest);
dst^.vType := src^.vType;
if not Assigned(dst^.vData) then
new(dst^.vData);
dst^.vData^ := src^.vData^;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantSet.Clear(var V: TVarData);
begin
with PSetVarData(@V)^ do begin
if Assigned(vData) then begin
Dispose(vData);
vData := nil;
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
initialization
VariantSet := TutlVariantSet.Create;

finalization
FreeAndNil(VariantSet);

end.


+ 8
- 4
uutlXmlHelper.pas View File

@@ -217,13 +217,17 @@ end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlNodeEnumerator.MoveNext: Boolean;
var
c: Integer;
begin
c := fParent.ChildNodes.Count;
repeat
inc(fIndex)
until (fIndex {%H-}>= fParent.ChildNodes.Count)
or ( (fName = '')
or (fName = fParent.ChildNodes[fIndex].NodeName));
result := (fIndex {%H-}< fParent.ChildNodes.Count);
until (fIndex >= c)
or ( (fParent.ChildNodes[fIndex] is TDOMElement)
and ( (fName = '')
or (fName = fParent.ChildNodes[fIndex].NodeName)));
result := (fIndex < c);
end;

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////


Loading…
Cancel
Save