Subversion Repositories currency_converter

Compare Revisions

No changes between revisions

Regard whitespace Rev 1 → Rev 2

/trunk/DLL/CurConv.bdsproj
0,0 → 1,176
<?xml version="1.0" encoding="utf-8"?>
<BorlandProject>
<PersonalityInfo>
<Option>
<Option Name="Personality">Delphi.Personality</Option>
<Option Name="ProjectType">VCLApplication</Option>
<Option Name="Version">1.0</Option>
<Option Name="GUID">{DF243950-30E5-47DF-98D8-73D40B947862}</Option>
</Option>
</PersonalityInfo>
<Delphi.Personality>
<Source>
<Source Name="MainSource">CurConv.dpr</Source>
</Source>
<FileVersion>
<FileVersion Name="Version">7.0</FileVersion>
</FileVersion>
<Compiler>
<Compiler Name="A">8</Compiler>
<Compiler Name="B">0</Compiler>
<Compiler Name="C">1</Compiler>
<Compiler Name="D">1</Compiler>
<Compiler Name="E">0</Compiler>
<Compiler Name="F">0</Compiler>
<Compiler Name="G">1</Compiler>
<Compiler Name="H">1</Compiler>
<Compiler Name="I">1</Compiler>
<Compiler Name="J">0</Compiler>
<Compiler Name="K">0</Compiler>
<Compiler Name="L">1</Compiler>
<Compiler Name="M">0</Compiler>
<Compiler Name="N">1</Compiler>
<Compiler Name="O">1</Compiler>
<Compiler Name="P">1</Compiler>
<Compiler Name="Q">0</Compiler>
<Compiler Name="R">0</Compiler>
<Compiler Name="S">0</Compiler>
<Compiler Name="T">0</Compiler>
<Compiler Name="U">0</Compiler>
<Compiler Name="V">1</Compiler>
<Compiler Name="W">0</Compiler>
<Compiler Name="X">1</Compiler>
<Compiler Name="Y">1</Compiler>
<Compiler Name="Z">1</Compiler>
<Compiler Name="ShowHints">True</Compiler>
<Compiler Name="ShowWarnings">True</Compiler>
<Compiler Name="UnitAliases">WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;</Compiler>
<Compiler Name="NamespacePrefix"></Compiler>
<Compiler Name="GenerateDocumentation">False</Compiler>
<Compiler Name="DefaultNamespace"></Compiler>
<Compiler Name="SymbolDeprecated">True</Compiler>
<Compiler Name="SymbolLibrary">True</Compiler>
<Compiler Name="SymbolPlatform">True</Compiler>
<Compiler Name="SymbolExperimental">True</Compiler>
<Compiler Name="UnitLibrary">True</Compiler>
<Compiler Name="UnitPlatform">True</Compiler>
<Compiler Name="UnitDeprecated">True</Compiler>
<Compiler Name="UnitExperimental">True</Compiler>
<Compiler Name="HResultCompat">True</Compiler>
<Compiler Name="HidingMember">True</Compiler>
<Compiler Name="HiddenVirtual">True</Compiler>
<Compiler Name="Garbage">True</Compiler>
<Compiler Name="BoundsError">True</Compiler>
<Compiler Name="ZeroNilCompat">True</Compiler>
<Compiler Name="StringConstTruncated">True</Compiler>
<Compiler Name="ForLoopVarVarPar">True</Compiler>
<Compiler Name="TypedConstVarPar">True</Compiler>
<Compiler Name="AsgToTypedConst">True</Compiler>
<Compiler Name="CaseLabelRange">True</Compiler>
<Compiler Name="ForVariable">True</Compiler>
<Compiler Name="ConstructingAbstract">True</Compiler>
<Compiler Name="ComparisonFalse">True</Compiler>
<Compiler Name="ComparisonTrue">True</Compiler>
<Compiler Name="ComparingSignedUnsigned">True</Compiler>
<Compiler Name="CombiningSignedUnsigned">True</Compiler>
<Compiler Name="UnsupportedConstruct">True</Compiler>
<Compiler Name="FileOpen">True</Compiler>
<Compiler Name="FileOpenUnitSrc">True</Compiler>
<Compiler Name="BadGlobalSymbol">True</Compiler>
<Compiler Name="DuplicateConstructorDestructor">True</Compiler>
<Compiler Name="InvalidDirective">True</Compiler>
<Compiler Name="PackageNoLink">True</Compiler>
<Compiler Name="PackageThreadVar">True</Compiler>
<Compiler Name="ImplicitImport">True</Compiler>
<Compiler Name="HPPEMITIgnored">True</Compiler>
<Compiler Name="NoRetVal">True</Compiler>
<Compiler Name="UseBeforeDef">True</Compiler>
<Compiler Name="ForLoopVarUndef">True</Compiler>
<Compiler Name="UnitNameMismatch">True</Compiler>
<Compiler Name="NoCFGFileFound">True</Compiler>
<Compiler Name="ImplicitVariants">True</Compiler>
<Compiler Name="UnicodeToLocale">True</Compiler>
<Compiler Name="LocaleToUnicode">True</Compiler>
<Compiler Name="ImagebaseMultiple">True</Compiler>
<Compiler Name="SuspiciousTypecast">True</Compiler>
<Compiler Name="PrivatePropAccessor">True</Compiler>
<Compiler Name="UnsafeType">False</Compiler>
<Compiler Name="UnsafeCode">False</Compiler>
<Compiler Name="UnsafeCast">False</Compiler>
<Compiler Name="OptionTruncated">True</Compiler>
<Compiler Name="WideCharReduced">True</Compiler>
<Compiler Name="DuplicatesIgnored">True</Compiler>
<Compiler Name="UnitInitSeq">True</Compiler>
<Compiler Name="LocalPInvoke">True</Compiler>
<Compiler Name="MessageDirective">True</Compiler>
<Compiler Name="CodePage"></Compiler>
</Compiler>
<Linker>
<Linker Name="MapFile">0</Linker>
<Linker Name="OutputObjs">0</Linker>
<Linker Name="GenerateHpps">False</Linker>
<Linker Name="ConsoleApp">1</Linker>
<Linker Name="DebugInfo">False</Linker>
<Linker Name="RemoteSymbols">False</Linker>
<Linker Name="GenerateDRC">False</Linker>
<Linker Name="MinStackSize">16384</Linker>
<Linker Name="MaxStackSize">1048576</Linker>
<Linker Name="ImageBase">4194304</Linker>
<Linker Name="ExeDescription"></Linker>
</Linker>
<Directories>
<Directories Name="OutputDir">e:\_test</Directories>
<Directories Name="UnitOutputDir"></Directories>
<Directories Name="PackageDLLOutputDir"></Directories>
<Directories Name="PackageDCPOutputDir"></Directories>
<Directories Name="SearchPath"></Directories>
<Directories Name="Packages"></Directories>
<Directories Name="Conditionals"></Directories>
<Directories Name="DebugSourceDirs"></Directories>
<Directories Name="UsePackages">False</Directories>
</Directories>
<Parameters>
<Parameters Name="RunParams"></Parameters>
<Parameters Name="HostApplication"></Parameters>
<Parameters Name="Launcher"></Parameters>
<Parameters Name="UseLauncher">False</Parameters>
<Parameters Name="DebugCWD"></Parameters>
<Parameters Name="Debug Symbols Search Path"></Parameters>
<Parameters Name="LoadAllSymbols">True</Parameters>
<Parameters Name="LoadUnspecifiedSymbols">False</Parameters>
</Parameters>
<Language>
<Language Name="ActiveLang"></Language>
<Language Name="ProjectLang">$00000000</Language>
<Language Name="RootDir"></Language>
</Language>
<VersionInfo>
<VersionInfo Name="IncludeVerInfo">True</VersionInfo>
<VersionInfo Name="AutoIncBuild">False</VersionInfo>
<VersionInfo Name="MajorVer">1</VersionInfo>
<VersionInfo Name="MinorVer">0</VersionInfo>
<VersionInfo Name="Release">0</VersionInfo>
<VersionInfo Name="Build">0</VersionInfo>
<VersionInfo Name="Debug">False</VersionInfo>
<VersionInfo Name="PreRelease">False</VersionInfo>
<VersionInfo Name="Special">False</VersionInfo>
<VersionInfo Name="Private">False</VersionInfo>
<VersionInfo Name="DLL">False</VersionInfo>
<VersionInfo Name="Locale">1033</VersionInfo>
<VersionInfo Name="CodePage">1252</VersionInfo>
</VersionInfo>
<VersionInfoKeys>
<VersionInfoKeys Name="CompanyName">ViaThinkSoft</VersionInfoKeys>
<VersionInfoKeys Name="FileDescription">Currency Converter</VersionInfoKeys>
<VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="InternalName"></VersionInfoKeys>
<VersionInfoKeys Name="LegalCopyright"></VersionInfoKeys>
<VersionInfoKeys Name="LegalTrademarks"></VersionInfoKeys>
<VersionInfoKeys Name="OriginalFilename"></VersionInfoKeys>
<VersionInfoKeys Name="ProductName">CurConv</VersionInfoKeys>
<VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="Comments"></VersionInfoKeys>
<VersionInfoKeys Name="ProgramID">com.embarcadero.CurConv</VersionInfoKeys>
</VersionInfoKeys>
</Delphi.Personality>
</BorlandProject>
/trunk/DLL/CurConv.cfg
0,0 → 1,39
-$A8
-$B-
-$C+
-$D+
-$E-
-$F-
-$G+
-$H+
-$I+
-$J-
-$K-
-$L+
-$M-
-$N+
-$O+
-$P+
-$Q-
-$R-
-$S-
-$T-
-$U-
-$V+
-$W-
-$X+
-$YD
-$Z1
-cg
-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-H+
-W+
-M
-$M16384,1048576
-K$00400000
-E"e:\_test"
-LE"C:\Users\DELL User\Documents\Borland Studio-Projekte\Bpl"
-LN"C:\Users\DELL User\Documents\Borland Studio-Projekte\Bpl"
-w-UNSAFE_TYPE
-w-UNSAFE_CODE
-w-UNSAFE_CAST
/trunk/DLL/CurConv.dpr
0,0 → 1,309
library CurConv;
 
uses
SysUtils,
Classes,
Windows,
Dialogs,
Controls,
uLkJSON in '..\RTL\uLkJSON.pas',
VtsCurConv in '..\RTL\VtsCurConv.pas';
 
{$R *.res}
 
type
TVtsCurConvFlags = type DWORD;
 
const
CONVERT_DONT_SHOW_ERRORS: TVtsCurConvFlags = 1;
CONVERT_FALLBACK_TO_CACHE: TVtsCurConvFlags = 2;
CONVERT_USE_SSL: TVtsCurConvFlags = 4;
CONVERT_CONFIRM_WEB_ACCESS: TVtsCurConvFlags = 8;
CONVERT_NO_INTERACTIVE_API_KEY_INPUT: TVtsCurConvFlags = 16;
 
const
S_VTSCONV_OK: HRESULT = $20000000; // Success, Customer defined, Facility 0, Code 0
S_VTSCONV_NOTHING: HRESULT = $20000001; // Success, Customer defined, Facility 0, Code 1
E_VTSCONV_GENERIC_FAILURE: HRESULT = $A0000000; // Failure, Customer defined, Facility 0, Code 0
E_VTSCONV_BAD_ARGS: HRESULT = $A0000001; // Failure, Customer defined, Facility 0, Code 1
E_VTSCONV_STOREDKEY_INVALID: HRESULT = $A0000002; // Failure, Customer defined, Facility 0, Code 2
E_VTSCONV_NO_STOREDKEY: HRESULT = $A0000003; // Failure, Customer defined, Facility 0, Code 3
 
function DeleteAPIKey(UserMode: BOOL; DontShowErrors: BOOL): HRESULT; stdcall;
begin
try
if TVtsCurConv.DeleteAPIKey(UserMode) then
result := S_VTSCONV_OK
else
result := S_VTSCONV_NOTHING;
except
on E: Exception do
begin
if DontShowErrors then MessageDlg(e.Message, mtError, [mbOk], 0);
result := E_VTSCONV_GENERIC_FAILURE;
end;
end;
end;
 
function WriteAPIKeyW(key: LPCWSTR; UserMode: BOOL; DontShowErrors: BOOL): HRESULT; stdcall;
begin
try
if Length(key) <> 32 then
begin
result := E_VTSCONV_BAD_ARGS;
Exit;
end;
TVtsCurConv.WriteAPIKey(TVtsCurApiKey(key), UserMode);
result := S_VTSCONV_OK;
except
on E: Exception do
begin
if DontShowErrors then MessageDlg(e.Message, mtError, [mbOk], 0);
result := E_VTSCONV_GENERIC_FAILURE;
end;
end;
end;
 
function WriteAPIKeyA(key: LPCSTR; UserMode: BOOL; DontShowErrors: BOOL): HRESULT; stdcall;
begin
try
if Length(key) <> 32 then
begin
result := E_VTSCONV_BAD_ARGS;
Exit;
end;
TVtsCurConv.WriteAPIKey(TVtsCurApiKey(key), UserMode);
result := S_VTSCONV_OK;
except
on E: Exception do
begin
if DontShowErrors then MessageDlg(e.Message, mtError, [mbOk], 0);
result := E_VTSCONV_GENERIC_FAILURE;
end;
end;
end;
 
function ReadAPIKeyW(key: LPWSTR; DontShowErrors: BOOL): HRESULT; stdcall;
var
s: WideString;
begin
try
s := WideString(TVtsCurConv.ReadAPIKey);
if s = '' then
begin
result := E_VTSCONV_NO_STOREDKEY;
Exit;
end;
if Length(s) <> 32 then
begin
result := E_VTSCONV_STOREDKEY_INVALID;
Exit;
end;
ZeroMemory(key, 33*SizeOf(WideChar));
CopyMemory(key, @s[1], 32*SizeOf(WideChar));
Result := S_VTSCONV_OK;
except
on E: Exception do
begin
if DontShowErrors then MessageDlg(e.Message, mtError, [mbOk], 0);
result := E_VTSCONV_GENERIC_FAILURE;
end;
end;
end;
 
function ReadAPIKeyA(key: LPSTR; DontShowErrors: BOOL): HRESULT; stdcall;
var
s: AnsiString;
begin
try
s := AnsiString(TVtsCurConv.ReadAPIKey);
if s = '' then
begin
result := E_VTSCONV_NO_STOREDKEY;
Exit;
end;
if Length(s) <> 32 then
begin
result := E_VTSCONV_STOREDKEY_INVALID;
Exit;
end;
ZeroMemory(key, 33*SizeOf(AnsiChar));
CopyMemory(key, @s[1], 32*SizeOf(AnsiChar));
result := S_VTSCONV_OK;
except
on E: Exception do
begin
if DontShowErrors then MessageDlg(e.Message, mtError, [mbOk], 0);
result := E_VTSCONV_GENERIC_FAILURE;
end;
end;
end;
 
function ConvertW(Value: Double; CurFrom, CurTo: LPCWSTR; MaxAge: integer;
Flags: TVtsCurConvFlags; HistoricDate: TDate): Double; stdcall;
var
x: TVtsCurConv;
begin
try
x := TVtsCurConv.Create;
try
x.Secure := Flags and CONVERT_USE_SSL <> 0;
x.MaxAgeSeconds := MaxAge;
x.ConfirmWebAccess := Flags and CONVERT_CONFIRM_WEB_ACCESS <> 0;
x.FallBackToCache := Flags and CONVERT_FALLBACK_TO_CACHE <> 0;
x.InteractiveAPIKeyInput := Flags and CONVERT_NO_INTERACTIVE_API_KEY_INPUT = 0;
result := x.Convert(value, TVtsCur(CurFrom), TVtsCur(CurTo), HistoricDate);
finally
x.Free;
end;
except
on E: Exception do
begin
if Flags and CONVERT_DONT_SHOW_ERRORS = 0 then MessageDlg(e.Message, mtError, [mbOk], 0);
result := -1;
end;
end;
end;
 
function ConvertA(Value: Double; CurFrom, CurTo: LPCSTR; MaxAge: integer;
Flags: TVtsCurConvFlags; HistoricDate: TDate): Double; stdcall;
var
x: TVtsCurConv;
begin
try
x := TVtsCurConv.Create;
try
x.Secure := Flags and CONVERT_USE_SSL <> 0;
x.MaxAgeSeconds := MaxAge;
x.ConfirmWebAccess := Flags and CONVERT_CONFIRM_WEB_ACCESS <> 0;
x.FallBackToCache := Flags and CONVERT_FALLBACK_TO_CACHE <> 0;
x.InteractiveAPIKeyInput := Flags and CONVERT_NO_INTERACTIVE_API_KEY_INPUT = 0;
result := x.Convert(value, TVtsCur(CurFrom), TVtsCur(CurTo), HistoricDate);
finally
x.Free;
end;
except
on E: Exception do
begin
if Flags and CONVERT_DONT_SHOW_ERRORS = 0 then MessageDlg(e.Message, mtError, [mbOk], 0);
result := -1;
end;
end;
end;
 
function AcceptedCurrenciesW(WriteTo: LPWSTR; MaxAge: integer; Flags: TVtsCurConvFlags;
HistoricDate: TDate): Integer; stdcall;
var
x: TVtsCurConv;
sl: TStringList;
s: WideString;
i: integer;
begin
try
x := TVtsCurConv.Create;
if Assigned(WriteTo) then sl := TStringList.Create else sl := nil;
try
x.Secure := Flags and CONVERT_USE_SSL <> 0;
x.MaxAgeSeconds := MaxAge;
x.ConfirmWebAccess := Flags and CONVERT_CONFIRM_WEB_ACCESS <> 0;
x.FallBackToCache := Flags and CONVERT_FALLBACK_TO_CACHE <> 0;
x.InteractiveAPIKeyInput := Flags and CONVERT_NO_INTERACTIVE_API_KEY_INPUT = 0;
result := x.GetAcceptedCurrencies(sl, HistoricDate);
if Assigned(WriteTo) then
begin
s := '';
for i := 0 to sl.Count - 1 do s := s + Trim(sl.Strings[i]);
ZeroMemory(WriteTo, (3*result+1)*SizeOf(WideChar));
CopyMemory(WriteTo, @s[1], 3*result*SizeOf(WideChar));
end;
finally
x.Free;
if Assigned(WriteTo) then sl.Free;
end;
except
on E: Exception do
begin
if Flags and CONVERT_DONT_SHOW_ERRORS = 0 then MessageDlg(e.Message, mtError, [mbOk], 0);
result := -1;
end;
end;
end;
 
function AcceptedCurrenciesA(WriteTo: LPSTR; MaxAge: integer; Flags: TVtsCurConvFlags;
HistoricDate: TDate): Integer; stdcall;
var
x: TVtsCurConv;
sl: TStringList;
s: AnsiString;
i: integer;
begin
try
x := TVtsCurConv.Create;
if Assigned(WriteTo) then sl := TStringList.Create else sl := nil;
try
x.Secure := Flags and CONVERT_USE_SSL <> 0;
x.MaxAgeSeconds := MaxAge;
x.ConfirmWebAccess := Flags and CONVERT_CONFIRM_WEB_ACCESS <> 0;
x.FallBackToCache := Flags and CONVERT_FALLBACK_TO_CACHE <> 0;
x.InteractiveAPIKeyInput := Flags and CONVERT_NO_INTERACTIVE_API_KEY_INPUT = 0;
result := x.GetAcceptedCurrencies(sl, HistoricDate);
if Assigned(WriteTo) then
begin
s := '';
for i := 0 to sl.Count - 1 do s := s + Trim(sl.Strings[i]);
ZeroMemory(WriteTo, (3*result+1)*SizeOf(AnsiChar));
CopyMemory(WriteTo, @s[1], 3*result*SizeOf(AnsiChar));
end;
finally
x.Free;
if Assigned(WriteTo) then sl.Free;
end;
except
on E: Exception do
begin
if Flags and CONVERT_DONT_SHOW_ERRORS = 0 then MessageDlg(e.Message, mtError, [mbOk], 0);
result := -1;
end;
end;
end;
 
function DownloadNow(Flags: TVtsCurConvFlags; HistoricDate: TDate): HRESULT; stdcall;
var
x: TVtsCurConv;
begin
try
x := TVtsCurConv.Create;
try
x.Secure := Flags and CONVERT_USE_SSL <> 0;
x.MaxAgeSeconds := 0; // Always Download
x.ConfirmWebAccess := Flags and CONVERT_CONFIRM_WEB_ACCESS <> 0;
x.FallBackToCache := Flags and CONVERT_FALLBACK_TO_CACHE <> 0;
x.InteractiveAPIKeyInput := Flags and CONVERT_NO_INTERACTIVE_API_KEY_INPUT = 0;
x.Convert(1, 'USD', 'USD', HistoricDate);
result := S_VTSCONV_OK
finally
x.Free;
end;
except
on E: Exception do
begin
if Flags and CONVERT_DONT_SHOW_ERRORS = 0 then MessageDlg(e.Message, mtError, [mbOk], 0);
result := E_VTSCONV_GENERIC_FAILURE;
end;
end;
end;
 
exports
DeleteAPIKey,
WriteAPIKeyW,
WriteAPIKeyA,
ReadAPIKeyW,
ReadAPIKeyA,
ConvertW,
ConvertA,
AcceptedCurrenciesW,
AcceptedCurrenciesA,
DownloadNow;
 
begin
end.
/trunk/DLL/CurConv.dproj
0,0 → 1,111
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{9D7D94E5-FD85-4F79-9E4E-F6373C7B3094}</ProjectGuid>
<MainSource>CurConv.dpr</MainSource>
<Base>True</Base>
<Config Condition="'$(Config)'==''">Debug</Config>
<TargetedPlatforms>1</TargetedPlatforms>
<AppType>Library</AppType>
<FrameworkType>None</FrameworkType>
<ProjectVersion>18.2</ProjectVersion>
<Platform Condition="'$(Platform)'==''">Win32</Platform>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''">
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''">
<Base_Win32>true</Base_Win32>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''">
<Cfg_1>true</Cfg_1>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''">
<Cfg_2>true</Cfg_2>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''">
<Cfg_2_Win32>true</Cfg_2_Win32>
<CfgParent>Cfg_2</CfgParent>
<Cfg_2>true</Cfg_2>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Base)'!=''">
<DCC_E>false</DCC_E>
<DCC_F>false</DCC_F>
<DCC_K>false</DCC_K>
<DCC_N>false</DCC_N>
<DCC_S>false</DCC_S>
<DCC_ImageBase>00400000</DCC_ImageBase>
<GenDll>true</GenDll>
<SanitizedProjectName>CurConv</SanitizedProjectName>
<VerInfo_Locale>1031</VerInfo_Locale>
<VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys>
<DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''">
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName)</VerInfo_Keys>
<VerInfo_Locale>1033</VerInfo_Locale>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1)'!=''">
<DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
<DCC_DebugInformation>0</DCC_DebugInformation>
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2)'!=''">
<DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
<DCC_Optimize>false</DCC_Optimize>
<DCC_GenerateStackFrames>true</DCC_GenerateStackFrames>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2_Win32)'!=''">
<DCC_ExeOutput>e:\_test</DCC_ExeOutput>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<VerInfo_Locale>1033</VerInfo_Locale>
<VerInfo_Keys>CompanyName=ViaThinkSoft;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName)</VerInfo_Keys>
<Manifest_File>(Ohne)</Manifest_File>
<DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)</DCC_Namespace>
</PropertyGroup>
<ItemGroup>
<DelphiCompile Include="$(MainSource)">
<MainSource>MainSource</MainSource>
</DelphiCompile>
<DCCReference Include="..\RTL\uLkJSON.pas"/>
<DCCReference Include="..\RTL\VtsCurConv.pas"/>
<BuildConfiguration Include="Debug">
<Key>Cfg_2</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
<BuildConfiguration Include="Release">
<Key>Cfg_1</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
</ItemGroup>
<ProjectExtensions>
<Borland.Personality>Delphi.Personality.12</Borland.Personality>
<Borland.ProjectType/>
<BorlandProject>
<Delphi.Personality>
<Source>
<Source Name="MainSource">CurConv.dpr</Source>
</Source>
</Delphi.Personality>
<Platforms>
<Platform value="Linux64">False</Platform>
<Platform value="Win32">True</Platform>
</Platforms>
</BorlandProject>
<ProjectFileVersion>12</ProjectFileVersion>
</ProjectExtensions>
<Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/>
<Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/>
</Project>
/trunk/DLL/CurConv.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property
/trunk/DLL Specification.html
0,0 → 1,248
<html>
 
<head>
<title>ViaThinkSoft Currency Converter - DLL specification</title>
</head>
 
<body>
 
<h1>ViaThinkSoft Currency Converter - DLL specification</h1>
 
<h2>Table of Contents</h2>
 
<p>These functions are exported by <b>CurConv.dll</b>:</p>
 
<ul>
<li><a href="#DeleteAPIKey">DeleteAPIKey</a></li>
<li><a href="#WriteAPIKey">WriteAPIKey</a></li>
<li><a href="#ReadAPIKey">ReadAPIKey</a></li>
<li><a href="#Convert">Convert</a></li>
<li><a href="#AcceptedCurrencies">AcceptedCurrencies</a></li>
<li><a href="#DownloadNow">DownloadNow</a></li>
</ul>
 
<h2 id="DeleteAPIKey">DeleteAPIKey</h3>
 
<h3>Syntax</h4>
<h4>Delphi</h5>
<pre>
function DeleteAPIKey(UserMode: BOOL; DontShowErrors: BOOL): HRESULT; stdcall;
</pre>
<h4>C</h5>
<pre>
HRESULT __stdcall DeleteAPIKey(BOOL UserMode, BOOL DontShowErrors);
</pre>
 
<h3>Description</h4>
<p>Deletes the API key from the registry.</p>
 
<h3>Parameters</h4>
<ul>
<li>UserMode: If true, the API key will be deleted from <code>HKEY_LOCAL_USER</code>, otherwise it will be deleted on <code>HKEY_LOCAL_MACHINE</code>.</li>
<li>DontShowErrors: If true, no errors will be displayed. If true, errors will result in a dialog box, in addition to the result code.</li>
</ul>
 
<h3>Returns</h4>
<ul>
<li>S_VTSCONV_OK (0x20000000) if the key could be successfully deleted.</li>
<li>S_VTSCONV_NOTHING (0x20000001) if no key could be found.</li>
<li>E_VTSCONV_GENERIC_FAILURE (0xA0000000) if an error occured.</li>
</ul>
 
<h2 id="WriteAPIKey">WriteAPIKey</h3>
 
<h3>Syntax</h4>
<h4>Delphi</h5>
<pre>
function WriteAPIKey(key: LPCTSTR; UserMode: BOOL; DontShowErrors: BOOL): HRESULT; stdcall;
function WriteAPIKeyW(key: LPCWSTR; UserMode: BOOL; DontShowErrors: BOOL): HRESULT; stdcall;
function WriteAPIKeyA(key: LPCSTR; UserMode: BOOL; DontShowErrors: BOOL): HRESULT; stdcall;
</pre>
<h4>C</h5>
<pre>
HRESULT __stdcall WriteAPIKeyW(LPCWSTR key, BOOL UserMode, BOOL DontShowErrors);
HRESULT __stdcall WriteAPIKeyA(LPCSTR key, BOOL UserMode, BOOL DontShowErrors);
</pre>
 
<h3>Description</h4>
<p>Writes the API key into the registry. This is usually not neccessary, since the convert functions are able to query the key from the user using the GUI.</p>
 
<h3>Parameters</h4>
<ul>
<li>key: The 32 digit key you received from currencylayer.com</li>
<li>UserMode: If true, the API key will be written into <code>HKEY_LOCAL_USER</code>, otherwise it will be written to <code>HKEY_LOCAL_MACHINE</code>.</li>
<li>DontShowErrors: If true, no errors will be displayed. If true, errors will result in a dialog box, in addition to the result code.</li>
</ul>
 
<h3>Returns</h4>
<ul>
<li>S_VTSCONV_OK (0x20000000) if the key could be successfully deleted.</li>
<li>E_VTSCONV_GENERIC_FAILURE (0xA0000000) if an error occured, e.g. if the registry is write protected.</li>
<li>E_VTSCONV_BAD_ARGS (0xA0000001) if the key is invalid.</li>
</ul>
 
<h2 id="ReadAPIKey">ReadAPIKey</h3>
 
<h3>Syntax</h4>
<h4>Delphi</h5>
<pre>
function ReadAPIKey(key: LPTSTR; DontShowErrors: BOOL): HRESULT; stdcall;
function ReadAPIKeyW(key: LPWSTR; DontShowErrors: BOOL): HRESULT; stdcall;
function ReadAPIKeyA(key: LPSTR; DontShowErrors: BOOL): HRESULT; stdcall;
</pre>
<h4>C</h5>
<pre>
HRESULT __stdcall ReadAPIKeyW(LPWSTR key, BOOL DontShowErrors);
HRESULT __stdcall ReadAPIKeyA(LPSTR key, BOOL DontShowErrors);
</pre>
 
<h3>Description</h4>
<p>Reads the API key from the registry.</p>
 
<h3>Parameters</h4>
<ul>
<li>key: A buffer where the 32 digit key will be written to. There should be at least 33 chars memory reserved (32 chars key + 1 char zero termination).</li>
<li>UserMode: If true, the API key will be written into <code>HKEY_LOCAL_USER</code>, otherwise it will be written to <code>HKEY_LOCAL_MACHINE</code>.</li>
<li>DontShowErrors: If true, no errors will be displayed. If true, errors will result in a dialog box, in addition to the result code.</li>
</ul>
 
<h3>Returns</h4>
<ul>
<li>S_VTSCONV_OK (0x20000000) if the key could be successfully deleted.</li>
<li>E_VTSCONV_GENERIC_FAILURE (0xA0000000) if an error occured, e.g. if the registry is write protected.</li>
<li>E_VTSCONV_STOREDKEY_INVALID (0xA0000002) if the key stored in the registry is invalid.</li>
<li>E_VTSCONV_NO_STOREDKEY (0xA0000003) if there is no key stored in the registry.</li>
</ul>
 
<h2 id="Convert">Convert</h3>
 
<h3>Syntax</h4>
<h4>Delphi</h5>
<pre>
function Convert(Value: Double; CurFrom, CurTo: LPCTSTR; MaxAge: integer; Flags: TVtsCurConvFlags; HistoricDate: TDate): Double; stdcall;
function ConvertW(Value: Double; CurFrom, CurTo: LPCWSTR; MaxAge: integer; Flags: TVtsCurConvFlags; HistoricDate: TDate): Double; stdcall;
function ConvertA(Value: Double; CurFrom, CurTo: LPCSTR; MaxAge: integer; Flags: TVtsCurConvFlags; HistoricDate: TDate): Double; stdcall;
</pre>
<h4>C</h5>
<pre>
Double __stdcall ConvertW(Double Value, LPCWSTR CurFrom, LPCWSTR CurTo, int MaxAge, DWORD Flags, DATE HistoricDate);
Double __stdcall ConvertA(Double Value, LPCSTR CurFrom, LPCSTR CurTo, int MaxAge; DWORD Flags, DATE HistoricDate);
</pre>
 
<h3>Description</h4>
<p>Converts into a differnt currency.</p>
 
<h3>Parameters</h4>
<ul>
<li>Value: The amount of money in the source currency you want to convert into the target currency.</li>
<li>CurFrom: The source currency, formatted as defined in ISO-4217 (3 chars, e.g. "USD")</li>
<li>CurTo: The target currency, formatted as defined in ISO-4217 (3 chars, e.g. "USD")</li>
<li>MaxAge: Defines, after which amount of time the exchange data needs to be re-downloaded from the server.<ul>
<li>-1: Only download once</li>
<li&gt;0: Always download, on each request (attention: API keys may have limited amount of accesses per month)</li>
<li>&gt;0: Download after the supplied amount of time (in seconds)</li>
</ul></li>
<li>Flags: Is a sum of following components:<ul>
<li>CONVERT_DONT_SHOW_ERRORS (1): Don't show errors in a dialog box.</li>
<li>CONVERT_FALLBACK_TO_CACHE (2): If download failed, use the previous downloaded cache file, even if it is older than MaxAge.</li>
<li>CONVERT_USE_SSL (4): Use SSL to download the data. Note that only a paid subscription allows download via SSL.</li>
<li>CONVERT_CONFIRM_WEB_ACCESS (8): Ask the user each time the API tries to download from the web.</li>
<li>CONVERT_NO_INTERACTIVE_API_KEY_INPUT (16): Don't ask the user for an API key in case the API key is missing or invalid.</li>
</ul></li>
<li>HistoricDate:<ul>
<li&gt;0: Use the current exchange data</li>
<li>any valid DATE: use an historic exchange</li>
</ul></li>
</ul>
 
<h3>Returns</h4>
<ul>
<li>-1 if an error occured</li>
<li>&gt;=0 the amount of money in the target currency</li>
</ul>
 
<h2 id="AcceptedCurrencies">AcceptedCurrencies</h3>
 
<h3>Syntax</h4>
<h4>Delphi</h5>
<pre>
function AcceptedCurrencies(WriteTo: LPTSTR; MaxAge: integer; Flags: TVtsCurConvFlags; HistoricDate: TDate): Integer; stdcall;
function AcceptedCurrenciesW(WriteTo: LPWSTR; MaxAge: integer; Flags: TVtsCurConvFlags; HistoricDate: TDate): Integer; stdcall;
function AcceptedCurrenciesA(WriteTo: LPSTR; MaxAge: integer; Flags: TVtsCurConvFlags; HistoricDate: TDate): Integer; stdcall;
</pre>
<h4>C</h5>
<pre>
int __stdcall AcceptedCurrencies(LPTSTR WriteTo, int MaxAge, DWORD Flags, DATE HistoricDate);
int __stdcall AcceptedCurrenciesW(LPWSTR WriteTo, int MaxAge, DWORD Flags, DATE HistoricDate);
int __stdcall AcceptedCurrenciesA(LPSTR WriteTo, int MaxAge, DWORD Flags, DATE HistoricDate);
</pre>
 
<h3>Description</h4>
<p>Shows a list of available currencies.</p>
 
<h3>Parameters</h4>
<ul>
<li>WriteTo: A pointer to which the available currencies will be written to. Please reserve at least (NumOfCurrencies*3+1) characters of memory. To query how many currencies are available, please invoke the method once and set this parameter to NULL. All currencies will be appended in the format as defined in ISO-4217. Example: "USDEURCAD\0" will be a list of USD, EUR and CAD.</li>
<li>MaxAge: Defines, after which amount of time the exchange data needs to be re-downloaded from the server.<ul>
<li>-1: Only download once</li>
<li&gt;0: Always download, on each request (attention: API keys may have limited amount of accesses per month)</li>
<li>&gt;0: Download after the supplied amount of time (in seconds)</li>
</ul></li>
<li>Flags: Is a sum of following components:<ul>
<li>CONVERT_DONT_SHOW_ERRORS (1): Don't show errors in a dialog box.</li>
<li>CONVERT_FALLBACK_TO_CACHE (2): If download failed, use the previous downloaded cache file, even if it is older than MaxAge.</li>
<li>CONVERT_USE_SSL (4): Use SSL to download the data. Note that only a paid subscription allows download via SSL.</li>
<li>CONVERT_CONFIRM_WEB_ACCESS (8): Ask the user each time the API tries to download from the web.</li>
<li>CONVERT_NO_INTERACTIVE_API_KEY_INPUT (16): Don't ask the user for an API key in case the API key is missing or invalid.</li>
</ul></li>
<li>HistoricDate:<ul>
<li&gt;0: Use the current exchange data</li>
<li>any valid DATE: use an historic exchange</li>
</ul></li>
</ul>
 
<h3>Returns</h4>
<ul>
<li>-1 if an error occured</li>
<li>&gt;=0 the number of currencies found/written</li>
</ul>
 
<h2 id="DownloadNow">DownloadNow</h3>
 
<h3>Syntax</h4>
<h4>Delphi</h5>
<pre>
function DownloadNow(Flags: TVtsCurConvFlags; HistoricDate: TDate): HRESULT; stdcall;
</pre>
<h4>C</h5>
<pre>
HRESULT __stdcall DownloadNow(DWORD Flags, DATE HistoricDate);
</pre>
 
<h3>Description</h4>
<p>Forces the framework to download the currency table.</p>
 
<h3>Parameters</h4>
<ul>
<li>Flags: Is a sum of following components:<ul>
<li>CONVERT_DONT_SHOW_ERRORS (1): Don't show errors in a dialog box.</li>
<li>CONVERT_FALLBACK_TO_CACHE (2): If download failed, use the previous downloaded cache file, even if it is older than MaxAge.</li>
<li>CONVERT_USE_SSL (4): Use SSL to download the data. Note that only a paid subscription allows download via SSL.</li>
<li>CONVERT_CONFIRM_WEB_ACCESS (8): Ask the user each time the API tries to download from the web.</li>
<li>CONVERT_NO_INTERACTIVE_API_KEY_INPUT (16): Don't ask the user for an API key in case the API key is missing or invalid.</li>
</ul></li>
<li>HistoricDate:<ul>
<li&gt;0: Use the current exchange data</li>
<li>any valid DATE: use an historic exchange</li>
</ul></li>
</ul>
 
<h3>Returns</h4>
<ul>
<li>S_VTSCONV_OK (0x20000000) if the download was successful.</li>
<li>E_VTSCONV_GENERIC_FAILURE (0xA0000000) if an error occured.</li>
</ul>
 
</body>
 
</html>
/trunk/DLL Usage Demo/Delphi/CurConvDLLDemo.bdsproj
0,0 → 1,175
<?xml version="1.0" encoding="utf-8"?>
<BorlandProject>
<PersonalityInfo>
<Option>
<Option Name="Personality">Delphi.Personality</Option>
<Option Name="ProjectType"></Option>
<Option Name="Version">1.0</Option>
<Option Name="GUID">{EF0A4978-FCC9-4307-B0F2-6CC5681592B8}</Option>
</Option>
</PersonalityInfo>
<Delphi.Personality>
<Source>
<Source Name="MainSource">CurConvDLLDemo.dpr</Source>
</Source>
<FileVersion>
<FileVersion Name="Version">7.0</FileVersion>
</FileVersion>
<Compiler>
<Compiler Name="A">8</Compiler>
<Compiler Name="B">0</Compiler>
<Compiler Name="C">1</Compiler>
<Compiler Name="D">1</Compiler>
<Compiler Name="E">0</Compiler>
<Compiler Name="F">0</Compiler>
<Compiler Name="G">1</Compiler>
<Compiler Name="H">1</Compiler>
<Compiler Name="I">1</Compiler>
<Compiler Name="J">0</Compiler>
<Compiler Name="K">0</Compiler>
<Compiler Name="L">1</Compiler>
<Compiler Name="M">0</Compiler>
<Compiler Name="N">1</Compiler>
<Compiler Name="O">1</Compiler>
<Compiler Name="P">1</Compiler>
<Compiler Name="Q">0</Compiler>
<Compiler Name="R">0</Compiler>
<Compiler Name="S">0</Compiler>
<Compiler Name="T">0</Compiler>
<Compiler Name="U">0</Compiler>
<Compiler Name="V">1</Compiler>
<Compiler Name="W">0</Compiler>
<Compiler Name="X">1</Compiler>
<Compiler Name="Y">1</Compiler>
<Compiler Name="Z">1</Compiler>
<Compiler Name="ShowHints">True</Compiler>
<Compiler Name="ShowWarnings">True</Compiler>
<Compiler Name="UnitAliases">WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;</Compiler>
<Compiler Name="NamespacePrefix"></Compiler>
<Compiler Name="GenerateDocumentation">False</Compiler>
<Compiler Name="DefaultNamespace"></Compiler>
<Compiler Name="SymbolDeprecated">True</Compiler>
<Compiler Name="SymbolLibrary">True</Compiler>
<Compiler Name="SymbolPlatform">True</Compiler>
<Compiler Name="SymbolExperimental">True</Compiler>
<Compiler Name="UnitLibrary">True</Compiler>
<Compiler Name="UnitPlatform">True</Compiler>
<Compiler Name="UnitDeprecated">True</Compiler>
<Compiler Name="UnitExperimental">True</Compiler>
<Compiler Name="HResultCompat">True</Compiler>
<Compiler Name="HidingMember">True</Compiler>
<Compiler Name="HiddenVirtual">True</Compiler>
<Compiler Name="Garbage">True</Compiler>
<Compiler Name="BoundsError">True</Compiler>
<Compiler Name="ZeroNilCompat">True</Compiler>
<Compiler Name="StringConstTruncated">True</Compiler>
<Compiler Name="ForLoopVarVarPar">True</Compiler>
<Compiler Name="TypedConstVarPar">True</Compiler>
<Compiler Name="AsgToTypedConst">True</Compiler>
<Compiler Name="CaseLabelRange">True</Compiler>
<Compiler Name="ForVariable">True</Compiler>
<Compiler Name="ConstructingAbstract">True</Compiler>
<Compiler Name="ComparisonFalse">True</Compiler>
<Compiler Name="ComparisonTrue">True</Compiler>
<Compiler Name="ComparingSignedUnsigned">True</Compiler>
<Compiler Name="CombiningSignedUnsigned">True</Compiler>
<Compiler Name="UnsupportedConstruct">True</Compiler>
<Compiler Name="FileOpen">True</Compiler>
<Compiler Name="FileOpenUnitSrc">True</Compiler>
<Compiler Name="BadGlobalSymbol">True</Compiler>
<Compiler Name="DuplicateConstructorDestructor">True</Compiler>
<Compiler Name="InvalidDirective">True</Compiler>
<Compiler Name="PackageNoLink">True</Compiler>
<Compiler Name="PackageThreadVar">True</Compiler>
<Compiler Name="ImplicitImport">True</Compiler>
<Compiler Name="HPPEMITIgnored">True</Compiler>
<Compiler Name="NoRetVal">True</Compiler>
<Compiler Name="UseBeforeDef">True</Compiler>
<Compiler Name="ForLoopVarUndef">True</Compiler>
<Compiler Name="UnitNameMismatch">True</Compiler>
<Compiler Name="NoCFGFileFound">True</Compiler>
<Compiler Name="ImplicitVariants">True</Compiler>
<Compiler Name="UnicodeToLocale">True</Compiler>
<Compiler Name="LocaleToUnicode">True</Compiler>
<Compiler Name="ImagebaseMultiple">True</Compiler>
<Compiler Name="SuspiciousTypecast">True</Compiler>
<Compiler Name="PrivatePropAccessor">True</Compiler>
<Compiler Name="UnsafeType">False</Compiler>
<Compiler Name="UnsafeCode">False</Compiler>
<Compiler Name="UnsafeCast">False</Compiler>
<Compiler Name="OptionTruncated">True</Compiler>
<Compiler Name="WideCharReduced">True</Compiler>
<Compiler Name="DuplicatesIgnored">True</Compiler>
<Compiler Name="UnitInitSeq">True</Compiler>
<Compiler Name="LocalPInvoke">True</Compiler>
<Compiler Name="MessageDirective">True</Compiler>
<Compiler Name="CodePage"></Compiler>
</Compiler>
<Linker>
<Linker Name="MapFile">0</Linker>
<Linker Name="OutputObjs">0</Linker>
<Linker Name="GenerateHpps">False</Linker>
<Linker Name="ConsoleApp">1</Linker>
<Linker Name="DebugInfo">False</Linker>
<Linker Name="RemoteSymbols">False</Linker>
<Linker Name="GenerateDRC">False</Linker>
<Linker Name="MinStackSize">16384</Linker>
<Linker Name="MaxStackSize">1048576</Linker>
<Linker Name="ImageBase">4194304</Linker>
<Linker Name="ExeDescription"></Linker>
</Linker>
<Directories>
<Directories Name="OutputDir">e:\_test</Directories>
<Directories Name="UnitOutputDir"></Directories>
<Directories Name="PackageDLLOutputDir"></Directories>
<Directories Name="PackageDCPOutputDir"></Directories>
<Directories Name="SearchPath"></Directories>
<Directories Name="Packages"></Directories>
<Directories Name="Conditionals"></Directories>
<Directories Name="DebugSourceDirs"></Directories>
<Directories Name="UsePackages">False</Directories>
</Directories>
<Parameters>
<Parameters Name="RunParams"></Parameters>
<Parameters Name="HostApplication"></Parameters>
<Parameters Name="Launcher"></Parameters>
<Parameters Name="UseLauncher">False</Parameters>
<Parameters Name="DebugCWD"></Parameters>
<Parameters Name="Debug Symbols Search Path"></Parameters>
<Parameters Name="LoadAllSymbols">True</Parameters>
<Parameters Name="LoadUnspecifiedSymbols">False</Parameters>
</Parameters>
<Language>
<Language Name="ActiveLang"></Language>
<Language Name="ProjectLang">$00000000</Language>
<Language Name="RootDir"></Language>
</Language>
<VersionInfo>
<VersionInfo Name="IncludeVerInfo">False</VersionInfo>
<VersionInfo Name="AutoIncBuild">False</VersionInfo>
<VersionInfo Name="MajorVer">1</VersionInfo>
<VersionInfo Name="MinorVer">0</VersionInfo>
<VersionInfo Name="Release">0</VersionInfo>
<VersionInfo Name="Build">0</VersionInfo>
<VersionInfo Name="Debug">False</VersionInfo>
<VersionInfo Name="PreRelease">False</VersionInfo>
<VersionInfo Name="Special">False</VersionInfo>
<VersionInfo Name="Private">False</VersionInfo>
<VersionInfo Name="DLL">False</VersionInfo>
<VersionInfo Name="Locale">1031</VersionInfo>
<VersionInfo Name="CodePage">1252</VersionInfo>
</VersionInfo>
<VersionInfoKeys>
<VersionInfoKeys Name="CompanyName"></VersionInfoKeys>
<VersionInfoKeys Name="FileDescription"></VersionInfoKeys>
<VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="InternalName"></VersionInfoKeys>
<VersionInfoKeys Name="LegalCopyright"></VersionInfoKeys>
<VersionInfoKeys Name="LegalTrademarks"></VersionInfoKeys>
<VersionInfoKeys Name="OriginalFilename"></VersionInfoKeys>
<VersionInfoKeys Name="ProductName"></VersionInfoKeys>
<VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="Comments"></VersionInfoKeys>
</VersionInfoKeys>
</Delphi.Personality>
</BorlandProject>
/trunk/DLL Usage Demo/Delphi/CurConvDLLDemo.cfg
0,0 → 1,39
-$A8
-$B-
-$C+
-$D+
-$E-
-$F-
-$G+
-$H+
-$I+
-$J-
-$K-
-$L+
-$M-
-$N+
-$O+
-$P+
-$Q-
-$R-
-$S-
-$T-
-$U-
-$V+
-$W-
-$X+
-$YD
-$Z1
-cg
-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-H+
-W+
-M
-$M16384,1048576
-K$00400000
-E"e:\_test"
-LE"C:\Users\DELL User\Documents\Borland Studio-Projekte\Bpl"
-LN"C:\Users\DELL User\Documents\Borland Studio-Projekte\Bpl"
-w-UNSAFE_TYPE
-w-UNSAFE_CODE
-w-UNSAFE_CAST
/trunk/DLL Usage Demo/Delphi/CurConvDLLDemo.dpr
0,0 → 1,15
program CurConvDLLDemo;
 
uses
Forms,
Demo in 'Demo.pas' {Form1},
VtsCurConvDLLHeader in 'VtsCurConvDLLHeader.pas';
 
{$R *.res}
 
begin
ReportMemoryLeaksOnShutdown := true;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
/trunk/DLL Usage Demo/Delphi/CurConvDLLDemo.dproj
0,0 → 1,125
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{EF0A4978-FCC9-4307-B0F2-6CC5681592B8}</ProjectGuid>
<MainSource>CurConvDLLDemo.dpr</MainSource>
<Base>True</Base>
<Config Condition="'$(Config)'==''">Debug</Config>
<TargetedPlatforms>1</TargetedPlatforms>
<AppType>Application</AppType>
<FrameworkType>VCL</FrameworkType>
<ProjectVersion>18.2</ProjectVersion>
<Platform Condition="'$(Platform)'==''">Win32</Platform>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''">
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''">
<Base_Win32>true</Base_Win32>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''">
<Cfg_1>true</Cfg_1>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''">
<Cfg_1_Win32>true</Cfg_1_Win32>
<CfgParent>Cfg_1</CfgParent>
<Cfg_1>true</Cfg_1>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''">
<Cfg_2>true</Cfg_2>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''">
<Cfg_2_Win32>true</Cfg_2_Win32>
<CfgParent>Cfg_2</CfgParent>
<Cfg_2>true</Cfg_2>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Base)'!=''">
<DCC_DebugInformation>1</DCC_DebugInformation>
<DCC_E>false</DCC_E>
<DCC_F>false</DCC_F>
<DCC_K>false</DCC_K>
<DCC_N>true</DCC_N>
<DCC_S>false</DCC_S>
<DCC_SymbolReferenceInfo>1</DCC_SymbolReferenceInfo>
<DCC_ImageBase>00400000</DCC_ImageBase>
<DCC_ExeOutput>e:\_test</DCC_ExeOutput>
<SanitizedProjectName>CurConvDLLDemo</SanitizedProjectName>
<DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace>
<VerInfo_Locale>1031</VerInfo_Locale>
<VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''">
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName)</VerInfo_Keys>
<VerInfo_Locale>1033</VerInfo_Locale>
<Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File>
<Icon_MainIcon>CurConvDLLDemo_Icon.ico</Icon_MainIcon>
<AppEnableRuntimeThemes>true</AppEnableRuntimeThemes>
<UWP_DelphiLogo44>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png</UWP_DelphiLogo44>
<UWP_DelphiLogo150>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png</UWP_DelphiLogo150>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1)'!=''">
<DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
<DCC_DebugInformation>0</DCC_DebugInformation>
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1_Win32)'!=''">
<AppEnableRuntimeThemes>true</AppEnableRuntimeThemes>
<AppEnableHighDPI>true</AppEnableHighDPI>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2)'!=''">
<DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
<DCC_Optimize>false</DCC_Optimize>
<DCC_GenerateStackFrames>true</DCC_GenerateStackFrames>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2_Win32)'!=''">
<AppEnableRuntimeThemes>true</AppEnableRuntimeThemes>
<AppEnableHighDPI>true</AppEnableHighDPI>
</PropertyGroup>
<ItemGroup>
<DelphiCompile Include="$(MainSource)">
<MainSource>MainSource</MainSource>
</DelphiCompile>
<DCCReference Include="Demo.pas">
<Form>Form1</Form>
</DCCReference>
<DCCReference Include="VtsCurConvDLLHeader.pas"/>
<BuildConfiguration Include="Debug">
<Key>Cfg_2</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
<BuildConfiguration Include="Release">
<Key>Cfg_1</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
</ItemGroup>
<ProjectExtensions>
<Borland.Personality>Delphi.Personality.12</Borland.Personality>
<Borland.ProjectType/>
<BorlandProject>
<Delphi.Personality>
<Source>
<Source Name="MainSource">CurConvDLLDemo.dpr</Source>
</Source>
</Delphi.Personality>
<Platforms>
<Platform value="Win32">True</Platform>
</Platforms>
</BorlandProject>
<ProjectFileVersion>12</ProjectFileVersion>
</ProjectExtensions>
<Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/>
<Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/>
</Project>
/trunk/DLL Usage Demo/Delphi/CurConvDLLDemo.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property
/trunk/DLL Usage Demo/Delphi/CurConvDLLDemo_Icon.ico
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property
/trunk/DLL Usage Demo/Delphi/CurConvDemo.cfg
0,0 → 1,38
-$A8
-$B-
-$C+
-$D+
-$E-
-$F-
-$G+
-$H+
-$I+
-$J-
-$K-
-$L+
-$M-
-$N+
-$O+
-$P+
-$Q-
-$R-
-$S-
-$T-
-$U-
-$V+
-$W-
-$X+
-$YD
-$Z1
-cg
-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-H+
-W+
-M
-$M16384,1048576
-K$00400000
-LE"C:\Users\DELL User\Documents\Borland Studio-Projekte\Bpl"
-LN"C:\Users\DELL User\Documents\Borland Studio-Projekte\Bpl"
-w-UNSAFE_TYPE
-w-UNSAFE_CODE
-w-UNSAFE_CAST
/trunk/DLL Usage Demo/Delphi/Demo.dfm
0,0 → 1,94
object Form1: TForm1
Left = 0
Top = 0
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsSingle
Caption = 'Currency converter'
ClientHeight = 114
ClientWidth = 381
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
KeyPreview = True
OldCreateOrder = False
Position = poScreenCenter
OnKeyUp = FormKeyUp
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 184
Top = 23
Width = 11
Height = 18
Caption = '='
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -15
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
end
object ComboBox1: TComboBox
Left = 111
Top = 24
Width = 58
Height = 21
Style = csDropDownList
TabOrder = 1
OnChange = Recalc
end
object ComboBox2: TComboBox
Left = 303
Top = 24
Width = 58
Height = 21
Style = csDropDownList
TabOrder = 3
OnChange = Recalc
end
object Edit1: TEdit
Left = 24
Top = 24
Width = 81
Height = 21
TabOrder = 0
Text = 'Edit1'
OnChange = Recalc
end
object Edit2: TEdit
Left = 216
Top = 24
Width = 81
Height = 21
TabStop = False
Color = clBtnFace
ReadOnly = True
TabOrder = 2
Text = 'Edit1'
end
object CheckBox1: TCheckBox
Left = 24
Top = 80
Width = 89
Height = 17
TabStop = False
Caption = 'Historic date:'
TabOrder = 5
OnClick = Recalc
end
object DateTimePicker1: TDateTimePicker
Left = 119
Top = 76
Width = 97
Height = 21
Date = 42973.608142604160000000
Time = 42973.608142604160000000
TabOrder = 4
TabStop = False
OnChange = Recalc
end
end
/trunk/DLL Usage Demo/Delphi/Demo.pas
0,0 → 1,108
unit Demo;
 
interface
 
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls;
 
type
TForm1 = class(TForm)
ComboBox1: TComboBox;
ComboBox2: TComboBox;
Edit1: TEdit;
Edit2: TEdit;
Label1: TLabel;
DateTimePicker1: TDateTimePicker;
CheckBox1: TCheckBox;
procedure FormShow(Sender: TObject);
procedure Recalc(Sender: TObject);
procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
private
Initialized: boolean;
procedure FillComboboxes;
function HistoricDate: TDate;
end;
 
var
Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
uses
Math, VtsCurConvDLLHeader;
 
const
MaxAge = 1*60*60;
Flags = CONVERT_FALLBACK_TO_CACHE;
 
procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
var
tmp: integer;
begin
if Key = VK_F5 then
begin
tmp := ComboBox1.ItemIndex;
ComboBox1.ItemIndex := ComboBox2.ItemIndex;
ComboBox2.ItemIndex := tmp;
Recalc(Sender);
end;
end;
 
procedure TForm1.FormShow(Sender: TObject);
begin
FillComboboxes;
ComboBox1.ItemIndex := Max(0, ComboBox1.Items.IndexOf('USD'));
ComboBox2.ItemIndex := Max(0, ComboBox2.Items.IndexOf('EUR'));
Edit1.Text := '';
Edit2.Text := '';
Edit1.SetFocus;
Edit1.Text := '1';
Edit1.SelectAll;
 
Initialized := true;
Recalc(Sender);
end;
 
function TForm1.HistoricDate: TDate;
begin
if CheckBox1.Checked then
result := DateTimePicker1.Date
else
result := 0;
end;
 
procedure TForm1.Recalc(Sender: TObject);
var
s: string;
d: double;
begin
if not Initialized then exit;
s := Edit1.Text;
if TryStrToFloat(s, d) and (ComboBox1.Text <> '') and (ComboBox2.Text <> '') then
Edit2.Text := Format('%.2f', [Convert(d, PChar(ComboBox1.Text), PChar(ComboBox2.Text), MaxAge, Flags, HistoricDate)])
else
Edit2.Text := '';
end;
 
procedure TForm1.FillComboboxes;
var
num: integer;
s: string;
i: integer;
begin
num := AcceptedCurrencies(nil, MaxAge, Flags, HistoricDate);
SetLength(s, 3*num+1);
num := AcceptedCurrencies(PChar(s), MaxAge, Flags, HistoricDate);
ComboBox1.Clear;
ComboBox2.Clear;
for i := 0 to num - 1 do
begin
ComboBox1.Items.Add(Copy(s, i*3+1, 3));
ComboBox2.Items.Add(Copy(s, i*3+1, 3));
end;
end;
 
end.
/trunk/DLL Usage Demo/Delphi/VtsCurConvDLLHeader.pas
0,0 → 1,91
unit VtsCurConvDLLHeader;
 
interface
 
uses
Windows, Controls;
 
type
TVtsCurConvFlags = type DWORD;
 
const
CONVERT_DONT_SHOW_ERRORS {:TVtsCurConvFlags} = 1;
CONVERT_FALLBACK_TO_CACHE {:TVtsCurConvFlags} = 2;
CONVERT_USE_SSL {:TVtsCurConvFlags} = 4;
CONVERT_CONFIRM_WEB_ACCESS {:TVtsCurConvFlags} = 8;
CONVERT_NO_INTERACTIVE_API_KEY_INPUT {:TVtsCurConvFlags} = 16;
 
const
S_VTSCONV_OK: HRESULT = $20000000; // Success, Customer defined, Facility 0, Code 0
S_VTSCONV_NOTHING: HRESULT = $20000001; // Success, Customer defined, Facility 0, Code 1
E_VTSCONV_GENERIC_FAILURE: HRESULT = $A0000000; // Failure, Customer defined, Facility 0, Code 0
E_VTSCONV_BAD_ARGS: HRESULT = $A0000001; // Failure, Customer defined, Facility 0, Code 1
 
function DeleteAPIKey(UserMode: BOOL; DontShowErrors: BOOL): HRESULT; stdcall;
 
function WriteAPIKey(key: LPCTSTR; UserMode: BOOL; DontShowErrors: BOOL): HRESULT; stdcall;
function WriteAPIKeyW(key: LPCWSTR; UserMode: BOOL; DontShowErrors: BOOL): HRESULT; stdcall;
function WriteAPIKeyA(key: LPCSTR; UserMode: BOOL; DontShowErrors: BOOL): HRESULT; stdcall;
 
function ReadAPIKey(key: LPTSTR; DontShowErrors: BOOL): HRESULT; stdcall;
function ReadAPIKeyW(key: LPWSTR; DontShowErrors: BOOL): HRESULT; stdcall;
function ReadAPIKeyA(key: LPSTR; DontShowErrors: BOOL): HRESULT; stdcall;
 
function Convert(Value: Double; CurFrom, CurTo: LPCTSTR; MaxAge: integer;
Flags: TVtsCurConvFlags; HistoricDate: TDate): Double; stdcall;
function ConvertW(Value: Double; CurFrom, CurTo: LPCWSTR; MaxAge: integer;
Flags: TVtsCurConvFlags; HistoricDate: TDate): Double; stdcall;
function ConvertA(Value: Double; CurFrom, CurTo: LPCSTR; MaxAge: integer;
Flags: TVtsCurConvFlags; HistoricDate: TDate): Double; stdcall;
 
function AcceptedCurrencies(WriteTo: LPTSTR; MaxAge: integer; Flags: TVtsCurConvFlags;
HistoricDate: TDate): Integer; stdcall;
function AcceptedCurrenciesW(WriteTo: LPWSTR; MaxAge: integer; Flags: TVtsCurConvFlags;
HistoricDate: TDate): Integer; stdcall;
function AcceptedCurrenciesA(WriteTo: LPSTR; MaxAge: integer; Flags: TVtsCurConvFlags;
HistoricDate: TDate): Integer; stdcall;
 
function DownloadNow(Flags: TVtsCurConvFlags; HistoricDate: TDate): HRESULT; stdcall;
implementation
 
const
curConvDLL = 'CurConv.dll';
 
function DeleteAPIKey; external curConvDLL name 'DeleteAPIKey';
 
{$IFDEF UNICODE}
function WriteAPIKey; external curConvDLL name 'WriteAPIKeyW';
{$ELSE}
function WriteAPIKey; external curConvDLL name 'WriteAPIKeyA';
{$ENDIF}
function WriteAPIKeyW; external curConvDLL name 'WriteAPIKeyW';
function WriteAPIKeyA; external curConvDLL name 'WriteAPIKeyA';
 
{$IFDEF UNICODE}
function ReadAPIKey; external curConvDLL name 'ReadAPIKeyW';
{$ELSE}
function ReadAPIKey; external curConvDLL name 'ReadAPIKeyA';
{$ENDIF}
function ReadAPIKeyW; external curConvDLL name 'ReadAPIKeyW';
function ReadAPIKeyA; external curConvDLL name 'ReadAPIKeyA';
 
{$IFDEF UNICODE}
function Convert; external curConvDLL name 'ConvertW';
{$ELSE}
function Convert; external curConvDLL name 'ConvertA';
{$ENDIF}
function ConvertW; external curConvDLL name 'ConvertW';
function ConvertA; external curConvDLL name 'ConvertA';
 
{$IFDEF UNICODE}
function AcceptedCurrencies; external curConvDLL name 'AcceptedCurrenciesW';
{$ELSE}
function AcceptedCurrencies; external curConvDLL name 'AcceptedCurrenciesA';
{$ENDIF}
function AcceptedCurrenciesW; external curConvDLL name 'AcceptedCurrenciesW';
function AcceptedCurrenciesA; external curConvDLL name 'AcceptedCurrenciesA';
 
function DownloadNow; external curConvDLL name 'DownloadNow';
 
end.
/trunk/DelphiProjGroup.groupproj
0,0 → 1,48
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{A2761CB4-70F5-45ED-85FE-60F3C127D634}</ProjectGuid>
</PropertyGroup>
<ItemGroup>
<Projects Include="DLL\CurConv.dproj">
<Dependencies/>
</Projects>
<Projects Include="DLL Usage Demo\Delphi\CurConvDLLDemo.dproj">
<Dependencies/>
</Projects>
</ItemGroup>
<ProjectExtensions>
<Borland.Personality>Default.Personality.12</Borland.Personality>
<Borland.ProjectType/>
<BorlandProject>
<Default.Personality/>
</BorlandProject>
</ProjectExtensions>
<Target Name="CurConv">
<MSBuild Projects="DLL\CurConv.dproj"/>
</Target>
<Target Name="CurConv:Clean">
<MSBuild Projects="DLL\CurConv.dproj" Targets="Clean"/>
</Target>
<Target Name="CurConv:Make">
<MSBuild Projects="DLL\CurConv.dproj" Targets="Make"/>
</Target>
<Target Name="CurConvDLLDemo">
<MSBuild Projects="DLL Usage Demo\Delphi\CurConvDLLDemo.dproj"/>
</Target>
<Target Name="CurConvDLLDemo:Clean">
<MSBuild Projects="DLL Usage Demo\Delphi\CurConvDLLDemo.dproj" Targets="Clean"/>
</Target>
<Target Name="CurConvDLLDemo:Make">
<MSBuild Projects="DLL Usage Demo\Delphi\CurConvDLLDemo.dproj" Targets="Make"/>
</Target>
<Target Name="Build">
<CallTarget Targets="CurConv;CurConvDLLDemo"/>
</Target>
<Target Name="Clean">
<CallTarget Targets="CurConv:Clean;CurConvDLLDemo:Clean"/>
</Target>
<Target Name="Make">
<CallTarget Targets="CurConv:Make;CurConvDLLDemo:Make"/>
</Target>
<Import Project="$(BDS)\Bin\CodeGear.Group.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')"/>
</Project>
/trunk/RTL/VtsCurConv.pas
0,0 → 1,492
unit VtsCurConv;
 
interface
 
uses
SysUtils, Classes, Controls;
 
type
EVtsCurConvException = class(Exception);
 
TVtsCurApiKey = string;
TVtsCur = string;
TVtsRate = double;
 
TVtsCurConv = class(TObject)
private
FSecure: boolean;
FMaxAgeSeconds: integer;
FConfirmWebAccess: boolean;
FFallBackToCache: boolean;
FInteractiveAPIKeyInput: boolean;
protected
function GetJsonRaw(HistoricDate: TDate=0): string;
procedure QueryAPIKey(msg: string=''); virtual;
public
property Secure: boolean read FSecure write FSecure;
property MaxAgeSeconds: integer read FMaxAgeSeconds write FMaxAgeSeconds;
property ConfirmWebAccess: boolean read FConfirmWebAccess write FConfirmWebAccess;
property FallBackToCache: boolean read FFallBackToCache write FFallBackToCache;
property InteractiveAPIKeyInput: boolean read FInteractiveAPIKeyInput write FInteractiveAPIKeyInput;
class procedure WriteAPIKey(key: TVtsCurApiKey; UserMode: boolean=true);
class function ReadAPIKey: TVtsCurApiKey;
class function DeleteAPIKey(UserMode: boolean=true): boolean;
function Convert(value: Currency; fromCur, toCur: TVtsCur; HistoricDate: TDate=0): Currency;
function GetAcceptedCurrencies(sl: TStringList=nil; HistoricDate: TDate=0): integer;
end;
 
implementation
 
uses
Windows, Registry, uLkJSON, Dialogs, IdHTTP, DateUtils;
 
function FileGetContents(filename: string): string;
var
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.LoadFromFile(filename);
result := sl.Text;
finally
sl.Free;
end;
end;
 
procedure FilePutContents(filename, content: string);
var
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.Text := content;
sl.SaveToFile(filename);
finally
sl.Free;
end;
end;
 
function GetPage(aURL: string): string;
var
Response: TStringStream;
HTTP: TIdHTTP;
const
HTTP_RESPONSE_OK = 200;
begin
// https://stackoverflow.com/questions/9239267/how-to-download-a-web-page-into-a-variable
Result := '';
Response := TStringStream.Create('');
try
HTTP := TIdHTTP.Create(nil);
try
HTTP.Get(aURL, Response);
if HTTP.ResponseCode = HTTP_RESPONSE_OK then
Result := Response.DataString
else
raise EVtsCurConvException.CreateFmt('Cannot download from %s', [aURL]);
finally
HTTP.Free;
end;
finally
Response.Free;
end;
end;
 
function GetTempDir: string;
var
Dir: string;
Len: DWord;
begin
SetLength(Dir, MAX_PATH);
Len := GetTempPath(MAX_PATH, PChar(Dir));
if Len > 0 then
begin
SetLength(Dir, Len);
Result := Dir;
end
else
RaiseLastOSError;
end;
 
{ TVtsCurConv }
 
class procedure TVtsCurConv.WriteAPIKey(key: TVtsCurApiKey; UserMode: boolean=true);
procedure _WriteAPIKey(root: HKEY);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
try
reg.RootKey := root;
if reg.OpenKey('Software\ViaThinkSoft\CurrencyConverter', true) then
begin
reg.WriteString('APIKey', key);
reg.CloseKey;
end
else raise EVtsCurConvException.Create('Cannot open registry key');
finally
reg.Free;
end;
end;
begin
if UserMode then
_WriteAPIKey(HKEY_CURRENT_USER)
else
_WriteAPIKey(HKEY_LOCAL_MACHINE);
end;
 
class function TVtsCurConv.DeleteAPIKey(UserMode: boolean=true): boolean;
procedure _DeleteAPIKey(root: HKEY);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
try
reg.RootKey := root;
if reg.OpenKey('Software\ViaThinkSoft\CurrencyConverter', true) then
begin
result := reg.DeleteValue('APIKey');
reg.CloseKey;
end;
finally
reg.Free;
end;
end;
begin
result := false;
if UserMode then
_DeleteAPIKey(HKEY_CURRENT_USER)
else
_DeleteAPIKey(HKEY_LOCAL_MACHINE);
end;
 
class function TVtsCurConv.ReadAPIKey: TVtsCurApiKey;
function _ReadAPIKey(root: HKEY): string;
var
reg: TRegistry;
begin
result := '';
reg := TRegistry.Create;
try
reg.RootKey := root;
if reg.OpenKeyReadOnly('Software\ViaThinkSoft\CurrencyConverter') then
begin
if reg.ValueExists('APIKey') then result := reg.ReadString('APIKey');
reg.CloseKey;
end;
finally
reg.Free;
end;
end;
begin
result := _ReadAPIKey(HKEY_CURRENT_USER);
if result = '' then result := _ReadAPIKey(HKEY_LOCAL_MACHINE);
end;
 
function TVtsCurConv.Convert(value: Currency; fromCur, toCur: TVtsCur; HistoricDate: TDate=0): Currency;
var
rateTo, rateFrom: TVtsRate;
i: Integer;
rateToFound: Boolean;
rateFromFound: Boolean;
sJSON: String;
xSource: TlkJSONstring;
xRoot: TlkJSONobject;
xQuotes: TlkJSONobject;
xRate: TlkJSONnumber;
begin
result := 0; // to avoid that the compiler shows a warning
 
fromCur := Trim(UpperCase(fromCur));
toCur := Trim(UpperCase(toCur));
 
sJSON := GetJsonRaw(HistoricDate);
 
xRoot := TlkJSON.ParseText(sJSON) as TlkJSONobject;
try
xSource := xRoot.Field['source'] as TlkJSONstring;
if not assigned(xSource) then raise EVtsCurConvException.Create('JSON entry "source" is missing!');
 
xQuotes := xRoot.Field['quotes'] as TlkJSONobject;
if not assigned(xQuotes) then raise EVtsCurConvException.Create('JSON entry "quotes" is missing!');
 
rateToFound := false;
rateFromFound := false;
rateTo := 0.00; // to avoid that the compiler shows a warning
rateFrom := 0.00; // to avoid that the compiler shows a warning
 
for i := 0 to xQuotes.Count - 1 do
begin
if Length(xQuotes.NameOf[i]) <> 6 then raise EVtsCurConvException.Create('Length of quotes-entry is unexpected!');
 
xRate := xQuotes.Field[xQuotes.NameOf[i]] as TlkJSONnumber;
if not Assigned(xRate) then raise EVtsCurConvException.Create('JSON entry quotes->rate is missing!');
 
if Copy(xQuotes.NameOf[i], 1, 3) = xSource.Value then
begin
if Copy(xQuotes.NameOf[i], 4, 3) = toCur then
begin
rateTo := xRate.Value;
rateToFound := true;
end;
if Copy(xQuotes.NameOf[i], 4, 3) = fromCur then
begin
rateFrom := xRate.Value;
rateFromFound := true;
end;
end;
end;
 
if not rateToFound then raise EVtsCurConvException.CreateFmt('Currency "%s" not supported', [toCur]);
if not rateFromFound then raise EVtsCurConvException.CreateFmt('Currency "%s" not supported', [fromCur]);
 
result := value * rateTo / rateFrom;
finally
xRoot.Free;
end;
end;
 
procedure TVtsCurConv.QueryAPIKey(msg: string='');
var
s: string;
begin
s := Trim(InputBox('currencylayer.com', Trim(msg + ' Please enter your API key:'), ''));
if s = '' then raise EVtsCurConvException.Create('No API key provided.');
WriteAPIKey(s);
end;
 
function TVtsCurConv.GetAcceptedCurrencies(sl: TStringList=nil; HistoricDate: TDate=0): integer;
var
i: Integer;
sJSON: String;
xSource: TlkJSONstring;
xRoot: TlkJSONobject;
xQuotes: TlkJSONobject;
begin
result := 0;
 
sJSON := GetJsonRaw(HistoricDate);
 
xRoot := TlkJSON.ParseText(sJSON) as TlkJSONobject;
try
xSource := xRoot.Field['source'] as TlkJSONstring;
if not assigned(xSource) then raise EVtsCurConvException.Create('JSON entry "source" is missing!');
 
xQuotes := xRoot.Field['quotes'] as TlkJSONobject;
if not assigned(xQuotes) then raise EVtsCurConvException.Create('JSON entry "quotes" is missing!');
 
for i := 0 to xQuotes.Count - 1 do
begin
if Length(xQuotes.NameOf[i]) <> 6 then raise EVtsCurConvException.Create('Length of quotes-entry is unexpected!');
 
if Copy(xQuotes.NameOf[i], 1, 3) = xSource.Value then
begin
Inc(result);
if Assigned(sl) then sl.Add(Copy(xQuotes.NameOf[i], 4, 3));
end;
end;
finally
xRoot.Free;
end;
end;
 
function TVtsCurConv.GetJsonRaw(HistoricDate: TDate=0): string;
 
procedure _HandleKeyInvalidOrMissing(cacheFileName: string; msg: string; out doRetry: boolean; out json: string);
begin
if FallBackToCache then
begin
if not InteractiveAPIKeyInput then
begin
json := FileGetContents(cacheFileName);
doRetry := false;
end
else
begin
if MessageDlg(Trim(msg + ' Do you want to enter a new one?'), mtError, mbYesNoCancel, 0) = ID_YES then
begin
QueryAPIKey;
doRetry := true;
end
else
begin
json := FileGetContents(cacheFileName);
doRetry := false;
end;
end;
end
else // if not FallBackToCache then
begin
if not InteractiveAPIKeyInput then
begin
raise EVtsCurConvException.Create(msg);
end
else
begin
QueryAPIKey(msg);
doRetry := true;
end;
end;
end;
 
var
sJSON, msg, protocol: string;
xRoot: TlkJSONobject;
xSuccess: TlkJSONboolean;
keyInvalid, doRetry: boolean;
sDate: string;
url: string;
cacheDirName, cacheFileName: string;
needDownload: boolean;
mTime: TDateTime;
begin
try
{$REGION 'Determinate file location and URL'}
// cacheDirName := IncludeTrailingPathDelimiter(GetSpecialPath(CSIDL_PROGRAM_FILES_COMMON)) + 'ViaThinkSoft\CurrencyConverter\';
cacheDirName := IncludeTrailingPathDelimiter(GetTempDir) + 'ViaThinkSoft\CurrencyConverter\';
if not ForceDirectories(cacheDirName) then
begin
raise EVtsCurConvException.CreateFmt('Cannot create directory %s', [cacheDirName]);
end;
 
if Secure then protocol := 'https' else protocol := 'http';
if HistoricDate = 0 then
begin
sDate := '';
url := protocol + '://www.apilayer.net/api/live?access_key=' + ReadAPIKey;
cacheFileName := IncludeTrailingPathDelimiter(cacheDirName) + 'live.json';
end
else
begin
DateTimeToString(sDate, 'YYYY-MM-DD', HistoricDate);
url := protocol + '://www.apilayer.net/api/historical?date=' + sDate + '&access_key=' + ReadAPIKey;
cacheFileName := IncludeTrailingPathDelimiter(cacheDirName) + 'historical-' + sDate + '.json';
end;
{$ENDREGION}
 
{$REGION 'Determinate if we need to download or not'}
if HistoricDate = 0 then
begin
needDownload := true;
if MaxAgeSeconds < -1 then
begin
raise EVtsCurConvException.Create('Invalid maxage');
end
else if MaxAgeSeconds = -1 then
begin
// Only download once
needDownload := not FileExists(cacheFileName);
end
else if MaxAgeSeconds = 0 then
begin
// Always download
needDownload := true;
end
else if MaxAgeSeconds > 0 then
begin
// Download if older than <MaxAge> seconds
FileAge(cacheFileName, mTime);
needDownload := not FileExists(cacheFileName) or (SecondsBetween(Now, mTime) > MaxAgeSeconds);
end;
end
else
begin
needDownload := not FileExists(cacheFileName)
end;
{$ENDREGION}
 
if not needDownload then
begin
sJSON := FileGetContents(cacheFileName);
end
else
begin
doRetry := false;
 
{$REGION 'Is an API key available?'}
if ReadAPIKey = '' then
begin
_HandleKeyInvalidOrMissing(cacheFileName, 'No API key provided.', doRetry, sJSON);
if not doRetry then
begin
result := sJSON;
Exit;
end;
end;
{$ENDREGION}
 
{$REGION 'Download and check if everything is OK'}
repeat
{$REGION 'Confirm web access?'}
if ConfirmWebAccess and (MessageDlg('Download ' + url + ' to ' + cacheFileName + ' ?', mtConfirmation, mbYesNoCancel, 0) <> ID_YES) then
begin
if FallBackToCache then
begin
result := FileGetContents(cacheFileName);
Exit;
end
else Abort;
end;
{$ENDREGION}
 
doRetry := false;
 
sJSON := GetPage(url);
 
xRoot := TlkJSON.ParseText(sJSON) as TlkJSONobject;
if not assigned(xRoot) then raise EVtsCurConvException.Create('JSON file invalid');
 
xSuccess := xRoot.Field['success'] as TlkJSONboolean;
if not assigned(xSuccess) then raise EVtsCurConvException.Create('Cannot determinate status of the query.');
 
if xSuccess.Value then
begin
try
FilePutContents(cacheFileName, sJSON);
except
// Since this is only a cache, we should not break the whole process if only the saving fails
end;
end
else
begin
{$REGION 'Get information of the error'}
try
keyInvalid := xRoot.Field['error'].Field['code'].Value = 101;
msg := Format('%s (%s, %s)', [
xRoot.Field['error'].Field['info'].Value,
xRoot.Field['error'].Field['code'].Value,
xRoot.Field['error'].Field['type'].Value]);
except
keyInvalid := false;
msg := 'Unknown error while loading JSON.';
end;
{$ENDREGION}
 
if keyInvalid then
begin
_HandleKeyInvalidOrMissing(cacheFileName, 'API key invalid.', doRetry, sJSON);
end
else // if not keyInvalid then
begin
if FallBackToCache then
begin
result := FileGetContents(cacheFileName);
Exit;
end
else
begin
raise EVtsCurConvException.Create(msg);
end;
end;
end;
until not doRetry;
{$ENDREGION}
end;
 
result := sJSON;
finally
FreeAndNil(xRoot);
end;
end;
 
end.
/trunk/RTL/uLkJSON.pas
0,0 → 1,2626
{
LkJSON v1.07
 
06 november 2009
 
* Copyright (c) 2006,2007,2008,2009 Leonid Koninin
* leon_kon@users.sourceforge.net
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* * Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* * Neither the name of the <organization> nor the
* names of its contributors may be used to endorse or promote products
* derived from this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY Leonid Koninin ``AS IS'' AND ANY
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL Leonid Koninin BE LIABLE FOR ANY
* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
changes:
 
v1.07 06/11/2009 * fixed a bug in js_string - thanks to Andrew G. Khodotov
* fixed error with double-slashes - thanks to anonymous user
* fixed a BOM bug in parser, thanks to jasper_dale
v1.06 13/03/2009 * fixed a bug in string parsing routine
* looked routine from the Adrian M. Jones, and get some
ideas from it; thanks a lot, Adrian!
* checked error reported by phpop and fix it in the string
routine; also, thanks for advice.
v1.05 26/01/2009 + added port to D2009 by Daniele Teti, thanx a lot! really,
i haven't the 2009 version, so i can't play with it. I was
add USE_D2009 directive below, disabled by default
* fixed two small bugs in parsing object: errors with empty
object and list; thanx to RSDN's delphi forum members
* fixed "[2229135] Value deletion is broken" tracker
issue, thanx to anonymous sender provided code for
tree version
* fixed js_string according to "[1917047] (much) faster
js_string Parse" tracker issue by Joao Inacio; a lot of
thanx, great speedup!
 
v1.04 05/04/2008 + a declaration of Field property moved from TlkJSONobject
to TlkJSONbase; thanx for idea to Andrey Lukyanov; this
improve objects use, look the bottom of SAMPLE2.DPR
* fixed field name in TlkJSONobject to WideString
v1.03 14/03/2008 + added a code for generating readable JSON text, sended to
me by Kusnassriyanto Saiful Bahri, thanx to him!
* from this version, library distributed with BSD
license, more pleasure for commercial programmers :)
* was rewritten internal storing of objects, repacing
hash tables with balanced trees (AA tree, by classic
author's variant). On mine machine, with enabled fastmm,
tree variant is about 30% slower in from-zero creation,
but about 50% faster in parsing; also deletion of
objects will be much faster than a hash-one.
Hashes (old-style) can be switched on by enabling
USE_HASH directive below
v1.02 14/09/2007 * fix mistypes in diffrent places; thanx for reports
to Aleksandr Fedorov and Tobias Wrede
v1.01 18/05/2007 * fix small bug in new text generation routine, check
library for leaks by fastmm4; thanx for idea and comments
for Glynn Owen
v1.00 12/05/2007 * some fixes in new code (mistypes, mistypes...)
* also many fixes by ideas of Henri Gourvest - big thanx
for him again; he send me code for thread-safe initializing
of hash table, some FPC-compatible issues (not tested by
myself) and better code for localization in latest
delphi versions; very, very big thanx!
* rewritten procedure of json text generating, with wich
work of it speeds up 4-5 times (on test) its good for
a large objects
* started a large work for making source code self-doc
(not autodoc!)
v0.99 10/05/2007 + add functions to list and object:
function getInt(idx: Integer): Integer;
function getString(idx: Integer): String;
function getWideString(idx: Integer):WideString;
function getDouble(idx: Integer): Double;
function getBoolean(idx: Integer): Boolean;
+ add overloaded functions to object:
function getDouble(nm: String): Double; overload;
function getInt(nm: String): Integer; overload;
function getString(nm: String): String; overload;
function getWideString(nm: String): WideString; overload;
function getBoolean(nm: String): Boolean; overload;
* changed storing mech of TlkJSONcustomlist descendants from
dynamic array to TList; this gives us great speedup with
lesser changes; thanx for idea to Henri Gourvest
* also reworked hashtable to work with TList, so it also
increase speed of work
v0.98 09/05/2007 * fix small bug in work with WideStrings(UTF8), thanx to
IVO GELOV to description and sources
v0.97 10/04/2007 + add capabilities to work with KOL delphi projects; for
this will define KOL variable in begin of text; of course,
in this case object TlkJSONstreamed is not compiled.
v0.96 03/30/2007 + add TlkJSONFuncEnum and method ForEach in all
TlkJSONcustomlist descendants
+ add property UseHash(r/o) to TlkJSONobject, and parameter
UseHash:Boolean to object constructors; set it to false
allow to disable using of hash-table, what can increase
speed of work in case of objects with low number of
methods(fields); [by default it is true]
+ added conditional compile directive DOTNET for use in .Net
based delphi versions; remove dot in declaration below
(thanx for idea and sample code to Tim Radford)
+ added property HashOf to TlkHashTable to allow use of
users hash functions; on enter is widestring, on exit is
cardinal (32 bit unsigned). Original HashOf renamed to
DefaultHashOf
* hash table object of TlkJSONobject wrapped by property called
HashTable
* fixed some minor bugs
v0.95 03/29/2007 + add object TlkJSONstreamed what descendant of TlkJSON and
able to load/save JSON objects from/to streams/files.
* fixed small bug in generating of unicode strings representation
v0.94 03/27/2007 + add properties NameOf and FieldByIndex to TlkJSONobject
* fix small error in parsing unicode chars
* small changes in hashing code (try to speed up)
v0.93 03/05/2007 + add overloaded functions to list and object
+ add enum type TlkJSONtypes
+ add functions: SelfType:TlkJSONtypes and
SelfTypeName: String to every TlkJSONbase child
* fix mistype 'IndefOfName' to 'IndexOfName'
* fix mistype 'IndefOfObject' to 'IndexOfObject'
v0.92 03/02/2007 + add some fix to TlkJSON.ParseText to fix bug with parsing
objects - object methods not always added properly
to hash array (thanx to Chris Matheson)
...
}
 
unit uLkJSON;
 
{$IFDEF fpc}
{$MODE objfpc}
{$H+}
{.$DEFINE HAVE_FORMATSETTING}
{$ELSE}
{$IF RTLVersion > 14.00}
{$DEFINE HAVE_FORMATSETTING}
{$IF RTLVersion > 19.00}
{$DEFINE USE_D2009}
{$IFEND}
{$IFEND}
{$ENDIF}
 
interface
 
{.$DEFINE USE_D2009}
{.$DEFINE KOL}
{.$define DOTNET}
{$DEFINE THREADSAFE}
{$DEFINE NEW_STYLE_GENERATE}
{.$DEFINE USE_HASH}
{.$DEFINE TCB_EXT}
 
uses windows,
SysUtils,
{$IFNDEF KOL}
classes,
{$ELSE}
kol,
{$ENDIF}
variants;
 
type
TlkJSONtypes = (jsBase, jsNumber, jsString, jsBoolean, jsNull,
jsList, jsObject);
 
{$IFDEF DOTNET}
 
TlkJSONdotnetclass = class
public
constructor Create;
destructor Destroy; override;
procedure AfterConstruction; virtual;
procedure BeforeDestruction; virtual;
end;
 
{$ENDIF DOTNET}
 
TlkJSONbase = class{$IFDEF DOTNET}(TlkJSONdotnetclass){$ENDIF}
protected
function GetValue: variant; virtual;
procedure SetValue(const AValue: variant); virtual;
function GetChild(idx: Integer): TlkJSONbase; virtual;
procedure SetChild(idx: Integer; const AValue: TlkJSONbase);
virtual;
function GetCount: Integer; virtual;
function GetField(AName: Variant):TlkJSONbase; virtual;
public
property Field[AName: Variant]: TlkJSONbase read GetField;
property Count: Integer read GetCount;
property Child[idx: Integer]: TlkJSONbase read GetChild write SetChild;
property Value: variant read GetValue write SetValue;
class function SelfType: TlkJSONtypes; virtual;
class function SelfTypeName: string; virtual;
end;
 
TlkJSONnumber = class(TlkJSONbase)
protected
FValue: extended;
function GetValue: Variant; override;
procedure SetValue(const AValue: Variant); override;
public
procedure AfterConstruction; override;
class function Generate(AValue: extended = 0): TlkJSONnumber;
class function SelfType: TlkJSONtypes; override;
class function SelfTypeName: string; override;
end;
 
TlkJSONstring = class(TlkJSONbase)
protected
FValue: WideString;
function GetValue: Variant; override;
procedure SetValue(const AValue: Variant); override;
public
procedure AfterConstruction; override;
class function Generate(const wsValue: WideString = ''):
TlkJSONstring;
class function SelfType: TlkJSONtypes; override;
class function SelfTypeName: string; override;
end;
 
TlkJSONboolean = class(TlkJSONbase)
protected
FValue: Boolean;
function GetValue: Variant; override;
procedure SetValue(const AValue: Variant); override;
public
procedure AfterConstruction; override;
class function Generate(AValue: Boolean = true): TlkJSONboolean;
class function SelfType: TlkJSONtypes; override;
class function SelfTypeName: string; override;
end;
 
TlkJSONnull = class(TlkJSONbase)
protected
function GetValue: Variant; override;
function Generate: TlkJSONnull;
public
class function SelfType: TlkJSONtypes; override;
class function SelfTypeName: string; override;
end;
 
TlkJSONFuncEnum = procedure(ElName: string; Elem: TlkJSONbase;
data: pointer; var Continue: Boolean) of object;
 
TlkJSONcustomlist = class(TlkJSONbase)
protected
// FValue: array of TlkJSONbase;
fList: TList;
function GetCount: Integer; override;
function GetChild(idx: Integer): TlkJSONbase; override;
procedure SetChild(idx: Integer; const AValue: TlkJSONbase);
override;
function ForEachElement(idx: Integer; var nm: string):
TlkJSONbase; virtual;
 
function GetField(AName: Variant):TlkJSONbase; override;
 
function _Add(obj: TlkJSONbase): Integer; virtual;
procedure _Delete(iIndex: Integer); virtual;
function _IndexOf(obj: TlkJSONbase): Integer; virtual;
public
procedure ForEach(fnCallBack: TlkJSONFuncEnum; pUserData:
pointer);
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
 
function getInt(idx: Integer): Integer; virtual;
function getString(idx: Integer): string; virtual;
function getWideString(idx: Integer): WideString; virtual;
function getDouble(idx: Integer): Double; virtual;
function getBoolean(idx: Integer): Boolean; virtual;
end;
 
TlkJSONlist = class(TlkJSONcustomlist)
protected
public
function Add(obj: TlkJSONbase): Integer; overload;
 
function Add(aboolean: Boolean): Integer; overload;
function Add(nmb: double): Integer; overload;
function Add(s: string): Integer; overload;
function Add(const ws: WideString): Integer; overload;
function Add(inmb: Integer): Integer; overload;
 
procedure Delete(idx: Integer);
function IndexOf(obj: TlkJSONbase): Integer;
class function Generate: TlkJSONlist;
class function SelfType: TlkJSONtypes; override;
class function SelfTypeName: string; override;
end;
 
TlkJSONobjectmethod = class(TlkJSONbase)
protected
FValue: TlkJSONbase;
FName: WideString;
procedure SetName(const AValue: WideString);
public
property ObjValue: TlkJSONbase read FValue;
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
property Name: WideString read FName write SetName;
class function Generate(const aname: WideString; aobj: TlkJSONbase):
TlkJSONobjectmethod;
end;
 
{$IFDEF USE_HASH}
PlkHashItem = ^TlkHashItem;
TlkHashItem = packed record
hash: cardinal;
index: Integer;
end;
 
TlkHashFunction = function(const ws: WideString): cardinal of
object;
 
TlkHashTable = class
private
FParent: TObject; // TCB:parent for check chaining op.
FHashFunction: TlkHashFunction;
procedure SetHashFunction(const AValue: TlkHashFunction);
protected
a_x: array[0..255] of TList;
procedure hswap(j, k, l: Integer);
function InTable(const ws: WideString; var i, j, k: cardinal):
Boolean;
public
function counters: string;
 
function DefaultHashOf(const ws: WideString): cardinal;
function SimpleHashOf(const ws: WideString): cardinal;
 
property HashOf: TlkHashFunction read FHashFunction write
SetHashFunction;
 
function IndexOf(const ws: WideString): Integer;
 
procedure AddPair(const ws: WideString; idx: Integer);
procedure Delete(const ws: WideString);
 
constructor Create;
destructor Destroy; override;
end;
 
{$ELSE}
 
// implementation based on "Arne Andersson, Balanced Search Trees Made Simpler"
 
PlkBalNode = ^TlkBalNode;
TlkBalNode = packed record
left,right: PlkBalNode;
level: byte;
key: Integer;
nm: WideString;
end;
 
TlkBalTree = class
protected
fdeleted,flast,fbottom,froot: PlkBalNode;
procedure skew(var t:PlkBalNode);
procedure split(var t:PlkBalNode);
public
function counters: string;
 
procedure Clear;
 
function Insert(const ws: WideString; x: Integer): Boolean;
function Delete(const ws: WideString): Boolean;
 
function IndexOf(const ws: WideString): Integer;
 
constructor Create;
destructor Destroy; override;
end;
{$ENDIF USE_HASH}
 
TlkJSONobject = class(TlkJSONcustomlist)
protected
{$IFDEF USE_HASH}
ht: TlkHashTable;
{$ELSE}
ht: TlkBalTree;
{$ENDIF USE_HASH}
FUseHash: Boolean;
function GetFieldByIndex(idx: Integer): TlkJSONbase;
function GetNameOf(idx: Integer): WideString;
procedure SetFieldByIndex(idx: Integer; const AValue: TlkJSONbase);
{$IFDEF USE_HASH}
function GetHashTable: TlkHashTable;
{$ELSE}
function GetHashTable: TlkBalTree;
{$ENDIF USE_HASH}
function ForEachElement(idx: Integer; var nm: string): TlkJSONbase;
override;
function GetField(AName: Variant):TlkJSONbase; override;
public
property UseHash: Boolean read FUseHash;
{$IFDEF USE_HASH}
property HashTable: TlkHashTable read GetHashTable;
{$ELSE}
property HashTable: TlkBalTree read GetHashTable;
{$ENDIF USE_HASH}
 
function Add(const aname: WideString; aobj: TlkJSONbase): Integer;
overload;
 
function OldGetField(nm: WideString): TlkJSONbase;
procedure OldSetField(nm: WideString; const AValue: TlkJSONbase);
 
function Add(const aname: WideString; aboolean: Boolean): Integer; overload;
function Add(const aname: WideString; nmb: double): Integer; overload;
function Add(const aname: WideString; s: string): Integer; overload;
function Add(const aname: WideString; const ws: WideString): Integer;
overload;
function Add(const aname: WideString; inmb: Integer): Integer; overload;
 
procedure Delete(idx: Integer);
function IndexOfName(const aname: WideString): Integer;
function IndexOfObject(aobj: TlkJSONbase): Integer;
property Field[nm: WideString]: TlkJSONbase read OldGetField
write OldSetField; default;
 
constructor Create(bUseHash: Boolean = true);
destructor Destroy; override;
 
class function Generate(AUseHash: Boolean = true): TlkJSONobject;
class function SelfType: TlkJSONtypes; override;
class function SelfTypeName: string; override;
 
property FieldByIndex[idx: Integer]: TlkJSONbase read GetFieldByIndex
write SetFieldByIndex;
property NameOf[idx: Integer]: WideString read GetNameOf;
 
function getDouble(idx: Integer): Double; overload; override;
function getInt(idx: Integer): Integer; overload; override;
function getString(idx: Integer): string; overload; override;
function getWideString(idx: Integer): WideString; overload; override;
function getBoolean(idx: Integer): Boolean; overload; override;
 
function {$ifdef TCB_EXT}getDoubleFromName{$else}getDouble{$endif}
(nm: string): Double; overload;
function {$ifdef TCB_EXT}getIntFromName{$else}getInt{$endif}
(nm: string): Integer; overload;
function {$ifdef TCB_EXT}getStringFromName{$else}getString{$endif}
(nm: string): string; overload;
function {$ifdef TCB_EXT}getWideStringFromName{$else}getWideString{$endif}
(nm: string): WideString; overload;
function {$ifdef TCB_EXT}getBooleanFromName{$else}getBoolean{$endif}
(nm: string): Boolean; overload;
end;
 
TlkJSON = class
public
class function ParseText(const txt: string): TlkJSONbase;
class function GenerateText(obj: TlkJSONbase): string;
end;
 
{$IFNDEF KOL}
TlkJSONstreamed = class(TlkJSON)
class function LoadFromStream(src: TStream): TlkJSONbase;
class procedure SaveToStream(obj: TlkJSONbase; dst: TStream);
class function LoadFromFile(srcname: string): TlkJSONbase;
class procedure SaveToFile(obj: TlkJSONbase; dstname: string);
end;
{$ENDIF}
 
function GenerateReadableText(vObj: TlkJSONbase; var vLevel:
Integer): string;
 
implementation
 
uses math,strutils;
 
type
ElkIntException = class(Exception)
public
idx: Integer;
constructor Create(idx: Integer; msg: string);
end;
 
// author of next two functions is Kusnassriyanto Saiful Bahri
 
function Indent(vTab: Integer): string;
begin
result := DupeString(' ', vTab);
end;
 
function GenerateReadableText(vObj: TlkJSONbase; var vLevel:
Integer): string;
var
i: Integer;
vStr: string;
xs: TlkJSONstring;
begin
vLevel := vLevel + 1;
if vObj is TlkJSONObject then
begin
vStr := '';
for i := 0 to TlkJSONobject(vObj).Count - 1 do
begin
if vStr <> '' then
begin
vStr := vStr + ','#13#10;
end;
vStr := vStr + Indent(vLevel) +
GenerateReadableText(TlkJSONobject(vObj).Child[i], vLevel);
end;
if vStr <> '' then
begin
vStr := '{'#13#10 + vStr + #13#10 + Indent(vLevel - 1) + '}';
end
else
begin
vStr := '{}';
end;
result := vStr;
end
else if vObj is TlkJSONList then
begin
vStr := '';
for i := 0 to TlkJSONList(vObj).Count - 1 do
begin
if vStr <> '' then
begin
vStr := vStr + ','#13#10;
end;
vStr := vStr + Indent(vLevel) +
GenerateReadableText(TlkJSONList(vObj).Child[i], vLevel);
end;
if vStr <> '' then
begin
vStr := '['#13#10 + vStr + #13#10 + Indent(vLevel - 1) + ']';
end
else
begin
vStr := '[]';
end;
result := vStr;
end
else if vObj is TlkJSONobjectmethod then
begin
vStr := '';
xs := TlkJSONstring.Create;
try
xs.Value := TlkJSONobjectMethod(vObj).Name;
vStr := GenerateReadableText(xs, vLevel);
vLevel := vLevel - 1;
vStr := vStr + ':' + GenerateReadableText(TlkJSONbase(
TlkJSONobjectmethod(vObj).ObjValue), vLevel);
//vStr := vStr + ':' + GenerateReadableText(TlkJSONbase(vObj), vLevel);
vLevel := vLevel + 1;
result := vStr;
finally
xs.Free;
end;
end
else
begin
if vObj is TlkJSONobjectmethod then
begin
if TlkJSONobjectMethod(vObj).Name <> '' then
begin
end;
end;
result := TlkJSON.GenerateText(vObj);
end;
vLevel := vLevel - 1;
end;
 
// author of this routine is IVO GELOV
 
function code2utf(iNumber: Integer): UTF8String;
begin
if iNumber < 128 then Result := chr(iNumber)
else if iNumber < 2048 then
Result := chr((iNumber shr 6) + 192) + chr((iNumber and 63) + 128)
else if iNumber < 65536 then
Result := chr((iNumber shr 12) + 224) + chr(((iNumber shr 6) and
63) + 128) + chr((iNumber and 63) + 128)
else if iNumber < 2097152 then
Result := chr((iNumber shr 18) + 240) + chr(((iNumber shr 12) and
63) + 128) + chr(((iNumber shr 6) and 63) + 128) +
chr((iNumber and 63) + 128);
end;
 
{ TlkJSONbase }
 
function TlkJSONbase.GetChild(idx: Integer): TlkJSONbase;
begin
result := nil;
end;
 
function TlkJSONbase.GetCount: Integer;
begin
result := 0;
end;
 
function TlkJSONbase.GetField(AName: Variant):TlkJSONbase;
begin
result := self;
end;
 
function TlkJSONbase.GetValue: variant;
begin
result := variants.Null;
end;
 
class function TlkJSONbase.SelfType: TlkJSONtypes;
begin
result := jsBase;
end;
 
class function TlkJSONbase.SelfTypeName: string;
begin
result := 'jsBase';
end;
 
procedure TlkJSONbase.SetChild(idx: Integer; const AValue:
TlkJSONbase);
begin
 
end;
 
procedure TlkJSONbase.SetValue(const AValue: variant);
begin
 
end;
 
{ TlkJSONnumber }
 
procedure TlkJSONnumber.AfterConstruction;
begin
inherited;
FValue := 0;
end;
 
class function TlkJSONnumber.Generate(AValue: extended):
TlkJSONnumber;
begin
result := TlkJSONnumber.Create;
result.FValue := AValue;
end;
 
function TlkJSONnumber.GetValue: Variant;
begin
result := FValue;
end;
 
class function TlkJSONnumber.SelfType: TlkJSONtypes;
begin
result := jsNumber;
end;
 
class function TlkJSONnumber.SelfTypeName: string;
begin
result := 'jsNumber';
end;
 
procedure TlkJSONnumber.SetValue(const AValue: Variant);
begin
FValue := VarAsType(AValue, varDouble);
end;
 
{ TlkJSONstring }
 
procedure TlkJSONstring.AfterConstruction;
begin
inherited;
FValue := '';
end;
 
class function TlkJSONstring.Generate(const wsValue: WideString):
TlkJSONstring;
begin
result := TlkJSONstring.Create;
result.FValue := wsValue;
end;
 
function TlkJSONstring.GetValue: Variant;
begin
result := FValue;
end;
 
class function TlkJSONstring.SelfType: TlkJSONtypes;
begin
result := jsString;
end;
 
class function TlkJSONstring.SelfTypeName: string;
begin
result := 'jsString';
end;
 
procedure TlkJSONstring.SetValue(const AValue: Variant);
begin
FValue := VarToWideStr(AValue);
end;
 
{ TlkJSONboolean }
 
procedure TlkJSONboolean.AfterConstruction;
begin
FValue := false;
end;
 
class function TlkJSONboolean.Generate(AValue: Boolean):
TlkJSONboolean;
begin
result := TlkJSONboolean.Create;
result.Value := AValue;
end;
 
function TlkJSONboolean.GetValue: Variant;
begin
result := FValue;
end;
 
class function TlkJSONboolean.SelfType: TlkJSONtypes;
begin
Result := jsBoolean;
end;
 
class function TlkJSONboolean.SelfTypeName: string;
begin
Result := 'jsBoolean';
end;
 
procedure TlkJSONboolean.SetValue(const AValue: Variant);
begin
FValue := boolean(AValue);
end;
 
{ TlkJSONnull }
 
function TlkJSONnull.Generate: TlkJSONnull;
begin
result := TlkJSONnull.Create;
end;
 
function TlkJSONnull.GetValue: Variant;
begin
result := variants.Null;
end;
 
class function TlkJSONnull.SelfType: TlkJSONtypes;
begin
result := jsNull;
end;
 
class function TlkJSONnull.SelfTypeName: string;
begin
result := 'jsNull';
end;
 
{ TlkJSONcustomlist }
 
function TlkJSONcustomlist._Add(obj: TlkJSONbase): Integer;
begin
if not Assigned(obj) then
begin
result := -1;
exit;
end;
result := fList.Add(obj);
end;
 
procedure TlkJSONcustomlist.AfterConstruction;
begin
inherited;
fList := TList.Create;
end;
 
procedure TlkJSONcustomlist.BeforeDestruction;
var
i: Integer;
begin
for i := (Count - 1) downto 0 do _Delete(i);
fList.Free;
inherited;
end;
 
// renamed
 
procedure TlkJSONcustomlist._Delete(iIndex: Integer);
var
idx: Integer;
begin
if not ((iIndex < 0) or (iIndex >= Count)) then
begin
if fList.Items[iIndex] <> nil then
TlkJSONbase(fList.Items[iIndex]).Free;
idx := pred(fList.Count);
if iIndex<idx then
begin
fList.Items[iIndex] := fList.Items[idx];
fList.Delete(idx);
end
else
begin
fList.Delete(iIndex);
end;
end;
end;
 
function TlkJSONcustomlist.GetChild(idx: Integer): TlkJSONbase;
begin
if (idx < 0) or (idx >= Count) then
begin
result := nil;
end
else
begin
result := fList.Items[idx];
end;
end;
 
function TlkJSONcustomlist.GetCount: Integer;
begin
result := fList.Count;
end;
 
function TlkJSONcustomlist._IndexOf(obj: TlkJSONbase): Integer;
begin
result := fList.IndexOf(obj);
end;
 
procedure TlkJSONcustomlist.SetChild(idx: Integer; const AValue:
TlkJSONbase);
begin
if not ((idx < 0) or (idx >= Count)) then
begin
if fList.Items[idx] <> nil then
TlkJSONbase(fList.Items[idx]).Free;
fList.Items[idx] := AValue;
end;
end;
 
procedure TlkJSONcustomlist.ForEach(fnCallBack: TlkJSONFuncEnum;
pUserData:
pointer);
var
iCount: Integer;
IsContinue: Boolean;
anJSON: TlkJSONbase;
wsObject: string;
begin
if not assigned(fnCallBack) then exit;
IsContinue := true;
for iCount := 0 to GetCount - 1 do
begin
anJSON := ForEachElement(iCount, wsObject);
if assigned(anJSON) then
fnCallBack(wsObject, anJSON, pUserData, IsContinue);
if not IsContinue then break;
end;
end;
 
///---- renamed to here
 
function TlkJSONcustomlist.GetField(AName: Variant):TlkJSONbase;
var
index: Integer;
begin
if VarIsNumeric(AName) then
begin
index := integer(AName);
result := GetChild(index);
end
else
begin
result := inherited GetField(AName);
end;
end;
 
function TlkJSONcustomlist.ForEachElement(idx: Integer; var nm:
string): TlkJSONbase;
begin
nm := inttostr(idx);
result := GetChild(idx);
end;
 
function TlkJSONcustomlist.getDouble(idx: Integer): Double;
var
jn: TlkJSONnumber;
begin
jn := Child[idx] as TlkJSONnumber;
if not assigned(jn) then result := 0
else result := jn.Value;
end;
 
function TlkJSONcustomlist.getInt(idx: Integer): Integer;
var
jn: TlkJSONnumber;
begin
jn := Child[idx] as TlkJSONnumber;
if not assigned(jn) then result := 0
else result := round(int(jn.Value));
end;
 
function TlkJSONcustomlist.getString(idx: Integer): string;
var
js: TlkJSONstring;
begin
js := Child[idx] as TlkJSONstring;
if not assigned(js) then result := ''
else result := VarToStr(js.Value);
end;
 
function TlkJSONcustomlist.getWideString(idx: Integer): WideString;
var
js: TlkJSONstring;
begin
js := Child[idx] as TlkJSONstring;
if not assigned(js) then result := ''
else result := VarToWideStr(js.Value);
end;
 
function TlkJSONcustomlist.getBoolean(idx: Integer): Boolean;
var
jb: TlkJSONboolean;
begin
jb := Child[idx] as TlkJSONboolean;
if not assigned(jb) then result := false
else result := jb.Value;
end;
 
{ TlkJSONobjectmethod }
 
procedure TlkJSONobjectmethod.AfterConstruction;
begin
inherited;
FValue := nil;
FName := '';
end;
 
procedure TlkJSONobjectmethod.BeforeDestruction;
begin
FName := '';
if FValue <> nil then
begin
FValue.Free;
FValue := nil;
end;
inherited;
end;
 
class function TlkJSONobjectmethod.Generate(const aname: WideString;
aobj: TlkJSONbase): TlkJSONobjectmethod;
begin
result := TlkJSONobjectmethod.Create;
result.FName := aname;
result.FValue := aobj;
end;
 
procedure TlkJSONobjectmethod.SetName(const AValue: WideString);
begin
FName := AValue;
end;
 
{ TlkJSONlist }
 
function TlkJSONlist.Add(obj: TlkJSONbase): Integer;
begin
result := _Add(obj);
end;
 
function TlkJSONlist.Add(nmb: double): Integer;
begin
Result := self.Add(TlkJSONnumber.Generate(nmb));
end;
 
function TlkJSONlist.Add(aboolean: Boolean): Integer;
begin
Result := self.Add(TlkJSONboolean.Generate(aboolean));
end;
 
function TlkJSONlist.Add(inmb: Integer): Integer;
begin
Result := self.Add(TlkJSONnumber.Generate(inmb));
end;
 
function TlkJSONlist.Add(const ws: WideString): Integer;
begin
Result := self.Add(TlkJSONstring.Generate(ws));
end;
 
function TlkJSONlist.Add(s: string): Integer;
begin
Result := self.Add(TlkJSONstring.Generate(s));
end;
 
procedure TlkJSONlist.Delete(idx: Integer);
begin
_Delete(idx);
end;
 
class function TlkJSONlist.Generate: TlkJSONlist;
begin
result := TlkJSONlist.Create;
end;
 
function TlkJSONlist.IndexOf(obj: TlkJSONbase): Integer;
begin
result := _IndexOf(obj);
end;
 
class function TlkJSONlist.SelfType: TlkJSONtypes;
begin
result := jsList;
end;
 
class function TlkJSONlist.SelfTypeName: string;
begin
result := 'jsList';
end;
 
{ TlkJSONobject }
 
function TlkJSONobject.Add(const aname: WideString; aobj:
TlkJSONbase):
Integer;
var
mth: TlkJSONobjectmethod;
begin
if not assigned(aobj) then
begin
result := -1;
exit;
end;
mth := TlkJSONobjectmethod.Create;
mth.FName := aname;
mth.FValue := aobj;
result := self._Add(mth);
if FUseHash then
{$IFDEF USE_HASH}
ht.AddPair(aname, result);
{$ELSE}
ht.Insert(aname, result);
{$ENDIF USE_HASH}
end;
 
procedure TlkJSONobject.Delete(idx: Integer);
var
//i,j,k:cardinal;
mth: TlkJSONobjectmethod;
begin
if (idx >= 0) and (idx < Count) then
begin
// mth := FValue[idx] as TlkJSONobjectmethod;
mth := TlkJSONobjectmethod(fList.Items[idx]);
if FUseHash then
begin
ht.Delete(mth.FName);
end;
end;
_Delete(idx);
{$ifdef USE_HASH}
if (idx<Count) and (FUseHash) then
begin
mth := TlkJSONobjectmethod(fList.Items[idx]);
ht.AddPair(mth.FName,idx);
end;
{$endif}
end;
 
class function TlkJSONobject.Generate(AUseHash: Boolean = true):
TlkJSONobject;
begin
result := TlkJSONobject.Create(AUseHash);
end;
 
function TlkJSONobject.OldGetField(nm: WideString): TlkJSONbase;
var
mth: TlkJSONobjectmethod;
i: Integer;
begin
i := IndexOfName(nm);
if i = -1 then
begin
result := nil;
end
else
begin
// mth := TlkJSONobjectmethod(FValue[i]);
mth := TlkJSONobjectmethod(fList.Items[i]);
result := mth.FValue;
end;
end;
 
function TlkJSONobject.IndexOfName(const aname: WideString): Integer;
var
mth: TlkJSONobjectmethod;
i: Integer;
begin
if not FUseHash then
begin
result := -1;
for i := 0 to Count - 1 do
begin
// mth := TlkJSONobjectmethod(FValue[i]);
mth := TlkJSONobjectmethod(fList.Items[i]);
if mth.Name = aname then
begin
result := i;
break;
end;
end;
end
else
begin
result := ht.IndexOf(aname);
end;
end;
 
function TlkJSONobject.IndexOfObject(aobj: TlkJSONbase): Integer;
var
mth: TlkJSONobjectmethod;
i: Integer;
begin
result := -1;
for i := 0 to Count - 1 do
begin
// mth := TlkJSONobjectmethod(FValue[i]);
mth := TlkJSONobjectmethod(fList.Items[i]);
if mth.FValue = aobj then
begin
result := i;
break;
end;
end;
end;
 
procedure TlkJSONobject.OldSetField(nm: WideString; const AValue:
TlkJSONbase);
var
mth: TlkJSONobjectmethod;
i: Integer;
begin
i := IndexOfName(nm);
if i <> -1 then
begin
// mth := TlkJSONobjectmethod(FValue[i]);
mth := TlkJSONobjectmethod(fList.Items[i]);
mth.FValue := AValue;
end;
end;
 
function TlkJSONobject.Add(const aname: WideString; nmb: double):
Integer;
begin
Result := self.Add(aname, TlkJSONnumber.Generate(nmb));
end;
 
function TlkJSONobject.Add(const aname: WideString; aboolean: Boolean):
Integer;
begin
Result := self.Add(aname, TlkJSONboolean.Generate(aboolean));
end;
 
function TlkJSONobject.Add(const aname: WideString; s: string):
Integer;
begin
Result := self.Add(aname, TlkJSONstring.Generate(s));
end;
 
function TlkJSONobject.Add(const aname: WideString; inmb: Integer):
Integer;
begin
Result := self.Add(aname, TlkJSONnumber.Generate(inmb));
end;
 
function TlkJSONobject.Add(const aname, ws: WideString): Integer;
begin
Result := self.Add(aname, TlkJSONstring.Generate(ws));
end;
 
class function TlkJSONobject.SelfType: TlkJSONtypes;
begin
Result := jsObject;
end;
 
class function TlkJSONobject.SelfTypeName: string;
begin
Result := 'jsObject';
end;
 
function TlkJSONobject.GetFieldByIndex(idx: Integer): TlkJSONbase;
var
nm: WideString;
begin
nm := GetNameOf(idx);
if nm <> '' then
begin
result := Field[nm];
end
else
begin
result := nil;
end;
end;
 
function TlkJSONobject.GetNameOf(idx: Integer): WideString;
var
mth: TlkJSONobjectmethod;
begin
if (idx < 0) or (idx >= Count) then
begin
result := '';
end
else
begin
mth := Child[idx] as TlkJSONobjectmethod;
result := mth.Name;
end;
end;
 
procedure TlkJSONobject.SetFieldByIndex(idx: Integer;
const AValue: TlkJSONbase);
var
nm: WideString;
begin
nm := GetNameOf(idx);
if nm <> '' then
begin
Field[nm] := AValue;
end;
end;
 
function TlkJSONobject.ForEachElement(idx: Integer;
var nm: string): TlkJSONbase;
begin
nm := GetNameOf(idx);
result := GetFieldByIndex(idx);
end;
 
function TlkJSONobject.GetField(AName: Variant):TlkJSONbase;
begin
if VarIsStr(AName) then
result := OldGetField(VarToWideStr(AName))
else
result := inherited GetField(AName);
end;
 
{$IFDEF USE_HASH}
function TlkJSONobject.GetHashTable: TlkHashTable;
{$ELSE}
function TlkJSONobject.GetHashTable: TlkBalTree;
{$ENDIF USE_HASH}
begin
result := ht;
end;
 
constructor TlkJSONobject.Create(bUseHash: Boolean);
begin
inherited Create;
FUseHash := bUseHash;
{$IFDEF USE_HASH}
ht := TlkHashTable.Create;
ht.FParent := self;
{$ELSE}
ht := TlkBalTree.Create;
{$ENDIF}
end;
 
destructor TlkJSONobject.Destroy;
begin
if assigned(ht) then FreeAndNil(ht);
inherited;
end;
 
function TlkJSONobject.getDouble(idx: Integer): Double;
var
jn: TlkJSONnumber;
begin
jn := FieldByIndex[idx] as TlkJSONnumber;
if not assigned(jn) then result := 0
else result := jn.Value;
end;
 
function TlkJSONobject.getInt(idx: Integer): Integer;
var
jn: TlkJSONnumber;
begin
jn := FieldByIndex[idx] as TlkJSONnumber;
if not assigned(jn) then result := 0
else result := round(int(jn.Value));
end;
 
function TlkJSONobject.getString(idx: Integer): string;
var
js: TlkJSONstring;
begin
js := FieldByIndex[idx] as TlkJSONstring;
if not assigned(js) then result := ''
else result := vartostr(js.Value);
end;
 
function TlkJSONobject.getWideString(idx: Integer): WideString;
var
js: TlkJSONstring;
begin
js := FieldByIndex[idx] as TlkJSONstring;
if not assigned(js) then result := ''
else result := VarToWideStr(js.Value);
end;
 
{$ifdef TCB_EXT}
function TlkJSONobject.getDoubleFromName(nm: string): Double;
{$else}
function TlkJSONobject.getDouble(nm: string): Double;
{$endif}
begin
result := getDouble(IndexOfName(nm));
end;
 
{$ifdef TCB_EXT}
function TlkJSONobject.getIntFromName(nm: string): Integer;
{$else}
function TlkJSONobject.getInt(nm: string): Integer;
{$endif}
begin
result := getInt(IndexOfName(nm));
end;
 
{$ifdef TCB_EXT}
function TlkJSONobject.getStringFromName(nm: string): string;
{$else}
function TlkJSONobject.getString(nm: string): string;
{$endif}
begin
result := getString(IndexOfName(nm));
end;
 
{$ifdef TCB_EXT}
function TlkJSONobject.getWideStringFromName(nm: string): WideString;
{$else}
function TlkJSONobject.getWideString(nm: string): WideString;
{$endif}
begin
result := getWideString(IndexOfName(nm));
end;
 
function TlkJSONobject.getBoolean(idx: Integer): Boolean;
var
jb: TlkJSONboolean;
begin
jb := FieldByIndex[idx] as TlkJSONboolean;
if not assigned(jb) then result := false
else result := jb.Value;
end;
 
{$ifdef TCB_EXT}
function TlkJSONobject.getBooleanFromName(nm: string): Boolean;
{$else}
function TlkJSONobject.getBoolean(nm: string): Boolean;
{$endif}
begin
result := getBoolean(IndexOfName(nm));
end;
 
{ TlkJSON }
 
class function TlkJSON.GenerateText(obj: TlkJSONbase): string;
var
{$IFDEF HAVE_FORMATSETTING}
fs: TFormatSettings;
{$ENDIF}
pt1, pt0, pt2: PChar;
ptsz: cardinal;
 
{$IFNDEF NEW_STYLE_GENERATE}
 
function gn_base(obj: TlkJSONbase): string;
var
ws: string;
i, j: Integer;
xs: TlkJSONstring;
begin
result := '';
if not assigned(obj) then exit;
if obj is TlkJSONnumber then
begin
{$IFDEF HAVE_FORMATSETTING}
result := FloatToStr(TlkJSONnumber(obj).FValue, fs);
{$ELSE}
result := FloatToStr(TlkJSONnumber(obj).FValue);
i := pos(DecimalSeparator, result);
if (DecimalSeparator <> '.') and (i > 0) then
result[i] := '.';
{$ENDIF}
end
else if obj is TlkJSONstring then
begin
ws := UTF8Encode(TlkJSONstring(obj).FValue);
i := 1;
result := '"';
while i <= length(ws) do
begin
case ws[i] of
'/', '\', '"': result := result + '\' + ws[i];
#8: result := result + '\b';
#9: result := result + '\t';
#10: result := result + '\n';
#13: result := result + '\r';
#12: result := result + '\f';
else
if ord(ws[i]) < 32 then
result := result + '\u' + inttohex(ord(ws[i]), 4)
else
result := result + ws[i];
end;
inc(i);
end;
result := result + '"';
end
else if obj is TlkJSONboolean then
begin
if TlkJSONboolean(obj).FValue then
result := 'true'
else
result := 'false';
end
else if obj is TlkJSONnull then
begin
result := 'null';
end
else if obj is TlkJSONlist then
begin
result := '[';
j := TlkJSONobject(obj).Count - 1;
for i := 0 to j do
begin
if i > 0 then result := result + ',';
result := result + gn_base(TlkJSONlist(obj).Child[i]);
end;
result := result + ']';
end
else if obj is TlkJSONobjectmethod then
begin
try
xs := TlkJSONstring.Create;
xs.FValue := TlkJSONobjectmethod(obj).FName;
result := gn_base(TlkJSONbase(xs)) + ':';
result := result +
gn_base(TlkJSONbase(TlkJSONobjectmethod(obj).FValue));
finally
if assigned(xs) then FreeAndNil(xs);
end;
end
else if obj is TlkJSONobject then
begin
result := '{';
j := TlkJSONobject(obj).Count - 1;
for i := 0 to j do
begin
if i > 0 then result := result + ',';
result := result + gn_base(TlkJSONobject(obj).Child[i]);
end;
result := result + '}';
end;
end;
{$ELSE}
 
procedure get_more_memory;
var
delta: cardinal;
begin
delta := 50000;
if pt0 = nil then
begin
pt0 := AllocMem(delta);
ptsz := 0;
pt1 := pt0;
end
else
begin
ReallocMem(pt0, ptsz + delta);
pt1 := pointer(cardinal(pt0) + ptsz);
end;
ptsz := ptsz + delta;
pt2 := pointer(cardinal(pt1) + delta);
end;
 
procedure mem_ch(ch: char);
begin
if pt1 >= pt2 then get_more_memory;
pt1^ := ch;
inc(pt1);
end;
 
procedure mem_write(rs: string);
var
i: Integer;
begin
for i := 1 to length(rs) do
begin
if pt1 >= pt2 then get_more_memory;
pt1^ := rs[i];
inc(pt1);
end;
end;
 
procedure gn_base(obj: TlkJSONbase);
var
ws: string;
i, j: Integer;
xs: TlkJSONstring;
begin
if not assigned(obj) then exit;
if obj is TlkJSONnumber then
begin
{$IFDEF HAVE_FORMATSETTING}
mem_write(FloatToStr(TlkJSONnumber(obj).FValue, fs));
{$ELSE}
ws := FloatToStr(TlkJSONnumber(obj).FValue);
i := pos(DecimalSeparator, ws);
if (DecimalSeparator <> '.') and (i > 0) then ws[i] := '.';
mem_write(ws);
{$ENDIF}
end
else if obj is TlkJSONstring then
begin
ws := UTF8Encode(TlkJSONstring(obj).FValue);
i := 1;
mem_ch('"');
while i <= length(ws) do
begin
case ws[i] of
'/', '\', '"':
begin
mem_ch('\');
mem_ch(ws[i]);
end;
#8: mem_write('\b');
#9: mem_write('\t');
#10: mem_write('\n');
#13: mem_write('\r');
#12: mem_write('\f');
else
if ord(ws[i]) < 32 then
mem_write('\u' + inttohex(ord(ws[i]), 4))
else
mem_ch(ws[i]);
end;
inc(i);
end;
mem_ch('"');
end
else if obj is TlkJSONboolean then
begin
if TlkJSONboolean(obj).FValue then
mem_write('true')
else
mem_write('false');
end
else if obj is TlkJSONnull then
begin
mem_write('null');
end
else if obj is TlkJSONlist then
begin
mem_ch('[');
j := TlkJSONobject(obj).Count - 1;
for i := 0 to j do
begin
if i > 0 then mem_ch(',');
gn_base(TlkJSONlist(obj).Child[i]);
end;
mem_ch(']');
end
else if obj is TlkJSONobjectmethod then
begin
try
xs := TlkJSONstring.Create;
xs.FValue := TlkJSONobjectmethod(obj).FName;
gn_base(TlkJSONbase(xs));
mem_ch(':');
gn_base(TlkJSONbase(TlkJSONobjectmethod(obj).FValue));
finally
if assigned(xs) then FreeAndNil(xs);
end;
end
else if obj is TlkJSONobject then
begin
mem_ch('{');
j := TlkJSONobject(obj).Count - 1;
for i := 0 to j do
begin
if i > 0 then mem_ch(',');
gn_base(TlkJSONobject(obj).Child[i]);
end;
mem_ch('}');
end;
end;
{$ENDIF NEW_STYLE_GENERATE}
 
begin
{$IFDEF HAVE_FORMATSETTING}
GetLocaleFormatSettings(GetThreadLocale, fs);
fs.DecimalSeparator := '.';
{$ENDIF}
{$IFDEF NEW_STYLE_GENERATE}
pt0 := nil;
get_more_memory;
gn_base(obj);
mem_ch(#0);
result := string(pt0);
freemem(pt0);
{$ELSE}
result := gn_base(obj);
{$ENDIF}
end;
 
class function TlkJSON.ParseText(const txt: string): TlkJSONbase;
{$IFDEF HAVE_FORMATSETTING}
var
fs: TFormatSettings;
{$ENDIF}
 
function js_base(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean; forward;
 
function xe(idx: Integer): Boolean;
{$IFDEF FPC}inline;
{$ENDIF}
begin
result := idx <= length(txt);
end;
 
procedure skip_spc(var idx: Integer);
{$IFDEF FPC}inline;
{$ENDIF}
begin
while (xe(idx)) and (ord(txt[idx]) < 33) do
inc(idx);
end;
 
procedure add_child(var o, c: TlkJSONbase);
var
i: Integer;
begin
if o = nil then
begin
o := c;
end
else
begin
if o is TlkJSONobjectmethod then
begin
TlkJSONobjectmethod(o).FValue := c;
end
else if o is TlkJSONlist then
begin
TlkJSONlist(o)._Add(c);
end
else if o is TlkJSONobject then
begin
i := TlkJSONobject(o)._Add(c);
if TlkJSONobject(o).UseHash then
{$IFDEF USE_HASH}
TlkJSONobject(o).ht.AddPair(TlkJSONobjectmethod(c).Name, i);
{$ELSE}
TlkJSONobject(o).ht.Insert(TlkJSONobjectmethod(c).Name, i);
{$ENDIF USE_HASH}
end;
end;
end;
 
function js_boolean(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
var
js: TlkJSONboolean;
begin
skip_spc(idx);
if copy(txt, idx, 4) = 'true' then
begin
result := true;
ridx := idx + 4;
js := TlkJSONboolean.Create;
js.FValue := true;
add_child(o, TlkJSONbase(js));
end
else if copy(txt, idx, 5) = 'false' then
begin
result := true;
ridx := idx + 5;
js := TlkJSONboolean.Create;
js.FValue := false;
add_child(o, TlkJSONbase(js));
end
else
begin
result := false;
end;
end;
 
function js_null(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
var
js: TlkJSONnull;
begin
skip_spc(idx);
if copy(txt, idx, 4) = 'null' then
begin
result := true;
ridx := idx + 4;
js := TlkJSONnull.Create;
add_child(o, TlkJSONbase(js));
end
else
begin
result := false;
end;
end;
 
function js_integer(idx: Integer; var ridx: Integer): Boolean;
begin
result := false;
while (xe(idx)) and (txt[idx] in ['0'..'9']) do
begin
result := true;
inc(idx);
end;
if result then ridx := idx;
end;
 
function js_number(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
var
js: TlkJSONnumber;
ws: string;
{$IFNDEF HAVE_FORMATSETTING}
i: Integer;
{$ENDIF}
begin
skip_spc(idx);
result := xe(idx);
if not result then exit;
if txt[idx] in ['+', '-'] then
begin
inc(idx);
result := xe(idx);
end;
if not result then exit;
result := js_integer(idx, idx);
if not result then exit;
if (xe(idx)) and (txt[idx] = '.') then
begin
inc(idx);
result := js_integer(idx, idx);
if not result then exit;
end;
if (xe(idx)) and (txt[idx] in ['e', 'E']) then
begin
inc(idx);
if (xe(idx)) and (txt[idx] in ['+', '-']) then inc(idx);
result := js_integer(idx, idx);
if not result then exit;
end;
if not result then exit;
js := TlkJSONnumber.Create;
ws := copy(txt, ridx, idx - ridx);
{$IFDEF HAVE_FORMATSETTING}
js.FValue := StrToFloat(ws, fs);
{$ELSE}
i := pos('.', ws);
if (DecimalSeparator <> '.') and (i > 0) then
ws[pos('.', ws)] := DecimalSeparator;
js.FValue := StrToFloat(ws);
{$ENDIF}
add_child(o, TlkJSONbase(js));
ridx := idx;
end;
 
{
 
}
function js_string(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
 
function strSpecialChars(const s: string): string;
var
i, j : integer;
begin
i := Pos('\', s);
if (i = 0) then
Result := s
else
begin
Result := Copy(s, 1, i-1);
j := i;
repeat
if (s[j] = '\') then
begin
inc(j);
case s[j] of
'\': Result := Result + '\';
'"': Result := Result + '"';
'''': Result := Result + '''';
'/': Result := Result + '/';
'b': Result := Result + #8;
'f': Result := Result + #12;
'n': Result := Result + #10;
'r': Result := Result + #13;
't': Result := Result + #9;
'u':
begin
Result := Result + code2utf(strtoint('$' + copy(s, j + 1, 4)));
inc(j, 4);
end;
end;
end
else
Result := Result + s[j];
inc(j);
until j > length(s);
end;
end;
 
var
js: TlkJSONstring;
fin: Boolean;
ws: String;
i,j,widx: Integer;
begin
skip_spc(idx);
 
result := xe(idx) and (txt[idx] = '"');
if not result then exit;
 
inc(idx);
widx := idx;
 
fin:=false;
REPEAT
i := 0;
j := 0;
while (widx<=length(txt)) and (j=0) do
begin
if (i=0) and (txt[widx]='\') then i:=widx;
if (j=0) and (txt[widx]='"') then j:=widx;
inc(widx);
end;
// incorrect string!!!
if j=0 then
begin
result := false;
exit;
end;
// if we have no slashed chars in string
if (i=0) or (j<i) then
begin
ws := copy(txt,idx,j-idx);
idx := j;
fin := true;
end
// if i>0 and j>=i - skip slashed char
else
begin
widx:=i+2;
end;
UNTIL fin;
 
ws := strSpecialChars(ws);
inc(idx);
 
js := TlkJSONstring.Create;
{$ifdef USE_D2009}
js.FValue := UTF8ToString(ws);
{$else}
js.FValue := UTF8Decode(ws);
{$endif}
add_child(o, TlkJSONbase(js));
ridx := idx;
end;
 
function js_list(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
var
js: TlkJSONlist;
begin
result := false;
try
js := TlkJSONlist.Create;
skip_spc(idx);
result := xe(idx);
if not result then exit;
result := txt[idx] = '[';
if not result then exit;
inc(idx);
while js_base(idx, idx, TlkJSONbase(js)) do
begin
skip_spc(idx);
if (xe(idx)) and (txt[idx] = ',') then inc(idx);
end;
skip_spc(idx);
result := (xe(idx)) and (txt[idx] = ']');
if not result then exit;
inc(idx);
finally
if not result then
begin
js.Free;
end
else
begin
add_child(o, TlkJSONbase(js));
ridx := idx;
end;
end;
end;
 
function js_method(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
var
mth: TlkJSONobjectmethod;
ws: TlkJSONstring;
begin
result := false;
try
ws := nil;
mth := TlkJSONobjectmethod.Create;
skip_spc(idx);
result := xe(idx);
if not result then exit;
result := js_string(idx, idx, TlkJSONbase(ws));
if not result then exit;
skip_spc(idx);
result := xe(idx) and (txt[idx] = ':');
if not result then exit;
inc(idx);
mth.FName := ws.FValue;
result := js_base(idx, idx, TlkJSONbase(mth));
finally
if ws <> nil then ws.Free;
if result then
begin
add_child(o, TlkJSONbase(mth));
ridx := idx;
end
else
begin
mth.Free;
end;
end;
end;
 
function js_object(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
var
js: TlkJSONobject;
begin
result := false;
try
js := TlkJSONobject.Create;
skip_spc(idx);
result := xe(idx);
if not result then exit;
result := txt[idx] = '{';
if not result then exit;
inc(idx);
while js_method(idx, idx, TlkJSONbase(js)) do
begin
skip_spc(idx);
if (xe(idx)) and (txt[idx] = ',') then inc(idx);
end;
skip_spc(idx);
result := (xe(idx)) and (txt[idx] = '}');
if not result then exit;
inc(idx);
finally
if not result then
begin
js.Free;
end
else
begin
add_child(o, TlkJSONbase(js));
ridx := idx;
end;
end;
end;
 
function js_base(idx: Integer; var ridx: Integer; var o:
TlkJSONbase): Boolean;
begin
skip_spc(idx);
result := js_boolean(idx, idx, o);
if not result then result := js_null(idx, idx, o);
if not result then result := js_number(idx, idx, o);
if not result then result := js_string(idx, idx, o);
if not result then result := js_list(idx, idx, o);
if not result then result := js_object(idx, idx, o);
if result then ridx := idx;
end;
 
var
idx: Integer;
begin
{$IFDEF HAVE_FORMATSETTING}
GetLocaleFormatSettings(GetThreadLocale, fs);
fs.DecimalSeparator := '.';
{$ENDIF}
 
result := nil;
if txt = '' then exit;
try
idx := 1;
// skip a BOM utf8 marker
if copy(txt,idx,3)=#239#187#191 then
begin
inc(idx,3);
// if there are only a BOM - exit;
if idx>length(txt) then exit;
end;
if not js_base(idx, idx, result) then FreeAndNil(result);
except
if assigned(result) then FreeAndNil(result);
end;
end;
 
{ ElkIntException }
 
constructor ElkIntException.Create(idx: Integer; msg: string);
begin
self.idx := idx;
inherited Create(msg);
end;
 
{ TlkHashTable }
 
{$IFDEF USE_HASH}
procedure TlkHashTable.AddPair(const ws: WideString; idx: Integer);
var
i, j, k: cardinal;
p: PlkHashItem;
find: boolean;
begin
find := false;
if InTable(ws, i, j, k) then
begin
// if string is already in table, changing index
if TlkJSONobject(FParent).GetNameOf(PlkHashItem(a_x[j].Items[k])^.index) = ws then
begin
PlkHashItem(a_x[j].Items[k])^.index := idx;
find := true;
end;
end;
if find = false then
begin
GetMem(p,sizeof(TlkHashItem));
k := a_x[j].Add(p);
p^.hash := i;
p^.index := idx;
while (k>0) and (PlkHashItem(a_x[j].Items[k])^.hash < PlkHashItem(a_x[j].Items[k-1])^.hash) do
begin
a_x[j].Exchange(k,k-1);
dec(k);
end;
end;
end;
 
function TlkHashTable.counters: string;
var
i, j: Integer;
ws: string;
begin
ws := '';
for i := 0 to 15 do
begin
for j := 0 to 15 do
// ws := ws + format('%.3d ', [length(a_h[i * 16 + j])]);
ws := ws + format('%.3d ', [a_x[i * 16 + j].Count]);
ws := ws + #13#10;
end;
result := ws;
end;
 
procedure TlkHashTable.Delete(const ws: WideString);
var
i, j, k: cardinal;
begin
if InTable(ws, i, j, k) then
begin
// while k < high(a_h[j]) do
// begin
// hswap(j, k, k + 1);
// inc(k);
// end;
// SetLength(a_h[j], k);
FreeMem(a_x[j].Items[k]);
a_x[j].Delete(k);
end;
end;
 
{$IFDEF THREADSAFE}
const
rnd_table: array[0..255] of byte =
(216, 191, 234, 201, 12, 163, 190, 205, 128, 199, 210, 17, 52, 43,
38, 149, 40, 207, 186, 89, 92, 179, 142, 93, 208, 215, 162,
161, 132, 59, 246, 37, 120, 223, 138, 233, 172, 195, 94, 237, 32,
231, 114, 49, 212, 75, 198, 181, 200, 239, 90, 121, 252, 211,
46, 125, 112, 247, 66, 193, 36, 91, 150, 69, 24, 255, 42, 9, 76,
227, 254, 13, 192, 7, 18, 81, 116, 107, 102, 213, 104, 15, 250,
153, 156, 243, 206, 157, 16, 23, 226, 225, 196, 123, 54, 101,
184, 31, 202, 41, 236, 3, 158, 45, 96, 39, 178, 113, 20, 139, 6,
245, 8, 47, 154, 185, 60, 19, 110, 189, 176, 55, 130, 1, 100,
155, 214, 133, 88, 63, 106, 73, 140, 35, 62, 77, 0, 71, 82, 145,
180,
171, 166, 21, 168, 79, 58, 217, 220, 51, 14, 221, 80, 87, 34, 33,
4, 187, 118, 165, 248, 95, 10, 105, 44, 67, 222, 109, 160, 103,
242, 177, 84, 203, 70, 53, 72, 111, 218, 249, 124, 83, 174, 253,
240, 119, 194, 65, 164, 219, 22, 197, 152, 127, 170, 137, 204,
99, 126, 141, 64, 135, 146, 209, 244, 235, 230, 85, 232, 143,
122, 25, 28, 115, 78, 29, 144, 151, 98, 97, 68, 251, 182, 229,
56,
159, 74, 169, 108, 131, 30, 173, 224, 167, 50, 241, 148, 11, 134,
117, 136, 175, 26, 57, 188, 147, 238, 61, 48, 183, 2, 129,
228, 27, 86, 5);
{$ELSE}
var
rnd_table: array[0..255] of byte;
{$ENDIF}
 
function TlkHashTable.DefaultHashOf(const ws: WideString): cardinal;
{$IFDEF DOTNET}
var
i, j: Integer;
x1, x2, x3, x4: byte;
begin
result := 0;
// result := 0;
x1 := 0;
x2 := 1;
for i := 1 to length(ws) do
begin
j := ord(ws[i]);
// first version of hashing
x1 := (x1 + j) {and $FF};
x2 := (x2 + 1 + (j shr 8)) {and $FF};
x3 := rnd_table[x1];
x4 := rnd_table[x3];
result := ((x1 * x4) + (x2 * x3)) xor result;
end;
end;
{$ELSE}
var
x1, x2, x3, x4: byte;
p: PWideChar;
begin
result := 0;
x1 := 0;
x2 := 1;
p := PWideChar(ws);
while p^ <> #0 do
begin
inc(x1, ord(p^)) {and $FF};
inc(x2, 1 + (ord(p^) shr 8)) {and $FF};
x3 := rnd_table[x1];
x4 := rnd_table[x3];
result := ((x1 * x4) + (x2 * x3)) xor result;
inc(p);
end;
end;
{$ENDIF}
 
procedure TlkHashTable.hswap(j, k, l: Integer);
//var
// h: TlkHashItem;
begin
// h := a_h[j, k];
// a_h[j, k] := a_h[j, l];
// a_h[j, l] := h;
a_x[j].Exchange(k, l);
end;
 
function TlkHashTable.IndexOf(const ws: WideString): Integer;
var
i, j, k: Cardinal;
begin
if not InTable(ws, i, j, k) then
begin
result := -1;
end
else
begin
// result := a_h[j, k].index;
result := PlkHashItem(a_x[j].Items[k])^.index;
end;
end;
 
function TlkHashTable.InTable(const ws: WideString; var i, j, k:
cardinal):
Boolean;
var
l, wu, wl: Integer;
x: Cardinal;
fin: Boolean;
begin
i := HashOf(ws);
j := i and $FF;
result := false;
{using "binary" search always, because array is sorted}
if a_x[j].Count-1 >= 0 then
begin
wl := 0;
wu := a_x[j].Count-1;
repeat
fin := true;
if PlkHashItem(a_x[j].Items[wl])^.hash = i then
begin
k := wl;
result := true;
end
else if PlkHashItem(a_x[j].Items[wu])^.hash = i then
begin
k := wu;
result := true;
end
else if (wu - wl) > 1 then
begin
fin := false;
x := (wl + wu) shr 1;
if PlkHashItem(a_x[j].Items[x])^.hash > i then
begin
wu := x;
end
else
begin
wl := x;
end;
end;
until fin;
end;
 
// verify k index in chain
if result = true then
begin
while (k > 0) and (PlkHashItem(a_x[j].Items[k])^.hash = PlkHashItem(a_x[j].Items[k-1])^.hash) do dec(k);
repeat
fin := true;
if TlkJSONobject(FParent).GetNameOf(PlkHashItem(a_x[j].Items[k])^.index) <> ws then
begin
if k < a_x[j].Count-1 then
begin
inc(k);
fin := false;
end
else
begin
result := false;
end;
end
else
begin
result := true;
end;
until fin;
end;
end;
 
{$IFNDEF THREADSAFE}
 
procedure init_rnd;
var
x0: Integer;
i: Integer;
begin
x0 := 5;
for i := 0 to 255 do
begin
x0 := (x0 * 29 + 71) and $FF;
rnd_table[i] := x0;
end;
end;
{$ENDIF}
 
procedure TlkHashTable.SetHashFunction(const AValue:
TlkHashFunction);
begin
FHashFunction := AValue;
end;
 
constructor TlkHashTable.Create;
var
i: Integer;
begin
inherited;
// for i := 0 to 255 do SetLength(a_h[i], 0);
for i := 0 to 255 do a_x[i] := TList.Create;
HashOf := {$IFDEF FPC}@{$ENDIF}DefaultHashOf;
end;
 
destructor TlkHashTable.Destroy;
var
i, j: Integer;
begin
// for i := 0 to 255 do SetLength(a_h[i], 0);
for i := 0 to 255 do
begin
for j := 0 to a_x[i].Count - 1 do Freemem(a_x[i].Items[j]);
a_x[i].Free;
end;
inherited;
end;
 
function TlkHashTable.SimpleHashOf(const ws: WideString): cardinal;
var
i: Integer;
begin
result := length(ws);
for i := 1 to length(ws) do result := result + ord(ws[i]);
end;
{$ENDIF USE_HASH}
 
{ TlkJSONstreamed }
{$IFNDEF KOL}
 
class function TlkJSONstreamed.LoadFromFile(srcname: string):
TlkJSONbase;
var
fs: TFileStream;
begin
result := nil;
if not FileExists(srcname) then exit;
try
fs := TFileStream.Create(srcname, fmOpenRead);
result := LoadFromStream(fs);
finally
if Assigned(fs) then FreeAndNil(fs);
end;
end;
 
class function TlkJSONstreamed.LoadFromStream(src: TStream):
TlkJSONbase;
var
ws: string;
len: int64;
begin
result := nil;
if not assigned(src) then exit;
len := src.Size - src.Position;
SetLength(ws, len);
src.Read(pchar(ws)^, len);
result := ParseText(ws);
end;
 
class procedure TlkJSONstreamed.SaveToFile(obj: TlkJSONbase;
dstname: string);
var
fs: TFileStream;
begin
if not assigned(obj) then exit;
try
fs := TFileStream.Create(dstname, fmCreate);
SaveToStream(obj, fs);
finally
if Assigned(fs) then FreeAndNil(fs);
end;
end;
 
class procedure TlkJSONstreamed.SaveToStream(obj: TlkJSONbase;
dst: TStream);
var
ws: string;
begin
if not assigned(obj) then exit;
if not assigned(dst) then exit;
ws := GenerateText(obj);
dst.Write(pchar(ws)^, length(ws));
end;
 
{$ENDIF}
 
{ TlkJSONdotnetclass }
 
{$IFDEF DOTNET}
 
procedure TlkJSONdotnetclass.AfterConstruction;
begin
 
end;
 
procedure TlkJSONdotnetclass.BeforeDestruction;
begin
 
end;
 
constructor TlkJSONdotnetclass.Create;
begin
inherited;
AfterConstruction;
end;
 
destructor TlkJSONdotnetclass.Destroy;
begin
BeforeDestruction;
inherited;
end;
{$ENDIF DOTNET}
 
{ TlkBalTree }
 
{$IFNDEF USE_HASH}
procedure TlkBalTree.Clear;
 
procedure rec(t: PlkBalNode);
begin
if t.left<>fbottom then rec(t.left);
if t.right<>fbottom then rec(t.right);
t.nm := '';
dispose(t);
end;
 
begin
if froot<>fbottom then rec(froot);
froot := fbottom;
fdeleted := fbottom;
end;
 
function TlkBalTree.counters: string;
begin
result := format('Balanced tree root node level is %d',[froot.level]);
end;
 
constructor TlkBalTree.Create;
begin
inherited Create;
new(fbottom);
fbottom.left := fbottom;
fbottom.right := fbottom;
fbottom.level := 0;
fdeleted := fbottom;
froot := fbottom;
end;
 
function TlkBalTree.Delete(const ws: WideString): Boolean;
 
procedure UpdateKeys(t: PlkBalNode; idx: integer);
begin
if t <> fbottom then begin
if t.key > idx then
t.key := t.key - 1;
UpdateKeys(t.left, idx);
UpdateKeys(t.right, idx);
end;
end;
 
function del(var t: PlkBalNode): Boolean;
begin
result := false;
if t<>fbottom then begin
flast := t;
if ws<t.nm then
result := del(t.left)
else begin
fdeleted := t;
result := del(t.right);
end;
if (t = flast) and (fdeleted <> fbottom) and (ws = fdeleted.nm) then begin
UpdateKeys(froot, fdeleted.key);
fdeleted.key := t.key;
fdeleted.nm := t.nm;
t := t.right;
flast.nm := '';
dispose(flast);
result := true;
end
else if (t.left.level < (t.level - 1)) or (t.right.level < (t.level - 1)) then begin
t.level := t.level - 1;
if t.right.level > t.level then
t.right.level := t.level;
skew(t);
skew(t.right);
skew(t.right.right);
split(t);
split(t.right);
end;
end;
end;
 
{
// mine version, buggy, see tracker message
// [ 2229135 ] Value deletion is broken by "Nobody/Anonymous - nobody"
 
function del(var t: PlkBalNode): Boolean;
begin
result := false;
if t<>fbottom then
begin
flast := t;
if ws<t.nm then
result := del(t.left)
else
begin
fdeleted := t;
result := del(t.right);
end;
if (t = flast) and (fdeleted<>fbottom) and (ws = t.nm) then
begin
fdeleted.key := t.key;
fdeleted.nm := t.nm;
t := t.right;
flast.nm := '';
dispose(flast);
result := true;
end
else if (t.left.level<(t.level-1)) or (t.right.level<(t.level-1)) then
begin
t.level := t.level-1;
if t.right.level>t.level then t.right.level := t.level;
skew(t);
skew(t.right);
skew(t.right.right);
split(t);
split(t.right);
end;
end;
end;
}
 
begin
result := del(froot);
end;
 
destructor TlkBalTree.Destroy;
begin
Clear;
dispose(fbottom);
inherited;
end;
 
function TlkBalTree.IndexOf(const ws: WideString): Integer;
var
tk: PlkBalNode;
begin
result := -1;
tk := froot;
while (result=-1) and (tk<>fbottom) do
begin
if tk.nm = ws then result := tk.key
else if ws<tk.nm then tk := tk.left
else tk := tk.right;
end;
end;
 
function TlkBalTree.Insert(const ws: WideString; x: Integer): Boolean;
 
function ins(var t: PlkBalNode): Boolean;
begin
if t = fbottom then
begin
new(t);
t.key := x;
t.nm := ws;
t.left := fbottom;
t.right := fbottom;
t.level := 1;
result := true;
end
else
begin
if ws < t.nm then
result := ins(t.left)
else if ws > t.nm then
result := ins(t.right)
else result := false;
skew(t);
split(t);
end;
end;
 
begin
result := ins(froot);
end;
 
procedure TlkBalTree.skew(var t: PlkBalNode);
var
temp: PlkBalNode;
begin
if t.left.level = t.level then
begin
temp := t;
t := t.left;
temp.left := t.right;
t.right := temp;
end;
end;
 
procedure TlkBalTree.split(var t: PlkBalNode);
var
temp: PlkBalNode;
begin
if t.right.right.level = t.level then
begin
temp := t;
t := t.right;
temp.right := t.left;
t.left := temp;
t.level := t.level+1;
end;
end;
{$ENDIF USE_HASH}
 
initialization
{$IFNDEF THREADSAFE}
{$IFDEF USE_HASH}
init_rnd;
{$ENDIF USE_HASH}
{$ENDIF THREADSAFE}
end.
 
/trunk/ToDo.txt
0,0 → 1,6
 
Make ConvertEx(): Shall return a struct (Success, Value, TimeStamp) Attention: Align by 4 byte to make it compatible with VBA.
 
DLL: Use resourcestrings
 
Make examples for VB, C++ etc
/trunk
Property changes:
Added: svn:ignore
+*.dcu
+*.~*
+__history
+*.local
+*.identcache
+*.stat