Vichingo455-RePacks/xtool
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity

source upload

Browse Source
This commit is contained in:
Razor12911
2022-01-17 22:16:47 +02:00
parent 12936d065b
commit 098e8c48de
1778 changed files with 1206749 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

540
contrib/mORMot/SQLite3/DDD/dom/asynch.pas.mustache Normal file
View File

@@ -0,0 +1,540 @@
{{#soa}}
{{#unitasynch}}
/// asynch version of {{#services}}{{interfaceName}} {{/services}}
{{/unitasynch}}
{{#unitsynch}}
/// implements {{#services}}{{interfaceName}} {{/services}}over *Asynch
{{/unitsynch}}
unit {{filename}};
{
WARNING:
This unit has been generated by {{exeName}}.
Any manual modification of this file may be lost after regeneration.
{{#unitasynch}}
Defines asynchronous (non-blocking) types for the following services:
{{#services}}
- {{interfaceName}} as non-blocking {{interfaceName}}Asynch,
associated with blocking T{{uri}}Synch / {{interfaceName}}Synch,
{{interfaceName}}AsynchAck and T{{uri}}Delays.
{{/services}}
{{/unitasynch}}
{{#unitsynch}}
Defines synchronous (blocking) implementation for the following services:
{{#services}}
- {{interfaceName}} as blocking T{{uri}}Abstract,
calling {{interfaceName}}Synch / {{interfaceName}}Asynch
{{/services}}
{{/unitsynch}}
Corresponding to {{projectname}} version {{exeVersion}}.
Generated by {{User}} at {{time}}.
}
{{<callparam}}const call: {{calltype}}{{/callparam}}
interface
{{<asynchparam}}{{#asynchkey}}const {{.}}: {{asynchkeytype}}{{/asynchkey}}{{/asynchparam}}
uses
SysUtils,
SynCommons,
SynLog,
mORMot,
{{#units}}
{{.}},
{{/units}}
mORMotDDD;
{{<methodasynch}}{{methodName}}({{>asynchparam}}{{#args}}{{#dirInput}};
{{dirName}} {{argName}}: {{typeSource}}{{/dirInput}}{{/args}};
{{>callparam}}){{#args}}{{#dirResult}}: {{typeSource}}{{/dirResult}}{{/args}};{{/methodasynch}}
{{<methodack}}{{methodName}}({{>callparam}}; {{#args}}{{^dirResult}}{{#dirOutput}}
const {{argName}}: {{typeSource}};{{/dirOutput}}{{/dirResult}}{{/args}}{{#args}}{{#dirResult}}
const res: {{typeSource}}{{/dirResult}}{{/args}});{{/methodack}}
{{<methodsynch}}{{methodName}}({{>asynchparam}}{{#args}}{{^dirResult}};
{{dirName}} {{argName}}: {{typeSource}}{{/dirResult}}{{/args}}){{#args}}{{#dirResult}}: {{typeSource}}{{/dirResult}}{{/args}};{{/methodsynch}}
{{#services}}{{#unitasynch}}
{ -------- asynchronous version of {{interfaceName}} }
type
{{<methoddelay}}{{#asynchdelay}}{{.}}{{/asynchdelay}}{{^asynchdelay}}{{defaultdelay}}{{/asynchdelay}}{{/methoddelay}}
/// settings associated to {{interfaceName}}Asynch timeouts
T{{uri}}Delays = class(TSynPersistent)
protected
{{#methods}}
{{^isInherited}}
f{{methodName}}: integer;
{{/isInherited}}
{{/methods}}
public
/// would set all delays to their default values
constructor Create; override;
published
{{#methods}}
{{^isInherited}}
/// default delay for {{interfaceName}}Asynch.{{methodName}} is {{>methoddelay}} ms
property {{methodName}}: integer read f{{methodName}} write f{{methodName}};
{{/isInherited}}
{{/methods}}
end;
/// the {{interfaceName}}Asynch progress callback definition
// - a single callback, after subscription via Subscribe{{uri}}(),
// would receive the acknowledgements of all {{interfaceName}}Asynch methods
// - some commands may take a lot of time, so this asynchronous mechanism
// would increase the system reactivity
// - naming is following the {{interfaceName}} method names
// - call: {{calltype}} is the opaque value supplied at command invoke
{{interfaceName}}AsynchAck = interface(IInvokable)
['{{newguid .}}']
{{#methods}}
{{^isInherited}}
procedure {{>methodack}}
{{/isInherited}}
{{/methods}}
end;
/// identify any {{interfaceName}}Asynch method
// - see also ToText(), ToMethodName() and To{{uri}}Ack() functions
T{{uri}}Ack = (
ack{{uri}}Undefined{{#methods}}{{^isInherited}},
ack{{methodName}}{{/isInherited}}{{/methods}});
/// high-level asynchronous (non blocking) definition of {{interfaceName}}
// - all the methods match the latest inheritance level of synchronous
// (blocking) {{interfaceName}} - it won't define the parents methods,
// since it would allow to work on a dual phase Select/Command with no
// prior Select (multiple inheritance of interfaces may have helped a lot, but
// but they are not allowed yet){{#asynchkey}} using {{.}}: {{asynchkeytype}} to redirect
// the {{interfaceName}}Asynch call to the corresponding {{interfaceName}}
{{/asynchkey}} // - call: {{calltype}} is an opaque value, which would identify the command
// when it is acknowledged by {{interfaceName}}AsynchAck
{{interfaceName}}Asynch = interface(IInvokable)
['{{newguid .}}']
/// this method is expected to be called once at the beginning of the
// process, to receive all asynchronous acknowledgements of the other methods
// - it would return the default delays for the associated timeouts, as
// defined on the server side
function Subscribe{{uri}}(const OnAck: {{interfaceName}}AsynchAck;
out Delays: T{{uri}}Delays): TCQRSResult;
// all methods below map {{interfaceName}} methods, and their input parameters
{{#methods}}
{{^isInherited}}
{{verb}} {{>methodasynch}}
{{/isInherited}}
{{/methods}}
end;
/// waiting semaphore associated to {{interfaceName}}Asynch
// - used internally by T{{uri}}AsynchAck
T{{uri}}AsynchCall = class(TBlockingProcessPoolItem)
protected
procedure ResetInternal; override; // set Params to 0
public
Params: record
// execution context
{{#asynchkey}}
{{.}}: {{asynchkeytype}};
{{/asynchkey}}
methodname: RawUTF8;
ack: T{{uri}}Ack;
// additional parameters, copied from {{interfaceName}}AsynchAck
res: TCQRSResult;{{#methods}}{{^isInherited}}{{#args}}{{#dirOutput}}{{^dirResult}}
{{argName}}{{methodIndex}}: {{typeSource}};{{/dirResult}}{{/dirOutput}}{{/args}}{{/isInherited}}{{/methods}}
end;
published
{{#asynchkey}}
property {{.}}: {{asynchkeytype}} read Params.{{.}};
{{/asynchkey}}
property ack: T{{uri}}Ack read Params.ack;
property res: TCQRSResult read Params.res;
end;
/// propagate acknowledgements for {{interfaceName}}Asynch
// - {{interfaceName}}AsynchAck acknowledgements would be propagated using the
// associated {{calltype}}, to release the wait of the main {{interfaceName}}
// blocking process
// - would allow to run {{interfaceName}} blocking methods over a supplied
// {{interfaceName}}Asynch instance
T{{uri}}AsynchAck = class(TCQRSServiceAsynchAck, {{interfaceName}}AsynchAck)
protected
function Notify({{>callparam}}; ack: T{{uri}}Ack;
res: TCQRSResult; out process: T{{uri}}AsynchCall): boolean; overload;
procedure Notify({{>callparam}}; ack: T{{uri}}Ack;
res: TCQRSResult); overload;
// {{interfaceName}}AsynchAck methods
// would propagate the acknowledgement, and copy any additional parameter
// to T{{uri}}AsynchCall.Params
{{#methods}}
{{^isInherited}}
procedure {{>methodack}}
{{/isInherited}}
{{/methods}}
public
constructor Create(aLog: TSynLogClass);
/// returns a blocking process from the internal semaphore pool
function NewAsynchCall: T{{uri}}AsynchCall;
end;
/// shared synchronous (blocking) interface of {{interfaceName}}Asynch
{{#asynchkey}}
// - every method expects a {{.}}: {{asynchkeytype}} first input
// parameter, in addition to the regular {{interfaceName}} parameters
{{/asynchkey}}
{{interfaceName}}Synch = interface(IInvokable)
['{{newguid .}}']
{{#methods}}
{{^isInherited}}
{{verb}} {{>methodsynch}}
{{/isInherited}}
{{/methods}}
end;
/// implements {{interfaceName}}Synch over a {{interfaceName}}Asynch instance
// - it will use a shared T{{uri}}AsynchAck callback to wait for each
// command to be finished, and emulate synchronous (non-blocking) execution
// - you may use this class e.g. at API level, over a blocking REST server,
// and communicate with the Domain event-driven services via asynchronous calls
T{{uri}}Synch = class(TCQRSServiceSynch, {{interfaceName}}Synch)
protected
fLog: TSynLogClass;
fDelays: T{{uri}}Delays;
fDelaysOwned: boolean;
fAsynch: {{interfaceName}}Asynch;
fSharedCallback: T{{uri}}AsynchAck;
procedure WaitFor(call: T{{uri}}AsynchCall;{{#asynchkey}} const {{.}}: {{asynchkeytype}};{{/asynchkey}}
delay: integer; ack: T{{uri}}Ack; var result: TCQRSResult);
public
/// initialize the blocking instance
// - would allocate an internal T{{uri}}AsynchAck callback, and
// execute {{interfaceName}}Asynch.Subscribe{{uri}}()
// - you may specify custom delays, to overload values supplied by the server
// during Subscribe{{uri}}()
constructor Create(const aAsynch: {{interfaceName}}Asynch;
aDelays: T{{uri}}Delays = nil; aLog: TSynLogClass = nil); reintroduce;
/// finalize the instance
destructor Destroy; override;
/// access to the asynchronous methods
property Asynch: {{interfaceName}}Asynch read fAsynch;
/// associated time out values, in ms
property Delays: T{{uri}}Delays read fDelays;
public
// {{interfaceName}}Synch blocking methods, returning cqrsTimeout if the
// non-blocking calls did not respond in the expected delay, or the
// TCQRSResult returned by the associated {{interfaceName}}Asynch method
{{#methods}}
{{^isInherited}}
{{verb}} {{>methodsynch}}
{{/isInherited}}
{{/methods}}
end;
/// returns the low-level text value of the enumerated, including trailing "ack"
// - may be used e.g. for debugging/logging purpose
function ToText(ack: T{{uri}}Ack): PShortString; overload;
/// returns the original method name without trailing "ack", as defined in
// {{interfaceName}}Asynch
// - reverse function of To{{uri}}Ack()
function ToMethodName(ack: T{{uri}}Ack): RawUTF8; overload;
/// find a T{{uri}}Ack item, matching original method name
// without trailing "ack", as defined in {{interfaceName}}Asynch
// - reverse function of ToMethodName()
function To{{uri}}Ack(const MethodName: RawUTF8): T{{uri}}Ack;
{{/unitasynch}}
{{#asynchkey}}{{#unitsynch}}{ -------- implements {{interfaceName}} over {{interfaceName}}Synch }
{{#query}}{{<method}}{{methodName}}({{#args}}{{^dirResult}}
{{dirName}} {{argName}}: {{typeSource}}{{commaArg}}{{/dirResult}}{{/args}}){{#args}}{{#dirResult}}: {{typeSource}}{{/dirResult}}{{/args}};{{/method}}
type
/// implements CQRS two-phase commit over a {{interfaceName}}Asynch instance
// - first Select phase should have been implemented in {{.}}
// - expects a f{{asynchkey}}: {{asynchkeytype}} field to be available,
// so that the proper {{interfaceName}}Synch method would be called
// - this abstract class should be inherited, and override Set{{uri}}Synch
T{{uri}}Abstract = class({{.}}, {{interfaceName}})
protected
f{{uri}}Synch: {{interfaceName}}Synch;
function BeginSynch(var aResult: TCQRSResult): boolean;
// should be overriden, to set f{{uri}}Synch from f{{asynchkey}}
procedure Set{{uri}}Synch; virtual; abstract;
public
// {{interfaceName}} blocking methods
{{#methods}}
{{^isInherited}}
{{verb}} {{>method}}
{{/isInherited}}
{{/methods}}
end;
{{/query}}{{/unitsynch}}{{/asynchkey}}
{{/services}}
implementation
{{#services}}
{{#unitasynch}}
{ -------- asynchronous version of {{interfaceName}} }
function ToText(ack: T{{uri}}Ack): PShortString;
begin
result := GetEnumName(TypeInfo(T{{uri}}Ack), ord(ack));
end;
function ToMethodName(ack: T{{uri}}Ack): RawUTF8;
begin
result := TrimLeftLowerCaseShort(ToText(ack));
end;
function To{{uri}}Ack(const MethodName: RawUTF8): T{{uri}}Ack;
var
ndx: integer;
begin
ndx := GetEnumNameValueTrimmed(TypeInfo(T{{uri}}Ack),
pointer(MethodName), length(MethodName));
if ndx > 0 then
result := T{{uri}}Ack(ndx)
else
result := ack{{uri}}Undefined;
end;
{ T{{uri}}Delays }
constructor T{{uri}}Delays.Create;
begin
inherited;
{{#methods}}
{{^isInherited}}
f{{methodName}} := {{>methoddelay}};
{{/isInherited}}
{{/methods}}
end;
{ T{{uri}}AsynchCall }
procedure T{{uri}}AsynchCall.ResetInternal;
begin
inherited ResetInternal; // set fEvent := evNone and fCall := 0
Finalize(Params);
FillCharFast(Params, sizeof(Params), 0);
end;
{ T{{uri}}AsynchAck }
constructor T{{uri}}AsynchAck.Create(aLog: TSynLogClass);
begin
inherited Create;
fLog := aLog;
fCalls := TBlockingProcessPool.Create(T{{uri}}AsynchCall);
end;
{{<callfmt}}%(call=%,{{#asynchkey}}%,{{/asynchkey}}%){{/callfmt}}
function T{{uri}}AsynchAck.Notify({{>callparam}};
ack: T{{uri}}Ack; res: TCQRSResult; out process: T{{uri}}AsynchCall): boolean;
var
id: integer;
begin
result := false;
{{#callfunction}}
if not {{.}}(call, id) then begin
fLog.Add.Log(sllTrace, 'Notify: invalid %(call=%) received', [ToText(ack)^, call], self);
exit;
end;
{{/callfunction}}
{{^callfunction}}
id := call;
{{/callfunction}}
process := pointer(fCalls.FromCall(id, true));
if process = nil then begin
fLog.Add.Log(sllTrace, 'Notify: deprecated/unexpected {{>callfmt}} received -> skipped',
[ToText(ack)^, id, {{#asynchkey}}'?', {{/asynchkey}}ToText(res)^], self);
exit;
end;
fLog.Add.Log(sllTrace, 'Notify: {{>callfmt}} received',
[process.Params.methodname, id, {{#asynchkey}}process.{{.}}, {{/asynchkey}}ToText(res)^], self);
process.Params.res := res;
result := true;
end;
procedure T{{uri}}AsynchAck.Notify({{>callparam}};
ack: T{{uri}}Ack; res: TCQRSResult);
var
process: T{{uri}}AsynchCall;
begin
if Notify(call, ack, res, process) then
process.NotifyFinished(true); // notify caller to unlock "WaitFor" method
end;
function T{{uri}}AsynchAck.NewAsynchCall: T{{uri}}AsynchCall;
begin
result := pointer(fCalls.NewProcess(0));
if result = nil then
raise {{Exception}}.CreateUTF8('%.NewAsynchCall: NewProcess=nil', [self]);
end;
// {{interfaceName}}AsynchAck methods
{{#methods}}
{{^isInherited}}
procedure T{{uri}}AsynchAck.{{>methodack}}
{{#hasOutNotResultParams}}
var
process: T{{uri}}AsynchCall;
begin
if Notify(call, ack{{methodName}}, res, process) then begin{{#args}}{{#dirOutput}}{{^dirResult}}
process.Params.{{argName}}{{methodIndex}} := {{argName}};{{/dirResult}}{{/dirOutput}}{{/args}}
process.NotifyFinished(true);
end;
{{/hasOutNotResultParams}}
{{^hasOutNotResultParams}}
begin
Notify(call, ack{{methodName}}, res);
{{/hasOutNotResultParams}}
end;
{{/isInherited}}
{{/methods}}
{ T{{uri}}Synch }
constructor T{{uri}}Synch.Create(const aAsynch: {{interfaceName}}Asynch;
aDelays: T{{uri}}Delays; aLog: TSynLogClass);
var
res: TCQRSResult;
outdelays: T{{uri}}Delays;
begin
if aAsynch = nil then
raise {{exception}}.CreateUTF8('%.Create(aAsynch=nil)', [self]);
fAsynch := aAsynch;
fLog := aLog;
fSharedCallback := T{{uri}}AsynchAck.Create(fLog);
inherited Create(fSharedCallback);
outdelays := T{{uri}}Delays.Create;
try
res := fAsynch.Subscribe{{uri}}(fSharedCallback, outdelays);
if res <> cqrsSuccess then
raise EDomPanel.CreateUTF8('%.Create: {{interfaceName}}Asynch.Subscribe=%',
[self, ToText(res)^]);
if aDelays <> nil then
fDelays := aDelays // force custom delays
else begin
fDelays := outdelays;
fDelaysOwned := true;
outdelays := nil;
end;
finally
outdelays.Free;
end;
end;
destructor T{{uri}}Synch.Destroy;
begin
if fDelaysOwned then
fDelays.Free;
inherited Destroy;
end;
procedure T{{uri}}Synch.WaitFor(call: T{{uri}}AsynchCall;
{{#asynchkey}}const {{.}}: {{asynchkeytype}}; {{/asynchkey}}delay: integer; ack: T{{uri}}Ack;
var result: TCQRSResult);
var
msg: RawUTF8;
begin
call.Lock;
try
{{#asynchkey}}
call.Params.{{.}} := {{.}}; // for Notify()
{{/asynchkey}}
call.Params.ack := ack;
call.Params.methodname := ToMethodName(ack);
FormatUTF8('WaitFor: Asynch.{{>callfmt}}',
[call.Params.methodname, call.Call, {{#asynchkey}}{{.}}, {{/asynchkey}}ToText(result)^], msg);
finally
call.Unlock;
end;
fLog.Add.Log(sllTrace, msg, self);
if result <> cqrsSuccess then
fLog.Add.Log(sllDDDError, '%: input parameters?', [msg])
else if call.WaitFor(delay) = evTimeOut then begin
fLog.Add.Log(sllDDDInfo, '% timeout after %ms', [msg, delay]);
result := cqrsTimeout;
end
else
result := call.Params.res;
end;
// {{interfaceName}}Synch blocking methods
{{<argvalue}}{{#isEnum}}ToText({{argName}})^{{/isEnum}}{{^isEnum}}{{argName}}{{/isEnum}}{{/argvalue}}
{{#methods}}
{{^isInherited}}
{{verb}} T{{uri}}Synch.{{>methodsynch}}
var
log: ISynLog;
call: T{{uri}}AsynchCall;
begin
if fLog <> nil then
log := fLog.Enter('{{methodName}}({{#asynchkey}}{{.}}=%{{/asynchkey}}{{#args}}{{#dirInput}}, {{argName}}=%{{/dirInput}}{{/args}})',
[{{#asynchkey}}{{.}}{{/asynchkey}}{{#args}}{{#dirInput}},{{>argvalue}}{{/dirInput}}{{/args}}], self);
try
call := fSharedCallback.NewAsynchCall;
try
result := Asynch.{{methodName}}({{#asynchkey}}{{.}}, {{/asynchkey}}{{#args}}{{#dirInput}}{{argName}}, {{/dirInput}}{{/args}}call.Call);
WaitFor(call, {{#asynchkey}}{{.}}, {{/asynchkey}}Delays.{{methodName}}, ack{{methodName}}, result);
finally{{#hasOutNotResultParams}}{{#args}}{{#dirOutput}}{{^dirResult}}
{{argName}} := call.Params.{{argName}}{{methodIndex}};{{/dirResult}}{{/dirOutput}}{{/args}}{{/hasOutNotResultParams}}
call.Reset;
end;
except
on Exception do
result := cqrsInternalError;
end;
if log <> nil then
log.Log(sllDebug, '{{methodName}}{{#asynchkey}}(%){{/asynchkey}} returned %{{#args}}{{#dirOutput}}{{^dirResult}} {{argName}}=%{{/dirResult}}{{/dirOutput}}{{/args}}',
[{{#asynchkey}}{{.}}, {{/asynchkey}}ToText(result)^{{#args}}{{#dirOutput}}{{^dirResult}}, {{>argvalue}}{{/dirResult}}{{/dirOutput}}{{/args}}], self);
end;
{{/isInherited}}
{{/methods}}
{{/unitasynch}}
{{#asynchkey}}{{#unitsynch}}{ -------- implements {{interfaceName}} over {{interfaceName}}Synch }
{{#query}}
{ T{{uri}}Abstract }
function T{{uri}}Abstract.BeginSynch(var aResult: TCQRSResult): boolean;
begin
result := false;
if CqrsBeginMethod(qaCommandOnSelect, aResult) then begin
Set{{uri}}Synch;
if f{{uri}}Synch = nil then
CqrsSetResultMsg(cqrsInternalError, '{{uri}}Synch=nil')
else
result := true;
end;
end;
{{#methods}}{{^isInherited}}
{{verb}} T{{uri}}Abstract.{{>method}}
begin
if BeginSynch(result) then
CqrsSetResult(f{{uri}}Synch.{{methodName}}(
f{{asynchkey}}{{#args}}{{^dirResult}}, {{argName}}{{/dirResult}}{{/args}}));
end;
{{/isInherited}}
{{/methods}}
{{/query}}{{/unitsynch}}{{/asynchkey}}
{{/services}}
initialization
{{#services}}
{{#unitasynch}}
TInterfaceFactory.RegisterInterfaces([
TypeInfo({{interfaceName}}AsynchAck), TypeInfo({{interfaceName}}Asynch)]);
{{/unitasynch}}
{{/services}}
{{/soa}}
end.

121
contrib/mORMot/SQLite3/DDD/dom/dddDomAuthInterfaces.pas Normal file
View File

@@ -0,0 +1,121 @@
/// shared DDD Domains: Authentication objects and interfaces
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddDomAuthInterfaces;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SynCommons,
SysUtils,
Classes,
mORMot,
mORMotDDD;
type
/// the data type which will be returned during a password challenge
// - in practice, will be e.g. Base-64 encoded SHA-256 binary hash
TAuthQueryNonce = RawUTF8;
TAuthInfoName = RawUTF8;
/// DDD entity used to store authentication information
TAuthInfo = class(TSynPersistent)
protected
fLogonName: TAuthInfoName;
published
/// the textual identifier by which the user would recognize himself
property LogonName: TAuthInfoName read fLogonName write fLogonName;
end;
/// repository service to authenticate credentials via a dual pass challenge
IDomAuthQuery = interface(ICQRSService)
['{5FB1E4A6-B432-413F-8958-1FA1857D1195}']
/// initiate the first phase of a dual pass challenge authentication
function ChallengeSelectFirst(const aLogonName: RawUTF8): TAuthQueryNonce;
/// validate the first phase of a dual pass challenge authentication
function ChallengeSelectFinal(const aChallengedPassword: TAuthQueryNonce): TCQRSResult;
/// returns TRUE if the dual pass challenge did succeed
function Logged: boolean;
/// returns the logon name of the authenticated user
function LogonName: RawUTF8;
/// set the credential for Get() or further IAuthCommand.Update/Delete
// - this method execution will be disabled for most clients
function SelectByName(const aLogonName: RawUTF8): TCQRSResult;
/// retrieve some information about the current selected credential
function Get(out aAggregate: TAuthInfo): TCQRSResult;
end;
/// repository service to update or register new authentication credentials
IDomAuthCommand = interface(IDomAuthQuery)
['{8252727B-336B-4105-80FD-C8DFDBD4801E}']
/// register a new credential, from its LogonName/HashedPassword values
// - aHashedPassword should match the algorithm expected by the actual
// implementation class, over UTF-8 encoded LogonName+':'+Password
// - on success, the newly created credential will be the currently selected
function Add(const aLogonName: RawUTF8; aHashedPassword: TAuthQueryNonce): TCQRSResult;
/// update the current selected credential password
// - aHashedPassword should match the algorithm expected by the actual
// implementation class, over UTF-8 encoded LogonName+':'+Password
// - will be allowed only for the current challenged user
function UpdatePassword(const aHashedPassword: TAuthQueryNonce): TCQRSResult;
/// delete the current selected credential
// - this method execution will be disabled for most clients
function Delete: TCQRSResult;
/// write all pending changes prepared by Add/UpdatePassword/Delete methods
function Commit: TCQRSResult;
end;
implementation
initialization
TInterfaceFactory.RegisterInterfaces(
[TypeInfo(IDomAuthQuery),TypeInfo(IDomAuthCommand)]);
end.

483
contrib/mORMot/SQLite3/DDD/dom/dddDomCountry.pas Normal file
View File

@@ -0,0 +1,483 @@
/// shared DDD Domains: TCountry object definition
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddDomCountry;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SysUtils,
Classes,
SynCommons,
SynTests,
mORMot,
mORMotDDD;
{ *********** Country Modeling }
type
/// Country identifiers, following ISO 3166-1 standard
TCountryIdentifier = (ccUndefined,
ccAF,ccAX,ccAL,ccDZ,ccAS,ccAD,ccAO,ccAI,ccAQ,ccAG,ccAR,ccAM,ccAW,ccAU,ccAT,
ccAZ,ccBS,ccBH,ccBD,ccBB,ccBY,ccBE,ccBZ,ccBJ,ccBM,ccBT,ccBO,ccBQ,ccBA,ccBW,
ccBV,ccBR,ccIO,ccBN,ccBG,ccBF,ccBI,ccKH,ccCM,ccCA,ccCV,ccKY,ccCF,ccTD,ccCL,
ccCN,ccCX,ccCC,ccCO,ccKM,ccCG,ccCD,ccCK,ccCR,ccCI,ccHR,ccCU,ccCW,ccCY,ccCZ,
ccDK,ccDJ,ccDM,ccDO,ccEC,ccEG,ccSV,ccGQ,ccER,ccEE,ccET,ccFK,ccFO,ccFJ,ccFI,
ccFR,ccGF,ccPF,ccTF,ccGA,ccGM,ccGE,ccDE,ccGH,ccGI,ccGR,ccGL,ccGD,ccGP,ccGU,
ccGT,ccGG,ccGN,ccGW,ccGY,ccHT,ccHM,ccVA,ccHN,ccHK,ccHU,ccIS,ccIN,ccID,ccIR,
ccIQ,ccIE,ccIM,ccIL,ccIT,ccJM,ccJP,ccJE,ccJO,ccKZ,ccKE,ccKI,ccKP,ccKR,ccKW,
ccKG,ccLA,ccLV,ccLB,ccLS,ccLR,ccLY,ccLI,ccLT,ccLU,ccMO,ccMK,ccMG,ccMW,ccMY,
ccMV,ccML,ccMT,ccMH,ccMQ,ccMR,ccMU,ccYT,ccMX,ccFM,ccMD,ccMC,ccMN,ccME,ccMS,
ccMA,ccMZ,ccMM,ccNA,ccNR,ccNP,ccNL,ccNC,ccNZ,ccNI,ccNE,ccNG,ccNU,ccNF,ccMP,
ccNO,ccOM,ccPK,ccPW,ccPS,ccPA,ccPG,ccPY,ccPE,ccPH,ccPN,ccPL,ccPT,ccPR,ccQA,
ccRE,ccRO,ccRU,ccRW,ccBL,ccSH,ccKN,ccLC,ccMF,ccPM,ccVC,ccWS,ccSM,ccST,ccSA,
ccSN,ccRS,ccSC,ccSL,ccSG,ccSX,ccSK,ccSI,ccSB,ccSO,ccZA,ccGS,ccSS,ccES,ccLK,
ccSD,ccSR,ccSJ,ccSZ,ccSE,ccCH,ccSY,ccTW,ccTJ,ccTZ,ccTH,ccTL,ccTG,ccTK,ccTO,
ccTT,ccTN,ccTR,ccTM,ccTC,ccTV,ccUG,ccUA,ccAE,ccGB,ccUS,ccUM,ccUY,ccUZ,ccVU,
ccVE,ccVN,ccVG,ccVI,ccWF,ccEH,ccYE,ccZM,ccZW);
/// store ISO 3166-1 alpha-2 code
TCountryIsoAlpha2 = type RawUTF8;
/// store ISO 3166-1 alpha-3 code
TCountryIsoAlpha3 = type RawUTF8;
/// store a ISO 3166-1 numeric value as 16-bit unsigned integer
TCountryIsoNumeric = type word;
/// defines a Country identifier object
// - will store internally the country as 16-bit ISO 3166-1 numeric value
// - includes conversion methods for ISO 3166-1 alpha-2/alpha-3/numeric codes
// as explained in http://en.wikipedia.org/wiki/ISO_3166-1
// - see also some low-level class methods for direct values conversions
// with no persistence
TCountry = class(TSynPersistent)
protected
fIso: TCountryIsoNumeric;
fCache: packed record
Identifier: TCountryIdentifier;
Iso: TCountryIsoNumeric;
end;
function GetIdentifier: TCountryIdentifier;
function GetIsoAlpha2: TCountryIsoAlpha2;
function GetIsoAlpha3: TCountryIsoAlpha3;
procedure SetIdentifier(const Value: TCountryIdentifier);
procedure SetIsoAlpha2(const Value: TCountryIsoAlpha2);
procedure SetIsoAlpha3(const Value: TCountryIsoAlpha3);
function GetEnglish: RawUTF8;
public
/// low-level Country conversion into its plain English text
class function ToEnglish(id: TCountryIdentifier): RawUTF8;
/// low-level Country conversion into its alpha-2 code
class function ToAlpha2(id: TCountryIdentifier): TCountryIsoAlpha2;
/// low-level Country conversion into its alpha-3 code
class function ToAlpha3(id: TCountryIdentifier): TCountryIsoAlpha3;
/// low-level Country conversion to its ISO 3166-1 numeric 3-digit code
class function ToIso(id: TCountryIdentifier): TCountryIsoNumeric;
/// low-level case-insensitive Country conversion from its plain English text
// - returns ccUndefined if the supplied Text has no case-insensitive match
class function FromEnglish(const text: RawUTF8): TCountryIdentifier;
/// low-level Country conversion from its alpha-2 code
// - returns ccUndefined if the supplied text has no case-insensitive match
class function FromAlpha2(const alpha: TCountryIsoAlpha2): TCountryIdentifier;
/// low-level Country conversion from its alpha-3 code
// - returns ccUndefined if the supplied Text has no case-insensitive match
class function FromAlpha3(const alpha: TCountryIsoAlpha3): TCountryIdentifier;
/// low-level Country conversion from its alpha-2 code
// - returns ccUndefined if the supplied 16-bit number as no match
class function FromIso(iso: TCountryIsoNumeric): TCountryIdentifier;
/// built-in simple unit tests
class procedure RegressionTests(test: TSynTestCase);
/// returns TRUE if both Country instances have the same content
// - slightly faster than global function ObjectEquals(self,another)
function Equals(another: TCountry): boolean; reintroduce;
/// internal enumerate corresponding to this country
property Identifier: TCountryIdentifier read GetIdentifier write SetIdentifier;
/// the ISO 3166-1 alpha-2 code of this country
property Alpha2: TCountryIsoAlpha2 read GetIsoAlpha2 write SetIsoAlpha2;
/// the ISO 3166-1 alpha-3 code of this countr
property Alpha3: TCountryIsoAlpha3 read GetIsoAlpha3 write SetIsoAlpha3;
/// plain English text of this country, e.g. 'France' or 'United States'
property English: RawUTF8 read GetEnglish;
published
/// the stored and transmitted value is this ISO 3166-1 numeric 3-digit code
property Iso: TCountryIsoNumeric read fIso write fIso;
end;
implementation
{ TCountry }
const
COUNTRY_NAME_EN: array[TCountryIdentifier] of RawUTF8 = ('',
'Afghanistan','Aland Islands','Albania','Algeria','American Samoa',
'Andorra','Angola','Anguilla','Antarctica','Antigua and Barbuda',
'Argentina','Armenia','Aruba','Australia','Austria','Azerbaijan',
'Bahamas','Bahrain','Bangladesh','Barbados','Belarus','Belgium',
'Belize','Benin','Bermuda','Bhutan','Bolivia, Plurinational State of',
'Bonaire, Sint Eustatius and Saba','Bosnia and Herzegovina','Botswana',
'Bouvet Island','Brazil','British Indian Ocean Territory',
'Brunei Darussalam','Bulgaria','Burkina Faso','Burundi','Cambodia',
'Cameroon','Canada','Cape Verde','Cayman Islands','Central African Republic',
'Chad','Chile','China','Christmas Island','Cocos (Keeling) Islands',
'Colombia','Comoros','Congo','Congo, the Democratic Republic of the',
'Cook Islands','Costa Rica','Ivory Coast','Croatia','Cuba','Curacao',
'Cyprus','Czech Republic','Denmark','Djibouti','Dominica',
'Dominican Republic','Ecuador','Egypt','El Salvador','Equatorial Guinea',
'Eritrea','Estonia','Ethiopia','Falkland Islands (Malvinas)',
'Faroe Islands','Fiji','Finland','France','French Guiana',
'French Polynesia','French Southern Territories','Gabon','Gambia','Georgia',
'Germany','Ghana','Gibraltar','Greece','Greenland','Grenada','Guadeloupe',
'Guam','Guatemala','Guernsey','Guinea','Guinea-Bissau','Guyana','Haiti',
'Heard Island and McDonald Islands','Holy See (Vatican City State)',
'Honduras','Hong Kong','Hungary','Iceland','India','Indonesia',
'Iran, Islamic Republic of','Iraq','Ireland','Isle of Man','Israel',
'Italy','Jamaica','Japan','Jersey','Jordan','Kazakhstan','Kenya',
'Kiribati','Korea, Democratic People''s Republic of','Korea, Republic of',
'Kuwait','Kyrgyzstan','Lao People''s Democratic Republic','Latvia',
'Lebanon','Lesotho','Liberia','Libyan Arab Jamahiriya','Liechtenstein',
'Lithuania','Luxembourg','Macao','Macedonia, the former Yugoslav Republic of',
'Madagascar','Malawi','Malaysia','Maldives','Mali','Malta','Marshall Islands',
'Martinique','Mauritania','Mauritius','Mayotte','Mexico',
'Micronesia, Federated States of','Moldova, Republic of','Monaco',
'Mongolia','Montenegro','Montserrat','Morocco','Mozambique','Myanmar',
'Namibia','Nauru','Nepal','Netherlands','New Caledonia','New Zealand',
'Nicaragua','Niger','Nigeria','Niue','Norfolk Island',
'Northern Mariana Islands','Norway','Oman','Pakistan','Palau',
'Palestinian Territory','Panama','Papua New Guinea','Paraguay','Peru',
'Philippines','Pitcairn','Poland','Portugal','Puerto Rico','Qatar',
'Reunion','Romania','Russian Federation','Rwanda','Saint Barthelemy',
'Saint Helena, Ascension and Tristan da Cunha','Saint Kitts and Nevis',
'Saint Lucia','Saint Martin (French part)','Saint Pierre and Miquelon',
'Saint Vincent and the Grenadines','Samoa','San Marino',
'Sao Tome and Principe','Saudi Arabia','Senegal','Serbia',
'Seychelles','Sierra Leone','Singapore','Sint Maarten (Dutch part)',
'Slovakia','Slovenia','Solomon Islands','Somalia','South Africa',
'South Georgia and the South Sandwich Islands','South Sudan','Spain',
'Sri Lanka','Sudan','Suriname','Svalbard and Jan Mayen','Swaziland',
'Sweden','Switzerland','Syrian Arab Republic','Taiwan, Province of China',
'Tajikistan','Tanzania, United Republic of','Thailand','Timor-Leste',
'Togo','Tokelau','Tonga','Trinidad and Tobago','Tunisia','Turkey',
'Turkmenistan','Turks and Caicos Islands','Tuvalu','Uganda','Ukraine',
'United Arab Emirates','United Kingdom','United States',
'United States Minor Outlying Islands','Uruguay','Uzbekistan','Vanuatu',
'Venezuela, Bolivarian Republic of','Viet Nam','Virgin Islands, British',
'Virgin Islands, U.S.','Wallis and Futuna','Western Sahara','Yemen',
'Zambia','Zimbabwe');
COUNTRY_ISO3: array[TCountryIdentifier] of array[0..3] of AnsiChar = ('',
'AFG','ALA','ALB','DZA','ASM','AND','AGO','AIA','ATA','ATG','ARG','ARM',
'ABW','AUS','AUT','AZE','BHS','BHR','BGD','BRB','BLR','BEL','BLZ','BEN',
'BMU','BTN','BOL','BES','BIH','BWA','BVT','BRA','IOT','BRN','BGR','BFA',
'BDI','KHM','CMR','CAN','CPV','CYM','CAF','TCD','CHL','CHN','CXR','CCK',
'COL','COM','COG','COD','COK','CRI','CIV','HRV','CUB','CUW','CYP','CZE',
'DNK','DJI','DMA','DOM','ECU','EGY','SLV','GNQ','ERI','EST','ETH','FLK',
'FRO','FJI','FIN','FRA','GUF','PYF','ATF','GAB','GMB','GEO','DEU','GHA',
'GIB','GRC','GRL','GRD','GLP','GUM','GTM','GGY','GIN','GNB','GUY','HTI',
'HMD','VAT','HND','HKG','HUN','ISL','IND','IDN','IRN','IRQ','IRL','IMN',
'ISR','ITA','JAM','JPN','JEY','JOR','KAZ','KEN','KIR','PRK','KOR','KWT',
'KGZ','LAO','LVA','LBN','LSO','LBR','LBY','LIE','LTU','LUX','MAC','MKD',
'MDG','MWI','MYS','MDV','MLI','MLT','MHL','MTQ','MRT','MUS','MYT','MEX',
'FSM','MDA','MCO','MNG','MNE','MSR','MAR','MOZ','MMR','NAM','NRU','NPL',
'NLD','NCL','NZL','NIC','NER','NGA','NIU','NFK','MNP','NOR','OMN','PAK',
'PLW','PSE','PAN','PNG','PRY','PER','PHL','PCN','POL','PRT','PRI','QAT',
'REU','ROU','RUS','RWA','BLM','SHN','KNA','LCA','MAF','SPM','VCT','WSM',
'SMR','STP','SAU','SEN','SRB','SYC','SLE','SGP','SXM','SVK','SVN','SLB',
'SOM','ZAF','SGS','SSD','ESP','LKA','SDN','SUR','SJM','SWZ','SWE','CHE',
'SYR','TWN','TJK','TZA','THA','TLS','TGO','TKL','TON','TTO','TUN','TUR',
'TKM','TCA','TUV','UGA','UKR','ARE','GBR','USA','UMI','URY','UZB','VUT',
'VEN','VNM','VGB','VIR','WLF','ESH','YEM','ZMB','ZWE');
COUNTRY_ISONUM: array[TCountryIdentifier] of word = (0,
4,248,8,12,16,20,24,660,10,28,32,51,533,36,40,31,44,48,50,52,112,56,84,
204,60,64,68,535,70,72,74,76,86,96,100,854,108,116,120,124,132,136,140,
148,152,156,162,166,170,174,178,180,184,188,384,191,192,531,196,203,208,
262,212,214,218,818,222,226,232,233,231,238,234,242,246,250,254,258,260,
266,270,268,276,288,292,300,304,308,312,316,320,831,324,624,328,332,334,
336,340,344,348,352,356,360,364,368,372,833,376,380,388,392,832,400,398,
404,296,408,410,414,417,418,428,422,426,430,434,438,440,442,446,807,450,
454,458,462,466,470,584,474,478,480,175,484,583,498,492,496,499,500,504,
508,104,516,520,524,528,540,554,558,562,566,570,574,580,578,512,586,585,
275,591,598,600,604,608,612,616,620,630,634,638,642,643,646,652,654,659,
662,663,666,670,882,674,678,682,686,688,690,694,702,534,703,705,90,706,
710,239,728,724,144,729,740,744,748,752,756,760,158,762,834,764,626,768,
772,776,780,788,792,795,796,798,800,804,784,826,840,581,858,860,548,862,
704,92,850,876,732,887,894,716);
ccFirst = succ(low(TCountryIdentifier));
var
COUNTRY_ISO2: array[TCountryIdentifier] of word;
COUNTRYU_ISO2, COUNTRYU_ISO3: array[TCountryIdentifier] of RawUTF8;
COUNTRY_ISONUM_ORDERED: record // for fast binary search of the ISO numeric
Values, Indexes: array[TCountryIdentifier] of integer;
end;
procedure Initialize;
var c: TCountryIdentifier;
ps: PAnsiChar; // circumvent FPC compilation issue
begin
with COUNTRY_ISONUM_ORDERED do begin
for c := ccFirst to high(c) do begin
Values[c] := COUNTRY_ISONUM[c];
ps := pointer(GetEnumName(TypeInfo(TCountryIdentifier),ord(c)));
COUNTRY_ISO2[c] := PWord(ps+3)^;
FastSetString(COUNTRYU_ISO2[c],ps+3,2);
FastSetString(COUNTRYU_ISO3[c],@COUNTRY_ISO3[c],3);
end;
FillIncreasing(@Indexes,0,length(Indexes));
QuickSortInteger(@Values,@Indexes,0,length(Values)-1);
end;
end;
class function TCountry.ToEnglish(id: TCountryIdentifier): RawUTF8;
begin
result := COUNTRY_NAME_EN[id];
end;
class function TCountry.ToAlpha2(id: TCountryIdentifier): TCountryIsoAlpha2;
begin
result := COUNTRYU_ISO2[id];
end;
class function TCountry.ToAlpha3(id: TCountryIdentifier): TCountryIsoAlpha3;
begin
result := COUNTRYU_ISO3[id];
end;
class function TCountry.ToIso(id: TCountryIdentifier): TCountryIsoNumeric;
begin
result := COUNTRY_ISONUM[id];
end;
class function TCountry.FromEnglish(const text: RawUTF8): TCountryIdentifier;
var L: integer;
P: PRawUTF8;
begin
L := length(text);
P := @COUNTRY_NAME_EN[ccFirst];
for result := ccFirst to high(result) do
if (length(P^)=L) and IdemPropNameUSameLen(pointer(P^),pointer(Text),L) then
exit else
inc(P);
result := ccUndefined;
end;
class function TCountry.FromAlpha2(const alpha: TCountryIsoAlpha2): TCountryIdentifier;
var up: RawUTF8;
ndx: PtrInt;
begin
up := UpperCaseU(Trim(alpha));
if length(up)=2 then begin
ndx := WordScanIndex(@COUNTRY_ISO2[ccFirst],length(COUNTRY_ISO2)-1,PWord(up)^);
if ndx>=0 then begin
result := TCountryIdentifier(ndx+1);
exit;
end;
end;
result := ccUndefined;
end;
class function TCountry.FromAlpha3(const alpha: TCountryIsoAlpha3): TCountryIdentifier;
var up: RawUTF8;
ndx: PtrInt;
begin
up := UpperCaseU(Trim(alpha));
if length(up)=3 then begin
ndx := IntegerScanIndex(@COUNTRY_ISO3[ccFirst],length(COUNTRY_ISO3)-1,PCardinal(up)^);
if ndx>=0 then begin
result := TCountryIdentifier(ndx+1);
exit;
end;
end;
result := ccUndefined;
end;
class function TCountry.FromIso(iso: TCountryIsoNumeric): TCountryIdentifier;
var ndx: PtrInt;
begin
with COUNTRY_ISONUM_ORDERED do begin
ndx := FastFindIntegerSorted(@Values,length(Values)-1,Iso);
if ndx<0 then
result := ccUndefined else
result := TCountryIdentifier(Indexes[TCountryIdentifier(ndx)]);
end;
end;
function TCountry.GetEnglish: RawUTF8;
begin
result := COUNTRY_NAME_EN[GetIdentifier];
end;
function TCountry.GetIdentifier: TCountryIdentifier;
begin
if Iso=0 then
result := ccUndefined
else if Iso=fCache.Iso then
result := fCache.Identifier
else begin
result := FromIso(Iso);
fCache.Iso := Iso;
fCache.Identifier := result;
end;
end;
function TCountry.GetIsoAlpha2: TCountryIsoAlpha2;
begin
result := COUNTRYU_ISO2[GetIdentifier];
end;
function TCountry.GetIsoAlpha3: TCountryIsoAlpha3;
begin
result := COUNTRYU_ISO3[GetIdentifier];
end;
procedure TCountry.SetIdentifier(const Value: TCountryIdentifier);
begin
fIso := COUNTRY_ISONUM[Value];
if Value<>ccUndefined then begin
fCache.Iso := fIso;
fCache.Identifier := Value;
end;
end;
procedure TCountry.SetIsoAlpha2(const Value: TCountryIsoAlpha2);
begin
SetIdentifier(FromAlpha2(Value));
end;
procedure TCountry.SetIsoAlpha3(const Value: TCountryIsoAlpha3);
begin
SetIdentifier(FromAlpha3(Value));
end;
class procedure TCountry.RegressionTests(test: TSynTestCase);
var c,c2: TCountry;
i: TCountryIdentifier;
t: RawUTF8;
begin
c := TCountry.Create;
c2 := TCountry.Create;
with test do
try
c.Alpha2 := ' fR ';
Check(c.Iso=250);
Check(c.Identifier=ccFR);
c.Alpha2 := ' zz ';
Check(c.Iso=0);
Check(c.Identifier=ccUndefined);
c.Alpha2 := ' fzz ';
Check(c.Iso=0);
Check(c.Identifier=ccUndefined);
c.Alpha3 := ' frA ';
Check(c.Iso=250);
Check(c.Identifier=ccFR);
c.Alpha3 := ' frz ';
Check(c.Iso=0);
Check(c.Identifier=ccUndefined);
Check(TCountry.FromEnglish('none')=ccUndefined);
for i := low(i) to high(i) do begin
c.Iso := COUNTRY_ISONUM[i];
Check(c.Iso=c.ToIso(i));
t := c.Alpha2;
Check(c.ToAlpha2(i)=t);
Check(c.Identifier=i);
c.Iso := 0;
c.Alpha2 := t;
Check(c.Identifier=i);
Check(c.Iso=COUNTRY_ISONUM[i]);
end;
for i := low(i) to high(i) do begin
c.Identifier := i;
Check(c.Iso=COUNTRY_ISONUM[i]);
Check(c.Identifier=i);
end;
for i := low(i) to high(i) do begin
c.Alpha3 := COUNTRY_ISO3[i];
Check(c.Iso=COUNTRY_ISONUM[i]);
Check(c.Identifier=i);
t := c.Alpha3;
check(c.ToAlpha3(i)=t);
c.Iso := 0;
c.Alpha3 := t;
Check(c.Identifier=i);
Check(c.Iso=COUNTRY_ISONUM[i]);
CopyObject(c,c2);
Check(c2.Iso=COUNTRY_ISONUM[i]);
Check(c2.Alpha3=c.Alpha3);
Check(ObjectEquals(c,c2,false));
Check(ObjectEquals(c,c2,true));
t := c.English;
Check(c.ToEnglish(i)=t);
Check(c.FromEnglish(t)=i);
end;
finally
c2.Free;
c.Free;
end;
end;
function TCountry.Equals(another: TCountry): boolean;
begin
if (self=nil) or (another=nil) then
result := another=self else
result := another.fIso=fIso;
end;
initialization
Initialize;
{$ifndef ISDELPHI2010}
{$ifndef HASINTERFACERTTI} // circumvent a old FPC bug
TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType(TypeInfo(TCountryIdentifier));
{$endif}
{$endif}
end.

47
contrib/mORMot/SQLite3/DDD/dom/dddDomEmailInterfaces.pas Normal file
View File

@@ -0,0 +1,47 @@
unit DomUserInterfaces;
interface
uses
SysUtils,
SynCommons,
mORMot,
mORMotDDD,
DomUserTypes;
type
IDomUserEmailCheck = interface(IInvokable)
['{2942BC2D-84F7-4A79-8657-07F0602C3505}']
function CheckRecipient(const aEmail: RawUTF8): TCQRSResult;
function CheckRecipients(const aEmails: TRawUTF8DynArray): TCQRSResult;
end;
IDomUserEmailValidation = interface(IDomUserEmailCheck)
['{20129489-5054-4D4A-84B9-463DB98156B8}']
function ComputeURIForReply(const aLogonName,aEmail: RawUTF8): RawUTF8;
function StartEmailValidation(const aTemplate: TDomUserEmailTemplate;
const aLogonName,aEmail: RawUTF8): TCQRSResult;
function IsEmailValidated(const aLogonName,aEmail: RawUTF8): boolean;
end;
IDomUserEmailer = interface(IInvokable)
['{20B88FCA-B345-4D5E-8E07-4581C814AFD9}']
function SendEmail(const aRecipients: TRawUTF8DynArray;
const aSender,aSubject,aHeaders,aBody: RawUTF8): TCQRSResult;
end;
IDomUserTemplate = interface(IInvokable)
['{378ACC52-46BE-488D-B7ED-3F4E59316DFF}']
function ComputeMessage(const aContext: variant;
const aTemplateName: RawUTF8): RawUTF8;
end;
implementation
initialization
TInterfaceFactory.RegisterInterfaces(
[TypeInfo(IDomUserEmailValidation),TypeInfo(IDomUserEmailer),
TypeInfo(IDomUserTemplate)]);
end.

147
contrib/mORMot/SQLite3/DDD/dom/dddDomUserCQRS.pas Normal file
View File

@@ -0,0 +1,147 @@
/// shared DDD Domains: User CQRS Repository interfaces
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddDomUserCQRS;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SynCommons,
SysUtils,
Classes,
mORMot,
mORMotDDD,
dddDomUserTypes;
type
/// defines an abstract CQRS Repository for Reading TUser Aggregate Roots
// - this interface allows only read access to the Aggregate: see
// IDomUserCommand to modify the content
// - you could use SelectByLogonName, SelectByLastName or SelectByEmailValidation
// methods to initialize a request, then call Get, GetAll or GetNext to retrieve
// the actual matching Aggregate Roots
IDomUserQuery = interface(ICQRSService)
['{198C01D6-5189-4B74-AAF4-C322237D7D53}']
/// would select a single TUser from its logon name
// - then use Get() method to retrieve its content
function SelectByLogonName(const aLogonName: RawUTF8): TCQRSResult;
/// would select one or several TUser from their email validation state
// - then use GetCount, GetAll() or GetNext() methods to retrieve the items
function SelectByEmailValidation(aValidationState: TDomUserEmailValidation): TCQRSResult;
/// would select one or several TUser from their last name
// - will search for a full matching name, unless aStartWith is TRUE so that
// it would search for the beginning characters
// - then use GetCount, GetAll() or GetNext() methods to retrieve the items
function SelectByLastName(const aName: TLastName; aStartWith: boolean): TCQRSResult;
/// would select all TUser instances
// - you should not use this search criteria, since it may return a huge
// number of values
// - then use GetCount, GetAll() or GetNext() methods to retrieve the items
function SelectAll: TCQRSResult;
/// retrieve a single TUser
function Get(out aAggregate: TUser): TCQRSResult;
/// retrieve all matching TUser instances
// - the caller should release all returned TUser by calling
// ! ObjArrayClear(aAggregates);
function GetAll(out aAggregates: TUserObjArray): TCQRSResult;
/// retrieve the next matching TUser instances
// - returns cqrsNoMoreData if there is no more pending data
function GetNext(out aAggregate: TUser): TCQRSResult;
/// retrieve how many TUser instances do match the selection
function GetCount: integer;
/// retrieve how many TUser have their email validated
function HowManyValidatedEmail: integer;
end;
/// defines an abstract CQRS Repository for Writing TUser Aggregate Roots
// - would implement a dual-phase commit to change TUser content
// - first phase consists in calling Add, Update, Delete or DeleteAll methods
// which would call the registered validators on the supplied content
// - you can call Add, Update, Delete or DeleteAll methods several times,
// so that several write operations will be recorded for the TUser
// - during the first phase, nothing is actually written to the persistence
// storage itself (which may be a RDBMS or a NoSQL engine)
// - then the second phase would take place when the Commit method would
// be executed, which would save all prepared content to the actual storage
// engine (e.g. using a transaction via a BATCH process if implemented by
// mORMot's ORM, via TInfraRepoUser as defined in dddInfraRepoUser)
IDomUserCommand = interface(IDomUserQuery)
['{D345854F-7337-4006-B324-5D635FBED312}']
/// persist a new TUser aggregate
function Add(const aAggregate: TUser): TCQRSResult;
/// update an existing TUser aggregate
// - the existing content should have been retrieved by a previous Select*
// method, e.g. IDomUserQuery.SelectByLogonName
function Update(const aUpdatedAggregate: TUser): TCQRSResult;
/// erase an existing TUser aggregate
// - the existing content should have been retrieved by a previous Select*
// method, e.g. IDomUserQuery.SelectByLogonName
function Delete: TCQRSResult;
/// erase existing TUser aggregate, matching a
// - the existing content should have been retrieved by a previous Select*
// method, e.g. IDomUserQuery.SelectByLogonName: a plain DeleteAll call
// with no prious Select* would return an error
function DeleteAll: TCQRSResult;
/// write all pending changes prepared by Add/Update/Delete methods
// - following the dual-phase pattern, nothing would be written to the
// actual persistence store unless this method is actually called
function Commit: TCQRSResult;
/// flush any pending changes prepared by Add/Update/Delete methods
// - is the same as releasing the actual IDomUserCommand instance and
// creating a new one
function Rollback: TCQRSResult;
end;
implementation
initialization
TInterfaceFactory.RegisterInterfaces(
[TypeInfo(IDomUserQuery),TypeInfo(IDomUserCommand)]);
end.

114
contrib/mORMot/SQLite3/DDD/dom/dddDomUserInterfaces.pas Normal file
View File

@@ -0,0 +1,114 @@
/// shared DDD Domains: User interfaces definition
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddDomUserInterfaces;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SynCommons,
SysUtils,
Classes,
mORMot,
mORMotDDD,
dddDomUserTypes;
type
/// defines a service able to check the correctness of email addresses
// - will be implemented e.g. by TDDDEmailServiceAbstract and
// TDDDEmailValidationService as defined in the dddInfraEmail unit
IDomUserEmailCheck = interface(IInvokable)
['{2942BC2D-84F7-4A79-8657-07F0602C3505}']
/// check if the supplied email address seems correct
function CheckRecipient(const aEmail: RawUTF8): TCQRSResult;
/// check if the supplied email addresses seem correct
function CheckRecipients(const aEmails: TRawUTF8DynArray): TCQRSResult;
end;
/// defines a service sending a confirmation email to validate an email address
// - will be implemented e.g. by TDDDEmailValidationService as defined in
// the dddInfraEmail unit
IDomUserEmailValidation = interface(IDomUserEmailCheck)
['{20129489-5054-4D4A-84B9-463DB98156B8}']
/// internal method used to compute the validation URI
// - will be included as data context to the email template, to create the
// validation link
function ComputeURIForReply(const aLogonName,aEmail: RawUTF8): RawUTF8;
/// initiate an email validation process, using the given template
function StartEmailValidation(const aTemplate: TDomUserEmailTemplate;
const aLogonName,aEmail: RawUTF8): TCQRSResult;
function IsEmailValidated(const aLogonName,aEmail: RawUTF8): boolean;
end;
/// defines a generic service able to send emails
// - will be implemented e.g. by TDDDEmailerDaemon as defined in the
// dddInfraEmailer unit
IDomUserEmailer = interface(IInvokable)
['{20B88FCA-B345-4D5E-8E07-4581C814AFD9}']
function SendEmail(const aRecipients: TRawUTF8DynArray;
const aSender,aSubject,aHeaders,aBody: RawUTF8): TCQRSResult;
end;
/// defines a service for generic rendering of a template
// - will be implemented e.g. via our SynMustache engine by TDDDTemplateAbstract
// and TDDDTemplateFromFolder as defined in the dddInfraEmailer unit
IDomUserTemplate = interface(IInvokable)
['{378ACC52-46BE-488D-B7ED-3F4E59316DFF}']
function ComputeMessage(const aContext: variant;
const aTemplateName: RawUTF8): RawUTF8;
end;
implementation
initialization
TInterfaceFactory.RegisterInterfaces(
[TypeInfo(IDomUserEmailValidation),TypeInfo(IDomUserEmailer),
TypeInfo(IDomUserTemplate)]);
end.

374
contrib/mORMot/SQLite3/DDD/dom/dddDomUserTypes.pas Normal file
View File

@@ -0,0 +1,374 @@
/// shared DDD Domains: User objects definition
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit dddDomUserTypes;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
Version: MPL 1.1/GPL 2.0/LGPL 2.1
The contents of this file are subject to the Mozilla Public License Version
1.1 (the "License"); you may not use this file except in compliance with
the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
for the specific language governing rights and limitations under the License.
The Original Code is Synopse mORMot framework.
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
Alternatively, the contents of this file may be used under the terms of
either the GNU General Public License Version 2 or later (the "GPL"), or
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
in which case the provisions of the GPL or the LGPL are applicable instead
of those above. If you wish to allow use of your version of this file only
under the terms of either the GPL or the LGPL, and not to allow others to
use your version of this file under the terms of the MPL, indicate your
decision by deleting the provisions above and replace them with the notice
and other provisions required by the GPL or the LGPL. If you do not delete
the provisions above, a recipient may use your version of this file under
the terms of any one of the MPL, the GPL or the LGPL.
***** END LICENSE BLOCK *****
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
SysUtils,
Classes,
SynCommons,
SynTests,
mORMot,
mORMotDDD,
dddDomCountry;
{ *********** Address Modeling }
type
TStreet = type RawUTF8;
TCityArea = type RawUTF8;
TCity = type RawUTF8;
TRegion = type RawUTF8;
TPostalCode = type RawUTF8;
/// Address object
// - we tried to follow a simple but worldwide layout - see
// http://en.wikipedia.org/wiki/Address_%28geography%29#Address_format
TAddress = class(TSynAutoCreateFields)
protected
fStreet1: TStreet;
fStreet2: TStreet;
fCityArea: TCityArea;
fCity: TCity;
fRegion: TRegion;
fCode: TPostalCode;
fCountry: TCountry;
public
function Equals(another: TAddress): boolean; reintroduce;
published
property Street1: TStreet read fStreet1 write fStreet1;
property Street2: TStreet read fStreet2 write fStreet2;
property CityArea: TCityArea read fCityArea write fCityArea;
property City: TCity read fCity write fCity;
property Region: TRegion read fRegion write fRegion;
property Code: TPostalCode read fCode write fCode;
property Country: TCountry read fCountry;
end;
TAddressObjArray = array of TAddress;
{ *********** Person / User / Customer Modeling }
type
TLastName = type RawUTF8;
TFirstName = type RawUTF8;
TMiddleName = type RawUTF8;
TFullName = type RawUTF8;
/// Person full name
TPersonFullName = class(TSynPersistent)
protected
fFirst: TFirstName;
fMiddle: TMiddleName;
fLast: TLastName;
public
function Equals(another: TPersonFullName): boolean; reintroduce;
function FullName(country: TCountryIdentifier=ccUndefined): TFullName; virtual;
published
property First: TFirstName read fFirst write fFirst;
property Middle: TMiddleName read fMiddle write fMiddle;
property Last: TLastName read fLast write fLast;
end;
/// Person birth date
TPersonBirthDate = class(TSynPersistent)
protected
fDate: TDateTime;
public
function Equals(another: TPersonBirthDate): boolean; reintroduce;
function Age: integer; overload;
function Age(FromDate: TDateTime): integer; overload;
published
property Date: TDateTime read fDate write fDate;
end;
/// Person object
TPerson = class(TSynAutoCreateFields)
protected
fBirthDate: TPersonBirthDate;
fName: TPersonFullName;
public
function Equals(another: TPerson): boolean; reintroduce;
published
property Name: TPersonFullName read fName;
property Birth: TPersonBirthDate read fBirthDate;
end;
TPhoneNumber = type RawUTF8;
TEmailAddress = type RawUTF8;
TEmailAddressDynArray = array of TEmailAddress;
/// a Person object, with some contact information
// - an User is a person, in the context of an application
TPersonContactable = class(TPerson)
protected
fAddress: TAddress;
fPhone1: TPhoneNumber;
fPhone2: TPhoneNumber;
fEmail: TEmailAddress;
public
function Equals(another: TPersonContactable): boolean; reintroduce;
/// built-in simple unit tests
class procedure RegressionTests(test: TSynTestCase);
published
property Address: TAddress read fAddress;
property Phone1: TPhoneNumber read fPhone1 write fPhone1;
property Phone2: TPhoneNumber read fPhone2 write fPhone2;
property Email: TEmailAddress read fEmail write fEmail;
end;
TPersonContactableObjArray = array of TPersonContactable;
{ *********** Email Validation Modeling }
type
/// the status of an email validation process
TDomUserEmailValidation = (evUnknown, evValidated, evFailed);
/// how a confirmation email is to be rendered, for email address validation
// - this information will be available as data context, e.g. to the Mustache
// template used for rendering of the email body
TDomUserEmailTemplate = class(TSynPersistent)
private
fFileName: RawUTF8;
fSenderEmail: RawUTF8;
fSubject: RawUTF8;
fApplication: RawUTF8;
fInfo: variant;
published
/// the local file name of the Mustache template
property FileName: RawUTF8 read fFileName write fFileName;
/// the "sender" field of the validation email
property SenderEmail: RawUTF8 read fSenderEmail write fSenderEmail;
/// the "subject" field of the validation email
property Subject: RawUTF8 read fSubject write fSubject;
/// the name of the application, currently sending the confirmation
property Application: RawUTF8 read fApplication write fApplication;
/// any unstructured additional information, also supplied as data context
property Info: variant read fInfo write fInfo;
end;
{ *********** Application User Modeling, with Logon and Email Validation }
type
TLogonName = type RawUTF8;
/// an application level-user, whose account would be authenticated per Email
TUser = class(TPersonContactable)
private
fLogonName: TLogonName;
fEmailValidated: TDomUserEmailValidation;
published
/// the logon name would be the main entry point to the application
property LogonName: TLogonName
read fLogonName write fLogonName;
/// will reflect the current state of email validation process for this user
// - the validation is not handled by this class: this is just a property
// which reflects the state of TDDDEmailValidationService/IDomUserEmailValidation
property EmailValidated: TDomUserEmailValidation
read fEmailValidated write fEmailValidated;
end;
TUserObjArray = array of TUser;
implementation
{ TAddress }
function TAddress.Equals(another: TAddress): boolean;
begin
if (self=nil) or (another=nil) then
result := another=self else
result := (another.Street1=Street1) and (another.Street2=Street2) and
(another.CityArea=CityArea) and (another.City=City) and
(another.Region=Region) and another.Country.Equals(Country);
end;
{ TPersonFullName }
function TPersonFullName.Equals(another: TPersonFullName): boolean;
begin
if (self=nil) or (another=nil) then
result := another=self else
result := (First=another.First) and (Last=another.Last) and
(Middle=another.Middle);
end;
function TPersonFullName.FullName(country: TCountryIdentifier): TFullName;
begin // see country-specific http://en.wikipedia.org/wiki/Family_name
case country of
ccJP,ccCN,ccTW,ccKP,ccKR,ccVN,ccHU,ccRO:
// Eastern Order
result := Trim(Trim(Last+' '+Middle)+' '+First);
else
// default Western Order
result := Trim(Trim(First+' '+Middle)+' '+Last);
end;
end;
{ TPersonBirthDate }
function TPersonBirthDate.Age: integer;
begin
result := Age(SysUtils.Date);
end;
function TPersonBirthDate.Age(FromDate: TDateTime): integer;
var YF,YD,MF,MD,DF,DD: word;
begin
if (self=nil) or (fDate=0) then
result := 0 else begin
DecodeDate(FromDate,YF,MF,DF);
DecodeDate(fDate,YD,MD,DD);
result := YF-YD;
if MF<MD then
dec(result) else
if (MF=MD) and (DF<DD) then
dec(result);
end;
end;
function TPersonBirthDate.Equals(another: TPersonBirthDate): boolean;
begin
if (self=nil) or (another=nil) then
result := another=self else
result := Date=another.Date;
end;
{ TPerson }
function TPerson.Equals(another: TPerson): boolean;
begin
if (self=nil) or (another=nil) then
result := another=self else
result := Name.Equals(another.Name) and Birth.Equals(another.Birth);
end;
{ TPersonContactable }
function TPersonContactable.Equals(another: TPersonContactable): boolean;
begin
if (self=nil) or (another=nil) then
result := another=self else
result := inherited Equals(Self) and Address.Equals(another.Address) and
(Phone1=another.Phone1) and (Phone2=another.Phone2) and (Email=another.Email);
end;
class procedure TPersonContactable.RegressionTests(test: TSynTestCase);
var p: TPersonContactable;
json: RawUTF8;
valid: boolean;
procedure TestP;
begin
test.Check(p.Phone2='123456');
test.Check(p.Name.Last='Smith');
test.Check(p.Name.First='John');
test.Check(p.Birth.Age(Iso8601ToDateTime('19821030'))=10);
test.Check(p.Address.Country.Alpha3='FRA');
end;
begin
p := TPersonContactable.Create;
with test do
try
p.Phone2 := '123456';
p.Name.Last := 'Smith';
p.Name.First := 'John';
p.Birth.Date := Iso8601ToDateTime('19721029');
Check(p.Birth.Age>40);
Check(p.Birth.Age(Iso8601ToDateTime('19821020'))=9);
Check(p.Birth.Age(Iso8601ToDateTime('19821030'))=10);
p.Address.Country.Alpha2 := 'FR';
json := ObjectToJSON(p)+'*';
finally
p.Free;
end;
p := TPersonContactable.Create;
with test do
try
// FileFromString(JSONReformat(json),'person.json');
Check(ObjectLoadJSON(p,json));
TestP;
finally
p.Free;
end;
p := TPersonContactable.Create;
with test do
try
Check(JSONToObject(p,pointer(json),valid)^='*');
Check(valid);
TestP;
finally
p.Free;
end;
end;
initialization
{$ifndef ISDELPHI2010}
{$ifndef HASINTERFACERTTI} // circumvent a old FPC bug
TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType(TypeInfo(TDomUserEmailValidation));
{$endif}
{$endif}
TJSONSerializer.RegisterObjArrayForJSON([
TypeInfo(TAddressObjArray),TAddress,
TypeInfo(TPersonContactableObjArray),TPersonContactable,
TypeInfo(TUserObjArray),TUser]);
end.