/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>0: Always download, on each request (attention: API keys may have limited amount of accesses per month)</li> |
<li>>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>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>>=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>0: Always download, on each request (attention: API keys may have limited amount of accesses per month)</li> |
<li>>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>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>>=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>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 |