source upload

contrib/mORMot/.github/FUNDING.yml

@@ -0,0 +1,12 @@
+# These are supported funding model platforms
+
+github: [synopse] # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]
+patreon: # Replace with a single Patreon username
+open_collective: # Replace with a single Open Collective username
+ko_fi: # Replace with a single Ko-fi username
+tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
+community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
+liberapay: # Replace with a single Liberapay username
+issuehunt: # Replace with a single IssueHunt username
+otechie: # Replace with a single Otechie username
+custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2']

contrib/mORMot/.gitignore

@@ -0,0 +1,88 @@
+# Uncomment these types if you want even more clean repository. But be careful.
+# It can make harm to an existing project source. Read explanations below.
+#
+# Resource files are binaries containing manifest, project icon and version info.
+# They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files.
+#*.res
+#
+# Type library file (binary). In old Delphi versions it should be stored.
+# Since Delphi 2009 it is produced from .ridl file and can safely be ignored.
+#*.tlb
+#
+# Diagram Portfolio file. Used by the diagram editor up to Delphi 7.
+# Uncomment this if you are not using diagrams or use newer Delphi version.
+*.ddp
+*.dof
+#
+# Visual LiveBindings file. Added in Delphi XE2.
+# Uncomment this if you are not using LiveBindings Designer.
+#*.vlb
+#
+# Deployment Manager configuration file for your project. Added in Delphi XE2.
+# Uncomment this if it is not mobile development and you do not use remote debug feature.
+#*.deployproj
+# 
+# C++ object files produced when C/C++ Output file generation is configured.
+# Uncomment this if you are not using external objects (zlib library for example).
+#*.obj
+#
+
+# Delphi compiler-generated binaries (safe to delete)
+*.exe
+*.dll
+*.bpl
+*.bpi
+*.dcp
+*.so
+*.apk
+*.drc
+*.map
+*.dres
+*.rsm
+*.tds
+*.dcu
+*.lib
+*.a
+*.o
+*.ocx
+
+# FreePascal compiler
+*.com
+*.class
+*.ppu
+*.compiled
+*.rsj 
+*.or
+*.lps
+*.db
+fpc/
+
+# Delphi autogenerated files (duplicated info)
+*.cfg
+*.hpp
+*Resource.rc
+
+# Delphi local files (user-specific info)
+*.local
+*.identcache
+*.projdata
+*.tvsconfig
+*.dsk
+
+# Delphi history and backups
+__history/
+__recovery/
+*.~*
+*.bak
+
+# Castalia statistics file (since XE7 Castalia is distributed with Delphi)
+*.stat
+
+#other VCS
+_FOSSIL_
+.svn/
+# SourceCodeRep artifact
+*.txt
+
+backup/
+.idea/

contrib/mORMot/CrossPlatform/CopySynCrossPlatformUnits.bat

@@ -0,0 +1,4 @@
+xcopy SynCrossPlatformSpecific.pas "c:\ProgramData\Optimale Systemer AS\Smart Mobile Studio\Libraries" /Y
+xcopy SynCrossPlatformCrypto.pas "c:\ProgramData\Optimale Systemer AS\Smart Mobile Studio\Libraries" /Y
+xcopy SynCrossPlatformREST.pas "c:\ProgramData\Optimale Systemer AS\Smart Mobile Studio\Libraries" /Y
+pause

contrib/mORMot/CrossPlatform/SynCrossPlatform.inc

@@ -0,0 +1,140 @@
+
+{
+    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 *****
+
+  
+  Version 1.18
+  - first public release, corresponding to mORMot Framework 1.18
+
+}
+
+{$ifdef FPC}
+
+  {.$MODE DELPHI} // we need e.g. auto-dereferenced pointers, as in Delphi
+  {$INLINE ON}
+  {$MINENUMSIZE 1}
+  {$PACKSET 1}
+  {$PACKENUM 1}
+
+  {$define HASINLINE}
+  {$define USEOBJECTINSTEADOFRECORD}
+  {$Q-} // disable overflow checking
+  {$R-} // disable range checking
+
+  {$ifdef VER2_7}
+    {$define ISFPC27}
+  {$endif}
+  {$ifdef VER3_0}
+    {$define ISFPC27}
+  {$endif}
+  {$ifdef VER3_1}
+    {$define ISFPC27}
+  {$endif}
+  {$ifdef VER3_2}
+    {$define ISFPC27}
+  {$endif}
+  {$ifdef VER3_3}
+    {$define ISFPC27}
+  {$endif}
+
+
+  {$ifdef ISFPC27}
+    // defined if the http://mantis.freepascal.org/view.php?id=26773 bug is fixed
+    // you should use 2.7.1/trunk branch in revision 28995 from 2014-11-05T22:17:54
+    // => this will change the TInvokeableVariantType.SetProperty() signature
+    {$define FPC_VARIANTSETVAR}
+  {$endif}
+
+{$else}
+
+{$ifdef DWSSCRIPT} // always defined since SMS 1.1.2
+  {$define ISDWS}           // e.g. for SmartMobileStudio or Delphi Web Script
+  {$define ISSMS}           // for SmartMobileStudio
+{$else}
+  {$ifdef CONDITIONALEXPRESSIONS}  // Delphi 6 or newer
+    {$ifdef NEXTGEN}
+      {$ZEROBASEDSTRINGS OFF}      // we expect to share code among platforms
+    {$endif NEXTGEN}
+    {$ifdef UNICODE}
+      {$ifdef CPUX64}
+        {$define CPU64}
+      {$endif}
+    {$else}
+      {$define USEOBJECTINSTEADOFRECORD}
+    {$endif UNICODE}
+    {$ifdef VER140}
+      {$define ISDELPHI6}
+    {$endif}
+    {$if CompilerVersion >= 18}    // Delphi 2006 or newer
+      {$define HASINLINE}
+    {$ifend}
+    {$if CompilerVersion >= 21.0}
+      {$define ISDELPHI2010}
+    {$ifend}
+    {$if CompilerVersion >= 22.0}
+      {$define ISDELPHIXE}
+    {$ifend}
+    {$if CompilerVersion >= 23.0}
+      {$define ISDELPHIXE2} // e.g. for Vcl.Graphics
+      {$ifndef MSWINDOWS}
+        {$define USETMONITOR}
+      {$endif}
+    {$ifend}
+    {$if CompilerVersion >= 25.0}
+      {$define ISDELPHIXE4}
+      {$ZEROBASEDSTRINGS OFF}      // we expect to share code among platforms
+      {$warn DUPLICATE_CTOR_DTOR OFF} // avoid W1029 unneeded hints
+    {$ifend}
+    {$if CompilerVersion >= 29.0}
+      {$define ISDELPHIXE8} // e.g. for System.Net.HttpClient
+    {$ifend}
+    {$if CompilerVersion >= 32.0}
+      {$define ISDELPHI102} // e.g. for System.Net.URLClient.ResponseTimeout
+    {$ifend}
+  {$else}
+    {$define ISDELPHI5OROLDER}
+    {$define USEOBJECTINSTEADOFRECORD}
+  {$endif CONDITIONALEXPRESSIONS}
+  {$Q-} // disable overflow checking
+  {$R-} // disable range checking
+{$endif DELPHIWEBSCRIPT}
+
+{$endif FPC}

contrib/mORMot/CrossPlatform/SynCrossPlatformCrypto.pas

@@ -0,0 +1,361 @@
+/// cryptographic cross-platform units
+// - this unit is a part of the freeware Synopse mORMot framework,
+// licensed under a MPL/GPL/LGPL tri-license; version 1.18
+unit SynCrossPlatformCrypto;
+
+{
+    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 *****
+
+  Should compile with Delphi for any platform (including NextGen for mobiles),
+    with FPC 2.7 or Kylix, and with SmartMobileStudio 2.1.1
+
+}
+
+{$ifdef DWSCRIPT} // always defined since SMS 1.1.2
+  {$define ISDWS}           // e.g. for SmartMobileStudio or Delphi Web Script
+  {$define ISSMS}           // for SmartMobileStudio
+{$else}
+   {$i SynCrossPlatform.inc} // define e.g. HASINLINE
+{$endif}
+
+interface
+
+{$ifdef ISDWS}
+uses
+  SmartCL.System;
+{$else}
+uses
+  SysUtils,
+  Classes;
+{$endif}
+
+
+type
+  {$ifdef ISDWS}
+  hash32 = integer;
+  {$else}
+  hash32 = cardinal;
+  {$endif}
+
+var
+  /// table used by crc32() function
+  // - table content is created from code in initialization section below
+  {$ifdef ISDWS}
+  crc32tab: array of hash32;
+  {$else}
+  crc32tab: array[byte] of hash32;
+  {$endif}
+
+{$ifndef ISDWS}
+/// compute the zlib/deflate crc32 hash value on a supplied buffer
+function crc32(aCrc32: hash32; const buf: array of byte): hash32;
+{$endif}
+
+/// compute the zlib/deflate crc32 hash value on a supplied ASCII-7 buffer
+function crc32ascii(aCrc32: hash32; const buf: string): hash32;
+
+type
+  /// internal buffer for SHA256 hashing
+  TSHA256Buffer = array[0..63] of hash32;
+  /// internal work buffer for SHA256 hashing
+  TSHAHash  = record
+    A,B,C,D,E,F,G,H: hash32;
+  end;
+  /// class for SHA256 hashing
+  TSHA256 = class
+  private
+    // Working hash
+    Hash: TSHAHash;
+    // 64bit msg length
+    MLen: integer;
+    // Block buffer
+    Buffer: TSHA256Buffer;
+    // Index in buffer
+    Index: integer;
+    // used by Update and Finalize
+    procedure Compress;
+  public
+    /// initialize SHA256 context for hashing
+    constructor Create;
+{$ifndef ISDWS}
+    /// update the SHA256 context with some data
+    procedure Update(const buf: array of byte); overload;
+{$endif}
+    /// update the SHA256 context with 8 bit ascii data (e.g. UTF-8)
+    procedure Update(const ascii: string); overload;
+    /// finalize and compute the resulting SHA256 hash Digest of all data
+    // affected to Update() method
+    // - returns the data as Hexadecimal
+    function Finalize: string;
+  end;
+
+{$ifndef ISDWS}
+/// compute SHA256 hexa digest of a supplied buffer
+function SHA256(const buf: array of byte): string; overload;
+{$endif}
+
+/// compute SHA256 hexa digest of a supplied 8 bit ascii data (e.g. UTF-8)
+function SHA256(const buf: string): string; overload;
+
+
+implementation
+
+
+{$ifdef ISDWS}
+function shr0(c: hash32): hash32; inline;
+begin
+  {$ifdef ISSMS} // circumvent DWS compiler bug
+  asm
+    @result = @c >>> 0;
+  end;
+  {$else}
+  result := c shr 0;
+  {$endif}
+end;
+{$else}
+type // no-operation for unmanaged Delphi
+  shr0 = hash32;
+{$endif}
+
+procedure InitCrc32Tab;
+var i,n,crc: hash32;
+begin
+  for i := 0 to 255 do begin
+    crc := i;
+    for n := 1 to 8 do
+      if (crc and 1)<>0 then
+        // $edb88320 from polynomial p=(0,1,2,4,5,7,8,10,11,12,16,22,23,26)
+        crc := shr0((crc shr 1) xor $edb88320) else
+        crc := crc shr 1;
+    {$ifndef ISSMS}
+    crc32tab[i] := crc;
+    {$else}
+    crc32tab.push(crc);
+    {$endif}
+  end;
+end;
+
+function crc32ascii(aCrc32: hash32; const buf: string): hash32;
+var i: integer;
+begin
+  result := shr0(not aCRC32);
+  for i := 1 to length(buf) do
+    result := crc32tab[(result xor ord(buf[i])) and $ff] xor (result shr 8);
+  result := shr0(not result);
+end;
+
+{$ifndef ISDWS}
+function crc32(aCrc32: hash32; const buf: array of byte): hash32;
+var i: integer;
+begin
+  result := shr0(not aCRC32);
+  for i := 0 to length(buf)-1 do
+    result := crc32tab[(result xor buf[i]) and $ff] xor (result shr 8);
+  result := shr0(not result);
+end;
+{$endif ISDWS}
+
+const
+  K: TSHA256Buffer = (
+   $428a2f98, $71374491, $b5c0fbcf, $e9b5dba5, $3956c25b, $59f111f1,
+   $923f82a4, $ab1c5ed5, $d807aa98, $12835b01, $243185be, $550c7dc3,
+   $72be5d74, $80deb1fe, $9bdc06a7, $c19bf174, $e49b69c1, $efbe4786,
+   $0fc19dc6, $240ca1cc, $2de92c6f, $4a7484aa, $5cb0a9dc, $76f988da,
+   $983e5152, $a831c66d, $b00327c8, $bf597fc7, $c6e00bf3, $d5a79147,
+   $06ca6351, $14292967, $27b70a85, $2e1b2138, $4d2c6dfc, $53380d13,
+   $650a7354, $766a0abb, $81c2c92e, $92722c85, $a2bfe8a1, $a81a664b,
+   $c24b8b70, $c76c51a3, $d192e819, $d6990624, $f40e3585, $106aa070,
+   $19a4c116, $1e376c08, $2748774c, $34b0bcb5, $391c0cb3, $4ed8aa4a,
+   $5b9cca4f, $682e6ff3, $748f82ee, $78a5636f, $84c87814, $8cc70208,
+   $90befffa, $a4506ceb, $bef9a3f7, $c67178f2);
+
+procedure TSHA256.Compress;
+var W: TSHA256Buffer;
+    H: TSHAHash;
+    i: integer;
+    t1, t2: hash32;
+begin
+  H := Hash;
+  for i := 0 to 15 do
+    W[i]:= shr0((Buffer[i*4] shl 24)or(Buffer[i*4+1] shl 16)or
+                (Buffer[i*4+2] shl 8)or Buffer[i*4+3]);
+  for i := 16 to 63 do
+    W[i] := shr0((((W[i-2]shr 17)or(W[i-2]shl 15))xor((W[i-2]shr 19)or(W[i-2]shl 13))
+      xor (W[i-2]shr 10))+W[i-7]+(((W[i-15]shr 7)or(W[i-15]shl 25))
+      xor ((W[i-15]shr 18)or(W[i-15]shl 14))xor(W[i-15]shr 3))+W[i-16]);
+  for i := 0 to high(W) do begin
+    t1 := shr0(H.H+(((H.E shr 6)or(H.E shl 26))xor((H.E shr 11)or(H.E shl 21))xor
+      ((H.E shr 25)or(H.E shl 7)))+((H.E and H.F)xor(not H.E and H.G))+K[i]+W[i]);
+    t2 := shr0((((H.A shr 2)or(H.A shl 30))xor((H.A shr 13)or(H.A shl 19))xor
+      ((H.A shr 22)xor(H.A shl 10)))+((H.A and H.B)xor(H.A and H.C)xor(H.B and H.C)));
+    H.H := H.G; H.G := H.F; H.F := H.E; H.E := shr0(H.D+t1);
+    H.D := H.C; H.C := H.B; H.B := H.A; H.A := shr0(t1+t2);
+  end;
+  Hash.A := shr0(Hash.A+H.A);
+  Hash.B := shr0(Hash.B+H.B);
+  Hash.C := shr0(Hash.C+H.C);
+  Hash.D := shr0(Hash.D+H.D);
+  Hash.E := shr0(Hash.E+H.E);
+  Hash.F := shr0(Hash.F+H.F);
+  Hash.G := shr0(Hash.G+H.G);
+  Hash.H := shr0(Hash.H+H.H);
+end;
+
+constructor TSHA256.Create;
+begin
+  Hash.A := $6a09e667;
+  Hash.B := $bb67ae85;
+  Hash.C := $3c6ef372;
+  Hash.D := $a54ff53a;
+  Hash.E := $510e527f;
+  Hash.F := $9b05688c;
+  Hash.G := $1f83d9ab;
+  Hash.H := $5be0cd19;
+end;
+
+{$ifndef ISDWS}
+procedure TSHA256.Update(const buf: array of byte);
+var Len, aLen, i: integer;
+    DataNdx: integer;
+begin
+  Len := length(buf);
+  DataNdx := 0;
+  inc(MLen,Len shl 3);
+  while Len>0 do begin
+    aLen := 64-Index;
+    if aLen<=Len then begin
+      for i := 0 to aLen-1 do
+        Buffer[Index+i] := buf[DataNdx+i];
+      dec(Len,aLen);
+      inc(DataNdx,aLen);
+      Compress;
+      Index:= 0;
+    end else begin
+      for i := 0 to Len-1 do
+        Buffer[Index+i] := buf[DataNdx+i];
+      inc(Index,Len);
+      break;
+    end;
+  end;
+end;
+{$endif ISDWS}
+
+procedure TSHA256.Update(const ascii: string);
+var Len, aLen, i: integer;
+    DataNdx: integer;
+begin
+  Len := length(ascii);
+  DataNdx := 1;
+  inc(MLen,Len shl 3);
+  while Len>0 do begin
+    aLen := 64-Index;
+    if aLen<=Len then begin
+      for i := 0 to aLen-1 do
+        Buffer[Index+i] := ord(ascii[DataNdx+i]);
+      dec(Len,aLen);
+      inc(DataNdx,aLen);
+      Compress;
+      Index:= 0;
+    end else begin
+      for i := 0 to Len-1 do
+        Buffer[Index+i] := ord(ascii[DataNdx+i]);
+      inc(Index,Len);
+      break;
+    end;
+  end;
+end;
+
+function TSHA256.Finalize: string;
+var i: integer;
+begin
+  // Message padding
+  // 1. append bit '1' after Buffer
+  Buffer[Index]:= $80;
+  for i := Index+1 to 63 do
+    Buffer[i] := 0;
+  // 2. Compress if more than 448 bits, (no room for 64 bit length)
+  if Index>=56 then begin
+    Compress;
+    for i := 0 to 59 do
+      Buffer[i] := 0;
+  end;
+  // Write 64 bit Buffer length into the last bits of the last block
+  // (in big endian format) and do a final compress
+  Buffer[60] := (MLen and $ff000000)shr 24;
+  Buffer[61] := (MLen and $ff0000)shr 16;
+  Buffer[62] := (MLen and $ff00)shr 8;
+  Buffer[63] := MLen and $ff;
+  Compress;
+  // Hash -> Digest to big endian format
+  result := LowerCase(IntToHex(Hash.A,8)+IntToHex(Hash.B,8)+IntToHex(Hash.C,8)+
+    IntToHex(Hash.D,8)+IntToHex(Hash.E,8)+IntToHex(Hash.F,8)+IntToHex(Hash.G,8)+
+    IntToHex(Hash.H,8));
+end;
+
+{$ifndef ISDWS}
+function SHA256(const buf: array of byte): string;
+var SHA: TSHA256;
+begin
+  SHA := TSHA256.Create;
+  try
+    SHA.Update(buf);
+    result := SHA.Finalize;
+  finally
+    SHA.Free;
+  end;
+end;
+{$endif}
+
+function SHA256(const buf: string): string;
+var SHA: TSHA256;
+begin
+  SHA := TSHA256.Create;
+  try
+    SHA.Update(buf);
+    result := SHA.Finalize;
+  finally
+    SHA.Free;
+  end;
+end;
+
+initialization
+  InitCrc32Tab;
+end.

contrib/mORMot/CrossPlatform/SynCrossPlatformSynLZ.pas

@@ -0,0 +1,261 @@
+/// SynLZ compression cross-platform unit
+// - this unit is a part of the freeware Synopse mORMot framework,
+// licensed under a MPL/GPL/LGPL tri-license; version 1.18
+unit SynCrossPlatformSynLZ;
+
+interface
+
+{
+    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 *****
+
+
+  Compatible with the main SynLZ.pas unit
+  Should compile with Delphi for any platform (including NextGen for mobiles),
+    with FPC 2.7 or Kylix - but not yet with SmartMobileStudio 2.1.1
+
+}
+
+/// get maximum possible (worse) compressed size for out_p
+function SynLZcomplen(in_len: cardinal): cardinal;
+
+/// get uncompressed size from lz-compressed buffer (to reserve memory, e.g.)
+function SynLZdecomplen(in_p: pointer): cardinal;
+
+/// 1st compression algorithm uses hashing with a 32bits control word
+function SynLZcomp(src: pointer; size: cardinal; dst: pointer): cardinal;
+
+/// 1st compression algorithm uses hashing with a 32bits control word
+// - this is the fastest pure pascal implementation
+function SynLZdecomp(src: pointer; size: cardinal; dst: pointer): cardinal;
+
+
+implementation
+
+function SynLZcomplen(in_len: cardinal): cardinal;
+begin
+  result := in_len+in_len shr 3+16; // worse case
+end;
+
+function SynLZdecomplen(in_p: pointer): cardinal;
+begin
+  result := PWord(in_p)^;
+  inc(PWord(in_p));
+  if result and $8000<>0 then
+    result := (result and $7fff) or (cardinal(PWord(in_p)^) shl 15);
+end;
+
+type
+{$ifdef FPC}
+  PBytes = PAnsiChar;
+{$else}
+  PtrUInt = {$ifdef CPUX64} NativeUInt {$else} cardinal {$endif};
+  TBytes = array[0..maxInt-1] of byte;
+  PBytes = ^TBytes;
+{$endif}
+
+function SynLZcomp(src: pointer; size: cardinal; dst: pointer): cardinal;
+var dst_beg,          // initial dst value
+    src_end,          // real last byte available in src
+    src_endmatch,     // last byte to try for hashing
+    o: PtrUInt;
+    CWbit: cardinal;
+    CWpoint: PCardinal;
+    v, h, cached, t, tmax: PtrUInt;
+    offset: array[0..4095] of PtrUInt;
+    cache: array[0..4095] of cardinal; // 16KB+16KB=32KB on stack (48KB under Win64)
+begin
+  dst_beg := PtrUInt(dst);
+  // 1. store in_len
+  if size>=$8000 then begin // size in 32KB..2GB -> stored as integer
+    PWord(dst)^ := $8000 or (size and $7fff);
+    PWord(PtrUInt(dst)+2)^ := size shr 15;
+    inc(PCardinal(dst));
+  end else begin
+    PWord(dst)^ := size ; // size<32768 -> stored as word
+    if size=0 then begin
+      result := 2;
+      exit;
+    end;
+    inc(PWord(dst));
+  end;
+  // 2. compress
+  src_end := PtrUInt(src)+size;
+  src_endmatch := src_end-(6+5);
+  CWbit := 1;
+  CWpoint := pointer(dst);
+  PCardinal(dst)^ := 0;
+  inc(PByte(dst),sizeof(CWpoint^));
+  fillchar(offset,sizeof(offset),0); // fast 16KB reset to 0
+  // 1. main loop to search using hash[]
+  if PtrUInt(src)<=src_endmatch then
+  repeat
+    v := PCardinal(src)^;
+    h := ((v shr 12) xor v) and 4095;
+    o := offset[h];
+    offset[h] := PtrUInt(src);
+    cached := v xor cache[h]; // o=nil if cache[h] is uninitialized
+    cache[h] := v;
+    if (cached and $00ffffff=0) and (o<>0) and (PtrUInt(src)-o>2) then begin
+      CWpoint^ := CWpoint^ or CWbit;
+      inc(PWord(src));
+      inc(o,2);
+      t := 1;
+      tmax := src_end-PtrUInt(src)-1;
+      if tmax>=(255+16) then
+        tmax := (255+16);
+      while (PBytes(o)[t]=PBytes(src)[t]) and (t<tmax) do
+        inc(t);
+      inc(PByte(src),t);
+      h := h shl 4;
+      // here we have always t>0
+      if t<=15 then begin // mark 2 to 17 bytes -> size=1..15
+        PWord(dst)^ := cardinal(t or h);
+        inc(PWord(dst));
+      end else begin // mark 18 to (255+16) bytes -> size=0, next byte=t
+        dec(t,16);
+        PWord(dst)^ := h; // size=0
+        PByte(PtrUInt(dst)+2)^ := t;
+        inc(PByte(dst),3);
+      end;
+    end else begin
+      PByte(dst)^ := PByte(src)^;
+      inc(PByte(src));
+      inc(PByte(dst));
+    end;
+    inc(CWbit,CWBit);
+    if CWbit=0 then begin
+      CWpoint := pointer(dst);
+      PCardinal(dst)^ := 0;
+      inc(PCardinal(dst));
+      inc(CWbit);
+    end;
+    if PtrUInt(src)<=src_endmatch then continue else break;
+  until false;
+  // 2. store remaining bytes
+  if PtrUInt(src)<src_end then
+  repeat
+    PByte(dst)^ := PByte(src)^;
+    inc(PByte(src));
+    inc(PByte(dst));
+    inc(CWbit,CWBit);
+    if CWbit=0 then begin
+      PCardinal(dst)^ := 0;
+      inc(PCardinal(dst));
+      inc(CWbit);
+    end;
+    if PtrUInt(src)<src_end then continue else break;
+  until false;
+  result := PtrUInt(dst)-dst_beg;
+end;
+
+function SynLZdecomp(src: pointer; size: cardinal; dst: pointer): cardinal;
+var last_hashed, // initial src and dst value
+    src_end: PtrUInt;
+    CW, CWbit: cardinal;
+    v, t, h, o: cardinal;
+    i: integer;
+    offset: array[0..4095] of PtrUInt; // 16KB hashing code
+label nextCW;
+begin
+  src_end := PtrUInt(src)+size;
+  // 1. retrieve out_len
+  result := PWord(src)^;
+  if result=0 then exit;
+  inc(PWord(src));
+  if result and $8000<>0 then begin
+    result := (result and $7fff) or (cardinal(PWord(src)^) shl 15);
+    inc(PWord(src));
+  end;
+  // 2. decompress
+  last_hashed := PtrUInt(dst)-1;
+nextCW:
+  CW := PCardinal(src)^;
+  inc(PCardinal(src));
+  CWbit := 1;
+  if PtrUInt(src)<src_end then
+  repeat
+    if CW and CWbit=0 then begin
+      PByte(dst)^ := PByte(src)^;
+      inc(PByte(src));
+      inc(PByte(dst));
+      if PtrUInt(src)>=src_end then break;
+      if last_hashed<PtrUInt(dst)-3 then begin
+        inc(last_hashed);
+        v := PCardinal(last_hashed)^;
+        offset[((v shr 12) xor v) and 4095] := last_hashed;
+      end;
+      CWbit := CWbit shl 1;
+      if CWbit<>0 then
+        continue else
+        goto nextCW;
+    end else begin
+      h := PWord(src)^;
+      inc(PWord(src));
+      t := (h and 15)+2;
+      h := h shr 4;
+      if t=2 then begin
+        t := PByte(src)^+(16+2);
+        inc(PByte(src));
+      end;
+      o := offset[h];
+      if PtrUInt(dst)-o<t then
+        for i := 0 to t-1 do // movechars is slower
+          PBytes(dst)[i] := PBytes(o)[i] else
+        if t<=8 then
+          PInt64(dst)^ := PInt64(o)^ else
+          move(pointer(o)^,pointer(dst)^,t);
+      if PtrUInt(src)=src_end then break;
+      while last_hashed<PtrUInt(dst) do begin
+        inc(last_hashed);
+        v := PCardinal(last_hashed)^;
+        offset[((v shr 12) xor v) and 4095] := last_hashed;
+      end;
+      inc(PByte(dst),t);
+      last_hashed := PtrUInt(dst)-1;
+      CWbit := CWbit shl 1;
+      if CWbit<>0 then
+        continue else
+        goto nextCW;
+    end;
+  until false;
+end;
+
+end.

contrib/mORMot/CrossPlatform/SynCrossPlatformTests.pas

@@ -0,0 +1,891 @@
+/// regression tests for mORMot's cross-platform units
+// - this unit is a part of the freeware Synopse mORMot framework,
+// licensed under a MPL/GPL/LGPL tri-license; version 1.18
+unit SynCrossPlatformTests;
+
+{
+    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 *****
+
+  Should compile with Delphi for any platform, or with FPC or Kylix
+
+}
+
+{$i SynCrossPlatform.inc} // define e.g. HASINLINE
+
+interface
+
+uses
+  SysUtils,
+  Classes,
+  Variants,
+  TypInfo,
+{$ifdef ISDELPHI2010}
+  System.Generics.Collections,
+{$endif}
+{$ifndef NEXTGEN}
+  Contnrs,
+{$endif}
+  mORMotClient, // as generated by mORMotWrappers.pas !
+  SynCrossPlatformJSON,
+  SynCrossPlatformCrypto,
+  SynCrossPlatformSpecific,
+  SynCrossPlatformRest;
+
+
+type
+  /// the prototype of an individual test
+  // - to be used with TSynTest descendants
+  TSynTestEvent = procedure of object;
+
+{$M+} { we need the RTTI for the published methods of this object class }
+  /// generic class for performing simple tests 
+  // - purpose of this ancestor is to have RTTI for its published methods,
+  // which will contain the tests
+  TSynTest = class
+  protected
+    fFailureMsg: string;
+    fCurrentTest: Integer;
+  public
+    /// the test case name
+    Ident: string;
+    /// the registered tests, i.e. all published methods of this class
+    Tests: TPublishedMethodDynArray;
+    /// how many Check() call did pass
+    Passed: cardinal;
+    /// how many Check() call did failed
+    Failed: cardinal;
+    /// create the test instance
+    // - this constructor will add all published methods to the internal
+    // test list, accessible via the Count/TestName/TestMethod properties
+    constructor Create(const aIdent: string='');
+    /// run all tests
+    procedure Run(LogToConsole: boolean);
+    /// validate a test
+    procedure Check(test: Boolean; const Msg: string=''); overload;
+  published
+  end;
+
+  /// regression tests of our CrossPlatform units
+  TSynCrossPlatformTests = class(TSynTest)
+  published
+    procedure Iso8601DateTime;
+    procedure Base64Encoding;
+    procedure JSON;
+    procedure Model;
+    procedure Cryptography;
+  end;
+
+  /// regression tests of our CrossPlatform units
+  TSynCrossPlatformClient = class(TSynTest)
+  protected
+    fAuthentication: TSQLRestServerAuthenticationClass;
+    fClient: TSQLRestClientHTTP;
+  public
+    constructor Create(aAuthentication: TSQLRestServerAuthenticationClass); reintroduce;
+    destructor Destroy; override;
+  published
+    procedure Connection;
+    procedure ORM;
+    procedure ORMBatch;
+    procedure Services;
+    procedure CleanUp;
+  end;
+{$M-}
+
+
+implementation
+
+type
+  TSQLRecordPeopleSimple = class(TSQLRecord)
+  private
+    fData: TSQLRawBlob;
+    fFirstName: RawUTF8;
+    fLastName: RawUTF8;
+    fYearOfBirth: integer;
+    fYearOfDeath: word;
+  published
+    property FirstName: RawUTF8 read fFirstName write fFirstName;
+    property LastName: RawUTF8 read fLastName write fLastName;
+    property Data: TSQLRawBlob read fData write fData;
+    property YearOfBirth: integer read fYearOfBirth write fYearOfBirth;
+    property YearOfDeath: word read fYearOfDeath write fYearOfDeath;
+  end;
+  
+  TMainNested = class(TCollectionItem)
+  private
+    fNumber: double;
+    fIdent: RawUTF8;
+  published
+    property Ident: RawUTF8 read fIdent write fIdent;
+    property Number: double read fNumber write fNumber;
+  end;
+
+  TMain = class(TPersistent)
+  private
+    fName: RawUTF8;
+    fNested: TCollection;
+    fList: TStringList;
+  public
+    constructor Create;
+    destructor Destroy; override;
+  published
+    property Name: RawUTF8 read fName write fName;
+    property Nested: TCollection read fNested;
+    property List: TStringList read fList;
+  end;
+
+
+{ TSynTest }
+
+procedure TSynTest.Check(test: Boolean; const Msg: string='');
+begin
+  if test then
+    inc(Passed) else begin
+    inc(Failed);
+    if Msg<>'' then
+      fFailureMsg := fFailureMsg+'['+Msg+'] ';
+  end;
+end;
+
+constructor TSynTest.Create(const aIdent: string);
+begin
+  Ident := aIdent;
+  GetPublishedMethods(self,Tests);
+end;
+
+procedure TSynTest.Run(LogToConsole: boolean);
+var i: integer;
+    BeforePassed,BeforeFailed: cardinal;
+    startclass, startmethod: TDateTime;
+    datetime: string;
+    LogFile: text;
+  procedure Log(const Fmt: string; const Args: array of const);
+  var msg: string;
+  begin
+    msg := format(Fmt,Args);
+    if LogToConsole then
+      writeln(msg) else
+      writeln(LogFile,msg);
+    if not LogToConsole then
+      Flush(LogFile);
+  end;
+begin
+  startclass := Now;
+  datetime := DateTimeToIso8601(startclass);
+  if not LogToConsole then begin
+    assign(LogFile,ExtractFilePath(ParamStr(0))+
+      FormatDateTime('yyyy mm dd hh nn ss',startclass)+'.txt');
+    rewrite(LogFile);
+  end;
+  Log(#13#10' %s'#13#10'%s',[Ident,StringOfChar('-',length(Ident)+2)]);
+  for i := 0 to high(Tests) do begin
+    Log(#13#10' %d. Running "%s"',[i+1,Tests[i].Name]);
+    startmethod := Now;
+    BeforePassed := Passed;
+    BeforeFailed := Failed;
+    try
+      fCurrentTest := i;
+      TSynTestEvent(Tests[i].Method)();
+    except
+      on E: Exception do
+        Check(False,format('Exception %s raised with message "%s"',[E.ClassName,E.Message]));
+    end;
+    if Failed<>BeforeFailed then
+      Log(' !!! %d test(s) failed / %d %s',[Failed-BeforeFailed,
+        Failed-BeforeFailed+Passed-BeforePassed,fFailureMsg]) else
+      Log('    %d tests passed in %s',[Passed-BeforePassed,
+        FormatDateTime('nn:ss:zzz',Now-startmethod)]);
+    fFailureMsg := '';
+  end;
+  Log(#13#10' Tests failed: %d / %d'#13#10' Time elapsed: %s'#13#10#13#10' %s',
+    [Failed,Failed+Passed,FormatDateTime('nn:ss:zzz',Now-startclass),datetime]);
+  if not LogToConsole then
+    close(LogFile);
+end;
+
+
+{ TSynCrossPlatformTests }
+
+procedure TSynCrossPlatformTests.Base64Encoding;
+var b,c: TByteDynArray;
+    i: integer;
+begin
+  check(b=nil);
+  for i := 0 to 100 do begin
+    SetLength(b,i);
+    if i>0 then
+      b[i-1] := i;
+    check(Base64JSONStringToBytes(BytesToBase64JSONString(b),c));
+    check(length(c)=i);
+    check(CompareMem(Pointer(b),pointer(c),i));
+  end;
+end;
+
+procedure TSynCrossPlatformTests.Cryptography;
+var c: array of byte;
+    s: string;
+begin
+  SetLength(c,5);
+  c[4] := $96;
+  Check(crc32(0,c)=$DF4EC16C,'crc32');
+  Check(crc32ascii(0,'abcdefghijklmnop')=$943AC093);
+  SetLength(c,3);
+  c[0] := ord('a');
+  c[1] := ord('b');
+  c[2] := ord('c');
+  s := SHA256(c);
+  check(s='ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad');
+  check(SHA256('abc')=s);
+end;
+
+procedure TSynCrossPlatformTests.Iso8601DateTime;
+procedure Test(D: TDateTime);
+var s: string;
+procedure One(D: TDateTime);
+var E: TDateTime;
+    V: TTimeLog;
+begin
+  s := DateTimeToIso8601(D);
+  E := Iso8601ToDateTime(s);
+  Check(Abs(D-E)<(1/SecsPerDay)); // we allow 1 sec error
+  Check(DateTimeToJSON(D)='"'+s+'"');
+  V := DateTimeToTTimeLog(D);
+  E := TTimeLogToDateTime(V);
+  Check(Abs(D-E)<(1/SecsPerDay));
+  Check(UrlDecode(UrlEncode(s))=s);
+end;
+begin
+  One(D);
+  Check(length(s)=19);
+  One(Trunc(D));
+  Check(length(s)=10);
+  One(Frac(D));
+  Check(length(s)=9);
+end;
+var D: TDateTime;
+    i: integer;
+    s: string;
+    T: TTimeLog;
+begin
+  s := '2014-06-28T11:50:22';
+  D := Iso8601ToDateTime(s);
+  Check(Abs(D-41818.49331)<(1/SecsPerDay));
+  Check(DateTimeToIso8601(D)=s);
+  T := DateTimeToTTimeLog(D);
+  Check(T=135181810838);
+  D := Now/20+Random*20; // some starting random date/time
+  for i := 1 to 2000 do begin
+    Test(D);
+    D := D+Random*57; // go further a little bit: change date/time
+  end;
+end;
+
+procedure TSynCrossPlatformTests.JSON;
+var doc: variant;
+    js,json2,inlined: string;
+    i: integer;
+    obj1,obj2: TMain;
+    item: TMainNested;
+begin
+  doc := JSONVariant('{"test":1234,"name":"Joh\"n\r","zero":0.0}');
+  check(doc.test=1234);
+  check(doc.name='Joh"n'#13);
+  check(doc.name2=null);
+  check(doc.zero=0);
+  js := doc;
+  check(js='{"test":1234,"name":"Joh\"n\r","zero":0}');
+  {$ifdef FPC}
+  TJSONVariantData(doc)['name2'] := 3.1415926;
+  TJSONVariantData(doc)['name'] := 'John';
+  {$else}
+  doc.name2 := 3.1415926;
+  doc.name := 'John';
+  {$endif}
+  js := doc;
+  check(js='{"test":1234,"name":"John","zero":0,"name2":3.1415926}');
+  doc := JSONVariant('[{ID:1,"Username":"xx","FirstName":"System",Active:-1}]');
+  check(TJSONVariantData(doc).Kind=jvArray);
+  check(TJSONVariantData(doc).Count=1);
+  check(TJSONVariantData(doc).Values[0].ID=1);
+  check(TJSONVariantData(doc).Values[0].Username='xx');
+  check(TJSONVariantData(doc).Values[0].Active=-1);
+  check(IsRowID('id'));
+  check(IsRowID('iD'));
+  check(IsRowID('rowid'));
+  check(IsRowID('RowID'));
+  check(not IsRowID('iz'));
+  check(not IsRowID('i2'));
+  check(not IsRowID('rawid'));
+  check(not IsRowID(''));
+  check(FormatBind('',[])='');
+  for i := 1 to 1000 do begin
+    js := IntToStr(i);
+    inlined := ':('+js+'):';
+    check(FormatBind(js,[])=js);
+    check(FormatBind(js,[i])=js);
+    check(FormatBind('?',[i])=inlined);
+    check(FormatBind('a?a',[i])='a'+inlined+'a');
+    check(FormatBind('a?',[i])='a'+inlined);
+    check(FormatBind('?a',[i])=inlined+'a');
+    check(FormatBind('ab?',[i])='ab'+inlined);
+    check(FormatBind('?ab',[i])=inlined+'ab');
+    check(FormatBind('ab?ab',[i])='ab'+inlined+'ab');
+    check(FormatBind('abc?abc',[i])='abc'+inlined+'abc');
+    check(FormatBind('abc?abc',[i,1])='abc'+inlined+'abc');
+    check(FormatBind(js+'?',[i])=js+inlined);
+    check(FormatBind('?'+js,[i])=inlined+js);
+    check(FormatBind('ab?ab',[js])='ab:("'+js+'"):ab');
+    check(FormatBind('ab?ab',[variant(js)])='ab:("'+js+'"):ab');
+    check(FormatBind('ab?ab',[variant(i)])='ab'+inlined+'ab');
+    check(FormatBind('ab?ab?',[variant(i)])='ab'+inlined+'ab:(null):');
+    check(FormatBind('ab?ab??cd',[i,i,js])='ab'+inlined+'ab'+inlined+
+      ':("'+js+'"):cd');
+  end;
+  RegisterClassForJSON([TMainNested]); // for JSONToNewObject()
+  obj1 := TMain.Create;
+  obj2 := TMain.Create;
+  try
+    for i := 1 to 100 do begin
+      obj1.Name := IntToStr(i);
+      item := obj1.Nested.Add as TMainNested;
+      item.Ident := obj1.Name;
+      item.Number := i/2;
+      check(obj1.Nested.Count=i);
+      obj1.list.Add(obj1.Name);
+      js := ObjectToJSON(obj1);
+      check(js<>'');
+      if i=1 then
+        check(js='{"Name":"1","Nested":[{"Ident":"1","Number":0.5}],"List":["1"]}');
+      JSONToObject(obj2,js);
+      check(obj2.Nested.Count=i);
+      json2 := ObjectToJSON(obj2);
+      check(json2=js);
+      js := ObjectToJSON(item,true);
+      item := TMainNested(JSONToNewObject(js));
+      check(item<>nil);
+      json2 := ObjectToJSON(item,true);
+      check(json2=js);
+      item.Free;
+    end;
+  finally
+    obj2.Free;
+    obj1.Free;
+  end;
+  js := 'one,two,3';
+  i := 1;
+  check(GetNextCSV(js,i,json2));
+  check(json2='one');
+  check(GetNextCSV(js,i,json2));
+  check(json2='two');
+  check(GetNextCSV(js,i,json2));
+  check(json2='3');
+  check(not GetNextCSV(js,i,json2));
+  check(not GetNextCSV(js,i,json2));
+  js := 'one';
+  i := 1;
+  check(GetNextCSV(js,i,json2));
+  check(json2='one');
+  check(not GetNextCSV(js,i,json2));
+  js := '';
+  i := 1;
+  check(not GetNextCSV(js,i,json2));
+  doc := JsonVariant('{}');
+  js := doc;
+  check(js='{}');
+end;
+
+procedure TSynCrossPlatformTests.Model;
+var mdel: TSQLModel;
+    people: TSQLRecordPeopleSimple;
+    i: integer;
+    js: string;
+    fields: TSQLFieldBits;
+begin
+  mdel := TSQLModel.Create([TSQLRecordPeopleSimple],'test/');
+  Check(mdel.Root='test');
+  Check(length(mdel.Info)=1);
+  Check(mdel.Info[0].Table=TSQLRecordPeopleSimple);
+  Check(mdel.Info[0].Name='PeopleSimple');
+  Check(length(mdel.Info[0].Prop)=6);
+  people := TSQLRecordPeopleSimple.Create;
+  try
+    for i := 1 to 1000 do begin
+      people.ID := i;
+      people.FirstName := IntToStr(i);
+      people.LastName := people.FirstName+people.FirstName;
+      people.YearOfBirth := i+500;
+      people.YearOfDeath := people.YearOfBirth+40;
+      js := ObjectToJSON(people);
+      check(js=Format('{"ID":%d,"FirstName":"%d","LastName":"%d%d",'+
+        '"Data":"","YearOfBirth":%d,"YearOfDeath":%d}',[i,i,i,i,i+500,i+540]));
+    end;
+  finally
+    people.Free;
+  end;
+  Check(PInteger(@mdel.Info[0].SimpleFields)^=$37);
+  Check(PInteger(@mdel.Info[0].BlobFields)^=8);
+  fields := mdel.Info[0].FieldNamesToFieldBits('',false);
+  Check(PInteger(@fields)^=$37);
+  fields := mdel.Info[0].FieldNamesToFieldBits('*',false);
+  Check(PInteger(@fields)^=PInteger(@mdel.Info[0].AllFields)^);
+  fields := mdel.Info[0].FieldNamesToFieldBits('id,firstname',false);
+  Check(PInteger(@fields)^=3);
+  fields := mdel.Info[0].FieldNamesToFieldBits('RowID ,  firstname ',false);
+  Check(PInteger(@fields)^=3);
+  Check(mdel.Info[0].FieldBitsToFieldNames(fields)='RowID,FirstName');
+  fields := mdel.Info[0].FieldNamesToFieldBits('firstname,id,toto',false);
+  Check(PInteger(@fields)^=3);
+  Check(mdel.Info[0].FieldBitsToFieldNames(fields)='RowID,FirstName');
+  mdel.Free;
+end;
+
+
+{ TMain }
+
+constructor TMain.Create;
+begin
+  inherited;
+  fNested := TCollection.Create(TMainNested);
+  fList := TStringList.Create;
+end;
+
+destructor TMain.Destroy;
+begin
+  fList.Free;
+  fNested.Free;
+  inherited;
+end;
+
+{ TSynCrossPlatformClient }
+
+constructor TSynCrossPlatformClient.Create(
+  aAuthentication: TSQLRestServerAuthenticationClass);
+begin
+  inherited Create;
+  fAuthentication := aAuthentication;
+end;
+
+destructor TSynCrossPlatformClient.Destroy;
+begin
+  CleanUp;
+  inherited;
+end;
+
+procedure TSynCrossPlatformClient.CleanUp;
+begin
+  FreeAndNil(fClient);
+  check(fClient=nil);
+end;
+
+procedure TSynCrossPlatformClient.Connection;
+var doremotelog: boolean;
+    dofilelog: boolean;
+begin
+  doremotelog := false;
+  dofilelog := false;
+  if fAuthentication=TSQLRestServerAuthenticationDefault then begin
+    fClient := GetClient('localhost','User','synopse');
+    if dofilelog then
+      fClient.LogToFile(LOG_VERBOSE);
+    if doremotelog then
+      fClient.LogToRemoteServer(LOG_VERBOSE,'localhost');
+  end else begin
+    fClient := TSQLRestClientHTTP.Create('localhost',SERVER_PORT,GetModel,true);
+    if dofilelog then
+      fClient.LogToFile(LOG_VERBOSE);
+    if doremotelog then
+      fClient.LogToRemoteServer(LOG_VERBOSE,'localhost');
+    check(fClient.Connect);
+    check(fClient.ServerTimeStamp<>0);
+    if fAuthentication<>nil then
+      fClient.SetUser(fAuthentication,'User','synopse');
+  end;
+end;
+
+procedure TSynCrossPlatformClient.ORM;
+  procedure TestPeople(people: TSQLRecordPeople; var id: integer);
+  begin
+    Check(people.InternalState=fClient.InternalState);
+    inc(id);
+    Check(people.ID=id);
+    Check(people.FirstName='');
+    Check(people.LastName='');
+    Check(people.YearOfBirth=id+1800);
+    Check(people.YearOfDeath=id+1825);
+    Check(people.Sexe=sFemale);
+  end;
+var people: TSQLRecordPeople;
+    Call: TSQLRestURIParams;
+    i,id: integer;
+    list: TObjectList;
+    {$ifdef ISDELPHI2010}
+    peoples: TObjectList<TSQLRecordPeople>;
+    {$endif ISDELPHI2010}
+begin
+  fClient.CallBackGet('DropTable',[],Call,TSQLRecordPeople);
+  Check(fClient.InternalState>0);
+  Check(Call.OutStatus=HTTP_SUCCESS);
+  people := TSQLRecordPeople.Create;
+  try
+    Check(people.InternalState=0);
+    for i := 1 to 200 do begin
+      people.FirstName := 'First'+IntToStr(i);
+      people.LastName := 'Last'+IntToStr(i);
+      people.YearOfBirth := i+1800;
+      people.YearOfDeath := i+1825;
+      people.Sexe := TPeopleSexe(i and 1);
+      Check(fClient.Add(people,true)=i);
+      Check(people.InternalState=fClient.InternalState);
+    end;
+  finally
+    people.Free;
+  end;
+  people := TSQLRecordPeople.CreateAndFillPrepare(fClient,'','',[]);
+  try
+    Check(people.InternalState=0);
+    id := 0;
+    while people.FillOne do begin
+      Check(people.InternalState=fClient.InternalState);
+      inc(id);
+      Check(people.ID=id);
+      Check(people.FirstName='First'+IntToStr(id));
+      Check(people.LastName='Last'+IntToStr(id));
+      Check(people.YearOfBirth=id+1800);
+      Check(people.YearOfDeath=id+1825);
+      Check(ord(people.Sexe)=id and 1);
+    end;
+    Check(id=200);
+  finally
+    people.Free;
+  end;
+  people := TSQLRecordPeople.CreateAndFillPrepare(fClient,
+    'YearOFBIRTH,Yearofdeath,id','',[]);
+  try
+    Check(people.InternalState=0);
+    id := 0;
+    while people.FillOne do
+       TestPeople(people,id);
+    Check(id=200);
+  finally
+    people.Free;
+  end;
+  list := fClient.RetrieveList(TSQLRecordPeople,'YearOFBIRTH,Yearofdeath,id','',[]);
+  try
+    id := 0;
+    for i := 0 to list.Count-1 do
+     TestPeople(TSQLRecordPeople(list[i]),id);
+    Check(id=200);
+  finally
+    list.Free;
+  end;
+  {$ifdef ISDELPHI2010}
+  peoples := fClient.RetrieveList<TSQLRecordPeople>('YearOFBIRTH,yearofdeath,id','',[]);
+  try
+    id := 0;
+    for i := 0 to peoples.Count-1 do
+     TestPeople(peoples[i],id);
+    Check(id=200);
+  finally
+    peoples.Free;
+  end;
+  {$endif ISDELPHI2010}
+  people := TSQLRecordPeople.CreateAndFillPrepare(fClient,'',
+    'yearofbirth=?',[1900]);
+  try
+    Check(people.InternalState=0);
+    id := 0;
+    while people.FillOne do begin
+      Check(people.InternalState=fClient.InternalState);
+      inc(id);
+      Check(people.ID=100);
+      Check(people.FirstName='First100');
+      Check(people.LastName='Last100');
+      Check(people.YearOfBirth=1900);
+      Check(people.YearOfDeath=1925);
+    end;
+    Check(id=1);
+  finally
+    people.Free;
+  end;
+  for i := 1 to 200 do
+    if i and 15=0 then
+      fClient.Delete(TSQLRecordPeople,i) else
+    if i mod 82=0 then begin
+      people := TSQLRecordPeople.Create;
+      try
+        id := i+1;
+        people.ID := i;
+        people.FirstName := 'First'+IntToStr(id);
+        people.LastName := 'Last'+IntToStr(id);
+        people.YearOfBirth := id+1800;
+        people.YearOfDeath := id+1825;
+        Check(people.InternalState=0);
+        Check(fClient.Update(people,'YEarOFBIRTH,YEarOfDeath'));
+        Check(people.InternalState=fClient.InternalState);
+      finally
+        people.Free;
+      end;
+    end;
+  for i := 1 to 200 do begin
+    people := TSQLRecordPeople.Create(fClient,i);
+    try
+      if i and 15=0 then
+        Check(people.ID=0) else begin
+        Check(people.InternalState=fClient.InternalState);
+        if i mod 82=0 then
+          id := i+1 else
+          id := i;
+        Check(people.ID=i);
+        Check(people.FirstName='First'+IntToStr(i));
+        Check(people.LastName='Last'+IntToStr(i));
+        Check(people.YearOfBirth=id+1800);
+        Check(people.YearOfDeath=id+1825);
+        Check(ord(people.Sexe)=i and 1);
+      end;
+    finally
+      people.Free;
+    end;
+  end;
+end;
+
+procedure TSynCrossPlatformClient.ORMBatch;
+var people: TSQLRecordPeople;
+    Call: TSQLRestURIParams;
+    res: TIDDynArray;
+    {$ifndef ISDWS}
+    blob: TSQLRawBlob;
+    {$endif}
+    i,id: integer;
+begin
+  fClient.CallBackGet('DropTable',[],Call,TSQLRecordPeople);
+  Check(fClient.InternalState>0);
+  Check(Call.OutStatus=HTTP_SUCCESS);
+  fClient.BatchStart(TSQLRecordPeople);
+  people := TSQLRecordPeople.Create;
+  try
+    for i := 1 to 200 do begin
+      Check(people.InternalState=0);
+      people.FirstName := 'First'+IntToStr(i);
+      people.LastName := 'Last'+IntToStr(i);
+      people.YearOfBirth := i+1800;
+      people.YearOfDeath := i+1825;
+      people.Sexe := TPeopleSexe(i and 1);
+      fClient.BatchAdd(people,true);
+    end;
+  finally
+    people.Free;
+  end;
+  Check(fClient.BatchSend(res)=HTTP_SUCCESS);
+  Check(length(res)=200);
+  for i := 1 to length(res) do
+    Check(res[i-1]=i);
+  people := TSQLRecordPeople.CreateAndFillPrepare(fClient,'','',[]);
+  try
+    Check(people.InternalState=0);
+    id := 0;
+    while people.FillOne do begin
+      Check(people.InternalState=fClient.InternalState);
+      inc(id);
+      Check(people.ID=id);
+      Check(people.FirstName='First'+IntToStr(id));
+      Check(people.LastName='Last'+IntToStr(id));
+      Check(people.YearOfBirth=id+1800);
+      Check(people.YearOfDeath=id+1825);
+      Check(ord(people.Sexe)=id and 1);
+    end;
+    Check(id=200);
+  finally
+    people.Free;
+  end;
+  people := TSQLRecordPeople.CreateAndFillPrepare(fClient,
+    'YearOFBIRTH,Yearofdeath,id','',[]);
+  try
+    id := 0;
+    Check(people.InternalState=0);
+    while people.FillOne do begin
+      Check(people.InternalState=fClient.InternalState);
+      inc(id);
+      Check(people.ID=id);
+      Check(people.FirstName='');
+      Check(people.LastName='');
+      Check(people.YearOfBirth=id+1800);
+      Check(people.YearOfDeath=id+1825);
+      Check(people.Sexe=sFemale);
+    end;
+    Check(id=200);
+  finally
+    people.Free;
+  end;
+  people := TSQLRecordPeople.CreateAndFillPrepare(fClient,'',
+    'yearofbirth=?',[1900]);
+  try
+    Check(people.InternalState=0);
+    id := 0;
+    while people.FillOne do begin
+      Check(people.InternalState=fClient.InternalState);
+      inc(id);
+      Check(people.ID=100);
+      Check(people.FirstName='First100');
+      Check(people.LastName='Last100');
+      Check(people.YearOfBirth=1900);
+      Check(people.YearOfDeath=1925);
+    end;
+    Check(id=1);
+  finally
+    people.Free;
+  end;
+  fClient.BatchStart(nil);
+  for i := 1 to 200 do
+    if i and 15=0 then
+      fClient.BatchDelete(TSQLRecordPeople,i) else
+    if i mod 82=0 then begin
+      people := TSQLRecordPeople.Create;
+      try
+        id := i+1;
+        people.ID := i;
+        people.FirstName := 'First'+IntToStr(id);
+        people.LastName := 'Last'+IntToStr(id);
+        people.YearOfBirth := id+1800;
+        people.YearOfDeath := id+1825;
+        Check(fClient.BatchUpdate(people,'YEarOFBIRTH,YEarOfDeath')>=0);
+        Check(people.InternalState=0);
+      finally
+        people.Free;
+      end;
+    end;
+  Check(fClient.BatchSend(res)=HTTP_SUCCESS);
+  Check(length(res)=14);
+  for i := 1 to 14 do
+    Check(res[i-1]=HTTP_SUCCESS);
+  for i := 1 to 200 do begin
+    people := TSQLRecordPeople.Create(fClient,i);
+    try
+      if i and 15=0 then
+        Check(people.ID=0) else begin
+        Check(people.InternalState=fClient.InternalState);
+        if i mod 82=0 then
+          id := i+1 else
+          id := i;
+        Check(people.ID=i);
+        Check(people.FirstName='First'+IntToStr(i));
+        Check(people.LastName='Last'+IntToStr(i));
+        Check(people.YearOfBirth=id+1800);
+        Check(people.YearOfDeath=id+1825);
+        Check(ord(people.Sexe)=i and 1);
+      end;
+    finally
+      people.Free;
+    end;
+  end;
+  {$ifndef ISDWS}
+  exit; // Add(..,'Data') below is buggy, but RetrieveBlob() seems fine
+  people := TSQLRecordPeople.Create;
+  try
+    people.FirstName := 'With';
+    people.LastName := 'Blob';
+    SetLength(blob,2);
+    blob[0] := 1;
+    blob[1] := 2;
+    people.Data := blob;
+    id := fClient.Add(people,true,false,'FirstName,LastName,Data');
+    Check(id=201);
+    Check(people.InternalState=fClient.InternalState);
+    blob := nil;
+  finally
+    people.Free;
+  end;
+  people := TSQLRecordPeople.Create(fClient,id);
+  try
+    Check(people.FirstName='With');
+    Check(people.LastName='Blob');
+    Check(people.Data=nil);
+    Check(not fClient.RetrieveBlob(TSQLRecordPeople,id,'wrongfieldname',blob));
+    Check(blob=nil);
+    Check(fClient.RetrieveBlob(TSQLRecordPeople,id,'data',blob));
+    Check(blob<>nil);
+  finally
+    people.Free;
+  end;
+  {$endif}
+end;
+
+procedure TSynCrossPlatformClient.Services;
+var calc: ICalculator;
+    i,j: integer;
+    sex: TPeopleSexe;
+    name: string;
+    rec: TTestCustomJSONArraySimpleArray;
+const SEX_TEXT: array[0..1] of RawUTF8 = ('Miss','Mister');
+begin
+  calc := TServiceCalculator.Create(fClient);
+  check(calc.InstanceImplementation=sicShared);
+  check(calc.ServiceName='Calculator');
+  for i := 1 to 200 do
+    check(calc.Add(i,i+1)=i*2+1);
+  for i := 1 to 200 do begin
+    sex := TPeopleSexe(i and 1);
+    name := 'Smith';
+    calc.ToText(i,'$',sex,name);
+    check(sex=sFemale);
+    check(name=format('$ %d for %s Smith',[i,SEX_TEXT[i and 1]]));
+  end;
+  Fillchar(rec,SizeOf(rec),0);
+  for i := 1 to 100 do begin
+    name := calc.RecordToText(rec);
+    if i=1 then
+      check(name='{"F":"","G":[],"H":{"H1":0,"H2":"","H3":{"H3a":false,"H3b":null}},"I":"","J":[]}');
+    check(length(Rec.F)=i);
+    for j := 1 to length(Rec.F) do
+      check(Rec.F[j]='!');
+    check(length(Rec.G)=i);
+    for j := 0 to high(Rec.G) do
+      check(Rec.G[j]=IntToStr(j+1));
+    check(Rec.H.H1=i);
+    check(length(Rec.J)=i-1);
+    for j := 0 to high(Rec.J) do begin
+      Check(Rec.J[j].J1=j);
+      Check(Rec.J[j].J2.D2=j);
+      Check(Rec.J[j].J3=TRecordEnum(j mod (ord(high(TRecordEnum))+1)));
+    end;
+  end;
+end;
+
+end.

contrib/mORMot/CrossPlatform/templates/API.adoc.mustache

@@ -0,0 +1,186 @@
+== API Documentation
+
+NOTE: API Documentation {{exeVersion}} retrieved {{#protocol}}from {{protocol}}://{{host}}/{{uri}} {{/protocol}}at {{time}}.
+
+This documentation has been generated by {{exeInfo}}, running mORMot {{mORMotVersion}}.
+
+WARNING: Any manual modification of this file may be lost after regeneration.
+
+=== Services
+
+This server does publish the following RESTful services:
+
+{{#soa.services}}
+* <<{{uri}}>>.
+{{/soa.services}}
+
+It will also use some <<Objects>>{{#withArrays}}, <<Arrays>>{{/withArrays}}{{#withEnumerates}}, <<Enumerations>>{{/withEnumerates}}{{#withsets}}, <<Sets>>{{/withsets}} type definitions, which will be transmitted as JSON objects, arrays or integers. The expected MIME transmission type, at HTTP level, is `application/json; charset=UTF-8`. Communication protocol may be either `http://` or `https://`, depending on the server configuration.
+
+The following documentation will detail each service, and the input/output JSON content, as expected by each command.
+
+
+{{#soa.services}}
+=== {{uri}}
+
+[.lead]
+{{serviceDescription}}
+
+This `{{uri}}` service does publish the following methods (aka commands):
+
+{{#methods}}
+* <<{{methodName}}>>.
+{{/methods}}
+{{<typeList}}{{#typePascal}}{{#isArray}}* <<{{typePascal}}>>.
+{{/isArray}}
+{{#isRecord}}* <<{{typePascal}}>>.
+{{/isRecord}}
+{{#isEnum}}* <<{{typePascal}}>>.
+{{/isEnum}}{{/typePascal}}{{/typeList}}
+
+{{#methods}}
+==== {{methodName}}
+
+[.lead]
+{{methodDescription}}
+
+.URI (alternatives)
+ POST {{protocol}}://servername:port/{{root}}/{{uri}}.{{methodName}}
+ POST {{protocol}}://servername:port/{{root}}/{{uri}}/{{methodName}}
+
+.Input Body
+----
+{{#hasInParams}}
+{
+{{#args}}
+{{#dirInput}}
+  {{jsonQuote argName}}: {{typePascal}}{{commaInSingle}}
+{{/dirInput}}
+{{/args}}
+}
+{{/hasInParams}}
+{{^hasInParams}}
+No input expected.
+{{/hasInParams}}
+----
+
+.Output Body
+----
+{{#hasOutParams}}
+{
+{{#args}}
+{{#dirOutput}}
+  {{jsonQuote argName}}: {{typePascal}}{{#commaOutResult}},{{/commaOutResult}}
+{{/dirOutput}}
+{{/args}}
+}
+{{/hasOutParams}}
+{{^hasOutParams}}
+No output expected.
+{{/hasOutParams}}
+----
+
+See also:
+
+{{#args}}
+{{>typeList}}
+{{/args}}
+* Other <<{{uri}}>> Services.
+
+{{/methods}}
+
+{{/soa.services}}
+
+{{#withRecords}}
+=== Objects
+
+The following objects are used during data transmission:
+{{<writerec}}{
+{{#fields}}
+{{nestedIdentation}}    {{jsonQuote propName}}: {{typePascal}}{{#nestedRecord}}{{>writerec}}{{nestedIdentation}}    }{{/nestedRecord}}{{#nestedSimpleArray}}array of {{typePascal}}{{/nestedSimpleArray}}{{#nestedRecordArray}}array of {{>writerec}}{{nestedIdentation}}    }{{/nestedRecordArray}}{{^-last}},{{/-last}}
+{{/fields}}{{/writerec}}
+
+{{#records}}
+==== {{name}}
+
+[.lead]
+{{recordDescription}}
+
+.Definition
+----
+{{>writerec}}
+}
+----
+See also:
+
+{{#fields}}
+{{>typeList}}
+{{/fields}}
+* Other <<Objects>>.
+{{#withArrays}}
+* Other <<Arrays>>.
+{{/withArrays}}
+{{#withEnumerates}}
+* Other <<Enumerations>>.
+{{/withEnumerates}}
+{{#withsets}}
+* Other <<Sets>>.
+{{/withsets}}
+
+{{/records}}
+
+{{/withRecords}}
+{{#withArrays}}
+=== Arrays
+
+The following arrays are used during data transmission:
+
+{{#arrays}}
+==== {{name}}
+
+This is a JSON array of <<{{typeSource}}>>.
+
+{{/arrays}}
+
+{{/withArrays}}
+{{#withEnumerates}}
+
+=== Enumerations
+
+When transmitted within other <<Services>>, <<Objects>> or <<Arrays>> content, enumerations are represented by their `integer` JSON value. Any other value will be ignored.
+
+The following enumerations have been defined:
+
+{{#enumerates}}
+==== {{name}}
+
+[.lead]
+{{enumDescription}}
+
+{{#values}}
+ {{-index0}} = {{EnumTrim .}}
+{{/values}}
+
+{{/enumerates}}
+{{/withEnumerates}}
+
+{{#withsets}}
+
+=== Sets
+
+When transmitted within other <<Services>>, <<Objects>> or <<Arrays>> content, sets are represented by their `integer` JSON value, matching binary bit storage. The `integer` values below may be added, to compute the set of individual flags - a value of `0` meaning a void set.
+
+The following sets have been defined:
+
+{{#sets}}
+==== {{name}}
+
+[.lead]
+{{setDescription}}
+
+{{#values}}
+ {{PowerOfTwo -index0}} = {{EnumTrim .}}
+{{/values}}
+
+{{/sets}}
+
+{{/withsets}}

contrib/mORMot/CrossPlatform/templates/CrossPlatform.pas.mustache

@@ -0,0 +1,309 @@
+/// remote access to a mORMot server using SynCrossPlatform* units
+{{#uri}}
+// - retrieved from {{protocol}}://{{host}}/{{uri}}
+// at {{time}} using "{{templateName}}" template
+{{/uri}}
+{{^uri}}
+// - generated at {{time}}
+{{/uri}}
+unit {{fileName}};
+
+{
+  WARNING:
+    This unit has been generated by a mORMot {{mORMotVersion}} server.
+    Any manual modification of this file may be lost after regeneration.
+
+  Synopse mORMot framework. Copyright (C) {{year}} Arnaud Bouchez
+    Synopse Informatique - http://synopse.info
+
+  This unit is released under a MPL/GPL/LGPL tri-license,
+  and therefore may be freely included in any application.
+
+  This unit would work on Delphi 6 and later, under all supported platforms
+  (including MacOSX, and NextGen iPhone/iPad), and the Free Pascal Compiler.
+}
+
+interface
+
+uses
+  SynCrossPlatformJSON,
+  SynCrossPlatformSpecific,
+  SynCrossPlatformREST;
+  
+{{! recursive partials used to write records type definition}}
+{{<writerec}}record
+{{#fields}}
+{{nestedIdentation}}    {{propName}}: {{#typePascal}}{{typePascal}};{{/typePascal}}{{#nestedRecord}}{{>writerec}}{{nestedIdentation}}    end;{{/nestedRecord}}{{#nestedSimpleArray}}array of {{typePascal}};{{/nestedSimpleArray}}{{#nestedRecordArray}}array of {{>writerec}}{{nestedIdentation}}    end;{{/nestedRecordArray}}
+{{/fields}}{{/writerec}}
+{{#withEnumerates}}
+type // define some enumeration types, used below
+{{#enumerates}}
+  {{name}} = ({{#values}}{{.}}{{^-last}}, {{/-last}}{{/values}});
+{{/enumerates}}
+
+{{/withEnumerates}}
+{{#withSets}}
+type // define some set types, used below
+{{#sets}}
+  {{name}} = set of({{#values}}{{.}}{{^-last}}, {{/-last}}{{/values}});
+{{/sets}}
+
+{{/withSets}}
+{{#withRecords}}
+type // define some record types, used as properties below
+{{#records}}
+  {{name}} = {{>writerec}}  end;
+
+{{/records}}
+{{/withRecords}}
+{{#withArrays}}
+type // define some dynamic array types, used as properties below
+{{#arrays}}
+  {{name}} = array of {{typeSource}};
+{{/arrays}}
+
+{{/withArrays}}
+{{<method}}{{methodName}}({{#args}}{{^dirResult}}{{dirName}} {{argName}}: {{typePascal}}{{commaArg}}{{/dirResult}}{{/args}}){{#args}}{{#dirResult}}: {{typePascal}}{{/dirResult}}{{/args}};{{/method}}
+type
+{{#orm}}
+{{^isInMormotPas}}
+  /// map "{{tableName}}" table
+  {{className}} = class(TSQLRecord)
+  protected
+    {{#fields}}
+    f{{name}}: {{typePascal}}; 
+    {{/fields}}
+  {{#hasRecords}}
+  public
+{{#fields}}
+{{#isrecord}}
+    property {{name}}: {{typePascal}} read f{{name}} write f{{name}}{{#unique}} stored AS_UNIQUE{{/unique}};
+{{/isrecord}}
+{{/fields}}
+  {{/hasRecords}}
+  published
+{{#fields}}
+{{^isrecord}}
+{{#isSQLRecord}}    // defined as {{name}}: {{typeDelphi}} on the server
+{{/isSQLRecord}}
+    property {{name}}: {{typePascal}}{{#width}} index {{width}}{{/width}} read f{{name}} write f{{name}}{{#unique}} stored AS_UNIQUE{{/unique}};
+{{/isrecord}}
+{{/fields}}
+  end;
+  
+{{/isInMormotPas}}
+{{/orm}}
+{{#soa.services}}
+  /// service implemented by TService{{interfaceURI}}
+  // - you can access this service as such:
+  // !var a{{interfaceURI}}: I{{interfaceURI}};
+  // !begin
+  // !   a{{interfaceURI}} := TService{{interfaceURI}}.Create(aClient);
+  // !   // now you can use a{{interfaceURI}} methods
+  // !...
+  I{{interfaceURI}} = interface(IServiceAbstract)
+    ['{{GUID}}']
+{{#methods}}
+    {{verb}} {{>method}}
+{{/methods}}
+  end;
+
+  /// implements I{{interfaceURI}} {{#uri}}from {{protocol}}://{{host}}/{{root}}/{{uri}}{{/uri}}
+  // - this service will run in sic{{instanceCreationName}} mode
+  TService{{interfaceURI}} = class(TServiceClientAbstract{{#isClientDriven}}ClientDriven{{/isClientDriven}},I{{interfaceURI}})
+  public
+    constructor Create(aClient: TSQLRestClientURI); override;
+{{#methods}}
+    {{verb}} {{>method}}
+{{/methods}}
+  end;
+
+{{/soa.services}}
+const
+  /// the server port{{#uri}}, corresponding to {{protocol}}://{{host}}{{/uri}}
+  SERVER_PORT = {{port}};
+  /// the server model root name{{#uri}}, corresponding to {{protocol}}://{{host}}{{/uri}}
+  SERVER_ROOT = '{{root}}';
+
+
+/// return the database Model corresponding to this server
+function GetModel(const aRoot: string=SERVER_ROOT): TSQLModel;
+
+/// create a TSQLRestClientHTTP instance and connect to the server
+// - it will use by default port {{port}} over root '{{root}}'{{#host}}, corresponding
+// to {{protocol}}://{{host}}/{{root}}{{/host}}
+{{#authClass}}
+// - secure connection will be established via {{.}}
+// with the supplied credentials - on connection or authentication error,
+// this function will raise a corresponding exception
+{{/authClass}}
+function GetClient(const aServerAddress{{#authClass}}, aUserName,aPassword{{/authClass}}: string;
+  aServerPort: integer=SERVER_PORT; const aServerRoot: string=SERVER_ROOT;
+  aHttps: boolean={{#https}}true{{/https}}{{^https}}false{{/https}}): TSQLRestClientHTTP;
+
+{{#withHelpers}}
+// publish some low-level helpers for variant conversion
+// - used internally: you should not need those functions in your end-user code
+{{#enumerates}}
+function Variant2{{name}}(const _variant: variant): {{name}};
+{{/enumerates}}
+{{#records}}
+function Variant2{{name}}(_variant: variant): {{name}};
+function {{name}}2Variant(const _record: {{name}}): variant;
+{{/records}}
+{{#arrays}}
+function Variant2{{name}}(const _variant: variant): {{name}};
+function {{name}}2Variant(const _array: {{name}}): variant;
+{{/arrays}}
+
+{{/withHelpers}}
+
+implementation
+
+{$HINTS OFF} // for H2164 hints of unused variables
+
+{{#withEnumerates}}
+
+{ Some helpers for enumerates types }
+
+{{#enumerates}}
+function Variant2{{name}}(const _variant: variant): {{name}};
+begin
+  result := {{name}}(VariantToEnum(_variant,[{{#values}}'{{.}}'{{^-last}},{{/-last}}{{/values}}]));
+end;
+
+{{/enumerates}}
+{{/withEnumerates}}
+{{#withRecords}}
+{{<setrec}}{{#fields}}
+{{#isSimple}}  result.{{fullPropName}} := _variant.{{fullPropName}};
+{{/isSimple}}{{#nestedRecord}}{{>setrec}}{{/nestedRecord}}{{#fromVariant}}  result.{{fullPropName}} := {{fromVariant}}(_variant.{{fullPropName}});
+{{/fromVariant}}{{#nestedSimpleArray}}  _arr := JSONVariantDataSafe(_variant.{{fullPropName}},jvArray);
+  SetLength(result.{{fullPropName}},_arr^.Count);
+  for _a := 0 to high(result.{{fullPropName}}) do
+    result.{{fullPropName}}[_a] := {{#fromVariant}}{{fromVariant}}({{/fromVariant}}_arr^.Values[_a]{{#fromVariant}}){{/fromVariant}};
+{{/nestedSimpleArray}}{{#nestedRecordArray}}  _arr := JSONVariantDataSafe(_variant.{{fullPropName}},jvArray);
+  SetLength(result.{{fullPropName}},_arr^.Count);
+  for _a := 0 to high(result.{{fullPropName}}) do
+  with result.{{fullPropName}}[_a] do begin
+{{#fields}}
+    {{propName}} := {{#fromVariant}}{{fromVariant}}({{/fromVariant}}_arr^.Values[_a].{{propName}}{{#fromVariant}}){{/fromVariant}};
+{{/fields}}
+  end;
+{{/nestedRecordArray}}{{/fields}}{{/setrec}}
+{{<getrec}}{{#fields}}
+{{#isSimple}}  res.SetPath('{{fullPropName}}',_record.{{fullPropName}});
+{{/isSimple}}{{#nestedRecord}}{{>getrec}}{{/nestedRecord}}{{#toVariant}}  res.SetPath('{{fullPropName}}',{{toVariant}}(_record.{{fullPropName}}));
+{{/toVariant}}{{#nestedSimpleArray}}  with res.EnsureData('{{fullPropName}}')^ do
+    for i := 0 to high(_record.{{fullPropName}}) do
+      AddValue({{#toVariant}}{{toVariant}}({{/toVariant}}_record.{{fullPropName}}[i]{{#toVariant}}){{/toVariant}});
+{{/nestedSimpleArray}}{{#nestedRecordArray}}  with res.EnsureData('{{fullPropName}}')^ do
+    for i := 0 to high(_record.{{fullPropName}}) do
+    with AddItem^, _record.{{fullPropName}}[i] do begin
+{{#fields}}
+      AddNameValue('{{propName}}',{{#toVariant}}{{toVariant}}({{/toVariant}}{{propName}}{{#toVariant}}){{/toVariant}});
+{{/fields}}
+    end;
+{{/nestedRecordArray}}{{/fields}}{{/getrec}}{ Some helpers for record types }
+{{#records}}
+
+function Variant2{{name}}(_variant: variant): {{name}};
+var _a: integer;
+    _arr: PJSONVariantData;
+begin
+{{>setrec}}
+end;
+
+function {{name}}2Variant(const _record: {{name}}): variant;
+var i: integer;
+    res: TJSONVariantData;
+begin
+  res.Init;
+{{>getrec}}
+  result := variant(res);
+end;
+{{/records}}
+
+{{/withRecords}}
+{{#withArrays}}
+
+{ Some helpers for dynamic array types }
+
+{{#arrays}}
+function Variant2{{name}}(const _variant: variant): {{name}};
+var i: integer;
+    arr: PJSONVariantData;
+begin
+  arr := JSONVariantDataSafe(_variant,jvArray);
+  SetLength(result,arr^.Count);
+  for i := 0 to arr^.Count-1 do
+    result[i] := {{#fromVariant}}{{fromVariant}}{{/fromVariant}}(arr^.Values[i]);
+end;
+
+function {{name}}2Variant(const _array: {{name}}): variant;
+var i: integer;
+    res: TJSONVariantData;
+begin
+  res.Init;
+  for i := 0 to high(_array) do
+    res.AddValue({{#toVariant}}{{toVariant}}{{/toVariant}}(_array[i]));
+  result := variant(res);
+end;
+
+{{/arrays}}
+{{/withArrays}}
+
+{$HINTS ON} // for H2164 hints of unused variables
+
+function GetModel(const aRoot: string): TSQLModel;
+begin
+  result := TSQLModel.Create([{{#orm}}{{className}}{{comma}}{{/orm}}],aRoot);
+end;
+
+function GetClient(const aServerAddress{{#authClass}}, aUserName,aPassword{{/authClass}}: string;
+  aServerPort: integer; const aServerRoot: string; aHttps: boolean): TSQLRestClientHTTP;
+begin
+  result := TSQLRestClientHTTP.Create(aServerAddress,aServerPort,
+    GetModel(aServerRoot),true,aHttps); // aOwnModel=true
+  try
+    if (not result.Connect) or (result.ServerTimeStamp=0) then
+      raise ERestException.CreateFmt('Impossible to connect to %s:%d server',
+        [aServerAddress,aServerPort]);
+{{#authClass}}
+    if not result.SetUser({{.}},aUserName,aPassword) then 
+      raise ERestException.CreateFmt('%s:%d server rejected "%s" credentials',
+        [aServerAddress,aServerPort,aUserName]);
+{{/authClass}}
+  except
+    result.Free;
+    raise;
+  end;
+end;
+
+{{#soa.services}}
+
+{ TService{{interfaceURI}} }
+
+constructor TService{{interfaceURI}}.Create(aClient: TSQLRestClientURI);
+begin
+  fServiceName := '{{interfaceURI}}';
+  fServiceURI := '{{uri}}';
+  fInstanceImplementation := sic{{instanceCreationName}};
+  fContractExpected := '{{contractExpected}}';
+  inherited Create(aClient);
+end;
+
+{{#methods}}
+{{verb}} TService{{interfaceURI}}.{{>method}}
+var res: TVariantDynArray;
+begin
+  fClient.CallRemoteService(self,'{{methodName}}',{{ArgsOutputCount}}, // raise EServiceException on error
+    [{{#args}}{{#dirInput}}{{#toVariant}}{{toVariant}}({{argName}}){{/toVariant}}{{^toVariant}}{{argName}}{{/toVariant}}{{commaInSingle}}{{/dirInput}}{{/args}}],res{{#resultIsServiceCustomAnswer}},true{{/resultIsServiceCustomAnswer}});
+{{#args}}{{#dirOutput}}{{#isObject}}  {{argName}}.Free; // avoid memory leak
+{{/isObject}}  {{argName}} := {{#fromVariant}}{{fromVariant}}({{/fromVariant}}res[{{indexOutResult}}{{#fromVariant}}){{/fromVariant}};
+{{/dirOutput}}{{/args}}end;
+
+{{/methods}}
+{{/soa.services}}
+
+end.

contrib/mORMot/CrossPlatform/templates/Delphi.pas.mustache

@@ -0,0 +1,174 @@
+/// remote access to a mORMot server using mORMot units
+{{#uri}}
+// - retrieved from http://{{host}}/{{uri}}
+// at {{time}} using "{{templateName}}" template
+{{/uri}}
+{{^uri}}
+// - generated at {{time}}
+{{/uri}}
+unit {{fileName}};
+
+{
+  WARNING:
+    This unit has been generated by a mORMot {{mORMotVersion}} server.
+    Any manual modification of this file may be lost after regeneration.
+
+  Synopse mORMot framework. Copyright (C) {{year}} Arnaud Bouchez
+    Synopse Informatique - http://synopse.info
+
+  This unit is released under a MPL/GPL/LGPL tri-license,
+  and therefore may be freely included in any application.
+
+  This unit would work on Delphi 6 and later, under Win32 and Win64 platforms,
+  and with FPC 2.7/trunk revision, under Win32 and Linux32.
+}
+
+interface
+
+uses
+  SynCommons,
+  mORMot;
+{{! recursive partials used to write records type definition}}
+{{<writerec}}packed record
+{{#fields}}
+{{nestedIdentation}}    {{propName}}: {{#typeDelphi}}{{typeDelphi}};{{/typeDelphi}}{{#nestedRecord}}{{>writerec}}{{nestedIdentation}}    end;{{/nestedRecord}}{{#nestedSimpleArray}}array of {{typeDelphi}};{{/nestedSimpleArray}}{{#nestedRecordArray}}array of {{>writerec}}{{nestedIdentation}}    end;{{/nestedRecordArray}}
+{{/fields}}{{/writerec}}
+{{<textrec}}{{#fields}}{{propName}} {{#typeDelphi}}{{typeDelphi}}{{/typeDelphi}}{{#nestedRecord}}{ {{>textrec}} }{{/nestedRecord}}{{#nestedSimpleArray}}array of {{typeDelphi}}{{/nestedSimpleArray}}{{#nestedRecordArray}}[ {{>textrec}} ]{{/nestedRecordArray}} {{/fields}}{{/textrec}}
+{{#withEnumerates}}
+type // define some enumeration types, used below
+{{#enumerates}}
+  {{name}} = ({{#values}}{{.}}{{^-last}}, {{/-last}}{{/values}});
+{{/enumerates}}
+
+{{/withEnumerates}}
+{{#withSets}}
+type // define some set types, used below
+{{#sets}}
+  {{name}} = set of({{#values}}{{.}}{{^-last}}, {{/-last}}{{/values}});
+{{/sets}}
+
+{{/withSets}}
+{{#withRecords}}
+type // define some record types, used as properties below
+{{#records}}
+  {{name}} = {{>writerec}}  end;
+
+{{/records}}
+{{/withRecords}}
+{{#withArrays}}
+type // define some dynamic array types, used as properties below
+{{#arrays}}
+  {{name}} = array of {{typeSource}};
+{{/arrays}}
+
+{{/withArrays}}
+{{<method}}{{verb}} {{methodName}}({{#args}}{{^dirResult}}{{dirName}} {{argName}}: {{typeDelphi}}{{commaArg}}{{/dirResult}}{{/args}}){{#args}}{{#dirResult}}: {{typeDelphi}}{{/dirResult}}{{/args}};{{/method}}
+type
+  {{#orm}}
+  {{^isInMormotPas}}
+  /// map "{{tableName}}" table
+  {{className}} = class({{classParent}})
+  protected
+    {{#fields}}
+    f{{name}}: {{typeDelphi}}; 
+    {{/fields}}
+  {{#hasRecords}}
+  public
+    class procedure InternalRegisterCustomProperties(Props: TSQLRecordProperties); override;
+    {{#fields}}
+    {{#isrecord}}
+    property {{name}}: {{typeDelphi}} read f{{name}} write f{{name}}{{#unique}} stored AS_UNIQUE{{/unique}};
+    {{/isrecord}}
+    {{/fields}}
+  {{/hasRecords}}
+  published
+    {{#fields}}
+    {{^isrecord}}
+    property {{name}}: {{typeDelphi}}{{#width}} index {{width}}{{/width}} read f{{name}} write f{{name}}{{#unique}} stored AS_UNIQUE{{/unique}};
+    {{/isrecord}}
+    {{/fields}}
+  end;
+  
+  {{/isInMormotPas}}
+  {{/orm}}
+  {{#soa.services}}
+  /// service accessible {{#uri}}via http://{{host}}/{{root}}/{{uri}}{{/uri}}
+  // - this service will run in sic{{instanceCreationName}} mode
+  I{{interfaceURI}} = interface(IInvokable)
+    ['{{GUID}}']
+{{#methods}}
+    {{>method}}
+{{/methods}}
+  end;
+
+  {{/soa.services}}
+  
+/// return the database Model corresponding to this server
+function GetModel: TSQLModel;
+
+const
+  /// the server port{{#uri}}, corresponding to http://{{host}}{{/uri}}
+  SERVER_PORT = {{port}};
+
+
+{{#soa.enabled}}
+/// define the interface-based services to be consummed by the client
+// - will define the following interfaces:
+{{#soa.services}}
+// ! I{{interfaceURI}}   sic{{instanceCreationName}}   {{GUID}}
+{{/soa.services}}
+procedure RegisterServices(Client: TSQLRestClientURI);
+{{/soa.enabled}}
+
+
+implementation
+
+{{#orm}}
+{{#hasRecords}}
+{ {{className}} }
+
+class procedure {{className}}.InternalRegisterCustomProperties(
+  Props: TSQLRecordProperties);
+begin
+{{#fields}}
+{{#isrecord}}
+  Props.RegisterCustomPropertyFromRTTI(Self,TypeInfo({{typeDelphi}}),
+    '{{name}}',@{{className}}(nil).f{{name}});
+{{/isrecord}}
+{{/fields}}
+end;
+
+{{/hasRecords}}
+{{/orm}}
+
+function GetModel: TSQLModel;
+begin
+  result := TSQLModel.Create([{{#orm}}{{className}}{{comma}}{{/orm}}],'{{root}}');
+end;
+
+{{#soa.enabled}}
+procedure RegisterServices(Client: TSQLRestClientURI);
+begin
+{{#soa.services}}
+  Client.ServiceRegister(TypeInfo(I{{interfaceURI}}),sic{{instanceCreationName}});
+{{/soa.services}}
+end;
+{{/soa.enabled}}
+
+{{#withRecords}}
+const // text-based types definition for records and dynamic arrays
+{{#records}}
+  __{{name}} = '{{>textrec}}';
+{{/records}}
+
+initialization
+{{#enumerates}}
+  TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType(
+    TypeInfo({{name}}));
+{{/enumerates}}
+{{#records}}
+  TTextWriter.RegisterCustomJSONSerializerFromText(
+    TypeInfo({{name}}),__{{name}});
+{{/records}}
+{{/withRecords}}
+end.

contrib/mORMot/CrossPlatform/templates/FPC-mORMotInterfaces.pas.mustache

@@ -0,0 +1,87 @@
+/// SOA interface methods definition to circumvent FPC missing RTTI
+{{#uri}}
+// - retrieved from http://{{host}}/{{uri}}
+// at {{time}} using "{{templateName}}" template
+{{/uri}}
+{{^uri}}
+// - generated at {{time}}
+{{/uri}}
+unit {{fileName}};
+
+{
+  WARNING:
+    This unit has been generated by a mORMot {{mORMotVersion}} server.
+    Any manual modification of this file may be lost after regeneration.
+
+  Synopse mORMot framework. Copyright (C) {{year}} Arnaud Bouchez
+    Synopse Informatique - http://synopse.info
+
+  This unit is released under a MPL/GPL/LGPL tri-license,
+  and therefore may be freely included in any application.
+
+  This unit is intended to work on older FPC compilers, which lack of RTTI
+  for interfaces - see http://bugs.freepascal.org/view.php?id=26774
+  
+  USAGE:
+
+  Add this {{fileName}} unit to your uses clause, so that the following
+  interfaces would be defined as expected by mORMot under FPC:
+
+{{#soa.services}}
+   - {{interfaceName}}
+{{/soa.services}}
+  
+}
+
+interface
+
+{$I Synopse.inc} // needed for setting HASINTERFACERTTI and proper FPC modes
+
+uses
+  SysUtils,
+  Classes,
+  SynCommons,
+  SynLog,
+  mORMot{{#units}},
+  {{.}}{{/units}};
+
+
+implementation
+
+{{#soa.enabled}}
+{$ifndef HASINTERFACERTTI} // circumvent old FPC bug of missing RTTI
+
+{ TInterfaceFactoryDefinition }
+
+type
+  /// define and manage missing interface RTTI for the following interfaces:
+{{#soa.services}}
+  // - {{interfaceName}}
+{{/soa.services}}
+  TInterfaceFactoryDefinition = class(TInterfaceFactoryGenerated)
+  protected
+    procedure AddMethodsFromTypeInfo(aInterface: PTypeInfo); override;
+  end;
+
+procedure TInterfaceFactoryDefinition.AddMethodsFromTypeInfo(aInterface: PTypeInfo);
+begin
+{{#soa.services}}
+  if aInterface=TypeInfo({{interfaceName}}) then begin
+{{#methods}}
+    AddMethod('{{methodName}}',[
+{{#args}}      ord(smd{{dirName}}),'{{argName}}',TypeInfo({{typeSource}}){{#isArgLast}}]);{{/isArgLast}}{{^isArgLast}},
+{{/isArgLast}}{{/args}}      {{^args}}]);{{/args}}
+{{/methods}}
+    exit;
+  end;
+{{/soa.services}}
+end;
+
+initialization
+{{#soa.services}}
+  TInterfaceFactoryDefinition.RegisterInterface(TypeInfo({{interfaceName}}));
+{{/soa.services}}
+
+{$endif HASINTERFACERTTI}
+{{/soa.enabled}}
+end.

contrib/mORMot/CrossPlatform/templates/FPCServer-mORMotServer.pas.mustache

@@ -0,0 +1,157 @@
+/// {{#units}}{{.}} {{/units}}generated types for a FPC mORMot server 
+{{#uri}}
+// - retrieved from http://{{host}}/{{uri}}
+// at {{time}} using "{{templateName}}" template
+{{/uri}}
+{{^uri}}
+// - generated at {{time}}
+{{/uri}}
+unit {{fileName}};
+
+(*
+  WARNING:
+    This unit has been generated by a mORMot {{mORMotVersion}} server.
+    Any manual modification of this file may be lost after regeneration.
+
+  Synopse mORMot framework. Copyright (C) {{year}} Arnaud Bouchez
+    Synopse Informatique - http://synopse.info
+
+  This unit is released under a MPL/GPL/LGPL tri-license,
+  and therefore may be freely included in any application.
+
+  This unit is intended to work on older FPC compilers, which lack of RTTI
+  for interfaces and records. As a result, you would be able to compile
+  your server executable for hosting in Linux.
+
+  It will also include RTTI for records for versions prior to Delphi 2010.
+  
+  USAGE:
+
+  1. Compile your code using latest versions of Delphi (which supports
+     record definition as published properties since XE5)
+
+  2. Enumerations, sets, dynamic arrays and records type definitions
+     would be shared from the original Delphi units
+
+  3. Add a reference to this {{fileName}} unit to your uses clause, so that
+     missing RTTI would be available for the following types:
+{{#records}}
+      - {{name}} record
+{{/records}}
+{{#soa.services}}
+      - I{{interfaceURI}} interface
+{{/soa.services}}
+{{#ORMWithRecords}}
+
+  4. Ensure there is a reference to {$I Synopse.inc} at the beginning of the following units:
+{{#units}}
+      - {{.}}.pas
+{{/units}}
+   
+  5. Modify the following type definitions to include the information
+     about record published properties:
+{{#orm}}
+{{#hasRecords}}
+
+  {{className}} = class({{classParent}}) // in {{unitName}}.pas
+  ...
+  public
+    {$ifndef PUBLISHRECORD} // defined in Synopse.inc
+    class procedure InternalRegisterCustomProperties(Props: TSQLRecordProperties); override;   
+    {$endif}
+  ...
+  
+{$ifndef PUBLISHRECORD}
+class procedure {{className}}.InternalRegisterCustomProperties(Props: TSQLRecordProperties);
+begin
+{{#fields}}
+{{#isrecord}}
+  Props.RegisterCustomPropertyFromRTTI(Self,TypeInfo({{typeDelphi}}),
+    '{{name}}',@{{className}}(nil).f{{name}});
+{{/isrecord}}
+{{/fields}}
+end;
+{$endif} 
+{{/hasRecords}}
+{{/orm}}
+{{/ORMWithRecords}}  
+*)
+
+interface
+
+{$I Synopse.inc} // needed for setting HASINTERFACERTTI and proper FPC modes
+
+uses
+  SysUtils,
+  Classes,
+  SynCommons,
+  mORMot,
+  mORMotDDD{{#units}},
+  {{.}}{{/units}};
+
+
+implementation
+
+{$ifndef HASINTERFACERTTI} // circumvent a old FPC bug
+{{#soa.enabled}}
+
+{ TInterfaceFactoryDefinition }
+
+type
+  /// define and manage missing interface RTTI for defined interfaces
+  TInterfaceFactoryDefinition = class(TInterfaceFactoryGenerated)
+  protected
+    /// will declare the following types to the interface factory:
+{{#soa.services}}
+    // - I{{interfaceURI}}
+{{/soa.services}}
+    procedure AddMethodsFromTypeInfo(aInterface: PTypeInfo); override;
+  end;
+
+procedure TInterfaceFactoryDefinition.AddMethodsFromTypeInfo(aInterface: PTypeInfo);
+begin
+{{#soa.services}}
+  if aInterface=TypeInfo(I{{interfaceURI}}) then begin
+{{#methods}}
+    AddMethod('{{methodName}}',[
+{{#args}}      ord(smd{{dirName}}),'{{argName}}',TypeInfo({{typeSource}}){{#isArgLast}}]);{{/isArgLast}}{{^isArgLast}},
+{{/isArgLast}}{{/args}}
+{{/methods}}
+    exit;
+  end;
+{{/soa.services}}
+end;
+
+{$endif HASINTERFACERTTI}
+{{/soa.enabled}}
+{{#withRecords}}
+{{<textrec}}{{#fields}}{{propName}} {{#typeDelphi}}{{typeDelphi}}{{/typeDelphi}}{{#nestedRecord}}{ {{>textrec}} }{{/nestedRecord}}{{#nestedSimpleArray}}array of {{typeDelphi}}{{/nestedSimpleArray}}{{#nestedRecordArray}}[ {{>textrec}} ]{{/nestedRecordArray}} {{/fields}}{{/textrec}}
+
+{$ifndef ISDELPHI2010}
+
+const // text-based types definition for records and dynamic arrays
+{{#records}}
+  __{{name}} = '{{>textrec}}';
+{{/records}}
+
+{{/withRecords}}
+initialization
+{{#enumerates}}
+  TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType(
+    TypeInfo({{name}}));
+{{/enumerates}}
+{{#records}}
+  TTextWriter.RegisterCustomJSONSerializerFromText(
+    TypeInfo({{name}}),__{{name}});
+{{/records}}
+{{#soa.enabled}}
+{$ifndef HASINTERFACERTTI} // circumvent a old FPC bug
+{{#soa.services}}
+  TInterfaceFactoryDefinition.RegisterInterface(
+    TypeInfo(I{{interfaceURI}}));
+{{/soa.services}}
+{$endif HASINTERFACERTTI}
+{{/soa.enabled}}
+
+{$endif ISDELPHI2010}
+end.

contrib/mORMot/CrossPlatform/templates/SmartMobileStudio.pas.mustache

@@ -0,0 +1,361 @@
+/// remote access to a mORMot server using SmartMobileStudio
+{{#uri}}
+// - retrieved from {{protocol}}://{{host}}/{{uri}}
+// at {{time}} using "{{templateName}}" template
+{{/uri}}
+{{^uri}}
+// - generated at {{time}}
+{{/uri}}
+unit {{fileName}};
+
+{
+  WARNING:
+    This unit has been generated by a mORMot {{mORMotVersion}} server.
+    Any manual modification of this file may be lost after regeneration.
+
+  Synopse mORMot framework. Copyright (C) {{year}} Arnaud Bouchez
+    Synopse Informatique - http://synopse.info
+
+  This unit is released under a MPL/GPL/LGPL tri-license,
+  and therefore may be freely included in any application.
+
+  This unit would work on Smart Mobile Studio 2.1.1 and later.
+}
+
+interface
+
+uses
+  SmartCL.System,
+  System.Types,
+  SynCrossPlatformSpecific,
+  SynCrossPlatformREST;
+
+{{! recursive partials used to write records type definition}}
+{{<writerec}}record
+{{#fields}}
+{{nestedIdentation}}    {{propName}}: {{#typePascal}}{{typePascal}};{{/typePascal}}{{#nestedRecord}}{{>writerec}}{{nestedIdentation}}    end;{{/nestedRecord}}{{#nestedSimpleArray}}array of {{typePascal}};{{/nestedSimpleArray}}{{#nestedRecordArray}}array of {{>writerec}}{{nestedIdentation}}    end;{{/nestedRecordArray}}
+{{/fields}}{{/writerec}}
+{{#withEnumerates}}
+type // define some enumeration types, used below
+{{#enumerates}}
+  {{name}} = ({{#values}}{{.}}{{^-last}}, {{/-last}}{{/values}});
+{{/enumerates}}
+
+{{/withEnumerates}}
+{{#withSets}}
+type // define some set types, used below
+{{#sets}}
+  {{name}} = set of({{#values}}{{.}}{{^-last}}, {{/-last}}{{/values}});
+{{/sets}}
+
+{{/withSets}}
+{{#withRecords}}
+type // define some record types, used as properties below
+{{#records}}
+  {{name}} = {{>writerec}}  end;
+
+{{/records}}
+{{/withRecords}}
+{{#withArrays}}
+type // define some dynamic array types, used as properties below
+{{#arrays}}
+  {{name}} = array of {{typeSource}};
+{{/arrays}}
+
+{{/withArrays}}
+type{{<methodAsynch}}{{methodName}}({{#args}}{{#dirInput}}{{argName}}: {{typePascal}}; {{/dirInput}}{{/args}}
+      onSuccess: procedure({{#args}}{{#dirOutput}}{{argName}}: {{typePascal}}{{commaOutResult}}{{/dirOutput}}{{/args}}); onError: TSQLRestEvent);{{/methodAsynch}}{{<methodSynch}}_{{methodName}}({{#args}}{{^dirResult}}{{dirNoOut}} {{argName}}: {{typePascal}}{{commaArg}}{{/dirResult}}{{/args}}){{#args}}{{#dirResult}}: {{typePascal}}{{/dirResult}}{{/args}};{{/methodSynch}}
+{{#orm}}
+{{^isInMormotPas}}
+  /// map "{{tableName}}" table
+  {{className}} = class(TSQLRecord)
+  protected
+    {{#fields}}
+    f{{name}}: {{typePascal}}; 
+    {{/fields}}
+    // those overridden methods will emulate the needed RTTI
+    class function ComputeRTTI: TRTTIPropInfos; override;
+    procedure SetProperty(FieldIndex: integer; const Value: variant); override;
+    function GetProperty(FieldIndex: integer): variant; override;
+  public
+{{#fields}}
+{{#isSQLRecord}}    // defined as {{name}}: {{typeDelphi}} on the server
+{{/isSQLRecord}}
+    property {{name}}: {{typePascal}} read f{{name}} write f{{name}};
+{{/fields}}
+  end;
+  
+{{/isInMormotPas}}
+{{/orm}}
+{{#soa.services}}
+  /// service accessible {{#uri}}via {{protocol}}://{{host}}/{{root}}/{{uri}}{{/uri}}
+  // - this service will run in sic{{instanceCreationName}} mode
+  // - synchronous and asynchronous methods are available, depending on use case
+  // - synchronous _*() methods will block the browser execution, so won't be
+  // appropriate for long process - on error, they may raise EServiceException
+  {{#isClientDriven}}
+  // - you should call explicitly Free to release the server instance
+  {{/isClientDriven}}
+  TService{{interfaceURI}} = class(TServiceClientAbstract{{#isClientDriven}}ClientDriven{{/isClientDriven}})
+  public
+    /// will initialize an access to the remote service
+    constructor Create(aClient: TSQLRestClientURI); override;
+{{#methods}}
+
+    procedure {{>methodAsynch}}
+    {{verb}} {{>methodSynch}}
+{{/methods}}
+  end;
+
+{{/soa.services}}
+
+const
+  /// the server port{{#uri}}, corresponding to {{protocol}}://{{host}}{{/uri}}
+  SERVER_PORT = {{port}};
+  /// the server model root name{{#uri}}, corresponding to {{protocol}}://{{host}}/{{root}}{{/uri}}
+  SERVER_ROOT = '{{root}}';
+
+
+/// return the database Model corresponding to this server
+function GetModel(aRoot: string=SERVER_ROOT): TSQLModel;
+
+/// create a TSQLRestClientHTTP instance and connect to the server
+// - it will use by default port {{port}} over root '{{root}}'{{#host}}, corresponding
+// to {{protocol}}://{{host}}/{{root}}{{/host}}
+{{#authClass}}
+// - secure connection will be established via {{.}}
+// with the supplied credentials
+{{/authClass}}
+// - request will be asynchronous, and trigger onSuccess or onError event
+procedure GetClient(const aServerAddress{{#authClass}}, aUserName,aPassword{{/authClass}}: string;
+  onSuccess, onError: TSQLRestEvent;
+  aServerPort: integer=SERVER_PORT; aServerRoot: string=SERVER_ROOT;
+  aHttps: boolean={{#https}}true{{/https}}{{^https}}false{{/https}});
+
+{{#withHelpers}}
+// publish some low-level helpers for variant conversion
+// - used internally: you should not need those functions in your end-user code
+{{#enumerates}}
+function Variant2{{name}}(const _variant: variant): {{name}};
+function {{name}}ToText(const value: {{name}}): string;
+{{/enumerates}}
+{{#records}}
+function Variant2{{name}}(const Value: variant): {{name}};
+function {{name}}2Variant(const Value: {{name}}): variant;
+{{/records}}
+{{#arrays}}
+function Variant2{{name}}(const _variant: variant): {{name}};
+function {{name}}2Variant(const _array: {{name}}): variant;
+{{/arrays}}
+
+{{/withHelpers}}
+
+implementation
+{{<setrec}}{{#fields}}
+{{#isSimple}}  result.{{fullPropName}} := Value.{{fullPropName}};
+{{/isSimple}}{{#nestedRecord}}{{>setrec}}{{/nestedRecord}}{{#fromVariant}}  result.{{fullPropName}} := {{fromVariant}}(Value.{{fullPropName}});
+{{/fromVariant}}{{#nestedSimpleArray}}  if VariantType(Value.{{fullPropName}})=jvArray then
+    for var i := 0 to integer(Value.{{fullPropName}}.length)-1 do
+      result.{{fullPropName}}.Add({{typePascal}}(Value.{{fullPropName}}[i]));
+{{/nestedSimpleArray}}{{#nestedRecordArray}}  if VariantType(Value.{{fullPropName}})=jvArray then begin
+    var tmp: {{name}};
+    tmp.{{propName}}.SetLength(1);
+    for var n := 0 to integer(Value.{{fullPropName}}.length)-1 do begin
+      var source := Value.{{fullPropName}}[n];
+      var dest := tmp.{{propName}}[0];
+{{#fields}}
+      dest.{{propName}} := {{#fromVariant}}{{fromVariant}}({{/fromVariant}}source.{{propName}}{{#fromVariant}}){{/fromVariant}};
+{{/fields}}
+      result.{{fullPropName}}.Add(dest);
+    end;
+  end;
+{{/nestedRecordArray}}{{/fields}}{{/setrec}}
+{{<getrec}}{{#fields}}
+{{#isSimple}}  result.{{fullPropName}} := Value.{{fullPropName}};
+{{/isSimple}}{{#nestedRecord}}  result.{{fullPropName}} := new JObject;
+{{>getrec}}{{/nestedRecord}}{{#toVariant}}  result.{{fullPropName}} := {{toVariant}}(Value.{{fullPropName}});
+{{/toVariant}}{{#nestedSimpleArray}}  result.{{fullPropName}} := variant(Value.{{fullPropName}});
+{{/nestedSimpleArray}}{{#nestedRecordArray}}  result.{{fullPropName}} := TVariant.CreateArray;
+  for var source in Value.{{fullPropName}} do begin
+    var dest: variant := new JObject;
+{{#fields}}
+    dest.{{propName}} := {{#toVariant}}{{toVariant}}({{/toVariant}}source.{{propName}}{{#toVariant}}){{/toVariant}};
+{{/fields}}
+    result.{{fullPropName}}.push(dest);
+  end;
+{{/nestedRecordArray}}{{/fields}}{{/getrec}}
+{{#withEnumerates}}
+{ Some helpers for enumerates types }
+
+{$HINTS OFF} // for begin asm return ... end; end below
+
+// those functions will use the existing generated string array constant
+// defined by the SMS compiler for each enumeration
+
+{{#enumerates}}
+function Variant2{{name}}(const _variant: variant): {{name}};
+begin
+  asm return @VariantToEnum(@_variant,@{{name}}); end;
+end;
+
+function {{name}}ToText(const value: {{name}}): string;
+begin
+  asm return @{{name}}[@value]; end;
+end;
+
+{{/enumerates}}
+{$HINTS ON}
+
+{{/withEnumerates}}
+{{#withRecords}}
+{ Some helpers for record types:
+  due to potential obfuscation of generated JavaScript, we can't assume
+  that the JSON used for transmission would match record fields naming }
+{{#records}}
+
+function Variant2{{name}}(const Value: variant): {{name}};
+begin
+{{>setrec}}
+end;
+
+function {{name}}2Variant(const Value: {{name}}): variant;
+begin
+  result := new JObject;
+{{>getrec}}
+end;
+{{/records}}
+
+{{/withRecords}}
+{{#withArrays}}
+
+{ Some helpers for dynamic array types }
+
+{{#arrays}}
+function Variant2{{name}}(const _variant: variant): {{name}};
+var tmp: {{typeSource}};
+begin
+  if VariantType(_variant)=jvArray then
+    for var i := 0 to integer(_variant.Length)-1 do begin
+      tmp := {{#fromVariant}}{{fromVariant}}{{/fromVariant}}(_variant[i]);
+      result.Add(tmp);
+    end;
+end;
+
+function {{name}}2Variant(const _array: {{name}}): variant;
+var i: integer;
+begin
+  result := TVariant.CreateArray;
+  for i := 0 to high(_array) do
+    result.push({{#toVariant}}{{toVariant}}{{/toVariant}}(_array[i]));
+end;
+
+{{/arrays}}
+{{/withArrays}}
+{{#orm}}
+
+{{^isInMormotPas}}
+
+{ {{className}} }
+
+class function {{className}}.ComputeRTTI: TRTTIPropInfos;
+begin
+  result := TRTTIPropInfos.Create(
+    [{{#fields}}'{{name}}'{{comma}}{{/fields}}],
+    [{{#fields}}{{typekindname}}{{comma}}{{/fields}}]);
+end;
+
+procedure {{className}}.SetProperty(FieldIndex: integer; const Value: variant);
+begin
+  case FieldIndex of
+  0: fID := Value;
+  {{#fields}}
+  {{index}}: f{{name}} := {{#fromVariant}}{{fromVariant}}({{/fromVariant}}Value{{#fromVariant}}){{/fromVariant}};
+  {{/fields}}
+  end;
+end;
+
+function {{className}}.GetProperty(FieldIndex: integer): variant;
+begin
+  case FieldIndex of
+  0: result := fID;
+  {{#fields}}
+  {{index}}: result := {{#toVariant}}{{toVariant}}({{/toVariant}}f{{name}}{{#toVariant}}){{/toVariant}};
+  {{/fields}}
+  end;
+end;
+
+{{/isInMormotPas}}
+{{/orm}}
+
+function GetModel(aRoot: string): TSQLModel;
+begin
+  result := TSQLModel.Create([{{#orm}}{{className}}{{comma}}{{/orm}}],aRoot);
+end;
+
+procedure GetClient(const aServerAddress{{#authClass}}, aUserName,aPassword{{/authClass}}: string;
+  onSuccess, onError: TSQLRestEvent; aServerPort: integer; aServerRoot: string;
+  aHttps: boolean);
+begin
+  var client := TSQLRestClientHTTP.Create(aServerAddress,aServerPort,
+    GetModel(aServerRoot),true,aHttps); // aOwnModel=true
+  client.Connect(
+  lambda
+    try
+      if client.ServerTimeStamp=0 then begin
+        if Assigned(onError) then
+          onError(client);
+        exit;
+      end;
+{{#authClass}}
+      if not client.SetUser({{.}},aUserName,aPassword) then begin
+        if Assigned(onError) then
+          onError(client);
+        exit;
+      end;
+{{/authClass}}
+      if Assigned(onSuccess) then
+        onSuccess(client);
+    except
+      if Assigned(onError) then
+        onError(client);
+    end;
+  end,
+  onError);
+end;
+
+{{#soa.services}}
+
+{ TService{{interfaceURI}} }
+
+constructor TService{{interfaceURI}}.Create(aClient: TSQLRestClientURI);
+begin
+  fServiceName := '{{interfaceURI}}';
+  fServiceURI := '{{uri}}';
+  fInstanceImplementation := sic{{instanceCreationName}};
+  fContractExpected := '{{contractExpected}}';
+  inherited Create(aClient);
+end;
+
+
+{{#methods}}
+procedure TService{{interfaceURI}}.{{>methodAsynch}}
+begin 
+  fClient.CallRemoteServiceAsynch(self,'{{methodName}}',{{ArgsOutputCount}},
+    [{{#args}}{{#dirInput}}{{#toVariant}}{{toVariant}}({{argName}}){{/toVariant}}{{^toVariant}}{{argName}}{{/toVariant}}{{commaInSingle}}{{/dirInput}}{{/args}}],
+    lambda (res: array of Variant)
+      onSuccess({{#args}}{{#dirOutput}}{{#fromVariant}}{{fromVariant}}({{/fromVariant}}res[{{indexOutResult}}{{#fromVariant}}){{/fromVariant}}{{#commaOutResult}},{{/commaOutResult}}{{/dirOutput}}{{/args}});
+    end, onError{{#resultIsServiceCustomAnswer}}, true{{/resultIsServiceCustomAnswer}}); 
+end;
+
+{{verb}} TService{{interfaceURI}}.{{>methodSynch}}
+begin
+  var res := fClient.CallRemoteServiceSynch(self,'{{methodName}}',{{ArgsOutputCount}},
+    [{{#args}}{{#dirInput}}{{#toVariant}}{{toVariant}}({{argName}}){{/toVariant}}{{^toVariant}}{{argName}}{{/toVariant}}{{commaInSingle}}{{/dirInput}}{{/args}}]{{#resultIsServiceCustomAnswer}},true{{/resultIsServiceCustomAnswer}});
+{{#args}}{{#dirOutput}}  {{argName}} := {{#fromVariant}}{{fromVariant}}({{/fromVariant}}res[{{indexOutResult}}{{#fromVariant}}){{/fromVariant}};
+{{/dirOutput}}{{/args}}end;
+
+
+{{/methods}}
+{{/soa.services}}
+
+end.

contrib/mORMot/CrossPlatform/templates/Swagger.json.mustache

@@ -0,0 +1,395 @@
+{{! recursive partial used to expand type definition
+   HACK: Objects, Enums, Records and Arrays, which are used by reference
+         and defined outside the main units have to be handled explicitly.
+         All internal types have their Swagger-Typ defined. }}
+{{<write-type}}{{#typeSwagger}}{{#Equals typeSwagger,typeSource}}{"$ref":"#/definitions/{{typeSwagger}}"}{{/Equals}}{{^Equals typeSwagger,typeSource}}{{typeSwagger}}{{/Equals}}{{/typeSwagger}}{{^typeSwagger}}{{#nestedSimpleArray}}{"type":"array","items":{{>write-type}}}{{/nestedSimpleArray}}{{/typeSwagger}}{{/write-type}}
+
+{
+    "swagger": "2.0",
+    "info": {
+        "description": "Generated by {{exeInfo}} using mORMot {{mORMotVersion}} at {{time}}",
+        "title": "{{root}} API{{#exeVersion}} {{.}}{{/exeVersion}}",
+        "version": "{{exeVersion}}"
+    },
+    "host": "{{host}}",
+    "basePath": "/{{root}}",
+    "tags": [
+          {{#orm}}
+		{
+                "name": "{{tableName}}",
+		"description": "ORM endpoint for {{root}}/{{tableName}} record"
+		}{{^-last}},{{/-last}}
+          {{/orm}}
+	        {{#soa}}{{#hasorm}},{{/hasorm}}
+          {{#services}}
+		{
+                "name": "{{uri}}",
+                "description": {{#serviceDescription}}{{jsonQuote serviceDescription}}{{/serviceDescription}}{{^serviceDescription}}"SOA endpoint for {{root}}/{{uri}} service"{{/serviceDescription}}
+		}{{^-last}},{{/-last}}
+	  {{/services}}
+          {{/soa}}
+	],
+
+    "definitions": {
+      {{#orm}}
+        "{{tableName}}": {
+            "type": "object",
+            "description": "ORM {{tableName}} record definition",
+            "properties": {
+              "ID":{"type":"integer","format":"int64"}{{#fields}},"{{name}}":{{typeSwagger}}{{/fields}}
+            }
+        },
+       {{/orm}}
+      {{#records}}
+        "{{name}}": { 
+            "type": "object",
+            "description": "SOA {{name}} object DTO definition",
+            "properties": {
+              {{#fields}}
+                "{{propName}}": {{>write-type}}{{^-last}},{{/-last}}
+              {{/fields}}
+            }
+        },
+
+      {{/records}}
+      {{#arrays}}
+        "{{name}}": {
+            "type": "array",
+            "summary": "SOA {{name}} array DTO definition",
+            "items": {{>write-type}}
+        },
+      {{/arrays}}
+      {{#enumerates}}
+       "{{name}}": {
+          "type": "string",
+          "description": "SOA {{name}} enumeration DTO definition",
+          "enum": [
+               {{#values}}
+               "{{.}}"{{^-last}},{{/-last}}
+               {{/values}}
+          ],           
+          "required": true  
+       },
+
+      {{/enumerates}}
+      "__error": {
+          "type": "object",
+          "description": "Generic error information",
+          "properties": {
+            "errorCode": {"type":"integer"},"errorText":{"type":"string"} }
+      }
+    },
+    "paths": {
+      {{#orm}}
+
+      "/{{tableName}}":{
+            "get": {
+                "tags": [
+                    "{{tableName}}"
+                ],
+                "summary": "query ORM fields values on {{tableName}}",
+                "description": "",
+                "produces": [
+                    "application/json"
+                ],
+                "parameters": [{
+                        "name": "select",
+                        "in": "query",
+                        "description": "define returned fields of {{tableName}} query, set * to return all fields",
+                        "required": true,
+                        "type":"string"
+                    },{
+                        "name": "where",
+                        "in": "query",
+                        "description": "SELECT-like where condition for {{tableName}} query",
+                        "required": false,
+                        "type":"string"
+                    },{
+                        "name": "sort",
+                        "in": "query",
+                        "description": "order fields for {{tableName}} query",
+                        "required": false,
+                        "type":"string"
+                    }],
+                "responses": {
+                    "200": {
+                        "description": "successful operation",
+                        "schema": {
+                            "$ref": "#/definitions/{{tableName}}"
+                        }
+                    },
+                    "403": {
+                        "description": "{{tableName}} not properly accessed",
+                        "schema": {
+                            "$ref": "#/definitions/__error"
+                        }
+                    },
+                    "404": {
+                        "description": "{{tableName}} not found"
+                    },
+                    "405": {
+                        "description": "Unauthorized access to {{tableName}}"
+                    }
+                }
+            }
+        },
+        "/{{tableName}}/":{
+            "get": {
+                "tags": [
+                    "{{tableName}}"
+                ],
+                "summary": "retrieve all {{tableName}} ORM ids",
+                "description": "",
+                "produces": [
+                    "application/json"
+                ],
+                "parameters": [],
+                "responses": {
+                    "200": {
+                        "description": "successful operation",
+                        "schema": {
+                            "$ref": "#/definitions/{{tableName}}"
+                        }
+                    },
+                    "403": {
+                        "description": "{{tableName}} not properly accessed",
+                        "schema": {
+                            "$ref": "#/definitions/__error"
+                        }
+                    },
+                    "404": {
+                        "description": "{{tableName}} not found"
+                    },
+                    "405": {
+                        "description": "Unauthorized access to {{tableName}}"
+                    }
+                }
+            }
+            , "post": {
+                "tags": [
+                    "{{tableName}}"
+                ],
+                "summary": "creates a new {{tableName}} ORM record",
+                "description": "",
+                "produces": [
+                    "application/json"
+                ],
+                "parameters": [{
+                        "name": "body",
+                        "in": "body",
+                        "description": "new {{tableName}} JSON object content",
+                        "schema": {
+                            "$ref": "#/definitions/{{tableName}}"
+                        },
+                        "required": true
+                    }],
+                "responses": {
+                    "201": {
+                        "description": "successful operation",
+                        "schema": {
+                            "$ref": "#/definitions/{{tableName}}"
+                        }
+                    },
+                    "403": {
+                        "description": "{{tableName}} not writable or not properly accessed",
+                        "schema": {
+                            "$ref": "#/definitions/__error"
+                        }
+                    },
+                    "404": {
+                        "description": "{{tableName}} not found"
+                    },
+                    "405": {
+                        "description": "Unauthorized access to {{tableName}}"
+                    }
+                }
+            }
+        },
+        "/{{tableName}}/{id}":{
+            "get": {
+                "tags": [
+                    "{{tableName}}"
+                ],
+                "summary": "retrieve a {{tableName}} ORM record by id",
+                "description": "",
+                "produces": [
+                    "application/json"
+                ],
+                "parameters": [{
+                        "name": "id",
+                        "in": "path",
+                        "description": "id to query {{tableName}}",
+                        "required": true,
+                        "type": "integer",
+                        "format":"int64"
+                    }],
+                "responses": {
+                    "200": {
+                        "description": "successful operation",
+                        "schema": {
+                            "$ref": "#/definitions/{{tableName}}"
+                        }
+                    },
+                    "403": {
+                        "description": "{{tableName}} not properly accessed",
+                        "schema": {
+                            "$ref": "#/definitions/__error"
+                        }
+                    },
+                    "404": {
+                        "description": "{{tableName}} not found"
+                    },
+                    "405": {
+                        "description": "Unauthorized access to {{tableName}}"
+                    }
+                }
+            }, "put": {
+                "tags": [
+                    "{{tableName}}"
+                ],
+                "summary": "change a {{tableName}} ORM record by id",
+                "description": "",
+                "produces": [
+                    "application/json"
+                ],
+                "parameters": [{
+                        "name": "id",
+                        "in": "path",
+                        "description": "id to update {{tableName}}",
+                        "required": true,
+                        "type": "integer",
+                        "format":"int64"
+                    },{
+                        "name": "body",
+                        "in": "body",
+                        "schema": {
+                            "$ref": "#/definitions/{{tableName}}"
+                        },
+                        "description": "modified {{tableName}} JSON object content (partial fields accepted)",
+                        "required": true
+                    }],
+                "responses": {
+                    "200": {
+                        "description": "successful operation",
+                        "schema": {
+                            "$ref": "#/definitions/{{tableName}}"
+                        }
+                    },
+                    "403": {
+                        "description": "{{tableName}} not writable or not properly accessed",
+                        "schema": {
+                            "$ref": "#/definitions/__error"
+                        }
+                    },
+                    "404": {
+                        "description": "{{tableName}} not found"
+                    },
+                    "405": {
+                        "description": "Unauthorized access to {{tableName}}"
+                    }
+                }
+            },"delete": {
+                "tags": [
+                    "{{tableName}}"
+                ],
+                "summary": "remove a {{tableName}} ORM record by id",
+                "description": "",
+                "produces": [
+                    "application/json"
+                ],
+                "parameters": [{
+                        "name": "id",
+                        "in": "path",
+                        "description": "id to delete {{tableName}}",
+                        "required": true,
+                        "type": "integer",
+                        "format":"int64"
+                    }],
+                "responses": {
+                    "200": {
+                        "description": "successful operation",
+                        "schema": {
+                            "$ref": "#/definitions/{{tableName}}"
+                        }
+                    },
+                    "403": {
+                        "description": "{{tableName}} not writable or not properly accessed",
+                        "schema": {
+                            "$ref": "#/definitions/__error"
+                        }
+                    },
+                    "404": {
+                        "description": "{{tableName}} not found"
+                    },
+                    "405": {
+                        "description": "Unauthorized access to {{tableName}}"
+                    }
+                }
+            }
+        }{{^-last}},{{/-last}}
+
+      {{/orm}}
+      {{#soa}}{{#hasorm}},{{/hasorm}}{{#services}}
+      {{#methods}}
+        "/{{uri}}/{{methodName}}": {
+            "post": {
+		"description": {{jsonQuote methodDescription}},
+		"tags": [
+                   "{{uri}}"
+                ],
+                "parameters": [{
+                    "in": "body",
+                    "name": "body",
+                    "schema": {
+                        "type": "object",
+                        "properties": { {{#args}}{{#dirInput}}
+                            "{{argName}}": {{>write-type}}{{commaInSingle}}{{/dirInput}}{{/args}}
+                        }
+                    }
+                }],
+                "responses": {
+                   "200": {
+                      "description": "{{uri}}.{{methodName}} executed - check returned content for any application-level error{{^resultAsJSONObjectWithoutResult}}\r\n **Warning: Swagger doesn't support untyped arrays, so isn't able to correctly define the response - please use rather *ResultAsJSONObjectWithoutResult* for a public API**{{/resultAsJSONObjectWithoutResult}}",
+                      "schema": {
+                            "type": "object",
+                            "properties": {
+                            {{#resultAsJSONObjectWithoutResult}}
+                            {{#args}} {{#dirOutput}}
+                                "{{argName}}": {{>write-type}}{{#commaOutResult}},{{/commaOutResult}}
+                            {{/dirOutput}}{{/args}}
+                            {{/resultAsJSONObjectWithoutResult}}
+                            {{^resultAsJSONObjectWithoutResult}}
+                                "result": {
+                                    "type": "array",
+                                    "items": {"type":"string"}
+                                }
+                            {{/resultAsJSONObjectWithoutResult}}
+                            }
+                        }
+                    },
+                    "401": {
+                        "description": "{{uri}}.{{methodName}} execution not allowed",
+                         "schema": {
+                            "$ref": "#/definitions/__error"
+                        }
+                    },
+                    "403": {
+                        "description": "{{uri}}.{{methodName}} not properly accessed",
+                        "schema": {
+                            "$ref": "#/definitions/__error"
+                        }
+                    },
+                    "406": {
+                        "description": "{{uri}}.{{methodName}} execution failed - probably due to unexpected input",
+                        "schema": {
+                            "$ref": "#/definitions/__error"
+                        }
+                    }
+                }
+            }
+        }{{^-last}},{{/-last}}
+      {{/methods}}{{^-last}},{{/-last}}
+
+      {{/services}}{{/soa}}
+    }
+}

contrib/mORMot/Delphinus.Info.json

@@ -0,0 +1,7 @@
+{
+    "id": "{58455621-E9CB-4DDC-8812-7FF096576B21}",
+    "name": "mORMot",
+    "picture": ".\\SQLite3\\Documentation\\mORMot128.png",
+    "package_compiler_min": 14,
+    "compiler_min": 14
+}

contrib/mORMot/Delphinus.Install.json

@@ -0,0 +1,26 @@
+{
+    "search_pathes":
+    [
+        {
+            "pathes": ".;.\\SQLite3;.\\CrossPlatform;.\\SynDBDataSet;.\\SQlite3\\DDD\\dom;.\\SQlite3\\DDD\\infra;.\\SQlite3\\DDD\\tools",
+            "platforms": "Win32;Win64"
+        }
+    ],
+
+    "browsing_pathes":
+    [
+        {
+            "pathes": ".;.\\SQLite3;.\\CrossPlatform;.\\SynDBDataSet;.\\SQlite3\\DDD\\dom;.\\SQlite3\\DDD\\infra;.\\SQlite3\\DDD\\tools",
+            "platforms": "Win32;Win64"
+        }
+    ],
+
+    "source_folders":
+    [
+        {
+            "folder": ".",
+            "recursive": true,
+            "filter": "*.*;*"
+        }
+    ]
+}

contrib/mORMot/Packages/.gitignore

@@ -0,0 +1 @@
+*.pas

contrib/mORMot/Packages/README.md

@@ -0,0 +1,38 @@
+
+# Synopse mORMot Packages
+
+We are providing two packages for FPC/Lazarus:
+
+- `mormot_base`: Core units needed by *mORMot*
+  - Implements ORM, SOA and MVC features
+  - ORM via static-linked *SQLite3*
+  - ORM over external SQL and *MongoDB*
+  - High-level Domain-Driven-Design units  
+- `mormot_cross`: Stand-alone package, client-side only, but should be running on all FPC targets
+
+## Lazarus
+
+Initially these Packages were designed to compile into Lazarus.
+
+The `mormot_base` package has just one dependency, disabled by default, which is [ZeosLib](https://sourceforge.net/projects/zeoslib/).
+
+If you want to use *ZeosLib*, you must setup the package before compile it, follwoing instructions below:
+
+1. Open the Package
+2. Click on Options
+3. In "Compile Options", click on "Custom Options"
+4. Click on "Defines" and uncheck `NOSYNDBZEOS` conditional
+5. Add `zcomponent` package from *ZeosLib* into it.
+6. Save and return to Package
+7. Compile
+
+If you have compiled without using this option before, follow the steps above, but using "More > Recompile Clean" option to recompile the package.
+
+If `NOSYNDBZEOS` is defined, `SynDBZeos.pas` unit will be just an "empty unit".
+
+
+## Delphi
+
+Delphi Packages are not defined since they don't make sense for *mORMot* source code, which doesn't have any visual component.
+
+Just get the *mORMot* sources, then add the corresponding search path to your IDE. See [the corresponding documentation](https://synopse.info/files/html/Synopse%20mORMot%20Framework%20SAD%201.18.html#TITL_113).

contrib/mORMot/Packages/mormot_base.lpk

@@ -0,0 +1,215 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <Package Version="4">
+    <PathDelim Value="\"/>
+    <Name Value="mormot_base"/>
+    <Type Value="RunTimeOnly"/>
+    <Author Value="Arnaud Bouchez"/>
+    <CompilerOptions>
+      <Version Value="11"/>
+      <PathDelim Value="\"/>
+      <SearchPaths>
+        <IncludeFiles Value="$PkgDir(zcore)\..\..\src;..;..\SQLite3"/>
+        <Libraries Value="..\static\$(TargetCPU)-$(TargetOS)"/>
+        <OtherUnitFiles Value="..;..\SQLite3;..\SQLite3\DDD\infra"/>
+        <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+      </SearchPaths>
+      <Other>
+        <CustomOptions Value="-dNOSYNDBZEOS"/>
+        <OtherDefines Count="1">
+          <Define0 Value="NOSYNDBZEOS"/>
+        </OtherDefines>
+      </Other>
+    </CompilerOptions>
+    <Description Value="Core units needed by mORMot
+- Implement ORM, SOA and MVC features
+- ORM via static-linked SQLite3
+- ORM over external SQL and MongoDB
+- High-level Domain-Driven-Design units"/>
+    <License Value="Licensed under a disjunctive tri-license giving you the choice of one of
+the three following sets of free software/open source licensing terms:
+ - Mozilla Public License, version 1.1 or later;
+ - GNU General Public License, version 2.0 or later;
+ - GNU Lesser General Public License, version 2.1 or later.
+This allows the use of our code in as wide a variety of software projects
+as possible, while still maintaining copy-left on code we wrote."/>
+    <Version Major="1" Minor="18"/>
+    <Files Count="40">
+      <Item1>
+        <Filename Value="..\SynCommons.pas"/>
+        <UnitName Value="SynCommons"/>
+      </Item1>
+      <Item2>
+        <Filename Value="..\SynBidirSock.pas"/>
+        <UnitName Value="SynBidirSock"/>
+      </Item2>
+      <Item3>
+        <Filename Value="..\SynTable.pas"/>
+        <UnitName Value="SynTable"/>
+      </Item3>
+      <Item4>
+        <Filename Value="..\SynCrtSock.pas"/>
+        <UnitName Value="SynCrtSock"/>
+      </Item4>
+      <Item5>
+        <Filename Value="..\SynCrypto.pas"/>
+        <UnitName Value="SynCrypto"/>
+      </Item5>
+      <Item6>
+        <Filename Value="..\SynEcc.pas"/>
+        <UnitName Value="SynEcc"/>
+      </Item6>
+      <Item7>
+        <Filename Value="..\SynFPCTypInfo.pas"/>
+        <UnitName Value="SynFPCTypInfo"/>
+      </Item7>
+      <Item8>
+        <Filename Value="..\SynLog.pas"/>
+        <UnitName Value="SynLog"/>
+      </Item8>
+      <Item9>
+        <Filename Value="..\SynLZ.pas"/>
+        <UnitName Value="SynLZ"/>
+      </Item9>
+      <Item10>
+        <Filename Value="..\SynLZO.pas"/>
+        <UnitName Value="SynLZO"/>
+      </Item10>
+      <Item11>
+        <Filename Value="..\SynLizard.pas"/>
+        <UnitName Value="SynLizard"/>
+      </Item11>
+      <Item12>
+        <Filename Value="..\SynZip.pas"/>
+        <UnitName Value="SynZip"/>
+      </Item12>
+      <Item13>
+        <Filename Value="..\SynZipFiles.pas"/>
+        <UnitName Value="SynZipFiles"/>
+      </Item13>
+      <Item14>
+        <Filename Value="..\SynMustache.pas"/>
+        <UnitName Value="SynMustache"/>
+      </Item14>
+      <Item15>
+        <Filename Value="..\SynSSPI.pas"/>
+        <UnitName Value="SynSSPI"/>
+      </Item15>
+      <Item16>
+        <Filename Value="..\SynSSPIAuth.pas"/>
+        <UnitName Value="SynSSPIAuth"/>
+      </Item16>
+      <Item17>
+        <Filename Value="..\SynGSSAPI.pas"/>
+        <UnitName Value="SynGSSAPI"/>
+      </Item17>
+      <Item18>
+        <Filename Value="..\SynGSSAPIAuth.pas"/>
+        <UnitName Value="SynGSSAPIAuth"/>
+      </Item18>
+      <Item19>
+        <Filename Value="..\SynOpenSSL.pas"/>
+        <UnitName Value="SynOpenSSL"/>
+      </Item19>
+      <Item20>
+        <Filename Value="..\SynTests.pas"/>
+        <UnitName Value="SynTests"/>
+      </Item20>
+      <Item21>
+        <Filename Value="..\SynWinSock.pas"/>
+        <UnitName Value="SynWinSock"/>
+      </Item21>
+      <Item22>
+        <Filename Value="..\SynDB.pas"/>
+        <UnitName Value="SynDB"/>
+      </Item22>
+      <Item23>
+        <Filename Value="..\SynDBDataset.pas"/>
+        <UnitName Value="SynDBDataset"/>
+      </Item23>
+      <Item24>
+        <Filename Value="..\SynDBODBC.pas"/>
+        <UnitName Value="SynDBODBC"/>
+      </Item24>
+      <Item25>
+        <Filename Value="..\SynDBOracle.pas"/>
+        <UnitName Value="SynDBOracle"/>
+      </Item25>
+      <Item26>
+        <Filename Value="..\SynDBRemote.pas"/>
+        <UnitName Value="SynDBRemote"/>
+      </Item26>
+      <Item27>
+        <Filename Value="..\SynDBSQLite3.pas"/>
+        <UnitName Value="SynDBSQLite3"/>
+      </Item27>
+      <Item28>
+        <Filename Value="..\SQLite3\mORMot.pas"/>
+        <UnitName Value="mORMot"/>
+      </Item28>
+      <Item29>
+        <Filename Value="..\SQLite3\mORMotHttpClient.pas"/>
+        <UnitName Value="mORMotHttpClient"/>
+      </Item29>
+      <Item30>
+        <Filename Value="..\SQLite3\mORMotHttpServer.pas"/>
+        <UnitName Value="mORMotHttpServer"/>
+      </Item30>
+      <Item31>
+        <Filename Value="..\SQLite3\mORMotMVC.pas"/>
+        <UnitName Value="mORMotMVC"/>
+      </Item31>
+      <Item32>
+        <Filename Value="..\SQLite3\mORMotService.pas"/>
+        <UnitName Value="mORMotService"/>
+      </Item32>
+      <Item33>
+        <Filename Value="..\SQLite3\mORMotWrappers.pas"/>
+        <UnitName Value="mORMotWrappers"/>
+      </Item33>
+      <Item34>
+        <Filename Value="..\SQLite3\mORMotDDD.pas"/>
+        <UnitName Value="mORMotDDD"/>
+      </Item34>
+      <Item35>
+        <Filename Value="..\SQLite3\DDD\infra\dddInfraApps.pas"/>
+        <UnitName Value="dddInfraApps"/>
+      </Item35>
+      <Item36>
+        <Filename Value="..\SQLite3\DDD\infra\dddInfraSettings.pas"/>
+        <UnitName Value="dddInfraSettings"/>
+      </Item36>
+      <Item37>
+        <Filename Value="..\SynSQLite3.pas"/>
+        <UnitName Value="SynSQLite3"/>
+      </Item37>
+      <Item38>
+        <Filename Value="..\SQLite3\mORMotSQLite3.pas"/>
+        <UnitName Value="mORMotSQLite3"/>
+      </Item38>
+      <Item39>
+        <Filename Value="..\SynSQLite3Static.pas"/>
+        <UnitName Value="SynSQLite3Static"/>
+      </Item39>
+      <Item40>
+        <Filename Value="..\SynDBZeos.pas"/>
+        <UnitName Value="SynDBZeos"/>
+      </Item40>
+    </Files>
+    <RequiredPkgs Count="1">
+      <Item1>
+        <PackageName Value="FCL"/>
+      </Item1>
+    </RequiredPkgs>
+    <UsageOptions>
+      <IncludePath Value="$(PkgIncPath)"/>
+      <LibraryPath Value="$(PkgDir)\..\static\$(TargetCPU)-$(TargetOS)"/>
+      <ObjectPath Value="$(PkgDir)\.."/>
+      <UnitPath Value="$(PkgOutDir)"/>
+    </UsageOptions>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+  </Package>
+</CONFIG>

contrib/mORMot/Packages/mormot_cross.lpk

@@ -0,0 +1,62 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <Package Version="4">
+    <PathDelim Value="\"/>
+    <Name Value="mormot_cross"/>
+    <Type Value="RunTimeOnly"/>
+    <Author Value="Arnaud Bouchez"/>
+    <CompilerOptions>
+      <Version Value="11"/>
+      <PathDelim Value="\"/>
+      <SearchPaths>
+        <IncludeFiles Value="..;..\CrossPlatform"/>
+        <Libraries Value="..\static\$(TargetCPU)-$(TargetOS)"/>
+        <OtherUnitFiles Value="..\CrossPlatform"/>
+        <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+      </SearchPaths>
+    </CompilerOptions>
+    <Description Value="Stand-alone package, client-side only, but should be running on all FPC targets"/>
+    <License Value="Licensed under a disjunctive tri-license giving you the choice of one of
+the three following sets of free software/open source licensing terms:
+ - Mozilla Public License, version 1.1 or later;
+ - GNU General Public License, version 2.0 or later;
+ - GNU Lesser General Public License, version 2.1 or later.
+This allows the use of our code in as wide a variety of software projects
+as possible, while still maintaining copy-left on code we wrote."/>
+    <Version Major="1" Minor="18"/>
+    <Files Count="5">
+      <Item1>
+        <Filename Value="..\CrossPlatform\SynCrossPlatformCrypto.pas"/>
+        <UnitName Value="SynCrossPlatformCrypto"/>
+      </Item1>
+      <Item2>
+        <Filename Value="..\CrossPlatform\SynCrossPlatformJSON.pas"/>
+        <UnitName Value="SynCrossPlatformJSON"/>
+      </Item2>
+      <Item3>
+        <Filename Value="..\CrossPlatform\SynCrossPlatformREST.pas"/>
+        <UnitName Value="SynCrossPlatformREST"/>
+      </Item3>
+      <Item4>
+        <Filename Value="..\CrossPlatform\SynCrossPlatformSpecific.pas"/>
+        <UnitName Value="SynCrossPlatformSpecific"/>
+      </Item4>
+      <Item5>
+        <Filename Value="..\CrossPlatform\SynCrossPlatformSynLZ.pas"/>
+        <UnitName Value="SynCrossPlatformSynLZ"/>
+      </Item5>
+    </Files>
+    <RequiredPkgs Count="1">
+      <Item1>
+        <PackageName Value="FCL"/>
+      </Item1>
+    </RequiredPkgs>
+    <UsageOptions>
+      <UnitPath Value="$(PkgOutDir)"/>
+    </UsageOptions>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+  </Package>
+</CONFIG>

contrib/mORMot/RTL7/FastMM4Messages.pas

@@ -0,0 +1,158 @@
+{
+
+Fast Memory Manager: Messages
+
+English translation by Pierre le Riche.
+
+}
+
+unit FastMM4Messages;
+
+interface
+
+{$Include FastMM4Options.inc}
+
+const
+  {The name of the debug info support DLL}
+  {$IFDEF MACOS}
+  FullDebugModeLibraryName32Bit = 'libFastMM_FullDebugMode.dylib';
+  {$ELSE}
+  FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll';
+  {$ENDIF}
+  FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll';
+  {Event log strings}
+  LogFileExtension = '_MemoryManager_EventLog.txt'#0;
+  CRLF = #13#10;
+  EventSeparator = '--------------------------------';
+  {Class name messages}
+  UnknownClassNameMsg = 'Unknown';
+  {Memory dump message}
+  MemoryDumpMsg = #13#10#13#10'Current memory dump of 256 bytes starting at pointer address ';
+  {Block Error Messages}
+  BlockScanLogHeader = 'Allocated block logged by LogAllocatedBlocksToFile. The size is: ';
+  ErrorMsgHeader = 'FastMM has detected an error during a ';
+  GetMemMsg = 'GetMem';
+  FreeMemMsg = 'FreeMem';
+  ReallocMemMsg = 'ReallocMem';
+  BlockCheckMsg = 'free block scan';
+  OperationMsg = ' operation. ';
+  BlockHeaderCorruptedMsg = 'The block header has been corrupted. ';
+  BlockFooterCorruptedMsg = 'The block footer has been corrupted. ';
+  FreeModifiedErrorMsg = 'FastMM detected that a block has been modified after being freed. ';
+  FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): ';
+  DoubleFreeErrorMsg = 'An attempt has been made to free/reallocate an unallocated block.';
+  WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.';
+  PreviousBlockSizeMsg = #13#10#13#10'The previous block size was: ';
+  CurrentBlockSizeMsg = #13#10#13#10'The block size is: ';
+  PreviousObjectClassMsg = #13#10#13#10'The block was previously used for an object of class: ';
+  CurrentObjectClassMsg = #13#10#13#10'The block is currently used for an object of class: ';
+  PreviousAllocationGroupMsg = #13#10#13#10'The allocation group was: ';
+  PreviousAllocationNumberMsg = #13#10#13#10'The allocation number was: ';
+  CurrentAllocationGroupMsg = #13#10#13#10'The allocation group is: ';
+  CurrentAllocationNumberMsg = #13#10#13#10'The allocation number is: ';
+  BlockErrorMsgTitle = 'Memory Error Detected';
+  VirtualMethodErrorHeader = 'FastMM has detected an attempt to call a virtual method on a freed object. An access violation will now be raised in order to abort the current operation.';
+  InterfaceErrorHeader = 'FastMM has detected an attempt to use an interface of a freed object. An access violation will now be raised in order to abort the current operation.';
+  BlockHeaderCorruptedNoHistoryMsg = ' Unfortunately the block header has been corrupted so no history is available.';
+  FreedObjectClassMsg = #13#10#13#10'Freed object class: ';
+  VirtualMethodName = #13#10#13#10'Virtual method: ';
+  VirtualMethodOffset = 'Offset +';
+  VirtualMethodAddress = #13#10#13#10'Virtual method address: ';
+  {Stack trace messages}
+  CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x';
+  CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:';
+  ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x';
+  ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x';
+  ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x';
+  ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x';
+  ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x';
+  StackTraceMsg = ', and the stack trace (return addresses) at the time was:';
+  {Installation Messages}
+  AlreadyInstalledMsg = 'FastMM4 is already installed.';
+  AlreadyInstalledTitle = 'Already installed.';
+  OtherMMInstalledMsg = 'FastMM4 cannot be installed since another third party memory '
+    + 'manager has already installed itself.'#13#10'If you want to use FastMM4, '
+    + 'please make sure that FastMM4.pas is the very first unit in the "uses"'
+    + #13#10'section of your project''s .dpr file.';
+  OtherMMInstalledTitle = 'Cannot install FastMM4 - Another memory manager is already installed';
+  MemoryAllocatedMsg = 'FastMM4 cannot install since memory has already been '
+    + 'allocated through the default memory manager.'#13#10'FastMM4.pas MUST '
+    + 'be the first unit in your project''s .dpr file, otherwise memory may '
+    + 'be allocated'#13#10'through the default memory manager before FastMM4 '
+    + 'gains control. '#13#10#13#10'If you are using an exception trapper '
+    + 'like MadExcept (or any tool that modifies the unit initialization '
+    + 'order),'#13#10'go into its configuration page and ensure that the '
+    + 'FastMM4.pas unit is initialized before any other unit.';
+  MemoryAllocatedTitle = 'Cannot install FastMM4 - Memory has already been allocated';
+  {Leak checking messages}
+  LeakLogHeader = 'A memory block has been leaked. The size is: ';
+  LeakMessageHeader = 'This application has leaked memory. ';
+  SmallLeakDetail = 'The small block leaks are'
+{$ifdef HideExpectedLeaksRegisteredByPointer}
+    + ' (excluding expected leaks registered by pointer)'
+{$endif}
+    + ':'#13#10;
+  LargeLeakDetail = 'The sizes of leaked medium and large blocks are'
+{$ifdef HideExpectedLeaksRegisteredByPointer}
+    + ' (excluding expected leaks registered by pointer)'
+{$endif}
+    + ': ';
+  BytesMessage = ' bytes: ';
+  AnsiStringBlockMessage = 'AnsiString';
+  UnicodeStringBlockMessage = 'UnicodeString';
+  LeakMessageFooter = #13#10
+{$ifndef HideMemoryLeakHintMessage}
+    + #13#10'Note: '
+  {$ifdef RequireIDEPresenceForLeakReporting}
+    + 'This memory leak check is only performed if Delphi is currently running on the same computer. '
+  {$endif}
+  {$ifdef FullDebugMode}
+    {$ifdef LogMemoryLeakDetailToFile}
+    + 'Memory leak detail is logged to a text file in the same folder as this application. '
+    {$else}
+    + 'Enable the "LogMemoryLeakDetailToFile" to obtain a log file containing detail on memory leaks. '
+    {$endif}
+  {$else}
+    + 'To obtain a log file containing detail on memory leaks, enable the "FullDebugMode" and "LogMemoryLeakDetailToFile" conditional defines. '
+  {$endif}
+    + 'To disable this memory leak check, undefine "EnableMemoryLeakReporting".'#13#10
+{$endif}
+    + #0;
+  LeakMessageTitle = 'Memory Leak Detected';
+{$ifdef UseOutputDebugString}
+  FastMMInstallMsg = 'FastMM has been installed.';
+  FastMMInstallSharedMsg = 'Sharing an existing instance of FastMM.';
+  FastMMUninstallMsg = 'FastMM has been uninstalled.';
+  FastMMUninstallSharedMsg = 'Stopped sharing an existing instance of FastMM.';
+{$endif}
+{$ifdef DetectMMOperationsAfterUninstall}
+  InvalidOperationTitle = 'MM Operation after uninstall.';
+  InvalidGetMemMsg = 'FastMM has detected a GetMem call after FastMM was uninstalled.';
+  InvalidFreeMemMsg = 'FastMM has detected a FreeMem call after FastMM was uninstalled.';
+  InvalidReallocMemMsg = 'FastMM has detected a ReallocMem call after FastMM was uninstalled.';
+  InvalidAllocMemMsg = 'FastMM has detected an AllocMem call after FastMM was uninstalled.';
+{$endif}
+
+{$ifdef LogLockContention}
+  LockingReportTitle = 'Locking Report';
+  LockingReportHeader = 'Top locking contention sites';
+{$endif}
+
+{$ifdef UseReleaseStack}
+{$ifdef DebugReleaseStack}
+  ReleaseStackUsageHeader = 'Release stack usage statistics';
+  ReleaseStackUsageSmallBlocksMsg1 = 'Small blocks [';
+  ReleaseStackUsageSmallBlocksMsg2 = ']: ';
+  ReleaseStackUsageTotalSmallBlocksMsg = 'Total small blocks: ';
+  ReleaseStackUsageMediumBlocksMsg = 'Medium blocks: ';
+  ReleaseStackUsageLargeBlocksMsg = 'Large blocks: ';
+  ReleaseStackUsageTotalMemoryMsg = 'Total memory: ';
+  ReleaseStackUsageBuffers1Msg = ' in ';
+  ReleaseStackUsageBuffers2Msg = ' buffers [';
+{$endif}
+{$endif}
+
+implementation
+
+end.
+

contrib/mORMot/RTL7/FastMM4Options.inc

@@ -0,0 +1,606 @@
+{
+
+Fast Memory Manager: Options Include File
+
+Set the default options for FastMM here.
+
+}
+
+{---------------------------Miscellaneous Options-----------------------------}
+
+{Enable Align16Bytes define to align all blocks on 16 byte boundaries,
+ or enable Align32Bytes define to align all blocks on 32 byte boundaries,
+ so aligned SSE instructions can be used safely.
+
+ If neither of these options are enabled, then some of the
+ smallest block sizes will be 8-byte aligned instead which may result in a
+ reduction in memory usage.
+
+ Even when small blocks are aligned by 8 bytes
+ (no Align16Bytes or Align32Bytes are defined),
+ Medium and large blocks are always 16-byte aligned.
+
+ If you enable AVX, then the alignment will always be 32 bytes.}
+
+
+{.$define Align16Bytes}
+{.$define Align32Bytes}
+
+
+{Enable to use faster fixed-size move routines when upsizing small blocks.
+ These routines are much faster than the Borland RTL move procedure since they
+ are optimized to move a fixed number of bytes. This option may be used
+ together with the FastMove library for even better performance.}
+{$define UseCustomFixedSizeMoveRoutines}
+
+{Enable this option to use an optimized procedure for moving a memory block of
+ an arbitrary size. Disable this option when using the Fastcode move
+ ("FastMove") library. Using the Fastcode move library allows your whole
+ application to gain from faster move routines, not just the memory manager. It
+ is thus recommended that you use the Fastcode move library in conjunction with
+ this memory manager and disable this option.}
+{$define UseCustomVariableSizeMoveRoutines}
+
+{Enable this option to only install FastMM as the memory manager when the
+ application is running inside the Delphi IDE. This is useful when you want
+ to deploy the same EXE that you use for testing, but only want the debugging
+ features active on development machines. When this option is enabled and
+ the application is not being run inside the IDE debugger, then the default
+ Delphi memory manager will be used (which, since Delphi 2006, is FastMM
+ without FullDebugMode.}
+{.$define InstallOnlyIfRunningInIDE}
+
+{Due to QC#14070 ("Delphi IDE attempts to free memory after the shutdown code
+ of borlndmm.dll has been called"), FastMM cannot be uninstalled safely when
+ used inside a replacement borlndmm.dll for the IDE. Setting this option will
+ circumvent this problem by never uninstalling the memory manager.}
+{.$define NeverUninstall}
+
+{Set this option when you use runtime packages in this application or library.
+ This will automatically set the "AssumeMultiThreaded" option. Note that you
+ have to ensure that FastMM is finalized after all live pointers have been
+ freed - failure to do so will result in a large leak report followed by a lot
+ of A/Vs. (See the FAQ for more detail.) You may have to combine this option
+ with the NeverUninstall option.}
+{.$define UseRuntimePackages}
+
+{-----------------------Concurrency Management Options------------------------}
+
+{Enable to always assume that the application is multithreaded. Enabling this
+ option will cause a significant performance hit with single threaded
+ applications. Enable if you are using multi-threaded third-party tools that do
+ not properly set the IsMultiThread variable. Also set this option if you are
+ going to share this memory manager between a single threaded application and a
+ multi-threaded DLL.}
+{.$define AssumeMultiThreaded}
+
+{Enable this option to not call Sleep when a thread contention occurs. This
+ option will improve performance if the ratio of the number of active threads
+ to the number of CPU cores is low (typically < 2). With this option set a
+ thread will usually enter a "busy waiting" loop instead of relinquishing its
+ timeslice when a thread contention occurs, unless UseSwitchToThread is
+ also defined (see below) in which case it will call SwitchToThread instead of
+ Sleep.
+
+*** Note: This option was added in FastMM 4 version Version 4.68
+    on 3 July 2006, is provided only if you wish to restore old
+    functionality (e.g. for testing, etc.), and is not recommended
+    for FastMM4-AVX, since this it provides suboptimal performance compare
+    to the new locking mechanism implemented in the FastMM4-AVX.
+This option has no effect when SmallBlocksLockedCriticalSection/
+MediumBlocksLockedCriticalSection/LargeBlocksLockedCriticalSection is enabled}
+
+{.$define NeverSleepOnThreadContention}
+
+{Set this option to call SwitchToThread instead of sitting in a "busy waiting"
+ loop when a thread contention occurs. This is used in conjunction with the
+ NeverSleepOnThreadContention option, and has no effect unless
+ NeverSleepOnThreadContention is also defined. This option may improve
+ performance with many CPU cores and/or threads of different priorities. Note
+ that the SwitchToThread API call is only available on Windows 2000 and later,
+ but FastMM4 loads it dynamically, so it would not fail even under very old
+ versions of Windows.
+
+*** Note: This option was added in FastMM 4 version Version 4.97
+    on 30 September 2010, is provided only if you wish to restore old
+    functionality (e.g. for testing, etc.), and is not recommended
+    for FastMM4-AVX, since this it provides suboptimal performance compare
+    to the new locking mechanism implemented in the FastMM4-AVX.
+This option has no effect when SmallBlocksLockedCriticalSection/
+MediumBlocksLockedCriticalSection/LargeBlocksLockedCriticalSection is enabled}
+
+{.$define UseSwitchToThread}
+
+{This option uses a simpler instruction to acquire a lock: "lock xchg",
+instead of "lock cmpxchg" used in earlier versions of FastMM4: there is
+actually no reason to use "cmpxchg", because  the simple instruction - "xchg" -
+perfectly suits our need. Although "xchg" has exactly the same latency and
+costs in terms of CPU cycles as "cmpxghg", it is just simper way to do the
+lock that we need, and, according to the Occam's razor principle, simple things
+are better. If you wish to restore old functionality of FastMM4 version 4.992,
+disable this option }
+{$define SimplifiedInterlockedExchangeByte}
+
+{These 3 options make FastMM4-AVX to use a new approach to waiting for a lock:
+CriticalSections instead of Sleep(). With these options, the Sleep() will
+never be used but EnterCriticalSection/LeaveCriticalSection will be
+used instead. Testing has shown that the approach of using CriticalSections
+instead of Sleep (which was used by default before in FastMM4) provides
+significant gain in situations when the number of threads working with the
+memory manager is the same or higher than the number of physical cores.
+This options take away the original FastMM4 approach of using
+Sleep(InitialSleepTime) and then Sleep(AdditionalSleepTime)
+(or Sleep(0) and Sleep(1)) and replace them with
+EnterCriticalSection/LeaveCriticalSection to save valuable CPU cycles wasted by
+Sleep(0) and to improve speed (reduce latency) that was affected each time by
+at least 1 millisecond by Sleep(1), because the Critical Sections are much more
+CPU-friendly and have definitely lower latency than Sleep(1).
+
+When these options are enabled, FastMM4-AVX it checks:
+ - whether the CPU supports SSE2 and thus the "pause" instruction, and
+ - whether the operating system has the SwitchToThread() API call, and,
+ and in this case uses "pause" spin-loop for 5000 iterations and then
+SwitchToThread() instead of critical sections; If a CPU doesn't have the
+"pause" instrcution or Windows doesn't have the SwitchToThread() API
+function, it will use EnterCriticalSection/LeaveCriticalSection.
+When FastMM4-AVX uses "pause" and SwitchToThread(), tests that allocate,
+reallocate and release memory finish up to two times faster when the
+number of threads is the same or greater than the number of physical cores}
+
+{$define SmallBlocksLockedCriticalSection}
+{$define MediumBlocksLockedCriticalSection}
+{$define LargeBlocksLockedCriticalSection}
+
+{$define CheckPauseAndSwitchToThreadForAsmVersion}
+
+
+{-----------------------------Debugging Options-------------------------------}
+
+{Enable this option to suppress the generation of debug info for the
+ FastMM4.pas unit. This will prevent the integrated debugger from stepping into
+ the memory manager code.}
+{$define NoDebugInfo}
+
+{Enable this option to suppress the display of all message dialogs. This is
+ useful in service applications that should not be interrupted.}
+{.$define NoMessageBoxes}
+
+{Set this option to use the Windows API OutputDebugString procedure to output
+ debug strings on startup/shutdown and when errors occur.}
+{.$define UseOutputDebugString}
+
+{Set this option to use the assembly language version which is faster than the
+ pascal version. Disable only for debugging purposes. Setting the
+ CheckHeapForCorruption option automatically disables this option.}
+{$define ASMVersion}
+
+{Allow using ".align" assembler directive. FreePascal doesn't support ".align"
+ Delphi incorrectly encodes conditional jumps (used 6-byte instructions instead
+ of just 2 bytes. So don't use it for Borland (Embarcadero) Delphi neither
+ for FreePascal}
+{.$define EnableAsmCodeAlign}
+
+{FastMM always catches attempts to free the same memory block twice, however it
+ can also check for corruption of the memory heap (typically due to the user
+ program overwriting the bounds of allocated memory). These checks are
+ expensive, and this option should thus only be used for debugging purposes.
+ If this option is set then the ASMVersion option is automatically disabled.}
+{.$define CheckHeapForCorruption}
+
+{Enable this option to catch attempts to perform MM operations after FastMM has
+ been uninstalled. With this option set when FastMM is uninstalled it will not
+ install the previous MM, but instead a dummy MM handler that throws an error
+ if any MM operation is attempted. This will catch attempts to use the MM
+ after FastMM has been uninstalled.}
+{$define DetectMMOperationsAfterUninstall}
+
+{Set the following option to do extensive checking of all memory blocks. All
+ blocks are padded with both a header and trailer that are used to verify the
+ integrity of the heap. Freed blocks are also cleared to ensure that they
+ cannot be reused after being freed. This option slows down memory operations
+ dramatically and should only be used to debug an application that is
+ overwriting memory or reusing freed pointers. Setting this option
+ automatically enables CheckHeapForCorruption and disables ASMVersion.
+ Very important: If you enable this option your application will require the
+ FastMM_FullDebugMode.dll library. If this library is not available you will
+ get an error on startup.}
+{.$define FullDebugMode}
+
+  {Set this option to perform "raw" stack traces, i.e. check all entries on the
+   stack for valid return addresses. Note that this is significantly slower
+   than using the stack frame tracing method, but is usually more complete. Has
+   no effect unless FullDebugMode is enabled}
+  {$define RawStackTraces}
+
+  {Set this option to check for user code that uses an interface of a freed
+   object. Note that this will disable the checking of blocks modified after
+   being freed (the two are not compatible). This option has no effect if
+   FullDebugMode is not also enabled.}
+  {.$define CatchUseOfFreedInterfaces}
+
+  {Set this option to log all errors to a text file in the same folder as the
+   application. Memory errors (with the FullDebugMode option set) will be
+   appended to the log file. Has no effect if "FullDebugMode" is not set.}
+  {$define LogErrorsToFile}
+
+  {Set this option to log all memory leaks to a text file in the same folder as
+   the application. Memory leak reports (with the FullDebugMode option set)
+   will be appended to the log file. Has no effect if "LogErrorsToFile" and
+   "FullDebugMode" are not also set. Note that usually all leaks are always
+   logged, even if they are "expected" leaks registered through
+   AddExpectedMemoryLeaks. Expected leaks registered by pointer may be excluded
+   through the HideExpectedLeaksRegisteredByPointer option.}
+  {$define LogMemoryLeakDetailToFile}
+
+  {Deletes the error log file on startup. No effect if LogErrorsToFile is not
+   also set.}
+  {.$define ClearLogFileOnStartup}
+
+  {Loads the FASTMM_FullDebugMode.dll dynamically. If the DLL cannot be found
+   then stack traces will not be available. Note that this may cause problems
+   due to a changed DLL unload order when sharing the memory manager. Use with
+   care.}
+  {.$define LoadDebugDLLDynamically}
+
+    {.$define DoNotInstallIfDLLMissing}
+    {If the FastMM_FullDebugMode.dll file is not available then FastMM will not
+     install itself. No effect unless FullDebugMode and LoadDebugDLLDynamically
+     are also defined.}
+
+    {.$define RestrictDebugDLLLoadPath}
+    {Allow to load debug dll only from host module directory.}
+
+  {FastMM usually allocates large blocks from the topmost available address and
+   medium and small blocks from the lowest available address (This reduces
+   fragmentation somewhat). With this option set all blocks are always
+   allocated from the highest available address. If the process has a >2GB
+   address space and contains bad pointer arithmetic code, this option should
+   help to catch those errors sooner.}
+  {$define AlwaysAllocateTopDown}
+
+  {Disables the logging of memory dumps together with the other detail for
+   memory errors.}
+  {.$define DisableLoggingOfMemoryDumps}
+
+  {If FastMM encounters a problem with a memory block inside the FullDebugMode
+   FreeMem handler then an "invalid pointer operation" exception will usually
+   be raised. If the FreeMem occurs while another exception is being handled
+   (perhaps in the try.. finally code) then the original exception will be
+   lost. With this option set FastMM will ignore errors inside FreeMem when an
+   exception is being handled, thus allowing the original exception to
+   propagate.}
+  {$define SuppressFreeMemErrorsInsideException}
+
+  {Adds support for notification of memory manager events in FullDebugMode.
+   With this define set, the application may assign the OnDebugGetMemFinish,
+   OnDebugFreeMemStart, etc. callbacks in order to be notified when the
+   particular memory manager event occurs.}
+  {.$define FullDebugModeCallBacks}
+
+{---------------------------Memory Leak Reporting-----------------------------}
+
+{Set the option EnableMemoryLeakReporting to enable reporting of memory leaks.
+Combine it with the two options below for further fine-tuning.}
+
+{$ifndef DisableMemoryLeakReporting}
+{.$define EnableMemoryLeakReporting}
+{$endif}
+
+  {Set this option to suppress the display and logging of expected memory leaks
+   that were registered by pointer. Leaks registered by size or class are often
+   ambiguous, so these expected leaks are always logged to file (in
+   FullDebugMode with the LogMemoryLeakDetailToFile option set) and are never
+   hidden from the leak display if there are more leaks than are expected.}
+  {$define HideExpectedLeaksRegisteredByPointer}
+
+  {Set this option to require the presence of the Delphi IDE to report memory
+   leaks. This option has no effect if the option "EnableMemoryLeakReporting"
+   is not also set.}
+  {.$define RequireIDEPresenceForLeakReporting}
+
+  {Set this option to require the program to be run inside the IDE debugger to
+   report memory leaks. This option has no effect if the option
+   "EnableMemoryLeakReporting" is not also set. Note that this option does not
+   work with libraries, only EXE projects.}
+  {$define RequireDebuggerPresenceForLeakReporting}
+
+  {Set this option to require the presence of debug info ($D+ option) in the
+   compiled unit to perform memory leak checking. This option has no effect if
+   the option "EnableMemoryLeakReporting" is not also set.}
+  {.$define RequireDebugInfoForLeakReporting}
+
+  {Set this option to enable manual control of the memory leak report. When
+   this option is set the ReportMemoryLeaksOnShutdown variable (default = false)
+   may be changed to select whether leak reporting should be done or not. When
+   this option is selected then both the variable must be set to true and the
+   other leak checking options must be applicable for the leak checking to be
+   done.}
+  {.$define ManualLeakReportingControl}
+
+  {Set this option to disable the display of the hint below the memory leak
+   message.}
+  {.$define HideMemoryLeakHintMessage}
+
+  {Set this option to use QualifiedClassName equivalent instead of ClassName
+   equivalent during memory leak reporting.
+   This is useful for duplicate class names (like EConversionError, which is in
+   units Data.DBXJSONReflect, REST.JsonReflect and System.ConvUtils,
+   or TClipboard being in Vcl.Clibprd and WinAPI.ApplicationModel.DataTransfer }
+  {$define EnableMemoryLeakReportingUsesQualifiedClassName}
+
+{--------------------------Instruction Set Options----------------------------}
+
+{Set this option to enable the use of MMX instructions. Disabling this option
+ will result in a slight performance hit, but will enable compatibility with
+ AMD K5, Pentium I and earlier CPUs. MMX is currently only used in the variable
+ size move routines, so if UseCustomVariableSizeMoveRoutines is not set then
+ this option has no effect.}
+{.$define EnableMMX}
+
+{$ifndef DontForceMMX}
+
+  {Set this option (ForceMMX) to force the use of MMX instructions without checking
+   whether the CPU supports it. If this option is disabled then the CPU will be
+   checked for compatibility first, and if MMX is not supported it will fall
+   back to the FPU move code. Has no effect unless EnableMMX is also set.}
+  {$define ForceMMX}
+
+{$endif}
+
+
+{$ifndef DisableAVX}
+
+  {Set this option (EnableAVX) to enable use of AVX instructions under 64-bit mode.
+  This option has no effect under 32-bit mode. If enalbed, the code will check
+  whether the CPU supports AVX or AVX2, and, if yes, will use the 32-byte YMM
+  registers for faster memory copy. Besides that, if this option is enabled,
+  all allocated memory blocks will be aligned by 32 bytes, that will incur
+  addition memory consumption overhead. Besides that, with this option, memory
+  copy will be slightly more secure, because all XMM/YMM registers used to copy
+  memory will be cleared by vxorps/vpxor at the end of a copy routine, so the
+  leftovers of the copied memory data will not be kept in the XMM/YMM registers
+  and will not be exposed. This option properly handles AVX-SSE transitions to not
+  incur the transition penalties, only calls vzeroupper under AVX1, but not under
+  AVX2, since it slows down subsequent SSE code under Kaby Lake}
+  {$define EnableAVX}
+
+{$endif}
+
+{$ifdef EnableAVX}
+  {If AVX is enabled, you can optionally disable one or more
+  of the following AVX modes:
+  - the first version - initial AVX (DisableAVX1); or
+  - the second version AVX2 (DisableAVX2); or
+  - AVX-512 (DisableAVX512);
+  but you cannot disable all of the above modes at once.
+
+  If you define DisableAVX1, it will not add to FastMM4 the instructions from
+  the initial (first) version of the Advanced Vector Extensions instruction set,
+  officially called just "AVX", proposed by Intel in March 2008 and first
+  supported by Intel with the Sandy Bridge processor shipping in Q1 2011
+  and later, on by AMD with the Bulldozer processor shipping in Q3 2011.
+
+  If you define DisableAVX2, it will not add to FastMM4 the instructions from
+  the second version of the Advanced Vector Extensions - officially called
+  "AVX2", also known as Haswell New Instructions, which is an expansion of the
+  AVX instruction set introduced in Intel's Haswell microarchitecture.
+  Intel has shipped first processors with AVX2 on June 2, 2013: Core i7 4770,
+  Core i5 4670, etc., and AMD has shipped first processors with AVX in Q2 2015
+  (Carrizo processor). AMD Ryzen processor (Q1 2017) also supports AVX2.
+  We use separate code for AVX1 and AVX2 because AVX2 doesn't use "vzeroupper"
+  and uses the new, faster instruction "vpxor" which was not available in the
+  initial AVX, which, in its turn, uses "vxorps" and "vzeroupper" before and
+  after any AVX code to counteract the AVX-SSE transition penalties.
+  FastMM4 checks whether AVX2 is supported by the CPU, and, if supported, never
+  calls AVX1 functions, since calling "vzeroupper" even once in a thread
+  significantly slows down all subsequent SSE code, which is not documented:
+  neither in the Intel 64 and IA-32 Architectures Software Developer<65>s Manual
+  nor in the Intel 64 and IA-32 Architectures Optimization Reference Manual.
+
+  The code of AVX1 is grouped separately from the code of AVX2, to not scatter
+  the cache}
+
+
+  {.$define DisableAVX1}
+  {.$define DisableAVX2}
+  {.$define DisableAVX512}
+{$endif}
+
+
+{$ifndef DisableERMS}
+
+  {Set this option (EnableERMS) to enable Enhanced Rep Movsb/Stosb CPU feature,
+  which improves speed of medium and large block memory copy
+  under 32-bit or 64-bit modes}
+  {$define EnableERMS}
+
+{$endif}
+
+
+{-----------------------Memory Manager Sharing Options------------------------}
+
+{Allow sharing of the memory manager between a main application and DLLs that
+ were also compiled with FastMM. This allows you to pass dynamic arrays and
+ long strings to DLL functions provided both are compiled to use FastMM.
+ Sharing will only work if the library that is supposed to share the memory
+ manager was compiled with the "AttemptToUseSharedMM" option set. Note that if
+ the main application is single threaded and the DLL is multi-threaded that you
+ have to set the IsMultiThread variable in the main application to true or it
+ will crash when a thread contention occurs. Note that statically linked DLL
+ files are initialized before the main application, so the main application may
+ well end up sharing a statically loaded DLL's memory manager and not the other
+ way around. }
+{.$define ShareMM}
+
+  {Allow sharing of the memory manager by a DLL with other DLLs (or the main
+   application if this is a statically loaded DLL) that were also compiled with
+   FastMM. Set this option with care in dynamically loaded DLLs, because if the
+   DLL that is sharing its MM is unloaded and any other DLL is still sharing
+   the MM then the application will crash. This setting is only relevant for
+   DLL libraries and requires ShareMM to also be set to have any effect.
+   Sharing will only work if the library that is supposed to share the memory
+   manager was compiled with the "AttemptToUseSharedMM" option set. Note that
+   if DLLs are statically linked then they will be initialized before the main
+   application and then the DLL will in fact share its MM with the main
+   application. This option has no effect unless ShareMM is also set.}
+  {.$define ShareMMIfLibrary}
+
+{Define this to attempt to share the MM of the main application or other loaded
+ DLLs in the same process that were compiled with ShareMM set. When sharing a
+ memory manager, memory leaks caused by the sharer will not be freed
+ automatically. Take into account that statically linked DLLs are initialized
+ before the main application, so set the sharing options accordingly.}
+{.$define AttemptToUseSharedMM}
+
+{Define this to enable backward compatibility for the memory manager sharing
+ mechanism used by Delphi 2006 and 2007, as well as older FastMM versions.}
+{$define EnableBackwardCompatibleMMSharing}
+
+{-----------------------Security Options------------------------}
+
+{Windows clears physical memory before reusing it in another process. However,
+ it is not known how quickly this clearing is performed, so it is conceivable
+ that confidential data may linger in physical memory longer than absolutely
+ necessary. If you're paranoid about this kind of thing, enable this option to
+ clear all freed memory before returning it to the operating system. Note that
+ this incurs a noticeable performance hit.}
+{.$define ClearMemoryBeforeReturningToOS}
+
+{With this option enabled freed memory will immediately be cleared inside the
+ FreeMem routine. This incurs a big performance hit, but may be worthwhile for
+ additional peace of mind when working with highly sensitive data. This option
+ supersedes the ClearMemoryBeforeReturningToOS option.}
+{.$define AlwaysClearFreedMemory}
+
+{----------------------------Lock Contention Logging--------------------------}
+
+{Define this to lock stack traces for all occasions where GetMem/FreeMem
+ go to sleep because of lock contention (IOW, when memory manager is already
+ locked by another thread). At the end of the program execution top 10 sites
+ (locations with highest occurrence) will be logged to the _MemoryManager_EventLog.txt
+ file.
+ This options works with FullDebugMode or without it, but requires
+ FastMM_FullDebugMode.dll to be present in both cases.
+}
+{.$define LogLockContention}
+
+{--------------------------------Option Grouping------------------------------}
+
+{Enabling this option enables FullDebugMode, InstallOnlyIfRunningInIDE and
+ LoadDebugDLLDynamically. Consequently, FastMM will install itself in
+ FullDebugMode if the application is being debugged inside the Delphi IDE.
+ Otherwise the default Delphi memory manager will be used (which is equivalent
+ to the non-FullDebugMode FastMM since Delphi 2006.)}
+{.$define FullDebugModeInIDE}
+
+{Combines the FullDebugMode, LoadDebugDLLDynamically and
+ DoNotInstallIfDLLMissing options. Consequently FastMM will only be installed
+ (In FullDebugMode) when the FastMM_FullDebugMode.dll file is available. This
+ is useful when the same executable will be distributed for both debugging as
+ well as deployment.}
+{.$define FullDebugModeWhenDLLAvailable}
+
+{Group the options you use for release and debug versions below}
+{$ifdef Release}
+  {Specify the options you use for release versions below}
+  {.$undef FullDebugMode}
+  {.$undef CheckHeapForCorruption}
+  {.$define ASMVersion}
+  {.$undef EnableMemoryLeakReporting}
+  {.$undef UseOutputDebugString}
+{$else}
+  {Specify the options you use for debugging below}
+  {.$define FullDebugMode}
+  {.$define EnableMemoryLeakReporting}
+  {.$define UseOutputDebugString}
+{$endif}
+
+{--------------------Compilation Options For borlndmm.dll---------------------}
+{If you're compiling the replacement borlndmm.dll, set the defines below
+ for the kind of dll you require.}
+
+{Set this option when compiling the borlndmm.dll}
+{.$define borlndmmdll}
+
+{Set this option if the dll will be used by the Delphi IDE}
+{.$define dllforide}
+
+{Set this option if you're compiling a debug dll}
+{.$define debugdll}
+
+{Do not change anything below this line}
+{$ifdef borlndmmdll}
+  {$define AssumeMultiThreaded}
+  {$undef HideExpectedLeaksRegisteredByPointer}
+  {$undef RequireDebuggerPresenceForLeakReporting}
+  {$undef RequireDebugInfoForLeakReporting}
+  {$define DetectMMOperationsAfterUninstall}
+  {$undef ManualLeakReportingControl}
+  {$undef ShareMM}
+  {$undef AttemptToUseSharedMM}
+  {$ifdef dllforide}
+    {$define NeverUninstall}
+    {$define HideMemoryLeakHintMessage}
+    {$undef RequireIDEPresenceForLeakReporting}
+    {$ifndef debugdll}
+      {$undef EnableMemoryLeakReporting}
+    {$endif}
+  {$else}
+    {$define EnableMemoryLeakReporting}
+    {$undef NeverUninstall}
+    {$undef HideMemoryLeakHintMessage}
+    {$define RequireIDEPresenceForLeakReporting}
+  {$endif}
+  {$ifdef debugdll}
+    {$define FullDebugMode}
+    {$define RawStackTraces}
+    {$undef CatchUseOfFreedInterfaces}
+    {$define LogErrorsToFile}
+    {$define LogMemoryLeakDetailToFile}
+    {$undef ClearLogFileOnStartup}
+  {$else}
+    {$undef FullDebugMode}
+  {$endif}
+{$endif}
+
+{Move BCB related definitions here, because CB2006/CB2007 can build borlndmm.dll
+ for tracing memory leaks in BCB applications with "Build with Dynamic RTL"
+ switched on}
+{------------------------------Patch BCB Terminate----------------------------}
+{To enable the patching for BCB to make uninstallation and leak reporting
+ possible, you may need to add "BCB" definition
+ in "Project Options->Pascal/Delphi Compiler->Defines".
+ (Thanks to JiYuan Xie for implementing this.)}
+
+{$ifdef BCB}
+  {$ifdef CheckHeapForCorruption}
+    {$define PatchBCBTerminate}
+  {$else}
+    {$ifdef DetectMMOperationsAfterUninstall}
+      {$define PatchBCBTerminate}
+    {$else}
+       {$ifdef EnableMemoryLeakReporting}
+         {$define PatchBCBTerminate}
+       {$endif}
+    {$endif}
+  {$endif}
+
+  {$ifdef PatchBCBTerminate}
+    {$define CheckCppObjectType}
+    {$undef CheckCppObjectTypeEnabled}
+
+    {$ifdef CheckCppObjectType}
+      {$define CheckCppObjectTypeEnabled}
+    {$endif}
+
+    {Turn off "CheckCppObjectTypeEnabled" option if neither "CheckHeapForCorruption"
+     option or "EnableMemoryLeakReporting" option were defined.}
+    {$ifdef CheckHeapForCorruption}
+    {$else}
+      {$ifdef EnableMemoryLeakReporting}
+      {$else}
+        {$undef CheckCppObjectTypeEnabled}
+      {$endif}
+    {$endif}
+  {$endif}
+{$endif}

contrib/mORMot/SQLite3/DDD/dom/asynch.pas.mustache

@@ -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.

contrib/mORMot/SQLite3/DDD/dom/dddDomAuthInterfaces.pas

@@ -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.

contrib/mORMot/SQLite3/DDD/dom/dddDomCountry.pas

@@ -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.

contrib/mORMot/SQLite3/DDD/dom/dddDomEmailInterfaces.pas

@@ -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.

contrib/mORMot/SQLite3/DDD/dom/dddDomUserCQRS.pas

@@ -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.

contrib/mORMot/SQLite3/DDD/dom/dddDomUserInterfaces.pas

@@ -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.

contrib/mORMot/SQLite3/DDD/dom/dddDomUserTypes.pas

@@ -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.

contrib/mORMot/SQLite3/DDD/infra/dddInfraAuthRest.pas

@@ -0,0 +1,374 @@
+/// shared DDD Infrastructure: Authentication implementation
+// - this unit is a part of the freeware Synopse mORMot framework,
+// licensed under a MPL/GPL/LGPL tri-license; version 1.18
+unit dddInfraAuthRest;
+
+{
+    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 *****
+
+  TODO:
+   - manage Authentication expiration?
+
+}
+
+{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
+
+interface
+
+uses
+  SysUtils,
+  Classes,
+  SynCommons,
+  SynCrypto,
+  SynTests,
+  mORMot,
+  mORMotDDD,
+  dddDomAuthInterfaces;
+
+  
+{ ----- Authentication Implementation using SHA-256 dual step challenge }
+
+type
+  /// ORM object to persist authentication information, i.e. TAuthInfo
+  TSQLRecordUserAuth = class(TSQLRecord)
+  protected
+    fLogon: RawUTF8;
+    fHashedPassword: RawUTF8;
+    class procedure InternalDefineModel(Props: TSQLRecordProperties); override;
+  published
+    /// will map TAuthInfo.LogonName
+    // - is defined as "stored AS_UNIQUE" so that it may be used as primary key
+    property Logon: RawUTF8 read fLogon write fLogon stored AS_UNIQUE;
+    /// the password, stored in a hashed form
+    // - this property does not exist at TAuthInfo level, so will be private
+    // to the storage layer - which is the safest option possible
+    property HashedPassword: RawUTF8 read fHashedPassword write fHashedPassword;
+  end;
+
+  /// generic class for implementing authentication
+  // - do not instantiate this abstract class, but e.g. TDDDAuthenticationSHA256
+  // or TDDDAuthenticationMD5
+  TDDDAuthenticationAbstract = class(TDDDRepositoryRestCommand,IDomAuthCommand)
+  protected
+    fChallengeLogonName: RawUTF8;
+    fChallengeNonce: TAuthQueryNonce;
+    fLogged: boolean;
+    // inherited classes should override this method with the proper algorithm
+    class function DoHash(const aValue: TAuthQueryNonce): TAuthQueryNonce; virtual; abstract;
+  public
+    /// 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;
+    /// set the credential for Get() or further IDomAuthCommand.Update/Delete
+    // - this method execution will be disabled for most clients
+    function SelectByName(const aLogonName: RawUTF8): TCQRSResult;
+    /// returns TRUE if the dual pass challenge did succeed
+    function Logged: boolean;
+    /// returns the logon name of the authenticated user
+    function LogonName: RawUTF8;
+    /// retrieve some information about the current selected credential
+    function Get(out aAggregate: TAuthInfo): TCQRSResult;
+    /// register a new credential, from its LogonName/HashedPassword values
+    // - 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
+    function UpdatePassword(const aHashedPassword: TAuthQueryNonce): TCQRSResult;
+    /// class method to be used to compute a password hash from its plain value
+    class function ComputeHashPassword(const aLogonName,aPassword: RawUTF8): TAuthQueryNonce;
+    /// class method to be used on the client side to resolve the challenge
+    // - is basically
+    // !   result := DoHash(aLogonName+':'+aChallengeFromServer+':'+
+    // !     ComputeHashPassword(aLogonName,aPlainPassword));
+    class function ClientComputeChallengedPassword(
+      const aLogonName,aPlainPassword: RawUTF8;
+      const aChallengeFromServer: TAuthQueryNonce): TAuthQueryNonce; virtual;
+    /// built-in simple unit tests
+    class procedure RegressionTests(test: TSynTestCase);
+  end;
+
+  /// allows to specify which actual hashing algorithm would be used
+  // - i.e. either TDDDAuthenticationSHA256 or TDDDAuthenticationMD5
+  TDDDAuthenticationClass = class of TDDDAuthenticationAbstract;
+
+  /// implements authentication using SHA-256 hashing
+  // - more secure than TDDDAuthenticationMD5
+  TDDDAuthenticationSHA256 = class(TDDDAuthenticationAbstract)
+  protected
+    /// will use SHA-256 algorithm for hashing, and the class name as salt
+    class function DoHash(const aValue: TAuthQueryNonce): TAuthQueryNonce; override;
+  end;
+
+  /// implements authentication using MD5 hashing
+  // - less secure than TDDDAuthenticationSHA256
+  TDDDAuthenticationMD5 = class(TDDDAuthenticationAbstract)
+  protected
+    /// will use MD5 algorithm for hashing, and the class name as salt
+    class function DoHash(const aValue: TAuthQueryNonce): TAuthQueryNonce; override;
+  end;
+
+  /// abstract factory of IDomAuthCommand repository instances using REST
+  TDDDAuthenticationRestFactoryAbstract = class(TDDDRepositoryRestFactory)
+  protected
+  public
+    /// initialize a factory with the supplied implementation algorithm
+    constructor Create(aRest: TSQLRest; aImplementationClass: TDDDAuthenticationClass;
+      aOwner: TDDDRepositoryRestManager); reintroduce;
+  end;
+  
+  /// factory of IDomAuthCommand repository instances using a RESTful ORM access
+  // and SHA-256 hashing algorithm
+  TDDDAuthenticationRestFactorySHA256 = class(TDDDAuthenticationRestFactoryAbstract)
+  protected
+  public
+    /// initialize a factory with the SHA-256 implementation algorithm
+    constructor Create(aRest: TSQLRest; aOwner: TDDDRepositoryRestManager=nil); reintroduce;
+  end;
+
+  /// factory of IDomAuthCommand repository instances using a RESTful ORM access
+  // and SHA-256 hashing algorithm
+  TDDDAuthenticationRestFactoryMD5 = class(TDDDAuthenticationRestFactoryAbstract)
+  protected
+  public
+    /// initialize a factory with the SHA-256 implementation algorithm
+    constructor Create(aRest: TSQLRest; aOwner: TDDDRepositoryRestManager=nil); reintroduce;
+  end;
+
+  
+
+implementation
+
+{ TDDDAuthenticationAbstract }
+
+function TDDDAuthenticationAbstract.ChallengeSelectFirst(
+  const aLogonName: RawUTF8): TAuthQueryNonce;
+begin
+  fLogged := false;
+  fChallengeLogonName := Trim(aLogonName);
+  fChallengeNonce := DoHash(aLogonName+NowToString);
+  result := fChallengeNonce;
+end;
+
+function TDDDAuthenticationAbstract.ChallengeSelectFinal(
+  const aChallengedPassword: TAuthQueryNonce): TCQRSResult;
+begin
+  if (fChallengeLogonName='') or (fChallengeNonce='') then
+    result := CqrsSetResultError(cqrsBadRequest) else
+    result := SelectByName(fChallengeLogonName);
+  if result<>cqrsSuccess then
+    exit;
+  CqrsBeginMethod(qaNone, result);
+  if DoHash(fChallengeLogonName+':'+fChallengeNonce+':'+
+     (fCurrentORMInstance as TSQLRecordUserAuth).HashedPassword)=aChallengedPassword then begin
+    fLogged := true;
+    CqrsSetResult(cqrsSuccess,result);
+  end else
+    CqrsSetResultMsg(cqrsBadRequest,'Wrong Password for [%]',[fChallengeLogonName],result);
+  fChallengeNonce := '';
+  fChallengeLogonName := '';
+end;
+
+function TDDDAuthenticationAbstract.LogonName: RawUTF8;
+begin
+  if (fCurrentORMInstance=nil) or not Logged then
+    result := '' else
+    result := TSQLRecordUserAuth(fCurrentORMInstance).Logon;
+end;
+
+function TDDDAuthenticationAbstract.Logged: boolean;
+begin
+  result := fLogged;
+end;
+
+class function TDDDAuthenticationAbstract.ComputeHashPassword(
+  const aLogonName, aPassword: RawUTF8): TAuthQueryNonce;
+begin
+  result := DoHash(aLogonName+':'+aPassword);
+end;
+
+class function TDDDAuthenticationAbstract.ClientComputeChallengedPassword(
+  const aLogonName,aPlainPassword: RawUTF8; const aChallengeFromServer: TAuthQueryNonce): TAuthQueryNonce;
+begin // see TDDDAuthenticationAbstract.ChallengeSelectFinal
+  result := DoHash(aLogonName+':'+aChallengeFromServer+':'+
+    ComputeHashPassword(aLogonName,aPlainPassword));
+end;
+
+function TDDDAuthenticationAbstract.SelectByName(
+  const aLogonName: RawUTF8): TCQRSResult;
+begin
+  result := ORMSelectOne('Logon=?',[aLogonName],(aLogonName=''));
+end;
+
+function TDDDAuthenticationAbstract.Get(
+  out aAggregate: TAuthInfo): TCQRSResult;
+begin
+  result := ORMGetAggregate(aAggregate);
+end;
+
+function TDDDAuthenticationAbstract.Add(const aLogonName: RawUTF8;
+  aHashedPassword: TAuthQueryNonce): TCQRSResult;
+begin
+  if not CqrsBeginMethod(qaCommandDirect,result) then
+    exit;
+  with fCurrentORMInstance as TSQLRecordUserAuth do begin
+    Logon := aLogonName;
+    HashedPassword := aHashedPassword;
+  end;
+  ORMPrepareForCommit(soInsert,nil,result);
+end;
+
+function TDDDAuthenticationAbstract.UpdatePassword(
+  const aHashedPassword: TAuthQueryNonce): TCQRSResult;
+begin
+  if not CqrsBeginMethod(qaCommandOnSelect,result) then
+    exit;
+  (fCurrentORMInstance as TSQLRecordUserAuth).HashedPassword := aHashedPassword;
+  ORMPrepareForCommit(soUpdate,nil,result);
+end;
+
+class procedure TDDDAuthenticationAbstract.RegressionTests(
+  test: TSynTestCase);
+var Factory: TDDDAuthenticationRestFactoryAbstract;
+  procedure TestOne;
+  const MAX=2000;
+  var auth: IDomAuthCommand;
+      nonce,challenge: TAuthQueryNonce;
+      log,pass: RawUTF8;
+      info: TAuthInfo;
+      i: integer;
+  begin
+    test.Check(Factory.GetOneInstance(auth));
+    for i := 1 to MAX do begin
+      UInt32ToUtf8(i,log);
+      UInt32ToUtf8(i*7,pass);
+      test.Check(auth.Add(log,ComputeHashPassword(log,pass))=cqrsSuccess);
+    end;
+    test.Check(auth.Commit=cqrsSuccess);
+    test.Check(Factory.GetOneInstance(auth));
+    info := TAuthInfo.Create;
+    try
+      for i := 1 to MAX do begin
+        UInt32ToUtf8(i,log);
+        UInt32ToUtf8(i*7,pass);
+        nonce := auth.ChallengeSelectFirst(log);
+        test.Check(nonce<>'');
+        challenge := ClientComputeChallengedPassword(log,pass,nonce);
+        test.Check(auth.ChallengeSelectFinal(challenge)=cqrsSuccess);
+        test.Check(auth.Get(info)=cqrsSuccess);
+        test.Check(info.LogonName=log);
+      end;
+    finally
+      info.Free;
+    end;
+  end;
+var Rest: TSQLRestServerFullMemory;
+begin
+  Rest := TSQLRestServerFullMemory.CreateWithOwnModel([TSQLRecordUserAuth]);
+  try
+    Factory := TDDDAuthenticationRestFactoryAbstract.Create(Rest,self,nil);
+    try
+      TestOne; // sub function to ensure that all I*Command are released
+    finally
+      Factory.Free;
+    end;
+  finally
+    Rest.Free;
+  end;
+end;
+
+
+{ TDDDAuthenticationSHA256 }
+
+class function TDDDAuthenticationSHA256.DoHash(
+  const aValue: TAuthQueryNonce): TAuthQueryNonce;
+begin
+  result := SHA256(RawUTF8(ClassName)+aValue);
+end;
+
+{ TDDDAuthenticationMD5 }
+
+class function TDDDAuthenticationMD5.DoHash(
+  const aValue: TAuthQueryNonce): TAuthQueryNonce;
+begin
+  result := MD5(RawUTF8(ClassName)+aValue);
+end;
+
+
+{ TDDDAuthenticationRestFactoryAbstract }
+
+constructor TDDDAuthenticationRestFactoryAbstract.Create(aRest: TSQLRest;
+  aImplementationClass: TDDDAuthenticationClass;
+  aOwner: TDDDRepositoryRestManager);
+begin
+  inherited Create(
+    IDomAuthCommand,aImplementationClass,TAuthInfo,aRest,TSQLRecordUserAuth,
+    ['Logon','LogonName'],aOwner);
+end;
+
+
+{ TDDDAuthenticationRestFactorySHA256 }
+
+constructor TDDDAuthenticationRestFactorySHA256.Create(aRest: TSQLRest;
+  aOwner: TDDDRepositoryRestManager);
+begin
+  inherited Create(aRest,TDDDAuthenticationSHA256,aOwner);
+end;
+
+{ TDDDAuthenticationRestFactoryMD5 }
+
+constructor TDDDAuthenticationRestFactoryMD5.Create(aRest: TSQLRest;
+  aOwner: TDDDRepositoryRestManager);
+begin
+  inherited Create(aRest,TDDDAuthenticationMD5,aOwner);
+end;
+
+
+
+{ TSQLRecordUserAuth }
+
+class procedure TSQLRecordUserAuth.InternalDefineModel(
+  Props: TSQLRecordProperties);
+begin
+  AddFilterNotVoidText(['Logon','HashedPassword']);
+end;
+
+end.

contrib/mORMot/SQLite3/DDD/infra/dddInfraEmail.pas

@@ -0,0 +1,473 @@
+/// shared DDD Infrastructure: implement an email validation service
+// - this unit is a part of the freeware Synopse mORMot framework,
+// licensed under a MPL/GPL/LGPL tri-license; version 1.18
+unit dddInfraEmail;
+
+{
+    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,
+  SynCommons,
+  SynTests,
+  SynCrypto,
+  SynTable, // for TSynFilter and TSynValidate
+  mORMot,
+  mORMotDDD,
+  dddDomUserTypes,
+  dddDomUserInterfaces;
+
+  
+{ ****************** Email Verification Service }
+
+type
+  /// exception raised during any email process of this DDD's infrastructure
+  // implementation
+  EDDDEmail = class(EDDDInfraException);
+
+  /// parameters used for the validation link of an email address
+  // - may be stored as daemon/service level settings, using e.g. dddInfraSettings
+  TDDDEmailRedirection = class(TSynPersistent)
+  private
+    fSuccessRedirectURI: RawUTF8;
+    fRestServerPublicRootURI: RawUTF8;
+    fValidationMethodName: RawUTF8;
+  published
+    /// the public URI which would be accessible from the Internet
+    // - may be e.g 'http://publicserver/restroot'
+    property RestServerPublicRootURI: RawUTF8
+      read fRestServerPublicRootURI write fRestServerPublicRootURI;
+    /// the validation method name for the URI
+    // - if not set, TDDDEmailValidationService will use 'EmailValidate'
+    // - clickable URI would be RestServerPublicRootURI+'/'+ValidationMethodName
+    property ValidationMethodName: RawUTF8
+      read fValidationMethodName write fValidationMethodName;
+    /// the URI on which the browser will be redirected on validation success
+    // - you can specify some '%' parameter markers, ordered as logon, email,
+    // and validation IP
+    // - may be e.g. 'http://publicwebsite/success&logon=%'
+    property SuccessRedirectURI: RawUTF8
+      read fSuccessRedirectURI write fSuccessRedirectURI;
+  end;
+
+  /// parameters used for the validation/verification process of an email address
+  // - may be stored as daemon/service level settings, using e.g. dddInfraSettings
+  TDDDEmailValidation = class(TSynAutoCreateFields)
+  private
+    fTemplate: TDomUserEmailTemplate;
+    fTemplateFolder: TFileName;
+    fRedirection: TDDDEmailRedirection;
+  public
+    /// will fill some default values in the properties, if none is set
+    procedure SetDefaultValuesIfVoid(const aSenderEmail,aApplication,
+      aRedirectionURIPublicRoot,aRedirectionURISuccess: RawUTF8);
+  published
+    /// how the email should be created from a given template
+    property Template: TDomUserEmailTemplate read fTemplate;
+    /// where the template files are to be found
+    property TemplateFolder: TFileName
+      read fTemplateFolder write fTemplateFolder;
+    /// parameters defining the validation link of an email address
+    property Redirection: TDDDEmailRedirection read fRedirection;
+  end;
+
+  TSQLRecordEmailAbstract = class;
+  TSQLRecordEmailValidation = class;
+  TSQLRecordEmailValidationClass = class of TSQLRecordEmailValidation;
+
+  /// abstract parent of any email-related service
+  // - will define some common methods to validate an email address
+  TDDDEmailServiceAbstract = class(TCQRSQueryObjectRest,IDomUserEmailCheck)
+  protected
+    fEmailValidate: TSynValidate;
+    function CheckEmailCorrect(aEmail: TSQLRecordEmailAbstract;
+      var aResult: TCQRSResult): boolean; virtual;
+    procedure SetEmailValidate(const Value: TSynValidate); virtual;
+  public
+    constructor Create(aRest: TSQLRest); override;
+    destructor Destroy; override;
+    function CheckRecipient(const aEmail: RawUTF8): TCQRSResult; virtual;
+    function CheckRecipients(const aEmails: TRawUTF8DynArray): TCQRSResult;
+  published
+    /// direct access to the email validation instance
+    // - you can customize the default TSynValidateEmail to meet your own
+    // expectations - once set, it will be owned by this class instance 
+    property EmailValidate: TSynValidate read fEmailValidate write SetEmailValidate;
+  end;
+
+  /// service used to validate an email address via an URL link to be clicked
+  TDDDEmailValidationService = class(TDDDEmailServiceAbstract,
+    IDomUserEmailValidation)
+  protected
+    fRestClass: TSQLRecordEmailValidationClass;
+    fEMailer: IDomUserEmailer;
+    fTemplate: IDomUserTemplate;
+    fValidationSalt: integer;
+    fValidationServerRoot: RawUTF8;
+    fValidationMethodName: RawUTF8;
+    fSuccessRedirectURI: RawUTF8;
+    function GetEmailValidation(const aLogonName: RawUTF8): TSQLRecordEmailValidation;
+    function GetWithSalt(const aLogonName,aEmail: RawUTF8; aSalt: integer): RawUTF8;
+    procedure EmailValidate(Ctxt: TSQLRestServerURIContext);
+  public
+    /// initialize the validation service for a given ORM persistence
+    // - would recognize the TSQLRecordEmailValidation class from aRest.Model
+    // - will use aRest.Services for IoC, e.g. EMailer/Template properties 
+    constructor Create(aRest: TSQLRest); override;
+    /// register the callback URI service
+    procedure SetURIForServer(aRestServerPublic: TSQLRestServer;
+      aParams: TDDDEmailRedirection); overload;
+    /// register the callback URI service
+    // - same as the overloaded function, but taking parameters one by one
+    procedure SetURIForServer(aRestServerPublic: TSQLRestServer;
+      const aRestServerPublicRootURI,aSuccessRedirectURI,aValidationMethodName: RawUTF8); overload;
+    /// compute the target URI corresponding to SetURIForServer() parameters
+    function ComputeURIForReply(const aLogonName,aEmail: RawUTF8): RawUTF8;
+    /// check the supplied parameters, and send an email for validation
+    function StartEmailValidation(const aTemplate: TDomUserEmailTemplate;
+      const aLogonName,aEmail: RawUTF8): TCQRSResult; virtual;
+    /// check if an email has been validated for a given logon
+    function IsEmailValidated(const aLogonName,aEmail: RawUTF8): boolean; virtual;
+  published
+    /// will be injected (and freed) with the emailer service
+    property EMailer: IDomUserEmailer read fEmailer;
+    /// will be injected (and freed) with the email template service
+    property Template: IDomUserTemplate read fTemplate;
+  published
+    /// the associated ORM class used to store the email validation process
+    // - any class inheriting from TSQLRecordEmailValidation in the aRest.Model
+    // will be recognized by Create(aRest) to store its information
+    // - this temporary storage should not be the main user persistence domain
+    property RestClass: TSQLRecordEmailValidationClass read fRestClass;
+    /// the validation method name for the URI
+    // - if not set, TDDDEmailValidationService will use 'EmailValidate'
+    // - clickable URI would be ValidationServerRoot+'/'+ValidationMethodName
+    property ValidationURI: RawUTF8 read fValidationMethodName;
+    /// the public URI which would be accessible from the Internet
+    // - may be e.g 'http://publicserver/restroot'
+    property ValidationServerRoot: RawUTF8 read fValidationServerRoot;
+  end;
+
+  /// ORM class storing an email in addition to creation/modification timestamps
+  // - declared as its own class, since may be reused
+  TSQLRecordEmailAbstract = class(TSQLRecordTimed)
+  private
+    fEmail: RawUTF8;
+  published
+    /// the stored email address
+    property Email: RawUTF8 read fEmail write fEmail;
+  end;
+
+  /// ORM class for email validation process
+  // - we do not create a whole domain here, just an ORM persistence layer
+  // - any class inheriting from TSQLRecordEmailValidation in the Rest.Model
+  // will be recognized by TDDDEmailValidationService to store its information
+  TSQLRecordEmailValidation = class(TSQLRecordEmailAbstract)
+  protected
+    fLogon: RawUTF8;
+    fRequestTime: TTimeLog;
+    fValidationSalt: Integer;
+    fValidationTime: TTimeLog;
+    fValidationIP: RawUTF8;
+  public
+    function IsValidated(const aEmail: RawUTF8): Boolean;
+  published
+    property Logon: RawUTF8 read fLogon write fLogon stored AS_UNIQUE;
+    property RequestTime: TTimeLog read fRequestTime write fRequestTime;
+    property ValidationSalt: Integer read fValidationSalt write fValidationSalt;
+    property ValidationTime: TTimeLog read fValidationTime write fValidationTime;
+    property ValidationIP: RawUTF8 read fValidationIP write fValidationIP;
+  end;
+
+
+implementation
+
+
+{ TDDDEmailServiceAbstract }
+
+constructor TDDDEmailServiceAbstract.Create(aRest: TSQLRest);
+begin
+  inherited Create(aRest);
+  fEmailValidate := TSynValidateEmail.Create;
+end;
+
+destructor TDDDEmailServiceAbstract.Destroy;
+begin
+  fEmailValidate.Free;
+  inherited;
+end;
+
+function TDDDEmailServiceAbstract.CheckEmailCorrect(
+  aEmail: TSQLRecordEmailAbstract; var aResult: TCQRSResult): boolean;
+var msg: string;
+begin
+  if (aEmail<>nil) and fEmailValidate.Process(0,aEmail.Email,msg) and
+     aEmail.FilterAndValidate(Rest,msg) then
+    result := true else  begin
+    CqrsSetResultString(cqrsDDDValidationFailed,msg,aResult);
+    result := false;
+  end;
+end;
+
+function TDDDEmailServiceAbstract.CheckRecipient(
+  const aEmail: RawUTF8): TCQRSResult;
+var msg: string;
+begin
+  CqrsBeginMethod(qaNone,result);
+  if fEmailValidate.Process(0,aEmail,msg) then
+    CqrsSetResult(cqrsSuccess,result) else
+    CqrsSetResultString(cqrsDDDValidationFailed,msg,result);
+end;
+
+function TDDDEmailServiceAbstract.CheckRecipients(
+  const aEmails: TRawUTF8DynArray): TCQRSResult;
+var msg: string;
+    i: integer;
+begin
+  CqrsBeginMethod(qaNone,result);
+  for i := 0 to high(aEMails) do
+    if not fEmailValidate.Process(0,aEmails[i],msg) then begin
+      CqrsSetResultString(cqrsDDDValidationFailed,msg,result);
+      exit;
+    end;
+  CqrsSetResult(cqrsSuccess,result);
+end;
+
+procedure TDDDEmailServiceAbstract.SetEmailValidate(
+  const Value: TSynValidate);
+begin
+  fEmailValidate.Free;
+  fEmailValidate := Value;
+end;
+
+
+{ TDDDEmailValidationService }
+
+constructor TDDDEmailValidationService.Create(aRest: TSQLRest);
+var rnd: Int64;
+begin
+  inherited Create(aRest); // will inject aRest.Services for IoC
+  fRestClass := fRest.Model.AddTableInherited(TSQLRecordEmailValidation);
+  fRestClass.AddFilterNotVoidText(['Email','Logon']);
+  rnd := GetTickCount64*PtrInt(self)*Random(MaxInt);
+  fValidationSalt := crc32c(PtrInt(self),@rnd,sizeof(rnd));
+end;
+
+function TDDDEmailValidationService.GetWithSalt(const aLogonName,
+  aEmail: RawUTF8; aSalt: integer): RawUTF8;
+begin
+  result := SHA256(FormatUTF8('%'#1'%'#2'%'#3,[aLogonName,aEmail,aSalt]));
+end;
+
+function TDDDEmailValidationService.ComputeURIForReply(
+  const aLogonName, aEmail: RawUTF8): RawUTF8;
+begin
+  result := aLogonName+#1+aEmail;
+  result := fValidationServerRoot+fValidationMethodName+'/'+
+    GetWithSalt(aLogonName,aEmail,fValidationSalt)+
+    BinToBase64URI(pointer(result),length(result));
+end;
+
+procedure TDDDEmailValidationService.EmailValidate(
+  Ctxt: TSQLRestServerURIContext);
+var code: RawUTF8;
+    logon,email,signature: RawUTF8;
+    EmailValidation: TSQLRecordEmailValidation;
+begin
+  signature := Copy(Ctxt.URIBlobFieldName,1,SHA256DIGESTSTRLEN);
+  if length(signature)<>SHA256DIGESTSTRLEN then
+    exit;
+  code := Base64uriToBin(Copy(Ctxt.URIBlobFieldName,SHA256DIGESTSTRLEN+1,200));
+  Split(code,#1,logon,email);
+  if (logon='') or (email='') then
+    exit;
+  EmailValidation := GetEmailValidation(logon);
+  if EmailValidation<>nil then
+  try
+    if signature=GetWithSalt(logon,email,EmailValidation.ValidationSalt) then begin
+      EmailValidation.ValidationTime := TimeLogNowUTC;
+      EmailValidation.ValidationIP := Ctxt.InHeader['remoteip'];
+      if Rest.Update(EmailValidation) then
+        Ctxt.Redirect(FormatUTF8(fSuccessRedirectURI,
+          [UrlEncode(logon),UrlEncode(email),UrlEncode(EmailValidation.ValidationIP)]));
+    end;
+  finally
+    EmailValidation.Free;
+  end;
+end;
+
+procedure TDDDEmailValidationService.SetURIForServer(
+  aRestServerPublic: TSQLRestServer; aParams: TDDDEmailRedirection);
+begin
+  if aParams=nil then
+    raise EDDDEmail.CreateUTF8('Invalid %.SetURIForServer(%,nil)',
+      [self,aRestServerPublic]);
+  SetURIForServer(aRestServerPublic,aParams.RestServerPublicRootURI,
+    aParams.SuccessRedirectURI,aParams.ValidationMethodName);
+end;
+
+procedure TDDDEmailValidationService.SetURIForServer(
+  aRestServerPublic: TSQLRestServer; const aRestServerPublicRootURI,
+  aSuccessRedirectURI, aValidationMethodName: RawUTF8);
+begin
+  fSuccessRedirectURI := Trim(aSuccessRedirectURI);
+  fValidationServerRoot := IncludeTrailingURIDelimiter(Trim(aRestServerPublicRootURI));
+  if (aRestServerPublic=nil) or (fSuccessRedirectURI='') or (fValidationServerRoot='') then
+    raise EDDDEmail.CreateUTF8('Invalid %.SetURIForServer(%,"%","%")',
+      [self,aRestServerPublic,fValidationServerRoot,fSuccessRedirectURI]);
+  if not IdemPChar(pointer(fValidationServerRoot),'HTTP') then
+    fValidationServerRoot := 'http://'+fValidationServerRoot;
+  fValidationMethodName := Trim(aValidationMethodName);
+  if fValidationMethodName='' then
+   fValidationMethodName := 'EmailValidate'; // match method name by default
+  aRestServerPublic.ServiceMethodRegister(fValidationMethodName,EmailValidate,true);
+end;
+
+function TDDDEmailValidationService.GetEmailValidation(const aLogonName: RawUTF8): TSQLRecordEmailValidation;
+begin
+  result := RestClass.Create(Rest,'Logon=?',[aLogonName]);
+  if result.fID=0 then
+    FreeAndNil(result);
+end;
+
+function TDDDEmailValidationService.IsEmailValidated(const aLogonName,
+  aEmail: RawUTF8): boolean;
+var EmailValidation: TSQLRecordEmailValidation;
+begin
+  EmailValidation := GetEmailValidation(aLogonName);
+  try
+    result := EmailValidation.IsValidated(trim(aEmail));
+  finally
+    EmailValidation.Free;
+  end;
+end;
+
+function TDDDEmailValidationService.StartEmailValidation(
+  const aTemplate: TDomUserEmailTemplate; const aLogonName, aEmail: RawUTF8): TCQRSResult;
+var EmailValidation: TSQLRecordEmailValidation;
+    email,msg: RawUTF8;
+    context: variant;
+begin
+  email := Trim(aEmail);
+  result := CheckRecipient(email);
+  if result<>cqrsSuccess then
+    exit; // supplied email address is invalid
+  CqrsBeginMethod(qaNone,result);
+  EmailValidation := GetEmailValidation(aLogonName);
+  try
+    if EmailValidation.IsValidated(email) then begin
+      CqrsSetResultMsg(cqrsSuccess,'Already validated',result);
+      exit;
+    end;
+    if EmailValidation=nil then begin
+      EmailValidation := RestClass.Create;
+      EmailValidation.Email := aEmail;
+      EmailValidation.Logon := aLogonName;
+      if not CheckEmailCorrect(EmailValidation,result) then
+        exit;
+    end else
+      if EmailValidation.Email<>email then
+        EmailValidation.Email := email; // allow validation for a new email
+    EmailValidation.RequestTime := TimeLogNowUTC;
+    EmailValidation.ValidationSalt := fValidationSalt;
+    context := EmailValidation.GetSimpleFieldsAsDocVariant(true);
+    _ObjAddProps(aTemplate,context);
+    _ObjAddProps(['ValidationUri',
+      ComputeURIForReply(EmailValidation.Logon,EmailValidation.Email)],context);
+    msg := Template.ComputeMessage(context,aTemplate.FileName);
+    if msg='' then
+      CqrsSetResultMsg(cqrsInvalidContent,
+        'Impossible to render template [%]',[aTemplate.FileName],result) else
+      if EMailer.SendEmail(TRawUTF8DynArrayFrom([aEmail]),
+          aTemplate.SenderEmail,aTemplate.Subject,'',msg)=cqrsSuccess then
+        if Rest.AddOrUpdate(EmailValidation)=0 then
+          CqrsSetResultError(cqrsDataLayerError) else
+          CqrsSetResultMsg(cqrsSuccess,'Validation email sent',result);
+  finally
+    EmailValidation.Free;
+  end;
+end;    
+
+
+{ TSQLRecordEmailValidation }
+
+function TSQLRecordEmailValidation.IsValidated(const aEmail: RawUTF8): Boolean;
+begin
+  result := (self<>nil) and (ValidationTime<>0) and (Email=aEmail);
+end;
+
+
+{ TDDDEmailValidation }
+
+procedure TDDDEmailValidation.SetDefaultValuesIfVoid(
+  const aSenderEmail,aApplication,
+  aRedirectionURIPublicRoot,aRedirectionURISuccess: RawUTF8);
+begin
+  if Template.SenderEmail='' then
+    Template.SenderEmail := aSenderEmail;
+  if Template.Application='' then
+    Template.Application := aApplication;
+  if Template.FileName='' then
+    Template.FileName := 'EmailValidate.txt';
+  if (TemplateFolder='') and
+     not FileExists(string(Template.FileName)) then
+    FileFromString('Welcome to {{Application}}!'#13#10#13#10+
+      'You have registered as "{{Logon}}", using {{EMail}} as contact address.'#13#10#13#10+
+      'Please click on the following link to validate your email:'#13#10+
+      '{{ValidationUri}}'#13#10#13#10'Best regards from the clouds'#13#10#13#10+
+      '(please do not respond to this email)',
+      UTF8ToString(Template.FileName));
+  if Template.Subject='' then
+    Template.Subject := 'Please Validate Your Email';
+  if Redirection.RestServerPublicRootURI='' then
+    Redirection.RestServerPublicRootURI := aRedirectionURIPublicRoot;
+  if Redirection.SuccessRedirectURI='' then
+    Redirection.SuccessRedirectURI := aRedirectionURISuccess;
+end;
+
+end.

contrib/mORMot/SQLite3/DDD/infra/dddInfraEmailer.pas

@@ -0,0 +1,804 @@
+/// shared DDD Infrastructure: generic emailing service
+// - this unit is a part of the freeware Synopse mORMot framework,
+// licensed under a MPL/GPL/LGPL tri-license; version 1.18
+unit dddInfraEmailer;
+
+{
+    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
+  {$ifdef MSWINDOWS}
+  Windows, // for fSafe.Lock/Unlock inlining
+  {$endif}
+  {$ifdef KYLIX3}
+  Types,
+  LibC,
+  {$endif}
+  SysUtils,
+  Classes,
+  SynCommons,
+  SynLog,
+  SynTests,
+  SynCrtSock,
+  SynMustache,
+  SynTable,
+  SyncObjs,
+  mORMot,
+  mORMotDDD,
+  dddDomUserTypes,
+  dddDomUserInterfaces,
+  dddInfraEmail; // for TDDDEmailServiceAbstract
+
+
+{ ****************** Email Sending Service }
+
+type
+  /// used to inject the exact SMTP process to TDDDEmailerDaemon
+  ISMTPServerConnection = interface(IInvokable)
+    ['{00479813-4CAB-4563-BD51-AB6606BC7BEE}']
+    /// this method should send the email, returning an error message on issue
+    // - if no header is supplied, it will expect one UTF-8 encoded text message
+    function SendEmail(const aRecipient: TRawUTF8DynArray;
+      const aSender,aSubject,aHeader,aBody: RawUTF8): RawUTF8;
+  end;
+
+  /// abstract class used to resolve ISMTPServerConnection
+  // - see TSMTPServerSocket for actual implementation
+  TSMTPServer = class(TInterfaceResolverForSingleInterface)
+  protected
+    fAddress: RawUTF8;
+    fPort: cardinal;
+    fLogin: RawUTF8;
+    fPassword: RawUTF8;
+    function CreateInstance: TInterfacedObject; override;
+  public
+    /// initialize the class with the supplied parameters
+    constructor Create(aImplementation: TInterfacedObjectClass;
+      const aAddress: RawUTF8; aPort: cardinal; const aLogin,aPassword: RawUTF8); overload;
+    /// initialize the class with the parameters of another TSMTPServer instance
+    // - in fact, TSMTPServer could be used as parameter storage of its needed
+    // published properties, e.g. in a TApplicationSettingsAbstract sub-class 
+    constructor Create(aImplementation: TInterfacedObjectClass;
+      aParameters: TSMTPServer); overload;
+    /// will fill some default values in the properties, if none is set
+    // - i.e. 'dummy:dummy@localhost:25'
+    procedure SetDefaultValuesIfVoid;
+  published
+    property Address: RawUTF8 read fAddress write fAddress;
+    property Port: cardinal read fPort write fPort;
+    property Login: RawUTF8 read fLogin write fLogin;
+    property Password: RawUTF8 read fPassword write fPassword;
+  end;
+
+  /// implements an abstract ISMTPServerConnection class
+  TSMTPServerSocketConnectionAbstract = class(TInterfacedObject,ISMTPServerConnection)
+  protected
+    fOwner: TSMTPServer;
+  public
+    constructor Create(aOwner: TSMTPServer); virtual;
+    function SendEmail(const aRecipient: TRawUTF8DynArray;
+      const aSender,aSubject,aHeader,aBody: RawUTF8): RawUTF8; virtual; abstract;
+  end;
+
+  TSMTPServerSocketConnectionAbstractClass = class of TSMTPServerSocketConnectionAbstract;
+
+  /// implements ISMTPServerConnection using SynCrtSock's low-level SMTP access
+  TSMTPServerSocketConnection = class(TSMTPServerSocketConnectionAbstract)
+  protected
+    fSocket: TCrtSocket;
+    procedure Expect(const Answer: RawByteString);
+    procedure Exec(const Command, Answer: RawByteString);
+  public
+    constructor Create(aOwner: TSMTPServer); override;
+    destructor Destroy; override;
+    function SendEmail(const aRecipient: TRawUTF8DynArray;
+      const aSender,aSubject,aHeader,aBody: RawUTF8): RawUTF8; override;
+  end;
+
+  TSQLRecordEmailer = class;
+  TSQLRecordEmailerClass = class of TSQLRecordEmailer;
+  TDDDEmailerDaemon = class;
+
+  /// statistics about a TDDDEmailerDaemon instance
+  // - in addition to a standard TSynMonitor, will maintain the connection count
+  TDDDEmailerDaemonStats = class(TSynMonitorWithSize)
+  protected
+    fConnection: cardinal;
+    procedure LockedSum(another: TSynMonitor); override;
+  public
+    /// will increase the connection count
+    procedure NewConnection;
+  published
+    /// the connection count
+    property Connection: cardinal read fConnection;
+  end;
+
+  /// thread processing a SMTP connection
+  TDDDEmailerDaemonProcess = class(TDDDMonitoredDaemonProcessRest)
+  protected
+    fSMTPConnection: ISMTPServerConnection;
+    // all the low-level process will take place in those overriden methods
+    function ExecuteRetrievePendingAndSetProcessing: boolean; override;
+    function ExecuteProcessAndSetResult: QWord; override;
+    procedure ExecuteIdle; override;
+  end;
+
+  /// daemon used to send emails via SMTP
+  // - it will maintain a list of action in a TSQLRecordEmailer ORM storage
+  TDDDEmailerDaemon = class(TDDDMonitoredDaemon,IDomUserEmailer)
+  protected
+    fRestClass: TSQLRecordEmailerClass;
+    fSMTPServer: TSMTPServer;
+  public
+    constructor Create(aRest: TSQLRest); overload; override;
+    constructor Create(aRest: TSQLRest; aSMTPServer: TSMTPServer;
+      aConnectionPool: integer=1); reintroduce; overload;
+    /// this is the main entry point of this service
+    // - here the supplied message body is already fully encoded, as
+    // expected by SMTP (i.e. as one text message, or multi-part encoded)
+    // - if no header is supplied, it will expect one UTF-8 encoded text message 
+    function SendEmail(const aRecipients: TRawUTF8DynArray;
+      const aSender,aSubject,aHeaders,aBody: RawUTF8): TCQRSResult;
+  published
+    /// the associated class TSQLRecordEmailer used for status persistence
+    // - any class inheriting from TSQLRecordEmailer in the Rest.Model
+    // will be recognized by TDDDEmailerDaemon to store its information
+    property RestClass: TSQLRecordEmailerClass read fRestClass;
+    /// the associated class used as actual SMTP client
+    property SMTPServer: TSMTPServer read fSMTPServer write fSMTPServer;
+  end;
+
+  /// state machine used during email validation process
+  TSQLRecordEmailerState = (esPending, esSending, esSent, esFailed);
+
+  /// ORM class for email validation process
+  // - we do not create a whole domain here, just an ORM persistence layer
+  TSQLRecordEmailer = class(TSQLRecordTimed)
+  private
+    fSender: RawUTF8;
+    fRecipients: TRawUTF8DynArray;
+    fSubject: RawUTF8;
+    fHeaders: RawUTF8;
+    fErrorMsg: RawUTF8;
+    fSendTime: TTimeLog;
+    fMessageCompressed: TByteDynArray; // will be transmitted as Base64 JSON
+    fState: TSQLRecordEmailerState;
+  public
+    // will create an index on State+ID
+    class procedure InitializeTable(Server: TSQLRestServer; const FieldName: RawUTF8;
+      Options: TSQLInitializeTableOptions); override;
+  published
+    property Sender: RawUTF8 read fSender write fSender;
+    property Recipients: TRawUTF8DynArray read fRecipients write fRecipients;
+    property Subject: RawUTF8 read fSubject write fSubject;
+    property Headers: RawUTF8 read fHeaders write fHeaders;
+    property State: TSQLRecordEmailerState read fState write fState;
+    property MessageCompressed: TByteDynArray read fMessageCompressed write fMessageCompressed;
+    property SendTime: TTimeLog read fSendTime write fSendTime;
+    property ErrorMsg: RawUTF8 read fErrorMsg write fErrorMsg;
+  end;
+
+
+{ ****************** Mustache-Based Templating Service }
+
+type
+  /// abstract Mustache-Based templating
+  TDDDTemplateAbstract = class(TCQRSService,IDomUserTemplate)
+  protected
+    fPartials: TSynMustachePartials;
+    fHelpers: TSynMustacheHelpers;
+    fOnTranslate: TOnStringTranslate;
+    fCache: TSynCache;
+    function RetrieveTemplate(const aTemplateName: RawUTF8;
+      out aTemplate, aType: RawUTF8): boolean; virtual; abstract;
+  public
+    destructor Destroy; override;
+    function ComputeMessage(const aContext: variant;
+      const aTemplateName: RawUTF8): RawUTF8;
+    property Partials: TSynMustachePartials read fPartials write fPartials;
+    property Helpers: TSynMustacheHelpers read fHelpers write fHelpers;
+    property OnTranslate: TOnStringTranslate read fOnTranslate write fOnTranslate;
+  end;
+
+  /// Mustache-Based templating from a local folder
+  TDDDTemplateFromFolder = class(TDDDTemplateAbstract)
+  protected
+    fFolder: TFileName;
+    fMemoryCacheSize: integer;
+    function RetrieveTemplate(const aTemplateName: RawUTF8;
+      out aTemplate, aType: RawUTF8): boolean; override;
+    procedure SetFolder(const Value: TFileName); virtual;
+    procedure SetMemoryCacheSize(const Value: integer);
+  public
+    constructor Create(const aTemplateFolder: TFileName;
+      aMemoryCacheSize: integer=1024*2048); reintroduce;
+  published
+    property Folder: TFileName read fFolder write SetFolder;
+    property MemoryCacheSize: integer read fMemoryCacheSize write SetMemoryCacheSize;
+  end;
+
+
+/// you can call this function within a TSynTestCase class to validate
+// the email validation via a full regression set
+// - could be used as such:
+// !procedure TTestCrossCuttingFeatures.Emailer;
+// !begin // TSQLRestServerDB is injected to avoid any dependency to mORMotSQLite3
+// !  TestDddInfraEmailer(TSQLRestServerDB,self);
+// !end;
+procedure TestDddInfraEmailer(serverClass: TSQLRestServerClass; test: TSynTestCase);
+
+
+implementation
+
+
+{ ****************** Email Sending Service }
+
+{ TSMTPServer }
+
+function TSMTPServer.CreateInstance: TInterfacedObject;
+begin
+  result := TSMTPServerSocketConnectionAbstractClass(fImplementation.ItemClass).
+    Create(self);
+end;
+
+constructor TSMTPServer.Create(aImplementation: TInterfacedObjectClass;
+  const aAddress: RawUTF8; aPort: cardinal; const aLogin, aPassword: RawUTF8);
+begin
+  inherited Create(TypeInfo(ISMTPServerConnection),aImplementation);
+  fAddress := aAddress;
+  fPort := aPort;
+  fLogin := aLogin;
+  fPassword := aPassword;
+end;
+
+constructor TSMTPServer.Create(aImplementation: TInterfacedObjectClass;
+  aParameters: TSMTPServer);
+begin
+  if (aParameters=nil) or (aImplementation=nil) then
+    raise EDDDEmail.CreateUTF8('%.Create(nil)',[self]);
+  Create(aImplementation,
+    aParameters.Address,aParameters.Port,aParameters.Login,aParameters.Password);
+end;
+
+procedure TSMTPServer.SetDefaultValuesIfVoid;
+begin
+  if Address='' then
+    Address := 'localhost';
+  if Port=0 then begin
+    Port := 25;
+    if Login='' then
+      Login := 'dummy';
+    if Password='' then
+      Password := 'dummy';
+  end;
+end;
+
+{ TSMTPServerSocketConnectionAbstract }
+
+constructor TSMTPServerSocketConnectionAbstract.Create(
+  aOwner: TSMTPServer);
+begin
+  fOwner := aOwner;
+end;
+
+
+{ TSMTPServerSocketConnection }
+
+{$I+} // low-level communication with readln/writeln should raise exception
+
+constructor TSMTPServerSocketConnection.Create(
+  aOwner: TSMTPServer);
+begin
+  inherited Create(aOwner);
+  fSocket := TCrtSocket.Open(fOwner.Address,UInt32ToUtf8(fOwner.Port));
+  fSocket.CreateSockIn; // we use SockIn and SockOut here
+  fSocket.CreateSockOut(64*1024);
+  Expect('220');
+  if (fOwner.Login<>'') and (fOwner.Password<>'') then begin
+    Exec('EHLO '+fOwner.Address,'25');
+    Exec('AUTH LOGIN','334');
+    Exec(BinToBase64(fOwner.Login),'334');
+    Exec(BinToBase64(fOwner.Password),'235');
+  end else
+    Exec('HELO '+fOwner.Address,'25');
+end;
+
+procedure TSMTPServerSocketConnection.Expect(const Answer: RawByteString);
+var Res: RawByteString;
+begin
+  repeat
+    readln(fSocket.SockIn^,Res);
+  until (Length(Res)<4)or(Res[4]<>'-');
+  if not IdemPChar(pointer(Res),pointer(Answer)) then
+    raise ECrtSocket.CreateFmt('returned [%s], expecting [%s]',[Res,Answer]);
+end;
+
+procedure TSMTPServerSocketConnection.Exec(const Command,
+  Answer: RawByteString);
+begin
+  writeln(fSocket.SockOut^,Command);
+  Expect(Answer)
+end;
+
+function TSMTPServerSocketConnection.SendEmail(
+  const aRecipient: TRawUTF8DynArray;
+  const aSender,aSubject,aHeader,aBody: RawUTF8): RawUTF8;
+var rcpt,toList,head: RawUTF8;
+    i: integer;
+begin
+  if (aRecipient=nil) or (aSender='') or (aBody='') then
+    result := FormatUTF8('Invalid parameters for %.SendEmail(%:%,%)',
+      [self,fOwner.Address,fOwner.Port,aSender]) else
+    try
+      writeln(fSocket.SockOut^,'MAIL FROM:<',aSender,'>');
+      Expect('250');
+      toList := 'To: ';
+      for i := 0 to high(aRecipient) do begin
+        rcpt := aRecipient[i];
+        if PosExChar('<',rcpt)=0 then
+          rcpt := '<'+rcpt+'>';
+        Exec('RCPT TO:'+rcpt,'25');
+        toList := toList+rcpt+', ';
+      end;
+      Exec('DATA','354');
+      write(fSocket.SockOut^,'From: ',aSender,#13#10'Subject: ');
+      if aSubject='' then
+        writeln(fSocket.SockOut^,'Information') else
+        if IsAnsiCompatible(PAnsiChar(pointer(aSubject))) then
+          writeln(fSocket.SockOut^,aSubject) else
+          writeln(fSocket.SockOut^,'=?utf-8?B?',BinToBase64(aSubject));
+      writeln(fSocket.SockOut^,toList);
+      head := Trim(aHeader);
+      if head='' then // default format is simple UTF-8 text message
+        head := 'Content-Type: text/plain; charset=utf-8'#13#10+
+          'Content-Transfer-Encoding: 8bit';
+      writeln(fSocket.SockOut^,head);
+      writeln(fSocket.SockOut^,#13#10,aBody,#13#10'.');
+      Expect('25');
+      result := ''; // for success
+    except
+      on E: Exception do
+        result := FormatUTF8('%.SendEmail(%:%) server failure % [%]',
+          [self,fOwner.Address,fOwner.Port,E,E.Message]);
+    end;
+end;
+
+{$I-}
+
+destructor TSMTPServerSocketConnection.Destroy;
+begin
+  try
+    if fSocket<>nil then begin
+      writeln(fSocket.SockOut^,'QUIT');
+      ioresult; // ignore any error within writeln() since we are after $I-
+    end;
+  finally
+    FreeAndNil(fSocket);
+    inherited Destroy;
+  end;
+end;
+
+
+
+{ TSQLRecordEmailer }
+
+class procedure TSQLRecordEmailer.InitializeTable(Server: TSQLRestServer;
+  const FieldName: RawUTF8; Options: TSQLInitializeTableOptions);
+begin
+  inherited;
+  if (FieldName='') or IdemPropNameU(FieldName,'State') then
+    Server.CreateSQLMultiIndex(self,['State','ID'],false);
+end;
+
+
+{ TDDDEmailerDaemonProcess }
+
+const
+  EMAILERSTAT_CONNECTIONCOUNT = 0;
+  
+function TDDDEmailerDaemonProcess.ExecuteRetrievePendingAndSetProcessing: boolean;
+begin
+  fPendingTask := (fDaemon as TDDDEmailerDaemon).RestClass.Create(
+    fDaemon.Rest,'State=? order by RowID',[ord(esPending)]);
+  if fPendingTask.ID=0 then begin
+    result := false; // no more fPendingTask tasks
+    exit;
+  end;
+  with fPendingTask as TSQLRecordEmailer do begin
+    State := esSending;
+    SendTime := TimeLogNowUTC;
+  end;
+  result := fDaemon.Rest.Update(fPendingTask,'State,SendTime');
+end;
+
+function TDDDEmailerDaemonProcess.ExecuteProcessAndSetResult: QWord;
+var body: RawByteString;
+    pendingEmail: TSQLRecordEmailer;
+begin
+  pendingEmail := fPendingTask as TSQLRecordEmailer;
+  body := SynLZDecompress(pendingEmail.MessageCompressed);
+  result := length(body);
+  fMonitoring.AddSize(length(body));
+  if fSMTPConnection=nil then begin // re-use the same connection
+    fDaemon.Resolve([ISMTPServerConnection],[@fSMTPConnection]);
+    (fMonitoring as TDDDEmailerDaemonStats).NewConnection;
+  end;
+  pendingEmail.ErrorMsg := fSMTPConnection.SendEmail(
+    pendingEmail.Recipients,pendingEmail.Sender,pendingEmail.Subject,
+    pendingEmail.Headers,body);
+  if pendingEmail.ErrorMsg='' then
+    pendingEmail.State := esSent else
+    pendingEmail.State := esFailed;
+  fDaemon.Rest.Update(pendingEmail,'State,ErrorMsg'); // always write
+end;
+
+procedure TDDDEmailerDaemonProcess.ExecuteIdle;
+begin
+  fSMTPConnection := nil; // release ISMTPServerConnection instance
+end;
+
+
+{ TDDDEmailerDaemon }
+
+constructor TDDDEmailerDaemon.Create(aRest: TSQLRest);
+begin
+  fResolver := fSMTPServer; // do it before aRest.Services is set
+  inherited Create(aRest);
+  fRestClass := Rest.Model.AddTableInherited(TSQLRecordEmailer);
+  RestClass.AddFilterNotVoidText(['MessageCompressed']);
+  fProcessClass := TDDDEmailerDaemonProcess;
+  fProcessMonitoringClass := TDDDEmailerDaemonStats;
+  fProcessIdleDelay := 1000; // checking for pending emails every second
+end;
+
+constructor TDDDEmailerDaemon.Create(aRest: TSQLRest;
+  aSMTPServer: TSMTPServer; aConnectionPool: integer);
+begin
+  if not Assigned(aSMTPServer) then
+    raise ECQRSException.CreateUTF8('%.Create(SMTPServer=nil)',[self]);
+  fProcessThreadCount := aConnectionPool;
+  fSMTPServer := aSMTPServer;
+  Create(aRest);
+end;
+
+function TDDDEmailerDaemon.SendEmail(const aRecipients: TRawUTF8DynArray;
+  const aSender,aSubject,aHeaders,aBody: RawUTF8): TCQRSResult;
+var Email: TSQLRecordEmailer;
+    msg: string;
+begin
+{  result := CheckRecipients(aRecipient);
+  if result<>cqrsSuccess then
+    exit; }
+  Email := RestClass.Create;
+  try
+    Email.Recipients := aRecipients;
+    Email.Sender := aSender;
+    Email.Subject := aSubject;
+    Email.Headers := aHeaders;
+    {$ifdef WITHLOG}
+    Rest.LogClass.Enter('SendEmail %',[Email],self);
+    {$endif}
+    Email.MessageCompressed := SynLZCompressToBytes(aBody);
+    CqrsBeginMethod(qaNone,result);
+    if not Email.FilterAndValidate(Rest,msg) then
+      CqrsSetResultString(cqrsDDDValidationFailed,msg,result) else
+      if Rest.Add(Email,true)=0 then
+        CqrsSetResult(cqrsDataLayerError,result) else
+        CqrsSetResult(cqrsSuccess,result);
+  finally
+    Email.Free;
+  end;
+end;
+
+
+{ ****************** Mustache-Based Templating Service }
+
+{ TDDDTemplateAbstract }
+
+function TDDDTemplateAbstract.ComputeMessage(const aContext: variant;
+  const aTemplateName: RawUTF8): RawUTF8;
+var template,templateType: RawUTF8;
+    escapeInvert: boolean;
+begin
+  result := '';
+  if not RetrieveTemplate(aTemplateName,template,templateType) then
+    exit;
+  escapeInvert := false;
+  if (PosEx('html',templateType)<0) and (PosEx('xml',templateType)<0) then
+    escapeInvert := true; // may be JSON or plain TEXT
+  // TODO: compute multi-part message with optional text reduction of the html
+  result := TSynMustache.Parse(template).Render(aContext,
+    Partials,Helpers,OnTranslate,escapeInvert);
+end;
+
+destructor TDDDTemplateAbstract.Destroy;
+begin
+  fPartials.Free;
+  fCache.Free;
+  inherited;
+end;
+
+
+{ TDDDTemplateFromFolder }
+
+constructor TDDDTemplateFromFolder.Create(
+  const aTemplateFolder: TFileName; aMemoryCacheSize: integer);
+begin
+  inherited Create;
+  if aTemplateFolder='' then
+    fFolder := IncludeTrailingPathDelimiter(GetCurrentDir) else begin
+    fFolder := IncludeTrailingPathDelimiter(ExpandFileName(aTemplateFolder));
+    if not DirectoryExists(Folder) then
+      raise ESynMustache.CreateUTF8('%.Create(%) is not a valid folder',[self,Folder]);
+  end;
+  fMemoryCacheSize := aMemoryCacheSize;
+end;
+
+function TDDDTemplateFromFolder.RetrieveTemplate(
+  const aTemplateName: RawUTF8; out aTemplate, aType: RawUTF8): boolean;
+var age: integer;
+    ageInCache: PtrInt;
+    filename: TFileName;
+begin
+  result := false;
+  if (aTemplateName='') or (PosEx('..',aTemplateName)>0) or
+     (aTemplateName[2]=':') then
+    exit; // for security reasons
+  filename := fFolder+UTF8ToString(Trim(aTemplateName));
+  {$WARN SYMBOL_DEPRECATED OFF} // we don't need full precision, just some value
+  age := FileAge(filename);
+  {$WARN SYMBOL_DEPRECATED ON}
+  if age<=0 then
+    exit;
+  fSafe.Lock;
+  try
+    if fCache=nil then
+      fCache := TSynCache.Create(MemoryCacheSize);
+    aTemplate := fCache.Find(aTemplateName,@ageInCache);
+    if (aTemplate='') or (ageInCache<>age) then begin
+      aTemplate := AnyTextFileToRawUTF8(filename,true);
+      if (aTemplate<>'') or (ageInCache<>0) then begin
+        fCache.Add(aTemplate,age);
+        result := true;
+      end;
+    end else
+      result := true; // from cache
+  finally
+    fSafe.UnLock;
+  end;
+  aType := GetMimeContentType(pointer(aTemplate),length(aTemplate),filename);
+end;
+
+procedure TDDDTemplateFromFolder.SetFolder(const Value: TFileName);
+begin
+  fSafe.Lock;
+  try
+    fFolder := Value;
+    fCache.Reset;
+  finally
+    fSafe.UnLock;
+  end;
+end;
+
+procedure TDDDTemplateFromFolder.SetMemoryCacheSize(
+  const Value: integer);
+begin
+  fSafe.Lock;
+  try
+    fMemoryCacheSize := Value;
+    FreeAndNil(fCache);
+  finally
+    fSafe.UnLock;
+  end;
+end;
+
+
+{ TDDDEmailerDaemonStats }
+
+procedure TDDDEmailerDaemonStats.NewConnection;
+begin
+  fSafe^.Lock;
+  try
+    inc(fConnection);
+  finally
+    fSafe^.UnLock;
+  end;
+end;
+
+procedure TDDDEmailerDaemonStats.LockedSum(another: TSynMonitor);
+begin
+  inherited LockedSum(another);
+  if another.InheritsFrom(TDDDEmailerDaemonStats) then
+    inc(fConnection,TDDDEmailerDaemonStats(another).Connection);
+end;
+
+
+procedure TestDddInfraEmailer(serverClass: TSQLRestServerClass; test: TSynTestCase);
+var Rest: TSQLRestServer;
+    daemon: TDDDEmailerDaemon;
+    daemonLocal: IUnknown;
+    smtpMock: TInterfaceMockSpy;
+    service: TDDDEmailValidationService;
+    valid: TSQLRecordEmailValidation;
+    template: TDomUserEmailTemplate;
+    email: TSQLRecordEmailer;
+    info: variant;
+    call: TSQLRestURIParams;
+    start: Int64;
+begin
+  // generate test ORM file for DDD persistence 
+  TDDDRepositoryRestFactory.ComputeSQLRecord([
+    TDDDEmailerDaemonStats,TSQLRestServerMonitor]);
+  // we test here up to the raw SMTP socket layer
+  Rest := serverClass.CreateWithOwnModel([]);
+  try
+    template := TDomUserEmailTemplate.Create;
+    smtpMock := TInterfaceMockSpy.Create(ISMTPServerConnection,test);
+    smtpMock.ExpectsCount('SendEmail',qoGreaterThanOrEqualTo,1);
+    daemon := TDDDEmailerDaemon.CreateInjected(Rest,[],[smtpMock],[]);
+    daemonLocal := daemon; // ensure daemon won't be released when resolved
+    service := TDDDEmailValidationService.CreateInjected(Rest,[],
+      [TInterfaceStub.Create(IDomUserTemplate).
+        Returns('ComputeMessage',['body'])],
+      [daemon]);
+    with test do
+    try
+      Rest.CreateMissingTables; // after Rest.Model has been completed
+      service.SetURIForServer(Rest,'http://validationserver/root',
+        'http://officialwebsite/success&logon=%','valid');
+      Check(Rest.TableRowCount(TSQLRecordEmailValidation)=0);
+      Check(Rest.TableRowCount(TSQLRecordEmailer)=0);
+      Check(not service.IsEmailValidated('toto','toto@toto.com'));
+      template.FileName := 'any';
+      template.Subject := 'Please Validate Your Email';
+      Check(service.StartEmailValidation(template,'toto','toto@toto .com')=cqrsDDDValidationFailed);
+      Check(service.StartEmailValidation(template,' ','toto@toto.com')=cqrsDDDValidationFailed);
+      Check(service.StartEmailValidation(template,'toto','toto@toto.com')=cqrsSuccess);
+      info := service.LastErrorInfo;
+      Check(VariantToUTF8(info)='{"Msg":"Validation email sent"}');
+      Check(not service.IsEmailValidated('toto','toto@toto.com'));
+      Check(Rest.TableRowCount(TSQLRecordEmailValidation)=1);
+      Check(Rest.TableRowCount(TSQLRecordEmailer)=1);
+      valid := TSQLRecordEmailValidation.Create(Rest,1);
+      Check(valid.Logon='toto');
+      Check(valid.RequestTime<>0);
+      Check(valid.ValidationTime=0);
+      valid.Free;
+      email := TSQLRecordEmailer.Create(Rest,1);
+      Check((length(email.Recipients)=1) and (email.Recipients[0]='toto@toto.com'));
+      Check(email.SendTime=0);
+      Check(SynLZDecompress(email.MessageCompressed)='body');
+      email.Free;
+      Check(daemon.RetrieveState(info)=cqrsSuccess);
+      Check(info.stats.taskcount=0);
+      Check(info.stats.connection=0);
+      daemon.ProcessIdleDelay := 1; // speed up tests
+      Check(daemon.Start=cqrsSuccess);
+      Check(daemon.RetrieveState(info)=cqrsSuccess);
+      start := GetTickCount64;
+      repeat
+        Sleep(1);
+        email := TSQLRecordEmailer.Create(Rest,1);
+        Check((length(email.Recipients)=1) and (email.Recipients[0]='toto@toto.com'));
+        if email.SendTime<>0 then
+          break;
+        FreeAndNil(email);
+      until GetTickCount64-start>5000;
+      if CheckFailed((email<>nil)and(email.SendTime<>0),
+         'Emailer thread sent message to toto@toto.com') then
+        exit;
+      Check(SynLZDecompress(email.MessageCompressed)='body');
+      email.Free;
+      Check(daemon.RetrieveState(info)=cqrsSuccess);
+      Check(info.stats.taskcount=1);
+      Check(info.stats.connection=1);
+      Check(not service.IsEmailValidated('toto','toto@toto.com'),'no click yet');
+      call.Url := service.ComputeURIForReply('titi','toto@toto.com');
+      Check(IdemPChar(pointer(call.Url),'HTTP://VALIDATIONSERVER/ROOT/VALID/'));
+      delete(call.Url,1,24);
+      Check(IdemPChar(pointer(call.Url),'ROOT/VALID/'),'deleted host in URI');
+      call.Method := 'GET';
+      Rest.URI(call);
+      Check(call.OutStatus=HTTP_BADREQUEST,'wrong link');
+      call.Url := service.ComputeURIForReply('toto','toto@toto.com');
+      delete(call.Url,1,24);
+      call.Method := 'GET';
+      Rest.URI(call);
+      Check(call.OutStatus=HTTP_TEMPORARYREDIRECT,'emulated click on link');
+      Check(call.OutHead='Location: http://officialwebsite/success&logon=toto');
+      Check(service.IsEmailValidated('toto','toto@toto.com'),'after click');
+      Check(daemon.Stop(info)=cqrsSuccess);
+      Check(service.StartEmailValidation(template,'toto','toto@toto.com')=cqrsSuccess);
+      info := service.LastErrorInfo;
+      Check(VariantToUTF8(info)='{"Msg":"Already validated"}');
+      Check(service.StartEmailValidation(template,'toto','toto2@toto.com')=cqrsSuccess);
+      info := service.LastErrorInfo;
+      Check(VariantToUTF8(info)='{"Msg":"Validation email sent"}');
+      Check(Rest.TableRowCount(TSQLRecordEmailValidation)=1);
+      Check(Rest.TableRowCount(TSQLRecordEmailer)=2);
+      Check(daemon.Start=cqrsSuccess);
+      start := GetTickCount64;
+      repeat
+        Sleep(1);
+        email := TSQLRecordEmailer.Create(Rest,2);
+        Check((length(email.Recipients)=1) and (email.Recipients[0]='toto2@toto.com'));
+        Check(email.Subject='Please Validate Your Email');
+        if email.SendTime<>0 then
+          break;
+        FreeAndNil(email);
+      until GetTickCount64-start>5000;
+      if CheckFailed((email<>nil)and(email.SendTime<>0),
+         'Emailer thread sent message to toto2@toto.com') then
+        exit;
+      Check(SynLZDecompress(email.MessageCompressed)='body');
+      email.Free;
+      sleep(10);
+      Check(daemon.Stop(info)=cqrsSuccess);
+      Check(info.working=0);
+      smtpMock.Verify('SendEmail',qoEqualTo,2);
+    finally
+      service.Free;
+      template.Free;
+    end;
+    info := Rest.Stats.ComputeDetails;
+    test.Check(info.ServiceMethod=2,'called root/valid twice');
+    test.Check(info.Errors=1,'root/valid titi');
+    test.Check(info.Success=1,'root/valid toto');
+    call.Url := 'root/stat?withall=true';
+    Rest.URI(call);
+    test.Check(PosEx('{"valid":{',call.OutBody)>0,'stats for root/valid');
+    FileFromString(JSONReformat(call.OutBody),'stats.json');
+  finally
+    Rest.Free;
+  end;
+end;
+
+
+initialization
+  TInterfaceFactory.RegisterInterfaces([TypeInfo(ISMTPServerConnection)]);
+end.

contrib/mORMot/SQLite3/DDD/infra/dddInfraRepoUser.pas

@@ -0,0 +1,383 @@
+/// shared DDD Infrastructure: User CQRS Repository via ORM
+// - this unit is a part of the freeware Synopse mORMot framework,
+// licensed under a MPL/GPL/LGPL tri-license; version 1.18
+unit dddInfraRepoUser;
+
+{
+    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,
+  SynCrypto,
+  SynTests,
+  SynTable, // for TSynFilter and TSynValidate
+  mORMot,
+  mORMotDDD,
+  dddDomUserTypes,
+  dddDomUserCQRS;
+
+
+{ *********** Implements User Aggregate CQRS Repository via mORMot's RESTful ORM }
+
+type
+  /// implements a User CQRS Repository via mORMot's RESTful ORM
+  // - this class will use a supplied TSQLRest instance to persist TUser
+  // Aggregate Roots, following the IDomUserCommand CQRS methods
+  // - each TUser aggregate will be mapped into a TSQLRecordUser ORM table
+  TInfraRepoUser = class(TDDDRepositoryRestCommand,IDomUserCommand,IDomUserQuery)
+  public
+    function SelectByLogonName(const aLogonName: RawUTF8): TCQRSResult;
+    function SelectByEmailValidation(aValidationState: TDomUserEmailValidation): TCQRSResult;
+    function SelectByLastName(const aName: TLastName; aStartWith: boolean): TCQRSResult;
+    function SelectAll: TCQRSResult;
+    function Get(out aAggregate: TUser): TCQRSResult;
+    function GetAll(out aAggregates: TUserObjArray): TCQRSResult;
+    function GetNext(out aAggregate: TUser): TCQRSResult;
+    function Add(const aAggregate: TUser): TCQRSResult;
+    function Update(const aUpdatedAggregate: TUser): TCQRSResult;
+    function HowManyValidatedEmail: integer;
+  end;
+
+  /// implements a Factory of User CQRS Repositories via mORMot's RESTful ORM
+  // - this class will associate the TUser Aggregate Root with a TSQLRecordUser
+  // ORM table, as managed in a given TSQLRest instance
+  TInfraRepoUserFactory = class(TDDDRepositoryRestFactory)
+  public
+    /// initialize the association with the ORM
+    constructor Create(aRest: TSQLRest; aOwner: TDDDRepositoryRestManager=nil); reintroduce;
+  	/// perform some tests on this Factory/Repository implementation
+    class procedure RegressionTests(test: TSynTestCase);
+  end;
+
+
+{ *********** Person / User / Customer Persistence ORM classes }
+
+type
+  /// ORM class able to store a TPerson object
+  // - the TPerson.Name property has been flattened to Name_* columns as
+  // expected by TDDDRepositoryRestFactory.ComputeMapping
+  TSQLRecordPerson = class(TSQLRecord)
+  protected
+    fFirst: RawUTF8;
+    fMiddle: RawUTF8;
+    fLast: RawUTF8;
+    fBirthDate: TDateTime;
+  published
+    property Name_First: RawUTF8 read fFirst write fFirst;
+    property Name_Middle: RawUTF8 read fMiddle write fMiddle;
+    property Name_Last: RawUTF8 read fLast write fLast;
+    property Birth: TDateTime read fBirthDate;
+  end;
+
+  /// ORM class able to store a TPersonContactable object
+  // - the TPersonContactable.Address property has been flattened to Address_*
+  // columns as expected by TDDDRepositoryRestFactory.ComputeMapping
+  TSQLRecordPersonContactable = class(TSQLRecordPerson)
+  protected
+    fStreet1: RawUTF8;
+    fStreet2: RawUTF8;
+    fCityArea: RawUTF8;
+    fCity: RawUTF8;
+    fRegion: RawUTF8;
+    fCode: RawUTF8;
+    fCountry: integer;
+    fEmail: RawUTF8;
+    fPhone1: RawUTF8;
+    fPhone2: RawUTF8;
+  published
+    property Address_Street1: RawUTF8 read fStreet1 write fStreet1;
+    property Address_Street2: RawUTF8 read fStreet2 write fStreet2;
+    property Address_CityArea: RawUTF8 read fCityArea write fCityArea;
+    property Address_City: RawUTF8 read fCity write fCity;
+    property Address_Region: RawUTF8 read fRegion write fRegion;
+    property Address_Code: RawUTF8 read fCode write fCode;
+    property Address_Country: integer read fCountry;
+    property Phone1: RawUTF8 read fPhone1 write fPhone1;
+    property Phone2: RawUTF8 read fPhone2 write fPhone2;
+    property Email: RawUTF8 read fEmail write fEmail;
+  end;
+
+  /// ORM class used to persist a TUser domain aggregate
+  TSQLRecordUser = class(TSQLRecordPersonContactable)
+  protected
+    fLogonName: RawUTF8;
+    fEmailValidated: TDomUserEmailValidation;
+  published
+    property LogonName: RawUTF8 read fLogonName write fLogonName stored AS_UNIQUE;
+    property EmailValidated: TDomUserEmailValidation read fEmailValidated write fEmailValidated;
+  end;
+
+
+  
+implementation
+
+{ TInfraRepoUser }
+
+{ in practice, implementing a I*Command interface mainly consist in calling
+  the various TDDDRepositoryRestCommand.ORM*() methods, which would perform
+  all process on the REST instance using the TSQLRecordUser table mapped to
+  the TUser aggregate root
+  - purpose of this I*Command interface is to use the loosely typed
+    TDDDRepositoryRestCommand.ORM*() methods to match the exact needs of
+    the DDD Aggregate class
+  - it would also hide the persistence details so that we would be able
+    to ignore e.g. what a primary key is, and avoid the "anemic domain model"
+    anti-pattern, which is basically CRUD in disguise }
+
+function TInfraRepoUser.SelectByLogonName(
+  const aLogonName: RawUTF8): TCQRSResult;
+begin
+  result := ORMSelectOne('LogonName=?',[aLogonName],(aLogonName=''));
+end;
+
+function TInfraRepoUser.SelectByEmailValidation(
+  aValidationState: TDomUserEmailValidation): TCQRSResult;
+begin
+  result := ORMSelectAll('EmailValidated=?',[ord(aValidationState)]);
+end;
+
+function TInfraRepoUser.SelectByLastName(const aName: TLastName;
+  aStartWith: boolean): TCQRSResult;
+begin
+  if aStartWith then
+    result := ORMSelectAll('Name_Last LIKE ?',[aName+'%'],(aName='')) else
+    result := ORMSelectAll('Name_Last=?',[aName],(aName=''));
+end;
+
+function TInfraRepoUser.SelectAll: TCQRSResult;
+begin
+  result := ORMSelectAll('',[]);
+end;
+
+function TInfraRepoUser.Get(out aAggregate: TUser): TCQRSResult;
+begin
+  result := ORMGetAggregate(aAggregate);
+end;
+
+function TInfraRepoUser.GetAll(
+  out aAggregates: TUserObjArray): TCQRSResult;
+begin
+  result := ORMGetAllAggregates(aAggregates);
+end;
+
+function TInfraRepoUser.GetNext(out aAggregate: TUser): TCQRSResult;
+begin
+  result := ORMGetNextAggregate(aAggregate);
+end;
+
+function TInfraRepoUser.Add(const aAggregate: TUser): TCQRSResult;
+begin
+  result := ORMAdd(aAggregate);
+end;
+
+function TInfraRepoUser.Update(
+  const aUpdatedAggregate: TUser): TCQRSResult;
+begin
+  result := ORMUpdate(aUpdatedAggregate);
+end;
+
+function TInfraRepoUser.HowManyValidatedEmail: integer;
+begin
+  if ORMSelectCount('EmailValidated=%',[ord(evValidated)],[],result)<>cqrsSuccess then
+    result := 0;
+end;
+
+
+{ TInfraRepoUserFactory }
+
+constructor TInfraRepoUserFactory.Create(aRest: TSQLRest;
+  aOwner: TDDDRepositoryRestManager);
+begin
+  inherited Create(IDomUserCommand,TInfraRepoUser,TUser,aRest,TSQLRecordUser,aOwner);
+  AddFilterOrValidate(['*'],TSynFilterTrim.Create);
+  AddFilterOrValidate(['LogonName'],TSynValidateNonVoidText.Create);
+end;
+
+class procedure TInfraRepoUserFactory.RegressionTests(test: TSynTestCase);
+
+procedure TestOne(Rest: TSQLRest);
+const MAX=1000;
+      MOD_EMAILVALID=ord(high(TDomUserEmailValidation))+1;
+var cmd: IDomUserCommand;
+    qry: IDomUserQuery;
+    user: TUser;
+    users: TUserObjArray;
+    i,usersCount: integer;
+    itext: RawUTF8;
+    v: TDomUserEmailValidation;
+    count: array[TDomUserEmailValidation] of integer;
+    msg: string;
+begin
+  test.Check(Rest.Services.Resolve(IDomUserCommand,cmd));
+  user := TUser.Create;
+  try
+    for i := 1 to MAX do begin
+      UInt32ToUtf8(i,itext);
+      user.LogonName := '  '+itext; // left '  ' to test TSynFilterTrim.Create
+      user.EmailValidated := TDomUserEmailValidation(i mod MOD_EMAILVALID);
+      user.Name.Last := 'Last'+itext;
+      user.Name.First := 'First'+itext;
+      user.Address.Street1 := 'Street '+itext;
+      user.Address.Country.Alpha2 := 'fr';
+      user.Phone1 := itext;
+      test.check(cmd.Add(user)=cqrsSuccess);
+    end;
+    test.check(cmd.Commit=cqrsSuccess);
+  finally
+    user.Free;
+  end; 
+  user := TUser.Create;
+  try
+    test.Check(Rest.Services.Resolve(IDomUserQuery,qry));
+    test.Check(qry.GetCount=0);
+    for i := 1 to MAX do begin
+      UInt32ToUtf8(i,itext);
+      test.Check(qry.SelectByLogonName(itext)=cqrsSuccess);
+      test.Check(qry.GetCount=1);
+      test.Check(qry.Get(user)=cqrsSuccess);
+      test.Check(qry.GetCount=1);
+      test.Check(user.LogonName=itext);
+      test.Check(user.EmailValidated=TDomUserEmailValidation(i mod MOD_EMAILVALID));
+      test.Check(user.Name.Last='Last'+itext);
+      test.Check(user.Name.First='First'+itext);
+      test.Check(user.Address.Street1='Street '+itext);
+      test.Check(user.Address.Country.Alpha2='FR');
+      test.Check(user.Phone1=itext);
+    end;
+    test.Check(Rest.Services.Resolve(IDomUserCommand,cmd));
+    try
+      usersCount := 0;
+      for v := low(TDomUserEmailValidation) to high(TDomUserEmailValidation) do begin
+        test.Check(cmd.SelectByEmailValidation(v)=cqrsSuccess);
+        ObjArrayClear(users); // should be done, otherwise memory leak
+        test.Check(cmd.GetAll(users)=cqrsSuccess);
+        test.Check(length(users)>=MAX div MOD_EMAILVALID);
+        count[v] := length(users);
+        inc(usersCount,length(users));
+        for i := 0 to high(users) do begin
+          test.Check(users[i].EmailValidated=v);
+          test.Check(users[i].LogonName=users[i].Phone1);
+          test.Check(users[i].Name.First='First'+users[i].LogonName);
+        end;
+      end;
+      test.Check(cmd.DeleteAll=cqrsSuccess,'delete all evFailed');
+      test.check(cmd.Commit=cqrsSuccess);
+      ObjArrayClear(users);
+      test.Check(cmd.SelectAll=cqrsSuccess);
+      test.Check(cmd.GetAll(users)=cqrsSuccess);
+      test.Check(length(users)=usersCount-count[evFailed]);
+      for i := 0 to high(users) do begin
+        test.Check(users[i].LogonName=users[i].Phone1);
+        test.Check(users[i].Name.First='First'+users[i].LogonName);
+        test.Check(users[i].Address.Country.Iso=250);
+      end;
+    finally
+      ObjArrayClear(users);
+    end;
+    test.Check(Rest.Services.Resolve(IDomUserCommand,cmd));
+    for v := low(TDomUserEmailValidation) to high(TDomUserEmailValidation) do begin
+      test.Check(cmd.SelectByEmailValidation(v)=cqrsSuccess);
+      if v=evFailed then
+        test.Check(cmd.GetCount=0) else
+        test.Check(cmd.GetCount=count[v]);
+      i := 0;
+      while cmd.GetNext(user)=cqrsSuccess do begin
+        test.Check(user.EmailValidated=v);
+        test.Check(user.Name.First='First'+user.LogonName);
+        test.Check(user.Address.Country.Iso=250);
+        inc(i);
+      end;
+      test.Check(i=cmd.GetCount);
+    end;
+    test.Check(cmd.HowManyValidatedEmail=count[evValidated]);
+    user.LogonName := '';
+    test.check(cmd.Add(user)=cqrsDDDValidationFailed);
+    test.check(cmd.GetLastError=cqrsDDDValidationFailed);
+    msg := cmd.GetLastErrorInfo.msg;
+    test.check(pos('TUser.LogonName',msg)>0,msg);
+  finally
+    user.Free;
+  end;
+end;
+
+var RestServer: TSQLRestServerFullMemory;
+    RestClient: TSQLRestClientURI;
+begin
+  RestServer := TSQLRestServerFullMemory.CreateWithOwnModel([TSQLRecordUser]);
+  try // first try directly on server side
+    RestServer.ServiceContainer.InjectResolver([TInfraRepoUserFactory.Create(RestServer)],true);
+    TestOne(RestServer); // sub function will ensure that all I*Command are released
+  finally
+    RestServer.Free;
+  end;
+  RestServer := TSQLRestServerFullMemory.CreateWithOwnModel([TSQLRecordUser]);
+  try // then try from a client-server process
+    RestServer.ServiceContainer.InjectResolver([TInfraRepoUserFactory.Create(RestServer)],true);
+    RestServer.ServiceDefine(TInfraRepoUser,[IDomUserCommand,IDomUserQuery],sicClientDriven);
+    test.Check(RestServer.ExportServer);
+    RestClient := TSQLRestClientURIDll.Create(TSQLModel.Create(RestServer.Model),@URIRequest);
+    try
+      RestClient.Model.Owner := RestClient;
+      RestClient.ServiceDefine([IDomUserCommand],sicClientDriven);
+      TestOne(RestServer);
+      RestServer.DropDatabase;
+      USEFASTMM4ALLOC := true; // for slightly faster process
+      TestOne(RestClient);
+    finally
+      RestClient.Free;
+    end;
+  finally
+    RestServer.Free;
+  end;
+end;
+
+
+
+end.

contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminDB.dfm

@@ -0,0 +1,170 @@
+object DBFrame: TDBFrame
+  Left = 0
+  Top = 0
+  Width = 689
+  Height = 339
+  TabOrder = 0
+  object spl2: TSplitter
+    Left = 169
+    Top = 0
+    Height = 339
+  end
+  object pnlRight: TPanel
+    Left = 172
+    Top = 0
+    Width = 517
+    Height = 339
+    Align = alClient
+    TabOrder = 0
+    object spl1: TSplitter
+      Left = 1
+      Top = 113
+      Width = 515
+      Height = 3
+      Cursor = crVSplit
+      Align = alTop
+    end
+    object pnlTop: TPanel
+      Left = 1
+      Top = 1
+      Width = 515
+      Height = 112
+      Align = alTop
+      Constraints.MinHeight = 100
+      TabOrder = 0
+      DesignSize = (
+        515
+        112)
+      object mmoSQL: TMemo
+        Left = 0
+        Top = 0
+        Width = 454
+        Height = 111
+        Anchors = [akLeft, akTop, akRight, akBottom]
+        Font.Charset = DEFAULT_CHARSET
+        Font.Color = clWindowText
+        Font.Height = -12
+        Font.Name = 'Consolas'
+        Font.Style = []
+        ParentFont = False
+        TabOrder = 0
+      end
+      object btnExec: TButton
+        Left = 461
+        Top = 8
+        Width = 43
+        Height = 25
+        Hint = 'Execute the SQL statement (F9)'
+        Anchors = [akTop, akRight]
+        Caption = 'Exec'
+        ParentShowHint = False
+        ShowHint = True
+        TabOrder = 1
+        OnClick = btnExecClick
+      end
+      object btnHistory: TButton
+        Left = 461
+        Top = 40
+        Width = 43
+        Height = 25
+        Hint = 'View SQL log history (Ctrl+H)'
+        Anchors = [akTop, akRight]
+        Caption = 'History'
+        ParentShowHint = False
+        ShowHint = True
+        TabOrder = 2
+        OnClick = btnHistoryClick
+      end
+      object btnCmd: TButton
+        Left = 461
+        Top = 72
+        Width = 43
+        Height = 25
+        Hint = 'Launch a pseudo-command (F5)'
+        Anchors = [akTop, akRight]
+        Caption = '#cmd'
+        ParentShowHint = False
+        PopupMenu = pmCmd
+        ShowHint = True
+        TabOrder = 3
+        OnClick = btnCmdClick
+      end
+    end
+    object drwgrdResult: TDrawGrid
+      Left = 1
+      Top = 116
+      Width = 515
+      Height = 117
+      Align = alTop
+      Font.Charset = DEFAULT_CHARSET
+      Font.Color = clWindowText
+      Font.Height = -12
+      Font.Name = 'Tahoma'
+      Font.Style = []
+      ParentFont = False
+      TabOrder = 1
+      Visible = False
+      OnClick = drwgrdResultClick
+    end
+  end
+  object pnlLeft: TPanel
+    Left = 0
+    Top = 0
+    Width = 169
+    Height = 339
+    Align = alLeft
+    TabOrder = 1
+    object lstTables: TListBox
+      Left = 1
+      Top = 45
+      Width = 167
+      Height = 293
+      Align = alClient
+      Font.Charset = DEFAULT_CHARSET
+      Font.Color = clWindowText
+      Font.Height = -12
+      Font.Name = 'Tahoma'
+      Font.Style = []
+      ItemHeight = 14
+      ParentFont = False
+      TabOrder = 0
+      OnDblClick = lstTablesDblClick
+    end
+    object pnlLeftTop: TPanel
+      Left = 1
+      Top = 1
+      Width = 167
+      Height = 44
+      Align = alTop
+      TabOrder = 1
+      DesignSize = (
+        167
+        44)
+      object edtLabels: TEdit
+        Left = 5
+        Top = 4
+        Width = 156
+        Height = 21
+        Hint = 'Incremental Search'
+        Anchors = [akLeft, akTop, akRight]
+        ParentShowHint = False
+        ShowHint = True
+        TabOrder = 0
+        OnChange = edtLabelsChange
+      end
+      object chkTables: TCheckBox
+        Left = 8
+        Top = 26
+        Width = 156
+        Height = 17
+        Caption = 'chkTables'
+        TabOrder = 1
+        Visible = False
+      end
+    end
+  end
+  object pmCmd: TPopupMenu
+    Left = 648
+    Top = 80
+  end
+end

contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminDB.pas

@@ -0,0 +1,695 @@
+unit dddToolsAdminDB;
+
+interface
+
+uses
+  Windows,
+  Messages,
+  SysUtils,
+  Variants,
+  Classes,
+  Graphics,
+  Controls,
+  Forms,
+  Dialogs,
+  Grids,
+  StdCtrls,
+  ExtCtrls,
+  Menus,
+  SynMemoEx,
+  SynCommons,
+  mORMot,
+  mORMotDDD,
+  mORMotHttpClient,
+  mORMotUI,
+  SynMustache;
+
+type
+  TDBFrame = class;
+  TOnExecute = function(Sender: TDBFrame; const SQL, Content: RawUTF8): boolean of object;
+  
+  TDBFrame = class(TFrame)
+    pnlRight: TPanel;
+    pnlTop: TPanel;
+    mmoSQL: TMemo;
+    btnExec: TButton;
+    drwgrdResult: TDrawGrid;
+    spl1: TSplitter;
+    spl2: TSplitter;
+    btnHistory: TButton;
+    btnCmd: TButton;
+    pmCmd: TPopupMenu;
+    pnlLeft: TPanel;
+    lstTables: TListBox;
+    pnlLeftTop: TPanel;
+    edtLabels: TEdit;
+    chkTables: TCheckBox;
+    procedure lstTablesDblClick(Sender: TObject); virtual;
+    procedure btnExecClick(Sender: TObject); virtual;
+    procedure drwgrdResultClick(Sender: TObject); virtual;
+    procedure btnHistoryClick(Sender: TObject); virtual;
+    procedure btnCmdClick(Sender: TObject); virtual;
+    procedure edtLabelsChange(Sender: TObject);
+  protected
+    fGridToCellRow: integer;
+    fGridToCellVariant: variant;
+    fJson: RawJSON;
+    fSQL, fPreviousSQL: RawUTF8;
+    fSQLLogFile: TFileName;
+    function ExecSQL(const SQL: RawUTF8): RawUTF8;
+    function OnText(Sender: TSQLTable; FieldIndex, RowIndex: Integer;
+      var Text: string): boolean;
+    procedure OnCommandsToGridAdd(const Item: TSynNameValueItem; Index: PtrInt);
+    function OnGridToCell(Sender: TSQLTable; Row, Field: integer;
+      HumanFriendly: boolean): RawJSON;
+    procedure LogClick(Sender: TObject);
+    procedure LogDblClick(Sender: TObject);
+    procedure LogSearch(Sender: TObject);
+  public
+    DatabaseName: RawUTF8;
+    mmoResult: TMemoEx; // initialized by code from SynMemoEx.pas
+    Grid: TSQLTableToGrid;
+    GridLastTableName: RawUTF8;
+    Client: TSQLHttpClientWebsockets;
+    Admin: IAdministratedDaemon;
+    Tables: TStringList;
+    AssociatedModel: TSQLModel;
+    AssociatedServices: TInterfaceFactoryObjArray;
+    // Add(cmdline/table,nestedobject,-1=text/0..N=nestedarray#)
+    CommandsToGrid: TSynNameValue;
+    TableDblClickSelect: TSynNameValue;
+    TableDblClickOrderByIdDesc: boolean;
+    TableDblClickOrderByIdDescCSV: string;
+    SavePrefix: TFileName;
+    OnBeforeExecute: TOnExecute;
+    OnAfterExecute: TOnExecute;
+    constructor Create(AOwner: TComponent); override;
+    procedure EnableChkTables(const aCaption: string);
+    procedure Open; virtual;
+    procedure FillTables(const customcode: string); virtual;
+    procedure AddSQL(SQL: string; AndExec: boolean);
+    procedure SetResult(const JSON: RawUTF8); virtual;
+    function NewCmdPopup(const c: string; NoCmdTrim: boolean): TMenuItem;
+    destructor Destroy; override;
+  end;
+
+  TDBFrameClass = class of TDBFrame;
+
+  TDBFrameDynArray = array of TDBFrame;
+
+implementation
+
+{$R *.dfm}
+
+const
+  WRAPPER_TEMPLATE = '{{#soa.services}}'#13#10'{{#methods}}'#13#10 +
+    '#get {{uri}}/{{methodName}}{{#hasInParams}}?{{#args}}{{#dirInput}}{{argName}}={{typeSource}}' +
+    '{{#commaInSingle}}&{{/commaInSingle}}{{/dirInput}}{{/args}}{{/hasInParams}}'#13#10 +
+    '{{#hasOutParams}}'#13#10' { {{#args}}{{#dirOutput}}{{jsonQuote argName}}: {{typeSource}}' +
+    '{{#commaOutResult}},{{/commaOutResult}} {{/dirOutput}}{{/args}} }'#13#10 +
+    '{{/hasOutParams}}{{/methods}}'#13#10'{{/soa.services}}'#13#10'{{#enumerates}}{{name}}: ' +
+    '{{#values}}{{EnumTrim .}}={{-index0}}{{^-last}}, {{/-last}}{{/values}}'#13#10'{{/enumerates}}';
+
+{ TDBFrame }
+
+constructor TDBFrame.Create(AOwner: TComponent);
+begin
+  inherited;
+  fSQLLogFile := ChangeFileExt(ExeVersion.ProgramFileName, '.history');
+  mmoResult := TMemoEx.Create(self);
+  mmoResult.Name := 'mmoResult';
+  mmoResult.Parent := pnlRight;
+  mmoResult.Align := alClient;
+  mmoResult.Font.Height := -11;
+  mmoResult.Font.Name := 'Consolas';
+  mmoResult.ReadOnly := true;
+  mmoResult.ScrollBars := ssVertical;
+  mmoResult.Text := '';
+  mmoResult.RightMargin := 130;
+  mmoResult.RightMarginVisible := true;
+  mmoResult.OnGetLineAttr := mmoResult.JSONLineAttr;
+  pnlLeftTop.Height := 30;
+  Tables := TStringList.Create;
+  TableDblClickSelect.Init(false);
+  CommandsToGrid.Init(false);
+  CommandsToGrid.OnAfterAdd := OnCommandsToGridAdd;
+end;
+
+procedure TDBFrame.Open;
+begin
+  FillTables('');
+  edtLabelsChange(nil);
+  mmoSQL.Text := '#help';
+  btnExecClick(nil);
+  mmoSQL.Text := '';
+  mmoResult.Text := '';
+end;
+
+procedure TDBFrame.FillTables(const customcode: string);
+var
+  i: integer;
+  aTables: TRawUTF8DynArray;
+begin
+  drwgrdResult.Align := alClient;
+  aTables := Admin.DatabaseTables(DatabaseName);
+  Tables.Clear;
+  Tables.BeginUpdate;
+  try
+    for i := 0 to high(aTables) do
+      Tables.Add(UTF8ToString(aTables[i]));
+  finally
+    Tables.EndUpdate;
+  end;
+end;
+
+procedure TDBFrame.lstTablesDblClick(Sender: TObject);
+var
+  i: integer;
+  table, fields, sql, orderby: string;
+begin
+  i := lstTables.ItemIndex;
+  if i < 0 then
+    exit;
+  table := lstTables.Items[i];
+  fields := string(TableDblClickSelect.Value(RawUTF8(table)));
+  if fields='' then
+    fields := '*' else begin
+    i := Pos(' order by ', fields);
+    if i > 0 then begin
+      orderby := copy(fields, i, maxInt);
+      Setlength(fields, i - 1);
+    end;
+  end;
+  sql := 'select '+fields+' from ' + table;
+  if orderby <> '' then
+    sql := sql + orderby
+  else begin
+    if TableDblClickOrderByIdDesc or ((TableDblClickOrderByIdDescCSV <> '') and
+       (Pos(table + ',', TableDblClickOrderByIdDescCSV + ',') > 0)) then
+      sql := sql + ' order by id desc';
+    sql := sql + ' limit 1000';
+  end;
+  AddSQL(sql, true);
+end;
+
+procedure TDBFrame.SetResult(const JSON: RawUTF8);
+begin
+  FreeAndNil(Grid);
+  drwgrdResult.Hide;
+  mmoResult.Align := alClient;
+  mmoResult.WordWrap := false;
+  mmoResult.ScrollBars := ssBoth;
+  mmoResult.RightMarginVisible := false;
+  if (JSON = '') or (JSON[1] in ['A'..'Z', '#']) then
+    mmoResult.OnGetLineAttr := nil
+  else
+    mmoResult.OnGetLineAttr := mmoResult.JSONLineAttr;
+  mmoResult.Text := UTF8ToString(StringReplaceTabs(JSON, '    '));
+  mmoResult.SetCaret(0, 0);
+  mmoResult.TopRow := 0;
+  fJson := '';
+end;
+
+procedure TDBFrame.OnCommandsToGridAdd(const Item: TSynNameValueItem;
+  Index: PtrInt);
+begin
+  pmCmd.Items.Insert(0, NewCmdPopup(UTF8ToString(Item.Name), true));
+end;
+
+function TDBFrame.NewCmdPopup(const c: string; NoCmdTrim: boolean): TMenuItem;
+var
+  cmd, name, lastname: string;
+  i, ext, num: integer;
+  res: TDocVariantData;
+  sub, subpar, subarch: TMenuItem;
+begin
+  result := TMenuItem.Create(self);
+  if length(c) > 40 then
+    result.Caption := copy(c, 1, 37) + '...'
+  else
+    result.Caption := c;
+  if NoCmdTrim then
+    cmd := c
+  else begin
+    i := Pos(' ', c);
+    if i > 0 then
+      cmd := copy(c, 1, i) + '*'
+    else begin
+      i := Pos('(', c);
+      if i > 0 then
+        cmd := copy(c, 1, i) + '*)'
+      else
+        cmd := c;
+    end;
+  end;
+  result.Hint := cmd;
+  if (cmd = '#log *') or (cmd = '#db *') then begin // log/db files in sub-menus
+    res.InitJSON(ExecSQL(StringToUTF8(cmd)), JSON_OPTIONS_FAST);
+    SetLength(cmd, length(cmd) - 1);
+    subpar := result;
+    subarch := nil;
+    if res.Kind = dvArray then
+      for i := 0 to res.Count - 1 do begin
+        name := res.Values[i].Name;
+        if name = lastname then
+          continue; // circumvent FindFiles() bug with *.dbs including *.dbsynlz
+        lastname := name;
+        case GetFileNameExtIndex(name, 'dbs,dbsynlz') of
+          0: begin // group sharded database files by 20 in sub-menus    
+            ext := Pos('.dbs', name);
+            if (ext > 4) and TryStrToInt(Copy(name, ext - 4, 4), num) then
+              if (subpar = result) or (num mod 20 = 0) then begin
+                subpar := NewCmdPopup(cmd + name + ' ...', true);
+                subpar.OnClick := nil;
+                result.Add(subpar);
+              end;
+          end;
+          1: begin // group database backup files in a dedicated sub-menu
+            if subarch = nil then begin
+              subarch := NewCmdPopup(cmd + '*.dbsynlz ...', true);
+              subarch.OnClick := nil;
+              result.Add(subarch);
+            end;
+            subpar := subarch;
+          end;
+          else
+            subpar := result;
+        end;
+        sub := NewCmdPopup(cmd + name, true);
+        if cmd = '#log ' then
+          sub.Caption := sub.Caption + '  ' + res.Values[i].TimeStamp
+        else
+          sub.Caption := FormatString('%  %', [sub.Caption, KB(res.Values[i].Size)]);
+        subpar.Add(sub);
+      end;
+  end
+  else
+    result.OnClick := btnExecClick;
+end;
+
+procedure TDBFrame.btnExecClick(Sender: TObject);
+var
+  res, ctyp, execTime: RawUTF8;
+  mmo, cmd, fn, local: string;
+  SelStart, SelLength, cmdToGrid, i: integer;
+  table: TSQLTable;
+  tables: TSQLRecordClassDynArray;
+  P: PUTF8Char;
+  exec: TServiceCustomAnswer;
+  ctxt: variant;
+  timer: TPrecisionTimer;
+begin
+  if (Sender <> nil) and Sender.InheritsFrom(TMenuItem) then begin
+    mmo := TMenuItem(Sender).Hint;
+    mmoSQL.Text := mmo;
+    i := Pos('*', mmo);
+    if (i > 0) and (mmo[1] = '#') then begin
+      mmoSQL.SelStart := i - 1;
+      mmoSQL.SelLength := 1;
+      mmoSQL.SetFocus;
+      exit;
+    end;
+  end;
+  SelStart := mmoSQL.SelStart;
+  SelLength := mmoSQL.SelLength;
+  if SelLength > 10 then
+    mmo := mmoSQL.SelText
+  else
+    mmo := mmoSQL.Lines.Text;
+  fSQL := Trim(StringToUTF8(mmo));
+  if fSQL = '' then
+    exit;
+  if IdemPropNameU(fSQL, '#client') then begin
+    fJson := ObjectToJSON(Client);
+  end
+  else if Assigned(OnBeforeExecute) and not OnBeforeExecute(self, fSQL, '') then
+    fJson := '"You are not allowed to execute this command for security reasons"'
+  else begin
+    Screen.Cursor := crHourGlass;
+    try
+      try
+        timer.Start;
+        exec := Admin.DatabaseExecute(DatabaseName, fSQL);
+        execTime := timer.Stop;
+        ctyp := FindIniNameValue(pointer(exec.Header), HEADER_CONTENT_TYPE_UPPER);
+        if IdemPChar(pointer(exec.Content), '<HEAD>') then begin // HTML in disguise
+          i := PosI('<BODY>', exec.content);
+          if i = 0 then
+            fJson := exec.Content
+          else
+            fJson := copy(exec.Content, i, maxInt);
+        end
+        else
+        if (ctyp = '') or IdemPChar(pointer(ctyp), JSON_CONTENT_TYPE_UPPER) then
+          fJson := exec.Content
+        else
+        if IdemPropNameU(ctyp, BINARY_CONTENT_TYPE) then begin
+          fn := UTF8ToString(trim(FindIniNameValue(pointer(exec.Header), 'FILENAME:')));
+          if (fn <> '') and (exec.Content <> '') then
+            with TSaveDialog.Create(self) do
+            try
+              Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofEnableSizing];
+              InitialDir := GetShellFolderPath(CSIDL_DOCUMENTS);
+              FileName := SavePrefix + fn;
+              if Execute then begin
+                local := FileName;
+                FileFromString(exec.Content, local);
+              end;
+            finally
+              Free;
+            end;
+          fJson := JSONEncode(['file', fn, 'size', length(exec.Content),
+            'type', ctyp, 'localfile', local]);
+        end
+        else
+          fJson := FormatUTF8('"Unknown content-type: %"', [ctyp]);
+      except
+        on E: Exception do
+          fJson := ObjectToJSON(E);
+      end;
+    finally
+      Screen.Cursor := crDefault;
+    end;
+  end;
+  FreeAndNil(Grid);
+  GridLastTableName := '';
+  fGridToCellRow := 0;
+  cmdToGrid := CommandsToGrid.Find(fSQL);
+  if (fSQL[1] = '#') and
+     ((cmdToGrid < 0) or (CommandsToGrid.List[cmdToGrid].Tag < 0))  then begin
+    if fJson <> '' then
+      if IdemPropNameU(fSQL, '#help') then begin
+        fJson := Trim(UnQuoteSQLString(fJson)) + '|#client'#13#10;
+        res := StringReplaceAll(fJson, '|', #13#10' ');
+        if pmCmd.Items.Count = 0 then begin
+          P := pointer(res);
+          while P <> nil do begin
+            cmd := UTF8ToString(Trim(GetNextLine(P, P)));
+            if (cmd <> '') and (cmd[1] = '#') then
+              pmCmd.Items.Add(NewCmdPopup(cmd, false));
+          end;
+        end;
+      end
+      else if IdemPropNameU(fSQL, '#wrapper') then begin
+        _Json(fJson,ctxt,JSON_OPTIONS_FAST);
+        res := TSynMustache.Parse(WRAPPER_TEMPLATE).Render(ctxt, nil,
+          TSynMustache.HelpersGetStandardList, nil, true);
+      end
+      else begin
+        JSONBufferReformat(pointer(fJson), res, jsonUnquotedPropName);
+        if (res = '') or (res = 'null') then
+          res := fJson;
+      end;
+    if Assigned(OnAfterExecute) then
+      OnAfterExecute(self,fSQL,res);
+    SetResult(res);
+  end
+  else begin
+    mmoResult.Text := '';
+    mmoResult.SetCaret(0, 0);
+    mmoResult.TopRow := 0;
+    mmoResult.Align := alBottom;
+    mmoResult.WordWrap := true;
+    mmoResult.ScrollBars := ssVertical;
+    mmoResult.Height := 100;
+    if AssociatedModel <> nil then
+      tables := AssociatedModel.Tables;
+    if cmdToGrid >= 0 then begin
+      GridLastTableName := CommandsToGrid.List[cmdToGrid].Name;
+      if isSelect(pointer(GridLastTableName)) then
+        GridLastTableName := GetTableNameFromSQLSelect(GridLastTableName,false);
+      if CommandsToGrid.List[cmdToGrid].Value <> '' then begin
+        // display a nested object in the grid
+        P := JsonObjectItem(pointer(fJson), CommandsToGrid.List[cmdToGrid].Value);
+        if CommandsToGrid.List[cmdToGrid].Tag > 0 then
+          P := JSONArrayItem(P, CommandsToGrid.List[cmdToGrid].Tag - 1);
+        if P <> nil then
+          GetJSONItemAsRawJSON(P, RawJSON(fJSON));
+      end;
+    end
+    else
+      GridLastTableName := GetTableNameFromSQLSelect(fSQL, false);
+    table := TSQLTableJSON.CreateFromTables(tables, fSQL, pointer(fJson), length(fJson));
+    Grid := TSQLTableToGrid.Create(drwgrdResult, table, nil);
+    Grid.SetAlignedByType(sftCurrency, alRight);
+    Grid.SetFieldFixedWidth(100);
+    Grid.FieldTitleTruncatedNotShownAsHint := true;
+    Grid.OnValueText := OnText;
+    Grid.Table.OnExportValue := OnGridToCell;
+    if Assigned(OnAfterExecute) then
+      OnAfterExecute(self, fSQL, fJSON);
+    drwgrdResult.Options := drwgrdResult.Options - [goRowSelect];
+    drwgrdResult.Show;
+    mmoResult.OnGetLineAttr := mmoResult.JSONLineAttr;
+    mmoResult.Text := FormatString(#13#10' Returned % row(s), as % in %',
+      [table.RowCount, KB(fJson), execTime]);
+  end;
+  if Sender <> nil then begin
+    mmoSQL.SelStart := SelStart;
+    mmoSQL.SelLength := SelLength;
+    mmoSQL.SetFocus;
+  end;
+  if ((fJson <> '') or ((fSQL[1] = '#') and (PosEx(' ', fSQL) > 0))) and
+     (fSQL <> fPreviousSQL) then begin
+    AppendToTextFile(fSQL, fSQLLogFile);
+    fPreviousSQL := fSQL;
+  end;
+end;
+
+destructor TDBFrame.Destroy;
+begin
+  FreeAndNil(Grid);
+  FreeAndNil(AssociatedModel);
+  FreeAndNil(Tables);
+  inherited;
+end;
+
+function TDBFrame.OnText(Sender: TSQLTable; FieldIndex, RowIndex: Integer;
+  var Text: string): boolean;
+begin
+  if Sender.FieldType(FieldIndex) in [sftBoolean] then
+    result := false
+  else begin
+    Text := Sender.GetString(RowIndex, FieldIndex); // display the value as such
+    result := true;
+  end;
+end;
+
+function TDBFrame.OnGridToCell(Sender: TSQLTable; Row, Field: integer;
+  HumanFriendly: boolean): RawJSON;
+var
+  methodName: RawUTF8;
+  serv, m: integer;
+begin
+  if fGridToCellRow <> Row then begin
+    Sender.ToDocVariant(Row, fGridToCellVariant, JSON_OPTIONS_FAST, true, true, true);
+    fGridToCellRow := Row;
+    if AssociatedServices <> nil then
+    with _Safe(fGridToCellVariant)^ do
+      if GetAsRawUTF8('Method', methodName) then
+        for serv := 0 to high(AssociatedServices) do begin
+          m := AssociatedServices[serv].FindFullMethodIndex(methodName, true);
+          if m >= 0 then
+            with AssociatedServices[serv].Methods[m] do begin
+              ArgsAsDocVariantFix(GetAsDocVariantSafe('Input')^, true);
+              ArgsAsDocVariantFix(GetAsDocVariantSafe('Output')^, false);
+              break;
+            end;
+        end;
+  end;
+  with _Safe(fGridToCellVariant)^ do
+    if cardinal(Field)>=cardinal(Count) then
+      result := '' else
+      if HumanFriendly and (_Safe(Values[Field])^.Kind = dvUndefined) then
+        VariantToUTF8(Values[field], RawUTF8(result))
+      else
+        result := VariantSaveJSON(Values[Field]);
+end;
+
+procedure TDBFrame.drwgrdResultClick(Sender: TObject);
+var
+  R: integer;
+  json: RawUTF8;
+begin
+  R := drwgrdResult.Row;
+  if (R > 0) and (R <> fGridToCellRow) and (Grid <> nil) then begin
+    OnGridToCell(Grid.Table,R,0,false);
+    JSONBufferReformat(pointer(VariantToUTF8(fGridToCellVariant)), json, jsonUnquotedPropNameCompact);
+    mmoResult.OnGetLineAttr := mmoResult.JSONLineAttr;
+    mmoResult.Text := UTF8ToString(json);
+    mmoResult.SetCaret(0, 0);
+    mmoResult.TopRow := 0;
+  end;
+end;
+
+procedure TDBFrame.btnHistoryClick(Sender: TObject);
+var
+  F: TForm;
+  List: TListBox;
+  Search: TEdit;
+  Details: TMemo;
+begin
+  F := TForm.Create(Application);
+  try
+    F.Caption := ' ' + btnHistory.Hint;
+    F.Font := Font;
+    F.Width := 800;
+    F.Height := 600;
+    F.Position := poMainFormCenter;
+    Search := TEdit.Create(F);
+    Search.Parent := F;
+    Search.Align := alTop;
+    Search.Height := 24;
+    Search.OnChange := LogSearch;
+    Details := TMemo.Create(F);
+    Details.Parent := F;
+    Details.Align := alBottom;
+    Details.Height := 200;
+    Details.readonly := true;
+    Details.Font.Name := 'Consolas';
+    List := TListBox.Create(F);
+    with List do begin
+      Parent := F;
+      Align := alClient;
+      Tag := PtrInt(Details);
+      OnClick := LogClick;
+      OnDblClick := LogDblClick;
+    end;
+    Search.Tag := PtrInt(List);
+    LogSearch(Search);
+    F.ShowModal;
+  finally
+    F.Free;
+  end;
+end;
+
+procedure TDBFrame.LogClick(Sender: TObject);
+var
+  List: TListBox absolute Sender;
+  ndx: integer;
+begin
+  ndx := cardinal(List.ItemIndex);
+  if ndx >= 0 then
+    TMemo(List.Tag).Text := copy(List.Items[ndx], 21, maxInt)
+  else
+    TMemo(List.Tag).Clear;
+end;
+
+procedure TDBFrame.LogDblClick(Sender: TObject);
+var
+  List: TListBox absolute Sender;
+  SQL: string;
+  ndx: integer;
+begin
+  ndx := cardinal(List.ItemIndex);
+  if ndx >= 0 then begin
+    SQL := copy(List.Items[ndx], 21, maxInt);
+    AddSQL(SQL, IsSelect(pointer(StringToAnsi7(SQL))));
+    TForm(List.Owner).Close;
+  end;
+end;
+
+procedure TDBFrame.LogSearch(Sender: TObject);
+const
+  MAX_LINES_IN_HISTORY = 500;
+var
+  Edit: TEdit absolute Sender;
+  List: TListBox;
+  i: integer;
+  s: RawUTF8;
+begin
+  s := SynCommons.UpperCase(StringToUTF8(Edit.Text));
+  List := pointer(Edit.Tag);
+  with TMemoryMapText.Create(fSQLLogFile) do
+  try
+    List.Items.BeginUpdate;
+    List.Items.Clear;
+    for i := Count - 1 downto 0 do
+      if (s = '') or LineContains(s, i) then
+        if List.Items.Add(Strings[i]) > MAX_LINES_IN_HISTORY then
+          break; // read last 500 lines from UTF-8 file
+  finally
+    Free;
+    List.Items.EndUpdate;
+  end;
+  List.ItemIndex := 0;
+  LogClick(List);
+end;
+
+procedure TDBFrame.AddSQL(SQL: string; AndExec: boolean);
+var
+  len: integer;
+  orig: string;
+begin
+  SQL := SysUtils.Trim(SQL);
+  len := Length(SQL);
+  if len = 0 then
+    exit;
+  orig := mmoSQL.Lines.Text;
+  if orig <> '' then
+    SQL := #13#10#13#10 + SQL;
+  SQL := orig + SQL;
+  mmoSQL.Lines.Text := SQL;
+  mmoSQL.SelStart := length(SQL) - len;
+  mmoSQL.SelLength := len;
+  if AndExec then
+    btnExecClick(btnExec)
+  else
+    mmoSQL.SetFocus;
+end;
+
+procedure TDBFrame.btnCmdClick(Sender: TObject);
+begin
+  with ClientToScreen(btnCmd.BoundsRect.TopLeft) do
+    pmCmd.Popup(X, Y + btnCmd.Height);
+end;
+
+function TDBFrame.ExecSQL(const SQL: RawUTF8): RawUTF8;
+var
+  exec: TServiceCustomAnswer;
+begin
+  exec := Admin.DatabaseExecute(DatabaseName, sql);
+  result := exec.Content;
+end;
+
+procedure TDBFrame.EnableChkTables(const aCaption: string);
+begin
+  pnlLeftTop.Height := 44;
+  chkTables.Show;
+  chkTables.Caption := aCaption;
+end;
+
+procedure TDBFrame.edtLabelsChange(Sender: TObject);
+var
+  i, index: integer;
+  match, previous: string;
+begin
+  i := lstTables.ItemIndex;
+  if i >= 0 then
+    previous := lstTables.Items[i];
+  index := -1;
+  match := SysUtils.Trim(SysUtils.UpperCase(edtLabels.Text));
+  if (length(match) > 5) and (match[1] = '%') then begin
+    FillTables(match);
+    match := '';
+  end;
+  with lstTables.Items do
+  try
+    BeginUpdate;
+    Clear;
+    for i := 0 to Tables.Count - 1 do
+      if (match = '') or (Pos(match, SysUtils.UpperCase(Tables[i])) > 0) then begin
+        AddObject(Tables[i], Tables.Objects[i]);
+        if previous = Tables[i] then
+          index := Count - 1;
+      end;
+  finally
+    EndUpdate;
+  end;
+  if index >= 0 then
+    lstTables.ItemIndex := index;
+end;
+
+
+end.
+

contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminLog.dfm

@@ -0,0 +1,176 @@
+object LogFrame: TLogFrame
+  Left = 0
+  Top = 0
+  Width = 516
+  Height = 367
+  TabOrder = 0
+  object spl2: TSplitter
+    Left = 0
+    Top = 275
+    Width = 516
+    Height = 3
+    Cursor = crVSplit
+    Align = alBottom
+  end
+  object pnlLeft: TPanel
+    Left = 0
+    Top = 0
+    Width = 145
+    Height = 275
+    Align = alLeft
+    TabOrder = 0
+    DesignSize = (
+      145
+      275)
+    object lblExistingLogKB: TLabel
+      Left = 12
+      Top = 34
+      Width = 56
+      Height = 13
+      Caption = 'Existing KB:'
+    end
+    object edtSearch: TEdit
+      Left = 5
+      Top = 8
+      Width = 98
+      Height = 21
+      Hint = 'Search (Ctrl+F, F3 for next) '
+      Anchors = [akLeft, akTop, akRight]
+      ParentShowHint = False
+      ShowHint = True
+      TabOrder = 0
+      Visible = False
+      OnChange = btnSearchNextClick
+    end
+    object chklstEvents: TCheckListBox
+      Left = 8
+      Top = 56
+      Width = 129
+      Height = 105
+      OnClickCheck = chklstEventsClickCheck
+      ItemHeight = 13
+      PopupMenu = pmFilter
+      Style = lbOwnerDrawFixed
+      TabOrder = 3
+      OnDblClick = chklstEventsDblClick
+      OnDrawItem = chklstEventsDrawItem
+    end
+    object btnStartLog: TButton
+      Left = 16
+      Top = 6
+      Width = 113
+      Height = 25
+      Caption = 'Start Logging'
+      TabOrder = 4
+      OnClick = btnStartLogClick
+    end
+    object edtExistingLogKB: TEdit
+      Left = 72
+      Top = 32
+      Width = 57
+      Height = 21
+      Hint = 'How many KB of log text should be transmitted at Start'
+      ParentShowHint = False
+      ShowHint = True
+      TabOrder = 5
+      Text = '512'
+    end
+    object btnStopLog: TButton
+      Left = 16
+      Top = 168
+      Width = 113
+      Height = 25
+      Caption = 'Stop Logging'
+      TabOrder = 6
+      Visible = False
+      OnClick = btnStopLogClick
+    end
+    object BtnSearchNext: TButton
+      Left = 103
+      Top = 6
+      Width = 20
+      Height = 23
+      Hint = 'Search Next (F3)'
+      Anchors = [akTop, akRight]
+      Caption = '?'
+      ParentShowHint = False
+      ShowHint = True
+      TabOrder = 1
+      Visible = False
+      OnClick = btnSearchNextClick
+    end
+    object BtnSearchPrevious: TButton
+      Left = 123
+      Top = 6
+      Width = 20
+      Height = 23
+      Hint = 'Search Previous (Shift F3)'
+      Anchors = [akTop, akRight]
+      Caption = '^'
+      ParentShowHint = False
+      ShowHint = True
+      TabOrder = 2
+      Visible = False
+      OnClick = btnSearchNextClick
+    end
+  end
+  object pnlRight: TPanel
+    Left = 145
+    Top = 0
+    Width = 371
+    Height = 275
+    Align = alClient
+    TabOrder = 1
+    object spl1: TSplitter
+      Left = 1
+      Top = 1
+      Height = 273
+    end
+    object drwgrdEvents: TDrawGrid
+      Left = 4
+      Top = 1
+      Width = 366
+      Height = 273
+      Align = alClient
+      ColCount = 3
+      DefaultColWidth = 100
+      DefaultRowHeight = 14
+      FixedCols = 0
+      RowCount = 1
+      FixedRows = 0
+      Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goDrawFocusSelected, goRowSelect, goThumbTracking]
+      TabOrder = 0
+      Visible = False
+      OnClick = drwgrdEventsClick
+      OnDblClick = drwgrdEventsDblClick
+      OnDrawCell = drwgrdEventsDrawCell
+    end
+  end
+  object mmoBottom: TMemo
+    Left = 0
+    Top = 278
+    Width = 516
+    Height = 89
+    Align = alBottom
+    Font.Charset = DEFAULT_CHARSET
+    Font.Color = clWindowText
+    Font.Height = -11
+    Font.Name = 'Consolas'
+    Font.Style = []
+    ParentFont = False
+    ReadOnly = True
+    ScrollBars = ssVertical
+    TabOrder = 2
+  end
+  object pmFilter: TPopupMenu
+    Left = 96
+    Top = 112
+  end
+  object tmrRefresh: TTimer
+    Enabled = False
+    Interval = 200
+    OnTimer = tmrRefreshTimer
+    Left = 153
+    Top = 32
+  end
+end

contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminLog.pas

@@ -0,0 +1,525 @@
+unit dddToolsAdminLog;
+
+interface
+
+uses
+  Windows,
+  Messages,
+  SysUtils,
+  Variants,
+  Classes,
+  Graphics,
+  Controls,
+  Forms,
+  Dialogs,
+  ExtCtrls,
+  StdCtrls,
+  CheckLst,
+  Menus,
+  Grids,
+  SynCommons,
+  SynLog,
+  mORMot,
+  mORMotDDD;
+
+type
+  TLogFrame = class(TFrame)
+    pnlLeft: TPanel;
+    pnlRight: TPanel;
+    spl1: TSplitter;
+    edtSearch: TEdit;
+    chklstEvents: TCheckListBox;
+    pmFilter: TPopupMenu;
+    mmoBottom: TMemo;
+    drwgrdEvents: TDrawGrid;
+    btnStartLog: TButton;
+    tmrRefresh: TTimer;
+    edtExistingLogKB: TEdit;
+    lblExistingLogKB: TLabel;
+    btnStopLog: TButton;
+    spl2: TSplitter;
+    BtnSearchNext: TButton;
+    BtnSearchPrevious: TButton;
+    procedure chklstEventsDrawItem(Control: TWinControl; Index: Integer; Rect:
+      TRect; State: TOwnerDrawState);
+    procedure btnStartLogClick(Sender: TObject);
+    procedure tmrRefreshTimer(Sender: TObject);
+    procedure drwgrdEventsDrawCell(Sender: TObject; ACol, ARow: Integer; Rect:
+      TRect; State: TGridDrawState);
+    procedure drwgrdEventsClick(Sender: TObject); virtual;
+    procedure btnSearchNextClick(Sender: TObject);
+    procedure chklstEventsDblClick(Sender: TObject);
+    procedure btnStopLogClick(Sender: TObject);
+    procedure chklstEventsClickCheck(Sender: TObject);
+    procedure drwgrdEventsDblClick(Sender: TObject);
+  protected
+    FLog: TSynLogFileView;
+    FMenuFilterAll, FMenuFilterNone: TMenuItem;
+    FCallbackPattern: RawUTF8;
+    FLogSafe: TSynLocker;
+    procedure EventsCheckToLogEvents;
+    procedure pmFilterClick(Sender: Tobject);
+    procedure ReceivedOne(const Text: RawUTF8);
+    procedure SetListItem(Index: integer; const search: RawUTF8 = '');
+  public
+    Admin: IAdministratedDaemon;
+    Callback: ISynLogCallback;
+    OnLogReceived: function(Sender: TLogFrame; Level: TSynLogInfo;
+      const Text: RawUTF8): boolean of object;
+    constructor Create(Owner: TComponent; const aAdmin: IAdministratedDaemon); reintroduce;
+    constructor CreateCustom(Owner: TComponent; const aAdmin: IAdministratedDaemon;
+      const aEvents, aPattern: RawUTF8); virtual;
+    destructor Destroy; override;
+    procedure LogFilter(F: TSynLogInfos);
+    procedure Closing;
+  end;
+
+  TLogFrameClass = class of TLogFrame;
+
+  TLogFrameDynArray = array of TLogFrame;
+
+  TLogFrameChat = class(TLogFrame)
+  protected
+    procedure mmoChatKeyPress(Sender: TObject; var Key: Char);
+  public
+    mmoChat: TMemo;
+    constructor CreateCustom(Owner: TComponent; const aAdmin:
+      IAdministratedDaemon; const aEvents, aPattern: RawUTF8); override;
+  end;
+
+implementation
+
+uses
+  dddToolsAdminMain;
+
+{$R *.dfm}
+
+{ TLogFrameCallback }
+
+type
+  TLogFrameCallback = class(TInterfacedObject, ISynLogCallback)
+  public
+    Owner: TLogFrame;
+    Pattern: RawUTF8;
+    procedure Log(Level: TSynLogInfo; const Text: RawUTF8);
+  end;
+
+procedure TLogFrameCallback.Log(Level: TSynLogInfo; const Text: RawUTF8);
+begin
+  if (Pattern <> '') and (Level <> sllNone) then
+    if PosI(pointer(Pattern), Text) = 0 then
+      exit;
+  Owner.ReceivedOne(Text);
+  if Assigned(Owner.OnLogReceived) then
+    Owner.OnLogReceived(Owner, Level, Text);
+end;
+
+procedure TLogFrame.chklstEventsDrawItem(Control: TWinControl; Index: Integer;
+  Rect: TRect; State: TOwnerDrawState);
+var
+  E: TSynLogInfo;
+begin
+  if Index < 0 then
+    exit;
+  E := TSynLogInfo(chklstEvents.Items.Objects[Index]);
+  with chklstEvents.Canvas do begin
+    Brush.Color := LOG_LEVEL_COLORS[false, E];
+    Font.Color := LOG_LEVEL_COLORS[true, E];
+    TextRect(Rect, Rect.Left + 4, Rect.Top, ToCaption(E));
+  end;
+end;
+
+var
+  LogFrameCount: integer;
+
+constructor TLogFrame.Create(Owner: TComponent; const aAdmin: IAdministratedDaemon);
+var
+  F: TSynLogFilter;
+  M: TMenuItem;
+begin
+  inherited Create(Owner);
+  FLogSafe.Init;
+  Admin := aAdmin;
+  Name := 'LogFrame' + IntToStr(LogFrameCount);
+  inc(LogFrameCount);
+  for F := low(F) to high(F) do begin
+    M := TMenuItem.Create(self);
+    M.Caption := ToCaption(F);
+    M.Tag := ord(F);
+    M.OnClick := pmFilterClick;
+    if F = lfAll then
+      FMenuFilterAll := M
+    else if F = lfNone then
+      FMenuFilterNone := M;
+    pmFilter.Items.Add(M);
+  end;
+  btnStopLogClick(nil);
+end;
+
+constructor TLogFrame.CreateCustom(Owner: TComponent;
+  const aAdmin: IAdministratedDaemon; const aEvents, aPattern: RawUTF8);
+var
+  P: PUTF8Char;
+  e: integer;
+begin
+  Create(Owner, aAdmin);
+  pmFilterClick(FMenuFilterNone);
+  P := pointer(aEvents);
+  while P <> nil do begin
+    e := PTypeInfo(TypeInfo(TSynLogInfo))^.EnumBaseType.GetEnumNameValue(
+      pointer(GetNextItem(P)));
+    if e > 0 then // ignore e=0=sllNone
+      chklstEvents.Checked[e - 1] := True;
+  end;
+  FCallbackPattern := UpperCase(aPattern);
+  btnStartLogClick(self);
+  btnStopLog.Hide; { TODO: allow event log closing }
+end;
+
+destructor TLogFrame.Destroy;
+begin
+  FLogSafe.Done;
+  inherited;
+end;
+
+procedure TLogFrame.btnStopLogClick(Sender: TObject);
+var
+  E: TSynLogInfo;
+begin
+  chklstEvents.Top := 56;
+  chklstEvents.Items.Clear;
+  for E := succ(sllNone) to high(E) do begin
+    if (Sender = Self) and not (E in FLog.Events) then
+      continue; // from TLogFrame.CreateCustom()
+    chklstEvents.Items.AddObject(ToCaption(E), pointer(ord(E)));
+  end;
+  chklstEvents.Height := 8 + chklstEvents.Count * chklstEvents.ItemHeight;
+  pmFilterClick(FMenuFilterAll);
+  if Sender = nil then
+    exit;
+  btnStartLog.Show;
+  btnStopLog.Hide;
+  edtExistingLogKB.Show;
+  lblExistingLogKB.Show;
+  edtSearch.Hide;
+  btnSearchNext.Hide;
+  BtnSearchPrevious.Hide;
+  mmoBottom.Text := '';
+  drwgrdEvents.Row := 0;
+  drwgrdEvents.RowCount := 0;
+  drwgrdEvents.Tag := 0;
+  tmrRefresh.Enabled := false;
+  (Owner as TAdminControl).EndLog(self);
+end;
+
+procedure TLogFrame.LogFilter(F: TSynLogInfos);
+var
+  i: integer;
+begin
+  for i := 0 to chklstEvents.Count - 1 do
+    chklstEvents.Checked[i] := TSynLogInfo(chklstEvents.Items.Objects[i]) in F;
+  chklstEventsClickCheck(nil);
+end;
+
+procedure TLogFrame.pmFilterClick(Sender: Tobject);
+begin
+  if Sender.InheritsFrom(TMenuItem) then
+    LogFilter(LOG_FILTER[TSynLogFilter(TMenuItem(Sender).Tag)]);
+end;
+
+procedure TLogFrame.EventsCheckToLogEvents;
+var
+  i: integer;
+  events: TSynLogInfos;
+begin
+ integer(events) := 0;
+  for i := 0 to chklstEvents.Count - 1 do
+    if chklstEvents.Checked[i] then
+      Include(events, TSynLogInfo(chklstEvents.Items.Objects[i]));
+  FLog.Events := events;
+end;
+
+procedure TLogFrame.btnStartLogClick(Sender: TObject);
+var
+  cb: TLogFrameCallback;
+  kb, i: integer;
+begin
+  cb := TLogFrameCallback.Create;
+  cb.Owner := Self;
+  cb.Pattern := FCallbackPattern;
+  Callback := cb;
+  FLogSafe.Lock;
+  try
+    try
+      FLog := TSynLogFileView.Create;
+      drwgrdEvents.DoubleBuffered := true;
+      drwgrdEvents.ColCount := 4;
+      drwgrdEvents.ColWidths[0] := 70;
+      drwgrdEvents.ColWidths[1] := 60;
+      drwgrdEvents.ColWidths[2] := 24;
+      drwgrdEvents.ColWidths[3] := 2000;
+      if Sender = self then
+        kb := 64 // from TLogFrame.CreateCustom
+      else
+        kb := StrToIntDef(edtExistingLogKB.Text, 0);
+      EventsCheckToLogEvents; // fill FLog.Events
+      Admin.SubscribeLog(FLog.Events, Callback, kb);
+      chklstEvents.Top := lblExistingLogKB.Top;
+      for i := chklstEvents.Count - 1 downto 0 do
+        if not chklstEvents.Checked[i] then
+          chklstEvents.Items.Delete(i);
+      chklstEvents.Height := 8 + chklstEvents.Count * chklstEvents.ItemHeight;
+      btnStopLog.Top := chklstEvents.Top + chklstEvents.Height + 8;
+      btnStartLog.Hide;
+      btnStopLog.Show;
+      edtExistingLogKB.Hide;
+      lblExistingLogKB.Hide;
+      edtSearch.Show;
+      btnSearchNext.Show;
+      BtnSearchPrevious.Show;
+      drwgrdEvents.Show;
+      tmrRefresh.Enabled := true;
+    except
+      Callback := nil;
+      FreeAndNil(FLog);
+    end;
+  finally
+    fLogSafe.UnLock;
+  end;
+end;
+
+const
+  TAG_NONE = 0;
+  TAG_REFRESH = 1;
+
+procedure TLogFrame.ReceivedOne(const Text: RawUTF8);
+var
+  P: PUTF8Char;
+  line: RawUTF8;
+begin
+  // warning: this method is called from WebSockets thread, not UI thread
+  if Callback = nil then
+    exit;
+  FLogSafe.Lock;
+  try
+    if (FLog = nil) or (Text = '') then
+      exit;
+    P := pointer(Text);
+    repeat // handle multiple log rows in the incoming text
+      line := GetNextLine(P, P);
+      if length(line) < 24 then
+        continue;
+      FLog.AddInMemoryLine(line);
+      tmrRefresh.Tag := TAG_REFRESH; // notify tmrRefreshTimer()
+    until P = nil;
+  finally
+    FLogSafe.UnLock;
+  end;
+end;
+
+procedure TLogFrame.tmrRefreshTimer(Sender: TObject);
+var
+  moveToLast: boolean;
+begin
+  FLogSafe.Lock; // to protect tmrRefresh.Tag access from ReceivedOne()
+  try
+    if (tmrRefresh.Tag = TAG_NONE) or (fLog = nil) then
+      exit;
+    moveToLast := drwgrdEvents.Row = drwgrdEvents.RowCount - 1;
+    drwgrdEvents.RowCount := FLog.SelectedCount;
+    if FLog.SelectedCount > 0 then
+      if (drwgrdEvents.Tag = 0) or moveToLast then begin
+        drwgrdEvents.Row := FLog.SelectedCount - 1;
+        drwgrdEvents.Tag := 1;
+      end;
+    drwgrdEvents.Invalidate;
+    tmrRefresh.Tag := TAG_NONE;
+  finally
+    FLogSafe.UnLock;
+  end;
+end;
+
+procedure TLogFrame.drwgrdEventsDrawCell(Sender: TObject; ACol, ARow: Integer;
+  Rect: TRect; State: TGridDrawState);
+var
+  txt: string;
+  inverted: boolean;
+  level: TSynLogInfo;
+begin
+  with drwgrdEvents.Canvas do begin
+    Brush.Style := bsClear;
+    FLogSafe.Lock;
+    try
+      txt := FLog.GetCell(ACol,ARow,level);
+    finally
+      FLogSafe.UnLock;
+    end;
+    if level=sllNone then
+      Brush.Color := clLtGray else begin
+      inverted := (gdFocused in State) or (gdSelected in State);
+      if inverted then
+        Brush.Color := clBlack else
+        Brush.Color := LOG_LEVEL_COLORS[inverted,level];
+      Font.Color  := LOG_LEVEL_COLORS[not inverted,level];
+    end;
+    FillRect(Rect);
+    TextRect(Rect,Rect.Left+4,Rect.Top,txt);
+  end;
+end;
+
+procedure TLogFrame.drwgrdEventsClick(Sender: TObject);
+var
+  row: integer;
+  s: string;
+  sel: TGridRect;
+begin
+  row := drwgrdEvents.Row;
+  sel := drwgrdEvents.Selection;
+  FLogSafe.Lock;
+  try
+    s := FLog.GetLineForMemo(row,sel.Top,sel.Bottom);
+  finally
+    FLogSafe.UnLock;
+  end;
+  mmoBottom.Text := s;
+end;
+
+procedure TLogFrame.btnSearchNextClick(Sender: TObject);
+var
+  s: RawUTF8;
+  ndx: integer;
+begin
+  s := UpperCase(StringToUTF8(edtSearch.Text));
+  FLogSafe.Lock;
+  Screen.Cursor := crHourGlass;
+  try
+    if Sender=BtnSearchPrevious then
+      ndx := FLog.SearchPreviousText(s,drwgrdEvents.Row) else
+    if Sender=edtSearch then
+      ndx := FLog.SearchNextText(s,drwgrdEvents.Row,0) else
+      ndx := FLog.SearchNextText(s,drwgrdEvents.Row,1); // e.g. BtnSearchNext
+    if ndx>=0 then
+      SetListItem(ndx,s);
+  finally
+    FLogSafe.UnLock;
+    Screen.Cursor := crDefault;
+  end;
+end;
+
+procedure TLogFrame.SetListItem(Index: integer; const search: RawUTF8);
+var
+  i: integer;
+  s, ss: string;
+begin
+  if (FLog = nil) or (cardinal(Index) >= cardinal(FLog.SelectedCount)) then
+    mmoBottom.Text := ''
+  else begin
+    drwgrdEvents.Row := Index;
+    if (search = '') and drwgrdEvents.Visible then
+      drwgrdEvents.SetFocus;
+    s := FLog.EventString(FLog.Selected[Index], '', 0, true);
+    mmoBottom.Text := s;
+    if search <> '' then begin
+      ss := UTF8ToString(search);
+      i := Pos(ss, SysUtils.UpperCase(s));
+      if i > 0 then begin
+        mmoBottom.SelStart := i - 1;
+        mmoBottom.SelLength := length(ss);
+        mmoBottom.SetFocus;
+      end;
+    end;
+  end;
+end;
+
+procedure TLogFrame.Closing;
+begin
+  Callback := nil;
+  FLogSafe.Lock;
+  try
+    FreeAndNil(fLog);
+  finally
+    FLogSafe.UnLock;
+  end;
+end;
+
+procedure TLogFrame.chklstEventsDblClick(Sender: TObject);
+var
+  i: integer;
+  E: TSynLogInfo;
+begin
+  if FLog.EventLevel = nil then // plain text file does not handle this
+    exit;
+  i := chklstEvents.ItemIndex;
+  if i < 0 then
+    exit;
+  E := TSynLogInfo(chklstEvents.Items.Objects[i]);
+  FLogSafe.Lock;
+  try
+    i := FLog.SearchNextEvent(E,drwgrdEvents.Row);
+    if i>=0 then
+      SetListItem(i);
+  finally
+    FLogSafe.UnLock;
+  end;
+end;
+
+procedure TLogFrame.chklstEventsClickCheck(Sender: TObject);
+var
+  selected: integer;
+begin
+  if FLog = nil then
+    exit;
+  EventsCheckToLogEvents; // fill FLog.Events
+  FLogSafe.Lock;
+  try
+    selected := FLog.Select(drwgrdEvents.Row);
+    if cardinal(selected) < cardinal(FLog.SelectedCount) then
+      drwgrdEvents.Row := 0; // avoid "Grid Out Of Range" when setting RowCount
+    drwgrdEvents.RowCount := FLog.SelectedCount;
+    if selected>=0 then
+      SetListItem(selected);
+  finally
+    FLogSafe.UnLock;
+  end;
+  if drwgrdEvents.Visible then begin
+    drwgrdEvents.Repaint;
+    drwgrdEventsClick(nil);
+  end;
+end;
+
+procedure TLogFrame.drwgrdEventsDblClick(Sender: TObject);
+var ndx: integer;
+begin
+  ndx := fLog.SearchEnterLeave(drwgrdEvents.Row);
+  if ndx>=0 then
+    SetListItem(ndx);
+end;
+
+
+{ TLogFrameChat }
+
+constructor TLogFrameChat.CreateCustom(Owner: TComponent; const aAdmin:
+  IAdministratedDaemon; const aEvents, aPattern: RawUTF8);
+begin
+  inherited;
+  chklstEvents.Enabled := false;
+  mmoChat := TMemo.Create(self);
+  mmoChat.Parent := self;
+  mmoChat.Height := 40;
+  mmoChat.Align := alTop;
+  mmoChat.OnKeyPress := mmoChatKeyPress;
+end;
+
+procedure TLogFrameChat.mmoChatKeyPress(Sender: TObject; var Key: Char);
+begin
+  if Key = #13 then begin
+    if Assigned(Admin) then
+      Admin.DatabaseExecute('', FormatUTF8('#chat % %',
+        [ExeVersion.User, StringToUTF8(mmoChat.Text)]));
+    mmoChat.Clear;
+    Key := #0;
+  end;
+end;
+
+end.
+

contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminMain.dfm

@@ -0,0 +1,20 @@
+object AdminForm: TAdminForm
+  Left = 379
+  Top = 162
+  Width = 697
+  Height = 478
+  Caption = ' Tools Administrator'
+  Color = clBtnFace
+  Font.Charset = DEFAULT_CHARSET
+  Font.Color = clWindowText
+  Font.Height = -11
+  Font.Name = 'Tahoma'
+  Font.Style = []
+  KeyPreview = True
+  OldCreateOrder = False
+  Position = poDefaultSizeOnly
+  OnCreate = FormCreate
+  OnShow = FormShow
+  PixelsPerInch = 96
+  TextHeight = 13
+end

contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminMain.pas

@@ -0,0 +1,505 @@
+unit dddToolsAdminMain;
+
+{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
+
+interface
+
+uses
+  Windows,
+  Messages,
+  SysUtils,
+  Variants,
+  Classes,
+  Graphics,
+  Controls,
+  Forms,
+  Dialogs,
+  Clipbrd,
+  mORMotUI,
+  mORMotUILogin,
+  mORMotToolbar,
+  SynTaskDialog,
+  SynCommons,
+  mORMot,
+  mORMotHttpClient,
+  mORMotDDD,
+  dddInfraApps,
+  dddToolsAdminDB,
+  dddToolsAdminLog;
+
+type
+  TAdminSaveOrExport = (expSaveGrid, expCopyGrid, expCopyRow);
+
+  TAdminControl = class(TWinControl)
+  protected
+    fClient: TSQLHttpClientWebsockets;
+    fAdmin: IAdministratedDaemon;
+    fDatabases: TRawUTF8DynArray;
+    fPage: TSynPager;
+    fPages: array of TSynPage;
+    fLogFrame: TLogFrame;
+    fLogFrames: TLogFrameDynArray;
+    fChatPage: TSynPage;
+    fChatFrame: TLogFrame;
+    fDBFrame: TDBFrameDynArray;
+    fDefinition: TDDDRestClientSettings;
+    fDlgSave: TSaveDialog;
+  public
+    LogFrameClass: TLogFrameClass;
+    DBFrameClass: TDBFrameClass;
+    State: record
+      raw: TDocVariantData;
+      daemon: RawUTF8;
+      version: RawUTF8;
+      mem: RawUTF8;
+      clients: integer;
+      exceptions: TRawUTF8DynArray;
+      lasttix: Int64;
+    end;
+    SavePrefix: TFileName;
+    OnBeforeExecute: TOnExecute;
+    OnAfterExecute: TOnExecute;
+    OnAfterGetState: TNotifyEvent;
+    destructor Destroy; override;
+    function Open(Definition: TDDDRestClientSettings; Model: TSQLModel = nil): boolean; virtual;
+    procedure Show; virtual;
+    procedure GetState;
+    function AddPage(const aCaption: RawUTF8): TSynPage; virtual;
+    function AddDBFrame(const aCaption, aDatabaseName: RawUTF8; aClass:
+      TDBFrameClass): TDBFrame; virtual;
+    function AddLogFrame(page: TSynPage; const aCaption, aEvents, aPattern: RawUTF8;
+      aClass: TLogFrameClass): TLogFrame; virtual;
+    procedure EndLog(aLogFrame: TLogFrame); virtual;
+    procedure OnPageChange(Sender: TObject); virtual;
+    function CurrentDBFrame: TDBFrame;
+    function FindDBFrame(const aDatabaseName: RawUTF8): TDBFrame;
+    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); virtual;
+    procedure SaveOrExport(Fmt: TAdminSaveOrExport; const ContextName: string = '';
+      DB: TDBFrame = nil);
+    property Client: TSQLHttpClientWebsockets read fClient;
+    property Page: TSynPager read fPage;
+    property LogFrame: TLogFrame read fLogFrame;
+    property DBFrame: TDBFrameDynArray read fDBFrame;
+    property ChatPage: TSynPage read fChatPage;
+    property ChatFrame: TLogFrame read fChatFrame;
+    property Admin: IAdministratedDaemon read fAdmin;
+  end;
+
+  TAdminForm = class(TSynForm)
+    procedure FormCreate(Sender: TObject);
+    procedure FormShow(Sender: TObject);
+  protected
+    fFrame: TAdminControl;
+  public
+    property Frame: TAdminControl read fFrame;
+  end;
+
+var
+  AdminForm: TAdminForm;
+
+function AskForUserIfVoid(Definition: TDDDRestClientSettings): boolean;
+
+implementation
+
+{$R *.dfm}
+
+function AskForUserIfVoid(Definition: TDDDRestClientSettings): boolean;
+var
+  U, P: string;
+begin
+  result := false;
+  if Definition.ORM.User = '' then
+    if TLoginForm.Login(Application.Mainform.Caption, FormatString(
+       'Credentials for %', [Definition.ORM.ServerName]), U, P, true, '') then begin
+      Definition.ORM.User := StringToUTF8(U);
+      Definition.ORM.PasswordPlain := StringToUTF8(P);
+    end
+    else
+      exit;
+  result := true;
+end;
+
+var
+  AdminControlConnecting: TForm; // only one Open() attempt at once
+
+function TAdminControl.Open(Definition: TDDDRestClientSettings; Model: TSQLModel): boolean;
+begin
+  result := false;
+  if Assigned(fAdmin) or (Definition.Orm.User = '') or Assigned(AdminControlConnecting) then
+    exit;
+  try
+    AdminControlConnecting := CreateTempForm('Connecting to ' + string(Definition.ORM.ServerName));
+    try
+      Application.ProcessMessages;
+      if Model = nil then
+        Model := TSQLModel.Create([], '');
+      Model.OnClientIdle := TLoginForm.OnIdleProcess; // allow basic UI interactivity
+      fClient := AdministratedDaemonClient(Definition, Model);
+      if not fClient.Services.Resolve(IAdministratedDaemon, fAdmin) then
+        raise EDDDRestClient.CreateUTF8('Resolve(IAdministratedDaemon)=false: check % version',
+          [Definition.ORM.ServerName]);
+      GetState;
+      fDefinition := Definition;
+      result := true;
+    finally
+      FreeAndNil(AdminControlConnecting);
+      if fClient <> nil then
+        fClient.OnIdle := nil; // back to default blocking behavior (safer UI)
+    end;
+  except
+    on E: Exception do begin
+      ShowException(E);
+      FreeAndNil(fClient);
+    end;
+  end;
+end;
+
+procedure TAdminControl.GetState;
+var
+  exec: TServiceCustomAnswer;
+begin
+  if self = nil then
+    exit;
+  try
+    if fAdmin <> nil then begin
+      State.raw.Clear;
+      exec := fAdmin.DatabaseExecute('', '#info');
+      if (exec.Content = '') or (exec.Content[1] <> '{') then
+        exec := fAdmin.DatabaseExecute('', '#state'); // backward compatibility
+      State.raw.InitJSONInPlace(pointer(exec.Content), JSON_OPTIONS_FAST);
+      State.raw.GetAsRawUTF8('daemon', State.daemon);
+      if not State.raw.GetAsRawUTF8('version', State.version) then
+        State.version := fClient.SessionVersion;
+      State.mem := State.raw.U['memused'];
+      if State.mem = '' then
+        KBU(state.Raw.O['SystemMemory'].O['Allocated'].I['Used'] shl 10, State.mem);
+      State.clients := State.raw.I['clients'];
+      State.raw.GetAsDocVariantSafe('exception')^.ToRawUTF8DynArray(State.exceptions);
+      State.raw.AddValue('remoteip', fClient.Server + ':' + fClient.Port);
+      State.lasttix := GetTickCount64;
+    end;
+    if Assigned(OnAfterGetState) then
+      OnAfterGetState(self);
+  except
+    Finalize(State);
+  end;
+end;
+
+procedure TAdminControl.Show;
+var
+  i, n: integer;
+  f: TDBFrame;
+begin
+  if (fClient = nil) or (fAdmin = nil) or (fPage <> nil) then
+    exit; // show again after hide
+  if LogFrameClass = nil then
+    LogFrameClass := TLogFrame;
+  if DBFrameClass = nil then
+    DBFrameClass := TDBFrame;
+  fDatabases := fAdmin.DatabaseList;
+  fPage := TSynPager.Create(self);
+  fPage.ControlStyle := fPage.ControlStyle + [csClickEvents]; // enable OnDblClick
+  fPage.Parent := self;
+  fPage.Align := alClient;
+  fPage.OnChange := OnPageChange;
+  n := length(fDatabases);
+  fLogFrame := AddLogFrame(nil, 'log', '', '', LogFrameClass);
+  if n > 0 then begin
+    for i := 0 to n - 1 do begin
+      f := AddDBFrame(fDatabases[i], fDatabases[i], DBFrameClass);
+      f.Open;
+      if i = 0 then begin
+        fPage.ActivePageIndex := 1;
+        f.SetResult(State.raw.ToJSON('', '', jsonUnquotedPropName));
+      end;
+    end;
+    Application.ProcessMessages;
+    fDBFrame[0].mmoSQL.SetFocus;
+  end;
+  fChatPage := AddPage('Chat');
+  fChatPage.TabVisible := false;
+end;
+
+procedure TAdminControl.EndLog(aLogFrame: TLogFrame);
+begin
+  if aLogFrame <> nil then
+  try
+    Screen.Cursor := crHourGlass;
+    if aLogFrame.Callback <> nil then begin
+      fClient.Services.CallBackUnRegister(aLogFrame.Callback);
+      aLogFrame.Callback := nil;
+      Sleep(10);
+    end;
+    aLogFrame.Closing;
+  finally
+    Screen.Cursor := crDefault;
+  end;
+end;
+
+destructor TAdminControl.Destroy;
+var
+  i: integer;
+begin
+  if fClient <> nil then
+    fClient.OnIdle := TLoginForm.OnIdleProcess; // allow basic UI interactivity
+  for i := 0 to high(fLogFrames) do begin
+    EndLog(fLogFrames[i]);
+    fLogFrames[i].Admin := nil;
+    fLogFrames[i] := nil;
+  end;
+  Finalize(fLogFrames);
+  for i := 0 to high(fDBFrame) do
+    fDBFrame[i].Admin := nil;
+  fDBFrame := nil;
+  fAdmin := nil;
+  fDefinition.Free;
+  if fClient <> nil then begin
+    for i := 1 to 5 do begin
+      Sleep(50); // leave some time to flush all pending CallBackUnRegister()
+      Application.ProcessMessages;
+    end;
+    FreeAndNil(fClient);
+  end;
+  inherited Destroy;
+end;
+
+procedure TAdminControl.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
+
+  procedure LogKeys(aLogFrame: TLogFrame);
+  var ch: char;
+  begin
+    if aLogFrame <> nil then
+      case Key of
+        VK_F3:
+         if Shift = [] then
+           aLogFrame.btnSearchNextClick(aLogFrame.btnSearchNext)
+         else
+           aLogFrame.btnSearchNextClick(aLogFrame.btnSearchPrevious);
+        ord('A')..ord('Z'), ord('0')..ord('9'), 32:
+          if (Shift = []) and (aLogFrame.ClassType <> TLogFrameChat) and not
+            aLogFrame.edtSearch.Focused then begin
+            ch := Char(Key);
+            if (Key in [ord('A')..ord('Z')]) and (GetKeyState(VK_CAPITAL) and 1=0) then
+              inc(ch,32); // emulate capslock behavior
+            aLogFrame.edtSearch.Text := aLogFrame.edtSearch.Text + string(ch);
+          end
+          else if (key = ord('F')) and (ssCtrl in Shift) then begin
+            aLogFrame.edtSearch.SelectAll;
+            aLogFrame.edtSearch.SetFocus;
+          end;
+      end;
+  end;
+
+var
+  page: TControl;
+  ndx: integer;
+begin
+  page := fPage.ActivePage;
+  if page = nil then
+    exit;
+  ndx := page.Tag;
+  if ndx > 0 then begin
+    ndx := ndx - 1; // see AddDBFrame()
+    if cardinal(ndx) < cardinal(length(fDBFrame)) then
+      with fDBFrame[ndx] do
+        case Key of
+          VK_F5:
+            btnCmdClick(btnCmd);
+          VK_F9:
+            btnExecClick(btnExec);
+          ord('A'):
+            if ssCtrl in Shift then begin
+              mmoSQL.SelectAll;
+              mmoSQL.SetFocus;
+            end;
+          ord('H'):
+            if ssCtrl in Shift then
+              btnHistoryClick(btnHistory);
+        end
+  end
+  else if ndx < 0 then begin
+    ndx := -(ndx + 1); // see AddLogFrame()
+    if cardinal(ndx) < cardinal(length(fLogFrames)) then
+      LogKeys(fLogFrames[ndx]);
+  end;
+end;
+
+function TAdminControl.AddPage(const aCaption: RawUTF8): TSynPage;
+var
+  n: integer;
+begin
+  n := length(fPages);
+  SetLength(fPages, n + 1);
+  result := TSynPage.Create(self);
+  result.Caption := UTF8ToString(aCaption);
+  result.PageControl := fPage;
+  fPages[n] := result;
+end;
+
+function TAdminControl.AddDBFrame(const aCaption, aDatabaseName: RawUTF8;
+  aClass: TDBFrameClass): TDBFrame;
+var
+  page: TSynPage;
+  n: integer;
+begin
+  page := AddPage(aCaption);
+  n := length(fDBFrame);
+  SetLength(fDBFrame, n + 1);
+  result := aClass.Create(self);
+  result.Name := FormatString('DBFrame%', [aCaption]);
+  result.Parent := page;
+  result.Align := alClient;
+  result.Client := fClient;
+  result.Admin := fAdmin;
+  result.DatabaseName := aDatabaseName;
+  result.OnBeforeExecute := OnBeforeExecute;
+  result.OnAfterExecute := OnAfterExecute;
+  result.SavePrefix := SavePrefix;
+  fDBFrame[n] := result;
+  page.Tag := n + 1; // Tag>0 -> index in fDBFrame[Tag-1] -> used in FormKeyDown
+end;
+
+function TAdminControl.AddLogFrame(page: TSynPage; const aCaption, aEvents,
+  aPattern: RawUTF8; aClass: TLogFrameClass): TLogFrame;
+var
+  n: integer;
+begin
+  if page = nil then begin
+    page := AddPage(aCaption);
+    fPage.ActivePageIndex := fPage.PageCount - 1;
+  end;
+  if aEvents = '' then
+    result := aClass.Create(self, fAdmin)
+  else
+    result := aClass.CreateCustom(self, fAdmin, aEvents, aPattern);
+  result.Parent := page;
+  result.Align := alClient;
+  n := length(fLogFrames);
+  SetLength(fLogFrames, n + 1);
+  fLogFrames[n] := result;
+  page.Tag := -(n + 1); // Tag<0 -> index in fLogFrames[-(Tag+1)] -> used in FormKeyDown
+end;
+
+procedure TAdminControl.OnPageChange(Sender: TObject);
+var
+  ndx: cardinal;
+begin
+  if fPage.ActivePage = fChatPage then begin
+    if fChatFrame = nil then
+      fChatFrame := AddLogFrame(fChatPage, '', 'Monitoring', '[CHAT] ', TLogFrameChat);
+    exit;
+  end;
+  ndx := fPage.ActivePageIndex - 1;
+  if ndx >= cardinal(Length(fDBFrame)) then
+    exit;
+end;
+
+function TAdminControl.CurrentDBFrame: TDBFrame;
+var
+  ndx: cardinal;
+begin
+  ndx := fPage.ActivePageIndex - 1;
+  if ndx >= cardinal(Length(fDBFrame)) then
+    result := nil
+  else
+    result := fDBFrame[ndx];
+end;
+
+function TAdminControl.FindDBFrame(const aDatabaseName: RawUTF8): TDBFrame;
+var
+  i: Integer;
+begin
+  for i := 0 to high(fDBFrame) do
+    if IdemPropNameU(fDBFrame[i].DatabaseName, aDatabaseName) then begin
+      result := fDBFrame[i];
+      exit;
+    end;
+  result := nil;
+end;
+
+procedure TAdminControl.SaveOrExport(Fmt: TAdminSaveOrExport;
+  const ContextName: string; DB: TDBFrame);
+var
+  grid: TSQLTable;
+  row: integer;
+  name, table: RawUTF8;
+begin
+  if DB = nil then
+    DB := CurrentDBFrame;
+  if DB = nil then
+    exit;
+  grid := DB.Grid.Table;
+  if (grid = nil) or (grid.RowCount = 0) then
+    exit;
+  if Fmt = expSaveGrid then begin
+    if fDlgSave = nil then begin
+      fDlgSave := TSaveDialog.Create(Owner);
+      fDlgSave.Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist,
+        ofEnableSizing];
+      fDlgSave.Filter :=
+        'JSON (human readable)|*.json|JSON (small)|*.json|CSV (text)|*.txt|Excel/Office (.ods)|*.ods|HTML|*.html';
+      fDlgSave.DefaultExt := '.html';
+      fDlgSave.FilterIndex := 5;
+      fDlgSave.InitialDir := GetShellFolderPath(CSIDL_DOCUMENTS);
+    end;
+    if PropNameValid(pointer(db.GridLastTableName)) then
+      name := db.GridLastTableName;
+    fDlgSave.FileName := SysUtils.Trim(FormatString('% % %',
+      [ContextName, name, NowToString(false)]));
+    if not fDlgSave.Execute then
+      exit;
+    case fDlgSave.FilterIndex of
+      1:
+        JSONBufferReformat(pointer(grid.GetJSONValues(true)), table);
+      2:
+        table := grid.GetJSONValues(true);
+      3:
+        table := grid.GetCSVValues(true);
+      4:
+        table := grid.GetODSDocument;
+      5:
+        table := grid.GetHtmlTable;
+    end;
+    if table <> '' then
+      FileFromString(table, fDlgSave.FileName);
+  end
+  else begin
+    case Fmt of
+      expCopyGrid:
+        table := grid.GetCSVValues(true);
+      expCopyRow:
+        begin
+          row := db.drwgrdResult.Row;
+          if row < 0 then
+            exit;
+          table := grid.GetCSVValues(true, ',', false, row, row);
+        end;
+    end;
+    if table <> '' then
+      Clipboard.AsText := UTF8ToString(table);
+  end;
+end;
+
+
+{ TAdminForm }
+
+procedure TAdminForm.FormCreate(Sender: TObject);
+begin
+  DefaultFont.Name := 'Tahoma';
+  DefaultFont.Size := 9;
+  Caption := FormatString('% %', [ExeVersion.ProgramName, ExeVersion.Version.Detailed]);
+  fFrame := TAdminControl.Create(self);
+  fFrame.Parent := self;
+  fFrame.Align := alClient;
+  OnKeyDown := fFrame.FormKeyDown;
+end;
+
+procedure TAdminForm.FormShow(Sender: TObject);
+begin
+  fFrame.Show;
+  Caption := FormatString('% - % % via %', [ExeVersion.ProgramName,
+    fFrame.State.daemon, fFrame.State.version, fFrame.fDefinition.ORM.ServerName]);
+end;
+
+end.
+

contrib/mORMot/SQLite3/Documentation/Release/Release.dpr

@@ -0,0 +1,14 @@
+program Release;
+
+uses
+  {$I SynDprUses.inc}
+  Forms,
+  ReleaseForm in 'ReleaseForm.pas' {Form1};
+
+{$R *.res}
+
+begin
+  Application.Initialize;
+  Application.CreateForm(TForm1, Form1);
+  Application.Run;
+end.

contrib/mORMot/SQLite3/Documentation/Release/ReleaseForm.dfm

@@ -0,0 +1,71 @@
+object Form1: TForm1
+  Left = 217
+  Top = 262
+  BorderStyle = bsSingle
+  Caption = ' Synopse mORMot Release Notes tool'
+  ClientHeight = 602
+  ClientWidth = 854
+  Color = clBtnFace
+  Font.Charset = DEFAULT_CHARSET
+  Font.Color = clWindowText
+  Font.Height = -11
+  Font.Name = 'Tahoma'
+  Font.Style = []
+  OldCreateOrder = False
+  Position = poScreenCenter
+  Scaled = False
+  PixelsPerInch = 96
+  TextHeight = 13
+  object Label1: TLabel
+    Left = 32
+    Top = 24
+    Width = 546
+    Height = 13
+    Caption = 
+      'Purpose of this tool is to create the release notes details by a' +
+      'utomated extraction from the several .pas unit files.'
+  end
+  object Label2: TLabel
+    Left = 48
+    Top = 56
+    Width = 80
+    Height = 13
+    Caption = 'Release Version:'
+  end
+  object Edit1: TEdit
+    Left = 136
+    Top = 53
+    Width = 121
+    Height = 21
+    TabOrder = 0
+    Text = '1.18'
+  end
+  object Button1: TButton
+    Left = 56
+    Top = 88
+    Width = 201
+    Height = 57
+    Caption = 'Generate'
+    Default = True
+    TabOrder = 1
+    OnClick = Button1Click
+  end
+  object Memo1: TMemo
+    Left = 280
+    Top = 48
+    Width = 561
+    Height = 537
+    ScrollBars = ssBoth
+    TabOrder = 2
+    WordWrap = False
+  end
+  object Button2: TButton
+    Left = 160
+    Top = 152
+    Width = 99
+    Height = 25
+    Caption = 'Open in browser'
+    TabOrder = 3
+    OnClick = Button2Click
+  end
+end

contrib/mORMot/SQLite3/Documentation/Release/ReleaseForm.pas

@@ -0,0 +1,175 @@
+unit ReleaseForm;
+
+interface
+
+uses
+  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
+  Dialogs, StdCtrls, ShellAPI, SynCommons;
+
+type
+  TForm1 = class(TForm)
+    Label1: TLabel;
+    Label2: TLabel;
+    Edit1: TEdit;
+    Button1: TButton;
+    Memo1: TMemo;
+    Button2: TButton;
+    procedure Button1Click(Sender: TObject);
+    procedure Button2Click(Sender: TObject);
+  private
+  public
+  end;
+
+var
+  Form1: TForm1;
+
+implementation
+
+{$R *.dfm}
+{$R vista.RES} // includes Win10 manifest - use .RES for linux cross-compilation
+
+procedure TForm1.Button1Click(Sender: TObject);
+var SearchVersion, Text, Head: string;
+
+  procedure ProcessFile(const FN: TFileName);
+  var SL: TStringList;
+      s,tag,title: string;
+      i,j,k,l: integer;
+      first,titledone: boolean;
+  begin
+    SL := TStringList.Create;
+    try
+      SL.LoadFromFile(FN);
+      first := false;
+      titledone := false;
+      for i := 0 to SL.Count-1 do begin
+        s := trim(SL[i]);
+        if s='' then continue;
+        if not titledone and (s[1]='/') then begin
+          while (s<>'') and (s[1] in [' ','/']) do delete(s,1,1);
+          if s='' then continue;
+          if s[1]='-' then
+            titledone := true else
+            title := title+s+' ';
+        end;
+        if SameText(s,'interface') then
+          exit else
+        if IdemPChar(pointer(s),'UNIT ') then
+          first := true else
+        if first and
+           (copy(s,length(s)-length(SearchVersion)+1,length(SearchVersion))=SearchVersion) then begin
+          s := ExtractFileName(FN);
+          tag := copy(s,1,pos('.',s)-1);
+          Head := Head+#13#10'<li><b><a href=#'+tag+'>'+s+'</a></b> - '+trim(title)+';</li>';
+          Text := Text+#13#10'<a name='+tag+'><h3>Unit '+s+'</h3></a>'#13#10;
+          for j := i+1 to SL.Count-1 do begin
+            s := trim(SL[j]);
+            if s='' then
+              break;
+            if s[1]='-' then begin
+              delete(s,1,1);
+              if first then begin
+                first := false;
+                Text := Text+'<ul>';
+              end else
+                Text := Text+';</li>';
+              s := trim(s);
+              s[1] := UpCase(s[1]);
+              s := #13#10'<li>'+s;
+            end else
+              if not first then
+                s := ' '+s;
+            k := 1;
+            repeat
+              k := PosEx('[',s,k);
+              if k=0 then break;
+              for l := k+1 to Length(s) do
+                case s[l] of
+                ']': begin
+                  if l-k-1>9 then begin
+                    Insert('>'+copy(s,k+1,l-k-1)+'</a>',s,l);
+                    Insert('<a href=https://synopse.info/fossil/info/',s,k+1);
+                  end;
+                  k := l;
+                end;
+                'a'..'z','0'..'9': ;
+                else begin
+                  k := l;
+                  break;
+                end;
+              end;
+              inc(k);
+            until false;
+            Text := Text+s;
+          end;
+          Text := Text+'.</li>'#13#10'</ul>'#13#10;
+          exit;
+        end;
+      end;
+    finally
+      SL.Free;
+    end;
+  end;
+  procedure Search(const Folder: TFileName);
+  var SR: TSearchRec;
+  begin
+    if FindFirst(Folder+'*.pas',faAnyFile,SR)<>0 then
+      exit;
+    repeat
+      if IdemPChar(pointer(SR.Name),'SYN') or
+         IdemPChar(pointer(SR.Name),'MORMOT') then
+        ProcessFile(Folder+SR.Name);
+    until FindNext(SR)<>0;
+    FindClose(SR);
+  end;
+begin
+  SearchVersion := Edit1.Text;
+  Search(ExtractFilePath(paramstr(0))+'..\..\..\'); // D:\Dev\Lib
+  Search(ExtractFilePath(paramstr(0))+'..\..\..\SynDBDataSet\'); 
+  Search(ExtractFilePath(paramstr(0))+'..\..\');    // D:\Dev\Lib\SQLite3
+  Head[length(Head)-5] := '.';
+  Text := '<p>Our Open Source <a href=https://synopse.info/fossil/wiki?name=SQLite3+Framework>'+
+    '<i>mORMot</i> framework</a> is now available in revision '+
+    SearchVersion+'.</p>'#13#10#13#10+
+    '<p>The main new features are the following:<ul><li>...</li></ul></p>'#13#10+
+    '<p>Go down to the <a href=#Download>download and forum links</a>.'#13#10+
+    '<h2>Synopse mORMot '+SearchVersion+' fixes and enhancements</h2>'#13#10+
+    '<p>This is a per-unit list of changes for the '+SearchVersion+
+    ' release of <i>mORMot</i>:</p>'#13#10'<ul>'+
+    Head+'</ul><p>Changes in details:<br />'#13#10+Text+#13#10'<p><br />'+
+    '<a name=Download><h2>Synopse mORMot download</h2></a>'+
+    'To get it, go to <a href="https://synopse.info/fossil/wiki?name=Downloads">this '+
+    'download page</a>, or <a href="https://synopse.info/fossil">use the '+
+    'source</a>...<p>Do not forget to get and read the '+
+    'full reference documentation available there (mainly the <a href='+
+    'https://synopse.info/files/pdf/Synopse%20mORMot%20Framework%20SAD%20'+SearchVersion+
+    '.pdf>"SAD" - Software Architecture Design</a> - document).</p>'#13#10+
+    '<p>Feedback and questions are <a href="https://synopse.info/forum/viewtopic.php?id=449">welcome in our forum</a>, just '+
+    'as usual.</p>';
+  Memo1.Text := Text;
+end;
+
+procedure TForm1.Button2Click(Sender: TObject);
+var FN: TFileName;
+    version, content: string;
+begin
+  version := Edit1.Text;
+  content := Memo1.Text;
+  if content='' then begin
+    Button1Click(nil);
+    content := Memo1.Text;
+  end;
+  FN := ChangeFileExt(paramstr(0),'_'+Version+'.htm');
+  with TFileStream.Create(FN,fmCreate) do
+  try
+    content := '<html><head><title>'+Caption+' '+Version+'</title></head>'+
+      '<body>'+Content+'</body></html>';
+    Write(content[1],length(content));
+  finally
+    Free;
+  end;
+  if DebugHook=0 then
+    ShellExecute(0,nil,pointer(FN),nil,nil,SW_SHOWNORMAL);
+end;
+
+end.

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/FossilCommit.bat

@@ -0,0 +1,11 @@
+del *.bak /s> nul
+
+fossil ci -M %1
+
+rem push if chkFossilPush checked in SourceCodeRep tool
+if %2==1 (
+  fossil push
+)
+
+@echo.
+@pause

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/FossilCommit.sh

@@ -0,0 +1,15 @@
+#!/bin/bash
+
+echo DescFile=$1
+echo Push=$2
+echo FossilRepository=$3
+
+
+cd $3
+fossil ci -M $1
+
+# push if chkFossilPush checked in SourceCodeRep tool
+if [ $2 -eq 1 ]
+then
+  fossil push
+fi

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/FossilStatus.bat

@@ -0,0 +1 @@
+fossil status>%1

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/FossilStatus.sh

@@ -0,0 +1,3 @@
+#!/bin/bash
+
+fossil status > $1

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/FossilUpdate.bat

@@ -0,0 +1,5 @@
+fossil pull
+fossil update
+
+@echo.
+@pause

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/FossilUpdate.sh

@@ -0,0 +1,4 @@
+#!/bin/bash
+
+fossil pull
+fossil update

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitCommit.bat

@@ -0,0 +1,22 @@
+@echo off
+@echo FossilRepository=%1
+@echo GitRepository=%2
+@echo GitExe=%3
+@echo DescFile=%4
+@echo DevPath=%5
+
+@echo.
+@echo.
+@echo mORMot repository
+@echo -----------------
+
+rem %3 pull
+
+del /q /s %2\*.bak %2\*.bk2 > nul 2> nul
+
+%3 add .
+%3 commit -a --file=%4
+%3 push
+
+echo.
+pause

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitCommit.sh

@@ -0,0 +1,17 @@
+#!/bin/bash
+
+echo FossilRepository=$1
+echo GitRepository=$2
+echo GitExe=$3
+echo DescFile=$4
+echo DevPath=$5
+
+echo
+echo
+echo mORMot repository
+echo -----------------
+
+cd $2
+$3 add .
+$3 commit -a --file=$4
+$3 push

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitCommitAll.bat

@@ -0,0 +1,60 @@
+@echo off
+@echo FossilRepository=%1
+@echo GitRepository=%2
+@echo GitExe=%3
+@echo DescFile=%4
+@echo DevPath=%5
+
+@echo.
+@echo.
+@echo mORMot repository
+@echo -----------------
+
+del /q /s %2\*.bak %2\*.bk2 > nul 2> nul
+%3 add .
+%3 commit -a --file=%4
+%3 push
+
+
+@echo.
+@echo.
+@echo SynPDF repository
+@echo -----------------
+
+@cd ..\SynPDF
+%3 add .
+%3 commit -a --file=%4
+%3 push
+
+@echo.
+@echo.
+@echo dmustache repository
+@echo --------------------
+
+@cd ..\dmustache
+%3 add .
+%3 commit -a --file=%4
+%3 push
+
+@echo.
+@echo.
+@echo LVCL repository
+@echo ---------------
+
+@cd ..\LVCL
+%3 add .
+%3 commit -a --file=%4
+%3 push
+
+@echo.
+@echo.
+@echo SynProject repository
+@echo ---------------------
+
+@cd ..\SynProject
+%3 add .
+%3 commit -a --file=%4
+%3 push
+
+@echo.
+@pause

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitCommitAll.sh

@@ -0,0 +1,7 @@
+#!/bin/bash
+
+GitCommit.sh
+GitCommitDMustache.sh
+GitCommitLVCL.sh
+GitCommitSynPdf.sh
+GitCommitSynProject.sh

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitCommitDMustache.bat

@@ -0,0 +1,19 @@
+@echo off
+@echo FossilRepository=%1
+@echo GitRepository=%2
+@echo GitExe=%3
+@echo DescFile=%4
+
+@echo.
+@echo.
+@echo dmustache repository
+@echo --------------------
+
+@cd ..\dmustache
+
+%3 add .
+%3 commit -a --file=%4
+%3 push
+
+@echo.
+@pause

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitCommitDMustache.sh

@@ -0,0 +1,18 @@
+#!/bin/bash
+
+echo FossilRepository=$1
+echo GitRepository=$2
+echo GitExe=$3
+echo DescFile=$4
+#echo DevPath=$5
+echo
+echo
+echo dmustache repository
+echo --------------------
+
+cd $2
+cd ../dmustache
+$3 add .
+$3 commit -a --file=$4
+$3 push
+

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitCommitLVCL.bat

@@ -0,0 +1,18 @@
+@echo off
+@echo FossilRepository=%1
+@echo GitRepository=%2
+@echo GitExe=%3
+@echo DescFile=%4
+
+@echo.
+@echo.
+@echo LVCL repository
+@echo ---------------
+
+@cd ..\LVCL
+%3 add .
+%3 commit -a --file=%4
+%3 push
+
+@echo.
+@pause

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitCommitLVCL.sh

@@ -0,0 +1,18 @@
+#!/bin/bash
+
+echo FossilRepository=$1
+echo GitRepository=$2
+echo GitExe=$3
+echo DescFile=$4
+#echo DevPath=$5
+echo
+echo
+echo LVCL repository
+echo ---------------
+
+cd $2
+cd ../LVCL
+$3 add .
+$3 commit -a --file=$4
+$3 push
+

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitCommitSynPdf.bat

@@ -0,0 +1,16 @@
+@echo off
+@echo FossilRepository=%1
+@echo GitRepository=%2
+@echo GitExe=%3
+@echo DescFile=%4
+
+@echo.
+@echo.
+@echo SynPDF repository
+@echo -----------------
+
+@cd ..\SynPDF
+%3 add .
+%3 commit -a --file=%4
+%3 push
+

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitCommitSynPdf.sh

@@ -0,0 +1,18 @@
+#!/bin/bash
+
+echo FossilRepository=$1
+echo GitRepository=$2
+echo GitExe=$3
+echo DescFile=$4
+#echo DevPath=$5
+echo
+echo
+echo SynPDF repository
+echo -----------------
+
+cd $2
+cd ../SynPDF
+$3 add .
+$3 commit -a --file=$4
+$3 push
+

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitCommitSynProject.bat

@@ -0,0 +1,19 @@
+@echo off
+@echo FossilRepository=%1
+@echo GitRepository=%2
+@echo GitExe=%3
+@echo DescFile=%4
+
+@echo.
+@echo.
+@echo SynProject repository
+@echo ---------------------
+
+@cd ..\SynProject
+
+%3 add .
+%3 commit -a --file=%4
+%3 push
+
+@echo.
+@pause

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitCommitSynProject.sh

@@ -0,0 +1,17 @@
+#!/bin/bash
+
+echo FossilRepository=$1
+echo GitRepository=$2
+echo GitExe=$3
+echo DescFile=$4
+#echo DevPath=$5
+echo
+echo
+echo SynProject repository
+echo ---------------------
+
+cd $2
+cd ../SynProject
+$3 commit -a --file=$4
+$3 push
+

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/GitShell.bat

@@ -0,0 +1,6 @@
+@echo GitPath=%1
+@echo.
+
+@set path=%1;%path%
+
+@cmd

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/SourceCodeRep.dpr

@@ -0,0 +1,23 @@
+program SourceCodeRep;
+
+{$ifndef MSWINDOWS}
+  {$AppType console}
+{$endif}
+
+{$I ../../../Synopse.inc}
+
+uses
+  {$I ../../../SynDprUses.inc} // includes FastMM4
+  {$ifdef FPC}
+  Interfaces, // set appropriate LCL CreateWidgetset()
+  {$endif FPC}
+  Forms,
+  SourceCodeRepMain in 'SourceCodeRepMain.pas' {MainForm};
+
+{$R *.res}
+
+begin
+  Application.Initialize;
+  Application.CreateForm(TMainForm, MainForm);
+  Application.Run;
+end.

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/SourceCodeRep.lpi

@@ -0,0 +1,145 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="11"/>
+    <General>
+      <Flags>
+        <MainUnitHasUsesSectionForAllUnits Value="False"/>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+        <MainUnitHasScaledStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="SourceCodeRep"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <BuildModes Count="3">
+      <Item1 Name="Default" Default="True"/>
+      <Item2 Name="linux64">
+        <CompilerOptions>
+          <Version Value="11"/>
+          <SearchPaths>
+            <IncludeFiles Value="../..;../../.."/>
+            <OtherUnitFiles Value="../..;../../.."/>
+            <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+          </SearchPaths>
+          <Parsing>
+            <SyntaxOptions>
+              <SyntaxMode Value="Delphi"/>
+            </SyntaxOptions>
+          </Parsing>
+          <CodeGeneration>
+            <TargetCPU Value="x86_64"/>
+            <TargetOS Value="linux"/>
+            <Optimizations>
+              <OptimizationLevel Value="2"/>
+            </Optimizations>
+          </CodeGeneration>
+          <Linking>
+            <Debugging>
+              <GenerateDebugInfo Value="False"/>
+            </Debugging>
+            <Options>
+              <Win32>
+                <GraphicApplication Value="True"/>
+              </Win32>
+            </Options>
+          </Linking>
+        </CompilerOptions>
+      </Item2>
+      <Item3 Name="win32">
+        <CompilerOptions>
+          <Version Value="11"/>
+          <SearchPaths>
+            <IncludeFiles Value="../..;../../.."/>
+            <Libraries Value="../../../static/$(TargetCPU)-$(TargetOS)"/>
+            <OtherUnitFiles Value="../..;../../.."/>
+            <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+          </SearchPaths>
+          <Parsing>
+            <SyntaxOptions>
+              <SyntaxMode Value="Delphi"/>
+            </SyntaxOptions>
+          </Parsing>
+          <CodeGeneration>
+            <TargetCPU Value="i386"/>
+            <TargetOS Value="win32"/>
+            <Optimizations>
+              <OptimizationLevel Value="2"/>
+            </Optimizations>
+          </CodeGeneration>
+          <Linking>
+            <Debugging>
+              <GenerateDebugInfo Value="False"/>
+            </Debugging>
+            <Options>
+              <Win32>
+                <GraphicApplication Value="True"/>
+              </Win32>
+            </Options>
+          </Linking>
+        </CompilerOptions>
+      </Item3>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+      <Modes Count="0"/>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="SourceCodeRep.dpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="SourceCodeRepMain.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="MainForm"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="Form"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <SearchPaths>
+      <IncludeFiles Value="../..;../../.."/>
+      <OtherUnitFiles Value="../..;../../.."/>
+      <UnitOutputDirectory Value="lib/default"/>
+    </SearchPaths>
+    <Parsing>
+      <SyntaxOptions>
+        <SyntaxMode Value="Delphi"/>
+      </SyntaxOptions>
+    </Parsing>
+    <Linking>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/SourceCodeRepMain.dfm

@@ -0,0 +1,249 @@
+object MainForm: TMainForm
+  Left = 506
+  Top = 235
+  BorderStyle = bsDialog
+  Caption = ' mORMot Source Code Repository Synch'
+  ClientHeight = 507
+  ClientWidth = 601
+  Color = clBtnFace
+  Constraints.MinHeight = 422
+  Constraints.MinWidth = 617
+  Font.Charset = DEFAULT_CHARSET
+  Font.Color = clWindowText
+  Font.Height = -11
+  Font.Name = 'Tahoma'
+  Font.Style = []
+  OldCreateOrder = False
+  OnCreate = FormCreate
+  DesignSize = (
+    601
+    507)
+  PixelsPerInch = 96
+  TextHeight = 13
+  object lbl1: TLabel
+    Left = 24
+    Top = 8
+    Width = 66
+    Height = 13
+    Caption = 'Pending Files:'
+  end
+  object lbl2: TLabel
+    Left = 24
+    Top = 224
+    Width = 95
+    Height = 13
+    Caption = 'Commit Description:'
+  end
+  object mmoStatus: TMemo
+    Left = 16
+    Top = 24
+    Width = 569
+    Height = 193
+    Anchors = [akLeft, akTop, akRight]
+    Font.Charset = DEFAULT_CHARSET
+    Font.Color = clWindowText
+    Font.Height = -11
+    Font.Name = 'Consolas'
+    Font.Style = []
+    ParentFont = False
+    ReadOnly = True
+    ScrollBars = ssVertical
+    TabOrder = 1
+  end
+  object mmoDescription: TMemo
+    Left = 16
+    Top = 240
+    Width = 569
+    Height = 180
+    Anchors = [akLeft, akTop, akRight, akBottom]
+    Font.Charset = DEFAULT_CHARSET
+    Font.Color = clWindowText
+    Font.Height = -11
+    Font.Name = 'Consolas'
+    Font.Style = []
+    ParentFont = False
+    ScrollBars = ssVertical
+    TabOrder = 0
+  end
+  object btnFossilSynch: TButton
+    Left = 168
+    Top = 427
+    Width = 113
+    Height = 32
+    Anchors = [akLeft, akBottom]
+    Caption = 'Fossil Synch'
+    TabOrder = 3
+    OnClick = btnFossilSynchClick
+  end
+  object btnFullSynch: TButton
+    Left = 472
+    Top = 427
+    Width = 113
+    Height = 57
+    Anchors = [akLeft, akBottom]
+    Caption = 'Fossil and Git Synch'
+    Font.Charset = DEFAULT_CHARSET
+    Font.Color = clWindowText
+    Font.Height = -13
+    Font.Name = 'Tahoma'
+    Font.Style = [fsBold]
+    ParentFont = False
+    TabOrder = 2
+    WordWrap = True
+    OnClick = btnFullSynchClick
+  end
+  object btnGitSynch: TButton
+    Left = 304
+    Top = 427
+    Width = 81
+    Height = 41
+    Anchors = [akLeft, akBottom]
+    Caption = 'Git Synch'
+    TabOrder = 4
+    OnClick = btnGitSynchClick
+  end
+  object btnRefreshStatus: TButton
+    Left = 520
+    Top = 5
+    Width = 75
+    Height = 18
+    Anchors = [akTop, akRight]
+    Caption = 'Refresh'
+    TabOrder = 5
+    OnClick = btnRefreshStatusClick
+  end
+  object btnGitShell: TButton
+    Left = 232
+    Top = 478
+    Width = 49
+    Height = 25
+    Anchors = [akLeft, akBottom]
+    Caption = 'Git Shell'
+    TabOrder = 6
+    OnClick = btnGitShellClick
+  end
+  object btnFossilShell: TButton
+    Left = 168
+    Top = 478
+    Width = 65
+    Height = 25
+    Anchors = [akLeft, akBottom]
+    Caption = 'Fossil Shell'
+    TabOrder = 7
+    OnClick = btnFossilShellClick
+  end
+  object btnTests: TButton
+    Left = 16
+    Top = 427
+    Width = 113
+    Height = 60
+    Anchors = [akLeft, akBottom]
+    Caption = 'Regression Tests'
+    TabOrder = 8
+    WordWrap = True
+    OnClick = btnTestsClick
+  end
+  object btnCopyLink: TButton
+    Left = 512
+    Top = 222
+    Width = 75
+    Height = 18
+    Caption = 'Copy Link'
+    TabOrder = 9
+    OnClick = btnCopyLinkClick
+  end
+  object btnGitAll: TButton
+    Left = 304
+    Top = 474
+    Width = 41
+    Height = 25
+    Hint = 
+      'Git Commit mORMot + SynPDF + SynMustache + LVCL + SynProject rep' +
+      'ositories'
+    Anchors = [akLeft, akBottom]
+    Caption = 'Git ALL'
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 10
+    OnClick = btnGitSynchClick
+  end
+  object btnSynProject: TButton
+    Left = 392
+    Top = 426
+    Width = 65
+    Height = 25
+    Hint = 'Git Commit SynProject Repository'
+    Anchors = [akLeft, akBottom]
+    Caption = 'SynProject'
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 11
+    OnClick = btnGitSynchClick
+  end
+  object btnSynPdf: TButton
+    Left = 392
+    Top = 450
+    Width = 65
+    Height = 25
+    Hint = 'Git Commit SynPdf Repository'
+    Anchors = [akLeft, akBottom]
+    Caption = 'SynPdf'
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 12
+    OnClick = btnGitSynchClick
+  end
+  object btnDMustache: TButton
+    Left = 392
+    Top = 474
+    Width = 65
+    Height = 25
+    Hint = 'Git Commit dmustache Repository'
+    Anchors = [akLeft, akBottom]
+    Caption = 'dmustache'
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 13
+    OnClick = btnGitSynchClick
+  end
+  object btnLVCL: TButton
+    Left = 344
+    Top = 474
+    Width = 41
+    Height = 25
+    Hint = 'Git Commit LVCL Repository'
+    Anchors = [akLeft, akBottom]
+    Caption = 'LVCL'
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 14
+    OnClick = btnGitSynchClick
+  end
+  object chkCopyLink: TCheckBox
+    Left = 496
+    Top = 486
+    Width = 89
+    Height = 17
+    Anchors = [akLeft, akBottom]
+    Caption = 'and copy link'
+    TabOrder = 15
+  end
+  object chkFossilPush: TCheckBox
+    Left = 168
+    Top = 458
+    Width = 65
+    Height = 17
+    Anchors = [akLeft, akBottom]
+    Caption = 'and push'
+    TabOrder = 16
+  end
+  object chkFossilPull: TCheckBox
+    Left = 230
+    Top = 458
+    Width = 59
+    Height = 17
+    Anchors = [akLeft, akBottom]
+    Caption = 'and pull'
+    TabOrder = 17
+  end
+end

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/SourceCodeRepMain.lfm

@@ -0,0 +1,237 @@
+object MainForm: TMainForm
+  Left = 506
+  Height = 507
+  Top = 235
+  Width = 617
+  BorderStyle = bsDialog
+  Caption = ' mORMot Source Code Repository Synch'
+  ClientHeight = 507
+  ClientWidth = 617
+  Color = clBtnFace
+  Constraints.MinHeight = 422
+  Constraints.MinWidth = 617
+  Font.Color = clWindowText
+  Font.Height = -11
+  Font.Name = 'Tahoma'
+  OnCreate = FormCreate
+  LCLVersion = '1.9.0.0'
+  object lbl1: TLabel
+    Left = 24
+    Height = 14
+    Top = 8
+    Width = 77
+    Caption = 'Pending Files:'
+    ParentColor = False
+  end
+  object lbl2: TLabel
+    Left = 24
+    Height = 14
+    Top = 224
+    Width = 115
+    Caption = 'Commit Description:'
+    ParentColor = False
+  end
+  object mmoStatus: TMemo
+    Left = 16
+    Height = 193
+    Top = 24
+    Width = 585
+    Anchors = [akTop, akLeft, akRight]
+    Font.Color = clWindowText
+    Font.Height = -11
+    Font.Name = 'Consolas'
+    ParentFont = False
+    ReadOnly = True
+    ScrollBars = ssVertical
+    TabOrder = 1
+  end
+  object mmoDescription: TMemo
+    Left = 16
+    Height = 180
+    Top = 240
+    Width = 585
+    Anchors = [akTop, akLeft, akRight, akBottom]
+    Font.Color = clWindowText
+    Font.Height = -11
+    Font.Name = 'Consolas'
+    ParentFont = False
+    ScrollBars = ssVertical
+    TabOrder = 0
+  end
+  object btnFossilSynch: TButton
+    Left = 168
+    Height = 32
+    Top = 427
+    Width = 113
+    Anchors = [akLeft, akBottom]
+    Caption = 'Fossil Synch'
+    OnClick = btnFossilSynchClick
+    TabOrder = 3
+  end
+  object btnFullSynch: TButton
+    Left = 472
+    Height = 57
+    Top = 427
+    Width = 113
+    Anchors = [akLeft, akBottom]
+    Caption = 'Fossil+Git'
+    Font.Color = clWindowText
+    Font.Height = -13
+    Font.Name = 'Tahoma'
+    Font.Style = [fsBold]
+    OnClick = btnFullSynchClick
+    ParentFont = False
+    TabOrder = 2
+  end
+  object btnGitSynch: TButton
+    Left = 304
+    Height = 41
+    Top = 427
+    Width = 81
+    Anchors = [akLeft, akBottom]
+    Caption = 'Git Synch'
+    OnClick = btnGitSynchClick
+    TabOrder = 4
+  end
+  object btnRefreshStatus: TButton
+    Left = 536
+    Height = 18
+    Top = 5
+    Width = 75
+    Anchors = [akTop, akRight]
+    Caption = 'Refresh'
+    OnClick = btnRefreshStatusClick
+    TabOrder = 5
+  end
+  object btnGitShell: TButton
+    Left = 232
+    Height = 25
+    Top = 478
+    Width = 49
+    Anchors = [akLeft, akBottom]
+    Caption = 'Git Shell'
+    OnClick = btnGitShellClick
+    TabOrder = 6
+  end
+  object btnFossilShell: TButton
+    Left = 168
+    Height = 25
+    Top = 478
+    Width = 65
+    Anchors = [akLeft, akBottom]
+    Caption = 'Fossil Shell'
+    OnClick = btnFossilShellClick
+    TabOrder = 7
+  end
+  object btnTests: TButton
+    Left = 16
+    Height = 60
+    Top = 427
+    Width = 113
+    Anchors = [akLeft, akBottom]
+    Caption = 'Regression Tests'
+    OnClick = btnTestsClick
+    TabOrder = 8
+  end
+  object btnCopyLink: TButton
+    Left = 512
+    Height = 18
+    Top = 222
+    Width = 75
+    Caption = 'Copy Link'
+    OnClick = btnCopyLinkClick
+    TabOrder = 9
+  end
+  object btnGitAll: TButton
+    Left = 304
+    Height = 25
+    Hint = 'Git Commit mORMot + SynPDF + SynMustache + LVCL + SynProject repositories'
+    Top = 474
+    Width = 41
+    Anchors = [akLeft, akBottom]
+    Caption = 'Git ALL'
+    OnClick = btnGitSynchClick
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 10
+  end
+  object btnSynProject: TButton
+    Left = 392
+    Height = 25
+    Hint = 'Git Commit SynProject Repository'
+    Top = 426
+    Width = 65
+    Anchors = [akLeft, akBottom]
+    Caption = 'SynProject'
+    OnClick = btnGitSynchClick
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 11
+  end
+  object btnSynPdf: TButton
+    Left = 392
+    Height = 25
+    Hint = 'Git Commit SynPdf Repository'
+    Top = 450
+    Width = 65
+    Anchors = [akLeft, akBottom]
+    Caption = 'SynPdf'
+    OnClick = btnGitSynchClick
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 12
+  end
+  object btnDMustache: TButton
+    Left = 392
+    Height = 25
+    Hint = 'Git Commit dmustache Repository'
+    Top = 474
+    Width = 65
+    Anchors = [akLeft, akBottom]
+    Caption = 'dmustache'
+    OnClick = btnGitSynchClick
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 13
+  end
+  object btnLVCL: TButton
+    Left = 344
+    Height = 25
+    Hint = 'Git Commit LVCL Repository'
+    Top = 474
+    Width = 41
+    Anchors = [akLeft, akBottom]
+    Caption = 'LVCL'
+    OnClick = btnGitSynchClick
+    ParentShowHint = False
+    ShowHint = True
+    TabOrder = 14
+  end
+  object chkCopyLink: TCheckBox
+    Left = 480
+    Height = 23
+    Top = 480
+    Width = 93
+    Anchors = [akLeft, akBottom]
+    Caption = '+copy link'
+    TabOrder = 15
+  end
+  object chkFossilPush: TCheckBox
+    Left = 168
+    Height = 23
+    Top = 455
+    Width = 66
+    Anchors = [akLeft, akBottom]
+    Caption = '+push'
+    TabOrder = 16
+  end
+  object chkFossilPull: TCheckBox
+    Left = 230
+    Height = 23
+    Top = 455
+    Width = 59
+    Anchors = [akLeft, akBottom]
+    Caption = '+pull'
+    TabOrder = 17
+  end
+end

contrib/mORMot/SQLite3/Documentation/SourceCodeRep/SourceCodeRepMain.pas

@@ -0,0 +1,371 @@
+unit SourceCodeRepMain;
+
+{$I ../../../Synopse.inc}
+
+interface
+
+uses
+  {$IFNDEF FPC}
+  Windows,
+  {$ELSE}
+  LCLIntf,
+  LCLType,
+  LMessages,
+  {$ENDIF}
+  SynCommons,
+  Messages,
+  SysUtils,
+  Variants,
+  Classes,
+  Graphics,
+  Controls,
+  Forms,
+  Dialogs,
+  StdCtrls,
+  Clipbrd;
+
+const
+  VERSION = '1.18';
+
+type
+
+  { TMainForm }
+
+  TMainForm = class(TForm)
+    mmoStatus: TMemo;
+    lbl1: TLabel;
+    lbl2: TLabel;
+    mmoDescription: TMemo;
+    btnFossilSynch: TButton;
+    btnFullSynch: TButton;
+    btnGitSynch: TButton;
+    btnRefreshStatus: TButton;
+    btnGitShell: TButton;
+    btnFossilShell: TButton;
+    btnTests: TButton;
+    btnCopyLink: TButton;
+    btnGitAll: TButton;
+    btnSynProject: TButton;
+    btnSynPdf: TButton;
+    btnDMustache: TButton;
+    btnLVCL: TButton;
+    chkCopyLink: TCheckBox;
+    chkFossilPush: TCheckBox;
+    chkFossilPull: TCheckBox;
+    procedure FormCreate(Sender: TObject);
+    procedure btnFullSynchClick(Sender: TObject);
+    procedure btnFossilSynchClick(Sender: TObject);
+    procedure btnGitSynchClick(Sender: TObject);
+    procedure btnRefreshStatusClick(Sender: TObject);
+    procedure btnGitShellClick(Sender: TObject);
+    procedure btnFossilShellClick(Sender: TObject);
+    procedure btnTestsClick(Sender: TObject);
+    procedure btnCopyLinkClick(Sender: TObject);
+  private
+    fBatPath: TFileName;
+    fFossilRepository: TFileName;
+    fDevPath: TFileName;
+    fGitExe: TFileName;
+    fGitRepository: TFileName;
+    function Exec(const folder, exe, arg1, arg2, arg3, arg4, arg5: TFileName;
+      exeisshell: boolean=true; wait: boolean=true): boolean;
+    procedure ReadStatus;
+  public
+    { Public declarations }
+  end;
+
+var
+  MainForm: TMainForm;
+
+implementation
+
+uses
+  mORMotService; // for cross-platform RunProcess()
+
+{$IFNDEF FPC}
+  {$R *.dfm}
+{$ELSE}
+  {$R *.lfm}
+{$ENDIF}
+
+{$ifdef MSWINDOWS}
+  {$R ..\..\..\vista.RES} // includes Win10 manifest - use .RES for linux cross-compilation
+const
+  SHELL = '.bat';
+  SHELLEXE = 'cmd.exe';
+  GITDEF = 'git.exe';
+  REPFOSSIL = 'd:\dev\fossil\lib';
+  REPLIB = 'd:\dev\lib';
+  REPGITHUB = 'd:\dev\github\';
+{$else}
+const
+  SHELL = '.sh';
+  GITDEF = '/usr/bin/git';
+var
+  REPFOSSIL: TFileName;
+  REPLIB: TFileName;
+  REPGITHUB: TFileName;
+{$endif}
+
+function TMainForm.Exec(const folder, exe, arg1, arg2, arg3, arg4, arg5: TFileName;
+  exeisshell, wait: boolean): boolean;
+var
+  bak, path: TFileName;
+  {$ifdef MSWINDOWS}
+  function q(const a: TFileName): TFileName;
+  begin
+    result := '"' + a + '"'; // paranoid quote for safety
+  end;
+  {$else}
+  type q = TFileName;
+  {$endif}
+begin
+  if folder <> '' then begin
+    bak := GetCurrentDir;
+    SetCurrentDir(folder);
+  end;
+  if exeisshell then
+    path := fBatPath + exe + SHELL
+  else
+    path := exe;
+  screen.Cursor := crHourGlass;
+  try
+    result := RunProcess(path, q(arg1), wait, q(arg2), q(arg3), q(arg4), q(arg5)) = 0;
+  finally
+    if bak <> '' then
+      SetCurrentDir(bak);
+    screen.Cursor := crDefault;
+  end;
+end;
+
+procedure TMainForm.ReadStatus;
+var
+  statusfile: TFileName;
+  status: RawUTF8;
+begin
+  statusfile := fBatPath + 'status.txt';
+  DeleteFile(statusfile);
+  if not Exec(fFossilRepository, 'FossilStatus', statusfile, '', '', '', '') then
+    status := 'error executing FossilStatus script'
+  else
+    status := StringFromFile(statusfile);
+  {$ifdef MSWINDOWS}
+  if PosEx(#13#10, status) = 0 then
+    status := StringReplaceAll(status, #10, #13#10);
+  {$endif}
+  mmoStatus.Text := UTF8ToString(status);
+end;
+
+procedure TMainForm.FormCreate(Sender: TObject);
+{$ifdef MSWINDOWS}
+begin
+{$else}
+var
+  dev: TFileName;
+begin
+  dev := GetSystemPath(spUserDocuments) + 'dev/';
+  REPFOSSIL := dev + 'fossil/lib';
+  REPLIB := dev + 'lib';
+  REPGITHUB := dev + 'github/';
+  btnFossilShell.caption := 'Fossil diff';
+  btnGitShell.caption := 'Git diff';
+{$endif MSWINDOWS}
+  fBatPath := ExeVersion.ProgramFilePath;
+  if not FileExists(fBatPath + 'FossilStatus' + SHELL) then // from exe sub-folder?
+    fBatPath := ExtractFilePath(ExcludeTrailingPathDelimiter(fBatPath));
+  if not FileExists(fBatPath + 'FossilStatus' + SHELL) then // from exe sub-folder?
+    fBatPath := ExtractFilePath(ExcludeTrailingPathDelimiter(fBatPath));
+  if not FileExists(fBatPath + 'FossilStatus' + SHELL) then
+    ShowMessage('Missing *' + SHELL +' files');
+  fFossilRepository := GetEnvironmentVariable('SYN_FOSSILREPO_PATH');
+  if fFossilRepository = '' then
+    fFossilRepository := REPFOSSIL;
+  fDevPath := GetEnvironmentVariable('SYN_DEVPATH');
+  if fDevPath = '' then
+    if DirectoryExists(REPLIB) then
+      fDevPath := REPLIB else
+      fDevPath := fFossilRepository;
+  fGitExe := GetEnvironmentVariable('GIT_PATH');
+  if fGitExe = '' then begin
+    {$ifdef MSWINDOWS}
+    fGitExe := 'c:\Program Files (x86)\Git\bin\git.exe';
+    if not FileExists(fGitExe) then
+    {$endif}
+      fGitExe := GITDEF;
+  end;
+  fGitRepository := GetEnvironmentVariable('SYN_GITREPO_PATH');
+  if fGitRepository = '' then
+    fGitRepository := REPGITHUB + 'mORMot';
+  if not DirectoryExists(fFossilRepository) then begin
+    ShowMessage('Please set Fossil Repository Name or environment variable SYN_FOSSILREPO_PATH');
+    Close;
+  end else if not DirectoryExists(fGitRepository) then begin
+    ShowMessage('Please set Git Repository Path or environment variable SYN_GITREPO_PATH');
+    Close;
+  end else if ((fGitExe <> GITDEF) and not FileExists(fGitExe)) or
+       ((fGitExe = GITDEF) and
+        not Exec(fGitRepository, GITDEF, 'status', '', '', '', '', {isshell=}false)) then begin
+    ShowMessage('Please install Git or set environment variable GIT_PATH');
+    Close;
+  end else
+    ReadStatus;
+end;
+
+procedure TMainForm.btnFullSynchClick(Sender: TObject);
+begin
+  btnFossilSynch.Click;
+  btnGitSynch.Click;
+  if chkCopyLink.Checked then
+    btnCopyLink.Click;
+end;
+
+procedure TMainForm.btnFossilSynchClick(Sender: TObject);
+var
+  Desc: string;
+  DescFile: TFileName;
+  VersionNumber: integer;
+  VersionText: RawUTF8;
+begin
+  Desc := trim(mmoDescription.Text);
+  if Desc = '' then begin
+    ShowMessage('Missing description');
+    mmoDescription.SetFocus;
+    exit;
+  end;
+  if chkFossilPull.Checked then
+    Exec(fFossilRepository, 'FossilUpdate', '', '', '', '', '');
+  VersionText := UnQuoteSQLString(StringFromFile(fDevPath + PathDelim + 'SynopseCommit.inc'));
+  VersionText := GetCSVItem(pointer(VersionText), 2, '.');
+  VersionNumber := GetCardinalDef(pointer(VersionText), 255);
+  inc(VersionNumber);
+  VersionText := '''' + VERSION + '.' + UInt32ToUtf8(VersionNumber) + ''''#13#10;
+  FileFromString(VersionText, fDevPath + PathDelim +'SynopseCommit.inc');
+  FileFromString(VersionText, fFossilRepository + PathDelim + 'SynopseCommit.inc');
+  DescFile := fBatPath + 'desc.txt';
+  FileFromString('{' + ToUTF8(VersionNumber) + '} ' + Desc, DescFile);
+  Exec(fFossilRepository, 'FossilCommit', DescFile, IntToStr(ord(chkFossilPush.Checked)), fFossilRepository, '', '');
+  btnRefreshStatus.Click;
+end;
+
+procedure TMainForm.btnGitSynchClick(Sender: TObject);
+var
+  Desc, status: string;
+  DescFile, BatchFile, GitHub: TFileName;
+  i,n: integer;
+begin
+  Desc := trim(mmoDescription.Text);
+  if Desc = '' then begin
+    status := mmoStatus.Text;
+    i := pos('comment:', status);
+    if i > 0 then begin
+      delete(status, 1, i + 8);
+      with TStringList.Create do
+      try
+        Text := trim(status);
+        status := Strings[0];
+        for i := 1 to Count - 1 do
+          if copy(Strings[i], 1, 3) = '   ' then
+            status := status + ' ' + trim(Strings[i])
+          else
+            break;
+      finally
+        Free;
+      end;
+      i := pos('(user: ', status);
+      if i > 0 then
+        SetLength(status, i - 1);
+      i := pos('} ', status);
+      if (i > 0) and (i < 10) then
+        delete(status, 1, i + 1); // trim left '{256} '
+      mmoDescription.Text := trim(status);
+    end
+    else begin
+      ShowMessage('Missing description');
+      mmoDescription.SetFocus;
+    end;
+    exit;
+  end;
+  if not DirectoryExists(fGitRepository) then begin
+    ShowMessage('Please set Git Repository Name');
+    exit;
+  end;
+  DescFile := fBatPath + 'desc.txt';
+  FileFromString(Desc, DescFile);
+  GitHub := ExtractFilePath(fGitRepository);
+  n := 0;
+  if (Sender = btnGitAll) or (Sender = btnSynProject) then
+    inc(n,SynchFolders(fFossilRepository, GitHub + 'SynProject', true, true, true));
+  if (Sender = btnGitAll) or (Sender = btnSynPdf) then
+    inc(n,SynchFolders(fFossilRepository, GitHub + 'SynPDF', false, true, true));
+  if (Sender = btnGitAll) or (Sender = btnDMustache) then
+    inc(n,SynchFolders(fFossilRepository, GitHub + 'dmustache', false, true, true));
+  if (Sender = btnGitAll) or (Sender = btnLVCL) then
+    inc(n,SynchFolders(fFossilRepository, GitHub + 'LVCL', false, true, true));
+  if (Sender = btnGitAll) or (Sender = btnGitSynch) then
+    inc(n,SynchFolders(fFossilRepository, GitHub + 'mORMot', true, true, true));
+  {$I-} Writeln(n,' file(s) synched to GitHub'#13#10); {$I+}
+  if Sender = btnGitAll then
+    BatchFile := 'GitCommitAll'
+  else if Sender = btnSynProject then
+    BatchFile := 'GitCommitSynProject'
+  else if Sender = btnSynPdf then
+    BatchFile := 'GitCommitSynPdf'
+  else if Sender = btnDMustache then
+    BatchFile := 'GitCommitDMustache'
+  else if Sender = btnLVCL then
+    BatchFile := 'GitCommitLVCL'
+  else
+    BatchFile := 'GitCommit';
+  Exec(fGitRepository, BatchFile, fFossilRepository, fGitRepository, fGitExe, DescFile, fDevPath);
+  mmoDescription.SetFocus; // ReadStatus not necessary if git only
+end;
+
+procedure TMainForm.btnRefreshStatusClick(Sender: TObject);
+begin
+  ReadStatus;
+  mmoDescription.SetFocus;
+  mmoDescription.SelectAll;
+end;
+
+procedure TMainForm.btnGitShellClick(Sender: TObject);
+begin
+  {$ifdef MSWINDOWS}
+  Exec(fGitRepository, SHELLEXE, '', '', '', '', '');
+  {$else}
+  Exec(fGitRepository, '/usr/bin/meld', fGitRepository, fDevPath, '', '', '', false, false);
+  {$endif}
+end;
+
+procedure TMainForm.btnFossilShellClick(Sender: TObject);
+begin
+  {$ifdef MSWINDOWS}
+  Exec(fFossilRepository, SHELLEXE, '', '', '', '', '');
+  {$else}
+  Exec(fFossilRepository, '/usr/bin/meld', fFossilRepository, fDevPath, '', '', '', false, false);
+  {$endif}
+end;
+
+procedure TMainForm.btnTestsClick(Sender: TObject);
+begin
+  {$ifdef MSWINDOWS}
+  Exec(fDevPath, 'compilpil', '', '', '', '', '');
+  {$endif}
+end;
+
+procedure TMainForm.btnCopyLinkClick(Sender: TObject);
+var
+  i: integer;
+  status: string;
+begin
+  status := mmoStatus.Lines.Text;
+  i := pos('checkout:', status);
+  if i < 0 then
+    exit;
+  inc(i, 10);
+  while (i < length(status)) and (status[i] <= ' ') do
+    inc(i);
+  Clipboard.AsText := 'https://synopse.info/fossil/info/' + copy(status, i, 10);
+end;
+
+end.
+

contrib/mORMot/SQLite3/SQLite3UI.rc

@@ -0,0 +1,3 @@
+butClose 2 SQLite3btnClose.bmp 
+butMax 2 SQLite3btnMax.bmp 
+butMin 2 SQLite3btnMin.bmp