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

source upload

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

4
contrib/mORMot/CrossPlatform/CopySynCrossPlatformUnits.bat Normal file
View File

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

140
contrib/mORMot/CrossPlatform/SynCrossPlatform.inc Normal file
View File

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

361
contrib/mORMot/CrossPlatform/SynCrossPlatformCrypto.pas Normal file
View File

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

2174
contrib/mORMot/CrossPlatform/SynCrossPlatformJSON.pas Normal file
View File

File diff suppressed because it is too large Load Diff

3805
contrib/mORMot/CrossPlatform/SynCrossPlatformREST.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1218
contrib/mORMot/CrossPlatform/SynCrossPlatformSpecific.pas Normal file
View File

File diff suppressed because it is too large Load Diff

261
contrib/mORMot/CrossPlatform/SynCrossPlatformSynLZ.pas Normal file
View File

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

891
contrib/mORMot/CrossPlatform/SynCrossPlatformTests.pas Normal file
View File

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

186
contrib/mORMot/CrossPlatform/templates/API.adoc.mustache Normal file
View File

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

309
contrib/mORMot/CrossPlatform/templates/CrossPlatform.pas.mustache Normal file
View File

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

174
contrib/mORMot/CrossPlatform/templates/Delphi.pas.mustache Normal file
View File

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

87
contrib/mORMot/CrossPlatform/templates/FPC-mORMotInterfaces.pas.mustache Normal file
View File

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

157
contrib/mORMot/CrossPlatform/templates/FPCServer-mORMotServer.pas.mustache Normal file
View File

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

361
contrib/mORMot/CrossPlatform/templates/SmartMobileStudio.pas.mustache Normal file
View File

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

395
contrib/mORMot/CrossPlatform/templates/Swagger.json.mustache Normal file
View File

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