Delphi/delphimvcframework
1
0
Fork 0
mirror of https://github.com/danieleteti/delphimvcframework.git synced 2024-11-15 15:55:54 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

added postgresql

Browse Source
This commit is contained in:
Daniele Teti 2020-12-23 14:33:50 +01:00
parent 3fc8d90942
commit d2af1470e4
199 changed files with 6905 additions and 3891 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
clean.bat
View File

@ -1,2 +1,2 @@
del /s *.~*;*.exe;*.cfg;*.dof;*.gdb;*.dcu;*.local;*.identcache;*.dSYM;*.o;*.rsm;*.so;*.apk;*.log;*.tvsconfig;*.map
del /s *.~*;*.dof;*.dcu;*.local;*.identcache;*.dSYM;*.o;*.rsm;*.so;*.apk;*.log;*.tvsconfig;*.map
exit

5846
lib/dmustache/SynCommons.pas
View File

File diff suppressed because it is too large Load Diff

671
lib/dmustache/SynFPCLinux.pas
View File

@ -1,671 +0,0 @@
/// wrapper of some Windows-like functions translated to Linux/BSD for FPC
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit SynFPCLinux;
{
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 Alfred Glaenzer.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
- Alan Chate
- Arnaud Bouchez
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 *****
}
interface
{$I Synopse.inc} // set proper flags, and define LINUX for BSD and ANDROID
uses
{$ifdef LINUX}
UnixType,
{$endif LINUX}
SysUtils;
const
{ HRESULT codes, delphi-like }
NOERROR = 0;
NO_ERROR = 0;
INVALID_HANDLE_VALUE = THandle(-1);
LOCALE_USER_DEFAULT = $400;
// for CompareStringW()
NORM_IGNORECASE = 1 shl ord(coIgnoreCase); // [widestringmanager.coIgnoreCase]
/// compatibility function, wrapping Win32 API mutex initialization
procedure InitializeCriticalSection(var cs : TRTLCriticalSection); inline;
/// compatibility function, wrapping Win32 API mutex finalization
procedure DeleteCriticalSection(var cs : TRTLCriticalSection); inline;
{$ifdef LINUX}
/// used by SynCommons to compute the sizes in byte
function getpagesize: Integer; cdecl; external 'c';
/// compatibility function, wrapping Win32 API high resolution timer
// - returns nanoseconds resolution, calling e.g. CLOCK_MONOTONIC on Linux/BSD
procedure QueryPerformanceCounter(out Value: Int64);
/// slightly faster than QueryPerformanceCounter() div 1000 - but not for Windows
// - returns microseconds resolution, calling e.g. CLOCK_MONOTONIC on Linux/BSD
procedure QueryPerformanceMicroSeconds(out Value: Int64); inline;
/// compatibility function, wrapping Win32 API high resolution timer
// - hardcoded to 1e9 for clock_gettime() nanoseconds resolution on Linux/BSD
function QueryPerformanceFrequency(out Value: Int64): boolean;
/// compatibility function, wrapping Win32 API file position change
function SetFilePointer(hFile: cInt; lDistanceToMove: TOff;
lpDistanceToMoveHigh: Pointer; dwMoveMethod: cint): TOff; inline;
/// compatibility function, wrapping Win32 API file size retrieval
function GetFileSize(hFile: cInt; lpFileSizeHigh: PDWORD): DWORD;
/// compatibility function, wrapping Win32 API file truncate at current position
procedure SetEndOfFile(hFile: cInt); inline;
/// compatibility function, wrapping Win32 API file flush to disk
procedure FlushFileBuffers(hFile: cInt); inline;
/// compatibility function, wrapping Win32 API last error code
function GetLastError: longint; inline;
/// compatibility function, wrapping Win32 API last error code
procedure SetLastError(error: longint); inline;
/// compatibility function, wrapping Win32 API text comparison
// - somewhat slow by using two temporary UnicodeString - but seldom called,
// unless our proprietary WIN32CASE collation is used in SynSQLite3
function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: Pwidechar;
cchCount1: longint; lpString2: Pwidechar; cchCount2: longint): longint;
/// returns the current UTC time
// - will convert from clock_gettime(CLOCK_REALTIME_COARSE) if available
function GetNowUTC: TDateTime;
/// returns the current UTC time, as Unix Epoch seconds
// - will call clock_gettime(CLOCK_REALTIME_COARSE) if available
function GetUnixUTC: Int64;
/// returns the current UTC time, as Unix Epoch milliseconds
// - will call clock_gettime(CLOCK_REALTIME_COARSE) if available
function GetUnixMSUTC: Int64;
/// returns the current UTC time as TSystemTime
// - will convert from clock_gettime(CLOCK_REALTIME_COARSE) if available
procedure GetNowUTCSystem(out result: TSystemTime);
var
/// will contain the current Linux kernel revision, as one 24-bit integer
// - e.g. $030d02 for 3.13.2, or $020620 for 2.6.32
KernelRevision: cardinal;
/// calls the pthread_setname_np() function, if available on this system
// - under Linux/FPC, this API truncates the name to 16 chars
procedure SetUnixThreadName(ThreadID: TThreadID; const Name: RawByteString);
{$ifdef BSD}
function fpsysctlhwint(hwid: cint): Int64;
function fpsysctlhwstr(hwid: cint; var temp: shortstring): pointer;
{$endif BSD}
{$ifndef DARWIN} // OSX has no clock_gettime() API
{$ifdef BSD}
const // see https://github.com/freebsd/freebsd/blob/master/sys/sys/time.h
CLOCK_REALTIME = 0;
CLOCK_MONOTONIC = 4;
CLOCK_REALTIME_COARSE = 10; // named CLOCK_REALTIME_FAST in FreeBSD 8.1+
CLOCK_MONOTONIC_COARSE = 12;
{$else}
const
CLOCK_REALTIME = 0;
CLOCK_MONOTONIC = 1;
CLOCK_REALTIME_COARSE = 5; // see http://lwn.net/Articles/347811
CLOCK_MONOTONIC_COARSE = 6;
{$endif BSD}
var
// contains CLOCK_REALTIME_COARSE since kernel 2.6.32
CLOCK_REALTIME_FAST: integer = CLOCK_REALTIME;
// contains CLOCK_MONOTONIC_COARSE since kernel 2.6.32
CLOCK_MONOTONIC_FAST: integer = CLOCK_MONOTONIC;
{$endif DARWIN}
{$endif LINUX}
/// compatibility function, to be implemented according to the running OS
// - expect more or less the same result as the homonymous Win32 API function
// - will call clock_gettime(CLOCK_MONOTONIC_COARSE) if available
function GetTickCount64: Int64;
/// compatibility function, to be implemented according to the running OS
// - expect more or less the same result as the homonymous Win32 API function
// - will call clock_gettime(CLOCK_MONOTONIC_COARSE) if available
function GetTickCount: cardinal;
var
/// could be set to TRUE to force SleepHiRes(0) to call the sched_yield API
// - in practice, it has been reported as buggy under POSIX systems
// - even Linus Torvald himself raged against its usage - see e.g.
// https://www.realworldtech.com/forum/?threadid=189711&curpostid=189752
// - you may tempt the devil and try it by yourself
SleepHiRes0Yield: boolean = false;
/// similar to Windows sleep() API call, to be truly cross-platform
// - using millisecond resolution
// - SleepHiRes(0) calls ThreadSwitch on windows, but this POSIX version will
// wait 10 microsecond unless SleepHiRes0Yield is forced to true (bad idea)
// - in respect to RTL's Sleep() function, it will return on ESysEINTR
procedure SleepHiRes(ms: cardinal);
/// check if any char is pending from StdInputHandle file descriptor
function UnixKeyPending: boolean;
implementation
{$ifdef LINUX}
uses
Classes,
Unix,
BaseUnix,
{$ifdef BSD}
sysctl,
{$else}
Linux,
{$endif BSD}
dl;
{$endif LINUX}
procedure InitializeCriticalSection(var cs : TRTLCriticalSection);
begin
InitCriticalSection(cs);
end;
procedure DeleteCriticalSection(var cs : TRTLCriticalSection);
begin
{$ifdef LINUXNOTBSD}
if cs.__m_kind<>0 then
{$endif LINUXNOTBSD}
DoneCriticalSection(cs);
end;
function UnixKeyPending: boolean;
var
fdsin: tfdSet;
begin
fpFD_ZERO(fdsin);
fpFD_SET(StdInputHandle,fdsin);
result := fpSelect(StdInputHandle+1,@fdsin,nil,nil,0)>0;
end;
{$ifdef LINUX}
const // Date Translation - see http://en.wikipedia.org/wiki/Julian_day
HoursPerDay = 24;
MinsPerHour = 60;
SecsPerMin = 60;
MinsPerDay = HoursPerDay*MinsPerHour;
SecsPerDay = MinsPerDay*SecsPerMin;
SecsPerHour = MinsPerHour*SecsPerMin;
C1970 = 2440588;
D0 = 1461;
D1 = 146097;
D2 = 1721119;
UnixDelta = 25569;
C_THOUSAND = Int64(1000);
C_MILLION = Int64(C_THOUSAND * C_THOUSAND);
C_BILLION = Int64(C_THOUSAND * C_THOUSAND * C_THOUSAND);
procedure JulianToGregorian(JulianDN: PtrUInt; out result: TSystemTime);
{$ifdef HASINLINE}inline;{$endif}
var YYear,XYear,Temp,TempMonth: PtrUInt;
begin
Temp := ((JulianDN-D2)*4)-1;
JulianDN := Temp div D1;
XYear := (Temp-(JulianDN*D1)) or 3;
YYear := XYear div D0;
Temp := (((XYear-(YYear*D0)+4) shr 2)*5)-3;
TempMonth := Temp div 153;
result.Day := ((Temp-(TempMonth*153))+5) div 5;
if TempMonth>=10 then begin
inc(YYear);
dec(TempMonth,12-3);
end else
inc(TempMonth,3);
result.Month := TempMonth;
result.Year := YYear+(JulianDN*100);
// initialize fake dayOfWeek - as used by SynCommons.FromGlobalTime RCU128
result.DayOfWeek := 0;
end;
procedure EpochToSystemTime(epoch: PtrUInt; out result: TSystemTime);
var t: PtrUInt;
begin
t := epoch div SecsPerDay;
JulianToGregorian(t+C1970,result);
dec(epoch,t*SecsPerDay);
t := epoch div SecsPerHour;
result.Hour := t;
dec(epoch,t*SecsPerHour);
t := epoch div SecsPerMin;
result.Minute := t;
result.Second := epoch-t*SecsPerMin;
end;
function GetTickCount: cardinal;
begin
result := cardinal(GetTickCount64);
end;
{$ifdef DARWIN}
// clock_gettime() is not implemented: http://stackoverflow.com/a/5167506
type
TTimebaseInfoData = record
Numer: cardinal;
Denom: cardinal;
end;
function mach_absolute_time: UInt64;
cdecl external 'libc.dylib' name 'mach_absolute_time';
function mach_timebase_info(var TimebaseInfoData: TTimebaseInfoData): Integer;
cdecl external 'libc.dylib' name 'mach_timebase_info';
var
mach_timeinfo: TTimebaseInfoData;
mach_timecoeff: double;
mach_timenanosecond: boolean; // very likely to be TRUE on Intel CPUs
procedure QueryPerformanceCounter(out Value: Int64);
begin // returns time in nano second resolution
Value := mach_absolute_time;
if mach_timeinfo.Denom=1 then
if mach_timeinfo.Numer=1 then
// seems to be the case on Intel CPUs
exit else
Value := Value*mach_timeinfo.Numer else
// use floating point to avoid potential overflow
Value := round(Value*mach_timecoeff);
end;
procedure QueryPerformanceMicroSeconds(out Value: Int64);
begin
if mach_timenanosecond then
Value := mach_absolute_time div C_THOUSAND else begin
QueryPerformanceCounter(Value);
Value := Value div C_THOUSAND; // ns to us
end;
end;
function GetTickCount64: Int64;
begin
if mach_timenanosecond then
result := mach_absolute_time else
QueryPerformanceCounter(result);
result := result div C_MILLION; // ns to ms
end;
function GetUnixUTC: Int64;
var tz: timeval;
begin
fpgettimeofday(@tz,nil);
result := tz.tv_sec;
end;
function GetUnixMSUTC: Int64;
var tz: timeval;
begin
fpgettimeofday(@tz,nil);
result := (tz.tv_sec*C_THOUSAND)+tz.tv_usec div C_THOUSAND; // in milliseconds
end;
procedure GetNowUTCSystem(out result: TSystemTime);
var tz: timeval;
begin
fpgettimeofday(@tz,nil);
EpochToSystemTime(tz.tv_sec,result);
result.MilliSecond := tz.tv_usec div C_THOUSAND;
end;
{$else}
{$ifdef BSD}
function clock_gettime(ID: cardinal; r: ptimespec): Integer;
cdecl external 'libc.so' name 'clock_gettime';
function clock_getres(ID: cardinal; r: ptimespec): Integer;
cdecl external 'libc.so' name 'clock_getres';
{$endif BSD}
function GetTickCount64: Int64;
var tp: timespec;
begin
clock_gettime(CLOCK_MONOTONIC_FAST,@tp); // likely = CLOCK_MONOTONIC_COARSE
Result := (Int64(tp.tv_sec) * C_THOUSAND) + (tp.tv_nsec div C_MILLION); // in ms
end;
function GetUnixMSUTC: Int64;
var r: timespec;
begin
clock_gettime(CLOCK_REALTIME_FAST,@r); // likely = CLOCK_REALTIME_COARSE
result := (Int64(r.tv_sec) * C_THOUSAND) + (r.tv_nsec div C_MILLION); // in ms
end;
function GetUnixUTC: Int64;
var r: timespec;
begin
clock_gettime(CLOCK_REALTIME_FAST,@r);
result := r.tv_sec;
end;
procedure QueryPerformanceCounter(out Value: Int64);
var r : TTimeSpec;
begin
clock_gettime(CLOCK_MONOTONIC,@r);
value := r.tv_nsec+r.tv_sec*C_BILLION; // returns nanoseconds resolution
end;
procedure QueryPerformanceMicroSeconds(out Value: Int64);
var r : TTimeSpec;
begin
clock_gettime(CLOCK_MONOTONIC,@r);
value := PtrUInt(r.tv_nsec) div C_THOUSAND+r.tv_sec*C_MILLION; // as microseconds
end;
procedure GetNowUTCSystem(out result: TSystemTime);
var r: timespec;
begin
clock_gettime(CLOCK_REALTIME_FAST,@r); // faster than fpgettimeofday()
EpochToSystemTime(r.tv_sec,result);
result.MilliSecond := r.tv_nsec div C_MILLION;
end;
{$endif DARWIN}
{$ifdef BSD}
function fpsysctlhwint(hwid: cint): Int64;
var mib: array[0..1] of cint;
len: cint;
begin
result := 0;
mib[0] := CTL_HW;
mib[1] := hwid;
len := SizeOf(result);
fpsysctl(pointer(@mib),2,@result,@len,nil,0);
end;
function fpsysctlhwstr(hwid: cint; var temp: shortstring): pointer;
var mib: array[0..1] of cint;
len: cint;
begin
mib[0] := CTL_HW;
mib[1] := hwid;
FillChar(temp,SizeOf(temp),0); // use shortstring as temp 0-terminated buffer
len := SizeOf(temp);
fpsysctl(pointer(@mib),2,@temp,@len,nil,0);
if temp[0]<>#0 then
result := @temp else
result := nil;
end;
{$endif BSD}
function GetNowUTC: TDateTime;
begin
result := GetUnixMSUTC / MSecsPerDay + UnixDelta;
end;
function QueryPerformanceFrequency(out Value: Int64): boolean;
begin
Value := C_BILLION; // 1 second = 1e9 nanoseconds
result := true;
end;
function SetFilePointer(hFile: cInt; lDistanceToMove: TOff;
lpDistanceToMoveHigh: Pointer; dwMoveMethod: cint): TOff;
var offs: Int64;
begin
Int64Rec(offs).Lo := lDistanceToMove;
if lpDistanceToMoveHigh=nil then
Int64Rec(offs).Hi := 0 else
Int64Rec(offs).Hi := PDWord(lpDistanceToMoveHigh)^;
offs := FpLseek(hFile,offs,dwMoveMethod);
result := Int64Rec(offs).Lo;
if lpDistanceToMoveHigh<>nil then
PDWord(lpDistanceToMoveHigh)^ := Int64Rec(offs).Hi;
end;
procedure SetEndOfFile(hFile: cInt);
begin
FpFtruncate(hFile,FPLseek(hFile,0,SEEK_CUR));
end;
procedure FlushFileBuffers(hFile: cInt);
begin
FpFsync(hFile);
end;
function GetLastError: longint;
begin
result := fpgeterrno;
end;
procedure SetLastError(error: longint);
begin
fpseterrno(error);
end;
function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: Pwidechar;
cchCount1: longint; lpString2: Pwidechar; cchCount2: longint): longint;
var U1,U2: UnicodeString; // (may be?) faster than WideString
begin // not inlined to avoid try..finally UnicodeString protection
if cchCount1<0 then
cchCount1 := StrLen(lpString1);
SetString(U1,lpString1,cchCount1);
if cchCount2<0 then
cchCount2 := StrLen(lpString2);
SetString(U2,lpString2,cchCount2);
result := widestringmanager.CompareUnicodeStringProc(U1,U2,TCompareOptions(dwCmpFlags));
end;
function GetFileSize(hFile: cInt; lpFileSizeHigh: PDWORD): DWORD;
var FileInfo: TStat;
begin
if fpFstat(hFile,FileInfo)<>0 then
FileInfo.st_Size := 0; // returns 0 on error
result := Int64Rec(FileInfo.st_Size).Lo;
if lpFileSizeHigh<>nil then
lpFileSizeHigh^ := Int64Rec(FileInfo.st_Size).Hi;
end;
procedure SleepHiRes(ms: cardinal);
var timeout: TTimespec;
begin
if ms=0 then // handle SleepHiRes(0) special case
if SleepHiRes0Yield then begin // reported as buggy by Alan on POSIX
ThreadSwitch; // call e.g. pthread's sched_yield API
exit;
end else begin
timeout.tv_sec := 0;
timeout.tv_nsec := 10000; // 10us is around timer resolution on modern HW
end else begin
timeout.tv_sec := ms div 1000;
timeout.tv_nsec := 1000000*(ms mod 1000);
end;
fpnanosleep(@timeout,nil)
// no retry loop on ESysEINTR (as with regular RTL's Sleep)
end;
procedure GetKernelRevision;
var uts: UtsName;
P: PAnsiChar;
tp: timespec;
function GetNext: cardinal;
var c: cardinal;
begin
result := 0;
repeat
c := ord(P^)-48;
if c>9 then
break else
result := result*10+c;
inc(P);
until false;
if P^ in ['.','-',' '] then
inc(P);
end;
begin
if fpuname(uts)=0 then begin
P := @uts.release[0];
KernelRevision := GetNext shl 16+GetNext shl 8+GetNext;
end else
uts.release[0] := #0;
{$ifdef DARWIN}
mach_timebase_info(mach_timeinfo);
mach_timecoeff := mach_timeinfo.Numer/mach_timeinfo.Denom;
mach_timenanosecond := (mach_timeinfo.Numer=1) and (mach_timeinfo.Denom=1);
{$else}
{$ifdef LINUX}
// try Linux kernel 2.6.32+ or FreeBSD 8.1+ fastest clocks
if clock_gettime(CLOCK_REALTIME_COARSE, @tp) = 0 then
CLOCK_REALTIME_FAST := CLOCK_REALTIME_COARSE;
if clock_gettime(CLOCK_MONOTONIC_COARSE, @tp) = 0 then
CLOCK_MONOTONIC_FAST := CLOCK_MONOTONIC_COARSE;
if (clock_gettime(CLOCK_REALTIME_FAST,@tp)<>0) or // paranoid check
(clock_gettime(CLOCK_MONOTONIC_FAST,@tp)<>0) then
raise Exception.CreateFmt('clock_gettime() not supported by %s kernel - errno=%d',
[PAnsiChar(@uts.release),GetLastError]);
{$endif LINUX}
{$endif DARWIN}
end;
type
TExternalLibraries = object
Lock: TRTLCriticalSection;
Loaded: boolean;
{$ifdef LINUX}
pthread: pointer;
{$ifdef LINUXNOTBSD} // see https://stackoverflow.com/a/7989973
pthread_setname_np: function(thread: pointer; name: PAnsiChar): LongInt; cdecl;
{$endif LINUXNOTBSD}
{$endif LINUX}
procedure EnsureLoaded;
procedure Done;
end;
var
ExternalLibraries: TExternalLibraries;
procedure TExternalLibraries.EnsureLoaded;
begin
EnterCriticalSection(Lock);
if not Loaded then begin
{$ifdef LINUX}
pthread := dlopen({$ifdef ANDROID}'libc.so'{$else}'libpthread.so.0'{$endif}, RTLD_LAZY);
if pthread <> nil then begin
{$ifdef LINUXNOTBSD}
@pthread_setname_np := dlsym(pthread, 'pthread_setname_np');
{$endif LINUXNOTBSD}
end;
{$endif LINUX}
Loaded := true;
end;
LeaveCriticalSection(Lock);
end;
procedure TExternalLibraries.Done;
begin
EnterCriticalSection(Lock);
if Loaded then begin
{$ifdef LINUX}
{$ifdef LINUXNOTBSD}
@pthread_setname_np := nil;
{$endif LINUXNOTBSD}
if pthread <> nil then
dlclose(pthread);
{$endif LINUX}
end;
LeaveCriticalSection(Lock);
DeleteCriticalSection(Lock);
end;
procedure SetUnixThreadName(ThreadID: TThreadID; const Name: RawByteString);
var trunc: array[0..15] of AnsiChar; // truncated to 16 bytes (including #0)
i,L: integer;
begin
if Name = '' then
exit;
L := 0; // trim unrelevant spaces and prefixes when filling the 16 chars
i := 1;
if Name[1] = 'T' then
if PCardinal(Name)^ = ord('T') + ord('S') shl 8 + ord('Q') shl 16 + ord('L') shl 24 then
i := 5
else
i := 2;
while i <= length(Name) do begin
if Name[i]>' ' then begin
trunc[L] := Name[i];
inc(L);
if L = high(trunc) then
break;
end;
inc(i);
end;
if L = 0 then
exit;
trunc[L] := #0;
{$ifdef LINUXNOTBSD}
ExternalLibraries.EnsureLoaded;
if Assigned(ExternalLibraries.pthread_setname_np) then
ExternalLibraries.pthread_setname_np(pointer(ThreadID), @trunc[0]);
{$endif LINUXNOTBSD}
end;
initialization
GetKernelRevision;
InitializeCriticalSection(ExternalLibraries.Lock);
finalization
ExternalLibraries.Done;
{$endif LINUX}
end.

196
lib/dmustache/SynFPCTypInfo.pas
View File

@ -1,196 +0,0 @@
/// wrapper around FPC typinfo.pp unit for SynCommons.pas and mORMot.pas
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit SynFPCTypInfo;
{
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 Alfred Glaenzer.
Portions created by the Initial Developer are Copyright (C) 2020
the Initial Developer. All Rights Reserved.
Contributor(s):
- Arnaud Bouchez
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 *****
Unit created to avoid polluting the SynCommons.pas/mORMot.pas namespace
with overloaded typinfo.pp types.
}
interface
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
uses
SysUtils,
TypInfo;
{$ifdef FPC_PROVIDE_ATTR_TABLE}
type
// if you have a compilation error here, your FPC trunk is too old
// - TTypeData.AttributeTable was introduced in SVN 42356-42411 (2019/07)
// -> undefine FPC_PROVIDE_ATTR_TABLE in Synopse.inc and recompile
PFPCAttributeTable = TypInfo.PAttributeTable;
{$endif FPC_PROVIDE_ATTR_TABLE}
{$ifdef HASALIGNTYPEDATA}
function AlignTypeData(p: pointer): pointer; inline;
function AlignTypeDataClean(p: pointer): pointer; inline;
{$else}
type
AlignTypeData = pointer;
AlignTypeDataClean = pointer;
{$endif HASALIGNTYPEDATA}
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
function AlignToPtr(p: pointer): pointer; inline;
function AlignPTypeInfo(p: pointer): pointer; inline;
{$else FPC_REQUIRES_PROPER_ALIGNMENT}
type
AlignToPtr = pointer;
AlignPTypeInfo = pointer;
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
type
/// some type definition to avoid inclusion of TypInfo in SynCommons/mORMot.pas
PFPCInterfaceData = TypInfo.PInterfaceData;
PFPCVmtMethodParam = TypInfo.PVmtMethodParam;
PFPCIntfMethodTable = TypInfo.PIntfMethodTable;
PFPCIntfMethodEntry = TypInfo.PIntfMethodEntry;
{$ifdef FPC_NEWRTTI}
PFPCRecInitData = TypInfo.PRecInitData;
{$endif FPC_NEWRTTI}
procedure FPCDynArrayClear(var a: Pointer; TypeInfo: Pointer);
procedure FPCFinalizeArray(p: Pointer; TypeInfo: Pointer; elemCount: PtrUInt);
procedure FPCFinalize(Data: Pointer; TypeInfo: Pointer);
procedure FPCRecordCopy(const Source; var Dest; TypeInfo: pointer);
procedure FPCRecordAddRef(var Data; TypeInfo : pointer);
implementation
procedure FPCDynArrayClear(var a: Pointer; TypeInfo: Pointer);
external name 'FPC_DYNARRAY_CLEAR';
procedure FPCFinalizeArray(p: Pointer; TypeInfo: Pointer; elemCount: PtrUInt);
external name 'FPC_FINALIZE_ARRAY';
procedure FPCFinalize(Data: Pointer; TypeInfo: Pointer);
external name 'FPC_FINALIZE';
procedure FPCRecordCopy(const Source; var Dest; TypeInfo: pointer);
external name 'FPC_COPY';
procedure FPCRecordAddRef(var Data; TypeInfo : pointer);
external name 'FPC_ADDREF';
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} // copied from latest typinfo.pp
function AlignToPtr(p: pointer): pointer;
begin
result := align(p,sizeof(p));
end;
function AlignTypeData(p: pointer): pointer;
{$packrecords c}
type
TAlignCheck = record // match RTTI TTypeInfo definition
b : byte; // = TTypeKind
q : qword; // = this is where the PTypeData begins
end;
{$packrecords default}
begin
{$ifdef VER3_0}
result := Pointer(align(p,SizeOf(Pointer)));
{$else VER3_0}
result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).q)));
{$endif VER3_0}
{$ifdef FPC_PROVIDE_ATTR_TABLE}
inc(PByte(result),SizeOf(PFPCAttributeTable)); // ignore attributes table
result := Pointer(align(result,PtrInt(@TAlignCheck(nil^).q)));
{$endif FPC_PROVIDE_ATTR_TABLE}
end;
{$else}
{$ifdef FPC_PROVIDE_ATTR_TABLE}
function AlignTypeData(p: pointer): pointer;
begin
result := p;
inc(PByte(result),SizeOf(PFPCAttributeTable)); // ignore attributes table
end;
{$endif FPC_PROVIDE_ATTR_TABLE}
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} // copied from latest typinfo.pp
function AlignTypeDataClean(p: pointer): pointer;
{$packrecords c}
type
TAlignCheck = record // match RTTI TTypeInfo definition
b : byte; // = TTypeKind
q : qword; // = this is where the PTypeData begins
end;
{$packrecords default}
begin
{$ifdef VER3_0}
result := Pointer(align(p,SizeOf(Pointer)));
{$else VER3_0}
result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).q)));
{$endif VER3_0}
end;
function AlignPTypeInfo(p: pointer): pointer; inline;
{$packrecords c}
type
TAlignCheck = record
b : byte;
p : pointer;
end;
{$packrecords default}
begin
Result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).p)))
end;
{$else}
{$ifdef HASALIGNTYPEDATA}
function AlignTypeDataClean(p: pointer): pointer;
begin
result := p;
end;
{$endif HASALIGNTYPEDATA}
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
end.

22
lib/dmustache/SynLZ.pas
View File

@ -175,6 +175,7 @@ end;
type // some cross-platform and cross-compiler definitions
{$ifndef FPC}
PtrInt = {$ifdef CPU64}NativeInt{$else}integer{$endif};
PtrUInt = {$ifdef CPU64}NativeUInt{$else}cardinal{$endif};
{$endif}
{$ifdef DELPHI5OROLDER} // Delphi 5 doesn't have those base types defined :(
@ -198,6 +199,7 @@ end;
// using direct x86 jmp also circumvents Internal Error C11715 for Delphi 5
{$ifdef CPUX86}
function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm
push ebp
push ebx
@ -626,13 +628,16 @@ end;
procedure movechars(s,d: PAnsiChar; t: PtrUInt); {$ifdef HASINLINE}inline;{$endif}
// fast code for unaligned and overlapping (see {$define WT}) small blocks
// this code is sometimes used rather than system.move()
var c: AnsiChar; // better code generation on FPC
begin
dec(PtrUInt(s), PtrUInt(d));
inc(t, PtrUInt(d));
inc(PtrUInt(s), t);
inc(PtrUInt(d), t);
PtrInt(t) := -PtrInt(t);
repeat
d^ := s[PtrUInt(d)];
inc(d);
until PtrUInt(d)=t;
c := s[t];
d[t] := c;
inc(t);
until t=0;
end;
const
@ -733,6 +738,7 @@ end;
{$ifdef CPUX86}
// using direct x86 jmp also circumvents Internal Error C11715 for Delphi 5
function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
{$ifdef FPC} nostackframe; assembler; {$endif}
asm
push ebp
push ebx
@ -965,12 +971,12 @@ asm // rcx=src, edx=size, r8=dest
jc @29
shr r12, 3
jz @30
@27: mov rbx, qword ptr [r14+rsi]
@27: mov rbx, qword ptr [r14+rsi] // inline move by 8 bytes
mov qword ptr [r8+rsi], rbx
add rsi, 8
dec r12
jnz @27
mov rbx, qword ptr [r14+rsi]
mov rbx, qword ptr [r14+rsi] // 1..7 remaining bytes
and r15, 7
jz @31
@28: mov byte ptr [r8+rsi], bl
@ -979,7 +985,7 @@ asm // rcx=src, edx=size, r8=dest
dec r15
jnz @28
jmp @31
@29: mov bl, byte ptr [r14+rsi]
@29: mov bl, byte ptr [r14+rsi] // overlaping move
mov byte ptr [r8+rsi], bl
inc rsi
dec r12

2
lib/dmustache/SynMustache.pas
View File

@ -419,7 +419,7 @@ type
Partials: TSynMustachePartials=nil; Helpers: TSynMustacheHelpers=nil;
OnTranslate: TOnStringTranslate=nil;
EscapeInvert: boolean=false): RawUTF8; overload;
/// search some text withing the {{mustache}} template text
/// search some text within the {{mustache}} template text
function FoundInTemplate(const text: RawUTF8): boolean;
/// read-only access to the raw {{mustache}} template content

265
lib/dmustache/SynTable.pas
View File

@ -96,7 +96,8 @@ type
// are handled with dedicated code, optionally with case-insensitive search
// - consider using TMatchs (or SetMatchs/TMatchDynArray) if you expect to
// search for several patterns, or even TExprParserMatch for expression search
{$ifdef UNICODE}TMatch = record{$else}TMatch = object{$endif}
{$ifdef USERECORDWITHMETHODS}TMatch = record
{$else}TMatch = object{$endif}
private
Pattern, Text: PUTF8Char;
P, T, PMax, TMax: PtrInt;
@ -697,6 +698,20 @@ type
property UTF8Length: boolean read fUTF8Length write fUTF8Length;
end;
resourcestring
sInvalidIPAddress = '"%s" is an invalid IP v4 address';
sInvalidEmailAddress = '"%s" is an invalid email address';
sInvalidPattern = '"%s" does not match the expected pattern';
sCharacter01n = 'character,character,characters';
sInvalidTextLengthMin = 'Expect at least %d %s';
sInvalidTextLengthMax = 'Expect up to %d %s';
sInvalidTextChar = 'Expect at least %d %s %s,Expect up to %d %s %s,'+
'alphabetical,digital,punctuation,lowercase,uppercase,space,'+
'Too much spaces on the left,Too much spaces on the right';
sValidationFailed = '"%s" rule failed';
sValidationFieldVoid = 'An unique key field must not be void';
sValidationFieldDuplicate = 'Value already used for this unique key field';
{ ************ Database types and classes ************************** }
@ -724,6 +739,7 @@ type
/// array of field/parameter/column types for abstract database access
// - this array as a fixed size, ready to handle up to MAX_SQLFIELDS items
TSQLDBFieldTypeArray = array[0..MAX_SQLFIELDS-1] of TSQLDBFieldType;
PSQLDBFieldTypeArray = ^TSQLDBFieldTypeArray;
/// how TSQLVar may be processed
// - by default, ftDate will use seconds resolution unless svoDateWithMS is set
@ -822,7 +838,8 @@ type
// - if no Stream is supplied, a temporary memory stream will be created
// (it's faster to supply one, e.g. any TSQLRest.TempMemoryStream)
constructor Create(aStream: TStream; Expand, withID: boolean;
const Fields: TSQLFieldIndexDynArray=nil; aBufSize: integer=8192); overload;
const Fields: TSQLFieldIndexDynArray=nil; aBufSize: integer=8192;
aStackBuffer: PTextWriterStackBuffer=nil); overload;
/// rewind the Stream position and write void JSON object
procedure CancelAllVoid;
/// write or init field names for appropriate JSON Expand later use
@ -915,7 +932,7 @@ procedure VariantToSQLVar(const Input: variant; var temp: RawByteString;
var Output: TSQLVar);
/// guess the correct TSQLDBFieldType from a variant type
function VariantVTypeToSQLDBFieldType(VType: word): TSQLDBFieldType;
function VariantVTypeToSQLDBFieldType(VType: cardinal): TSQLDBFieldType;
/// guess the correct TSQLDBFieldType from a variant value
function VariantTypeToSQLDBFieldType(const V: Variant): TSQLDBFieldType;
@ -1277,7 +1294,8 @@ type
// - is also safer, since will check for reaching end of buffer
// - raise a EFastReader exception on decoding error (e.g. if a buffer
// overflow may occur) or call OnErrorOverflow/OnErrorData event handlers
{$ifdef FPC_OR_UNICODE}TFastReader = record{$else}TFastReader = object{$endif}
{$ifdef USERECORDWITHMETHODS}TFastReader = record
{$else}TFastReader = object{$endif}
public
/// the current position in the memory
P: PAnsiChar;
@ -1966,9 +1984,6 @@ type
// - this class is thread-safe if you use properly the associated Safe lock
TSynCache = class(TSynPersistentLock)
protected
/// last index in fNameValue.List[] if was added by Find()
// - contains -1 if no previous immediate call to Find()
fFindLastAddedIndex: integer;
fFindLastKey: RawUTF8;
fNameValue: TSynNameValue;
fRamUsed: cardinal;
@ -2166,7 +2181,7 @@ type
fReaderTemp: PRawByteString;
fLoadFromLastUncompressed, fSaveToLastUncompressed: integer;
fLoadFromLastAlgo: TAlgoCompress;
/// low-level virtual methods implementing the persistence reading
/// low-level virtual methods implementing the persistence
procedure LoadFromReader; virtual;
procedure SaveToWriter(aWriter: TFileBufferWriter); virtual;
public
@ -2249,7 +2264,8 @@ type
TRawByteStringGroupValueDynArray = array of TRawByteStringGroupValue;
/// store several RawByteString content with optional concatenation
{$ifdef UNICODE}TRawByteStringGroup = record{$else}TRawByteStringGroup = object{$endif}
{$ifdef USERECORDWITHMETHODS}TRawByteStringGroup = record
{$else}TRawByteStringGroup = object{$endif}
public
/// actual list storing the data
Values: TRawByteStringGroupValueDynArray;
@ -2333,8 +2349,8 @@ type
/// simple stack-allocated type for handling a non-void type names list
// - Delphi "object" is buggy on stack -> also defined as record with methods
{$ifdef FPC_OR_UNICODE}TPropNameList = record
{$else}TPropNameList = object{$endif}
{$ifdef USERECORDWITHMETHODS}TPropNameList = record
{$else}TPropNameList = object{$endif}
public
/// the actual names storage
Values: TRawUTF8DynArray;
@ -2375,7 +2391,8 @@ type
// - bits 0..14 map a 15-bit increasing counter (collision-free)
// - bits 15..30 map a 16-bit process identifier
// - bits 31..63 map a 33-bit UTC time, encoded as seconds since Unix epoch
{$ifdef FPC_OR_UNICODE}TSynUniqueIdentifierBits = record{$else}TSynUniqueIdentifierBits = object{$endif}
{$ifdef USERECORDWITHMETHODS}TSynUniqueIdentifierBits = record
{$else}TSynUniqueIdentifierBits = object{$endif}
public
/// the actual 64-bit storage value
// - in practice, only first 63 bits are used
@ -2655,6 +2672,8 @@ type
function ComputeCredential(previous: boolean; const UserName,PassWord: RawUTF8): cardinal; virtual;
function GetPassword(const UserName: RawUTF8; out Password: RawUTF8): boolean; virtual; abstract;
function GetUsersCount: integer; virtual; abstract;
// check the given Hash challenge, against stored credentials
function CheckCredentials(const UserName: RaWUTF8; Hash: cardinal): boolean; virtual;
public
/// initialize the authentication scheme
constructor Create;
@ -2916,9 +2935,6 @@ type
function NextPendingTask: RawByteString; virtual;
/// flush all pending tasks
procedure Clear; virtual;
/// access to the locking methods of this instance
// - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block
property Safe: PSynlocker read fSafe;
/// access to the internal TPendingTaskListItem.Timestamp stored value
// - corresponding to the current time
// - default implementation is to return GetTickCount64, with a 16 ms
@ -3439,7 +3455,7 @@ type
TBlockingProcessPool = class(TSynPersistent)
protected
fClass: TBlockingProcessPoolItemClass;
fPool: TObjectListLocked;
fPool: TSynObjectListLocked;
fCallCounter: TBlockingProcessPoolCall; // set TBlockingProcessPoolItem.Call
public
/// initialize the pool, for a given implementation class
@ -3497,8 +3513,9 @@ type
TSystemUseDataDynArray = array of TSystemUseData;
/// low-level structure used to compute process memory and CPU usage
{$ifdef FPC_OR_UNICODE}TProcessInfo = record private
{$else}TProcessInfo = object protected{$endif}
{$ifdef USERECORDWITHMETHODS}TProcessInfo = record
{$else}TProcessInfo = object {$endif}
private
{$ifdef MSWINDOWS}
fSysPrevIdle, fSysPrevKernel, fSysPrevUser,
fDiffIdle, fDiffKernel, fDiffUser, fDiffTotal: Int64;
@ -3794,8 +3811,8 @@ type
/// used to store Time Zone information for a single area in TSynTimeZone
// - Delphi "object" is buggy on stack -> also defined as record with methods
{$ifdef FPC_OR_UNICODE}TTimeZoneData = record
{$else}TTimeZoneData = object{$endif}
{$ifdef USERECORDWITHMETHODS}TTimeZoneData = record
{$else}TTimeZoneData = object{$endif}
public
id: TTimeZoneID;
display: RawUTF8;
@ -3938,7 +3955,7 @@ function GetDiskInfo(var aDriveFolderOrFile: TFileName;
{$ifdef MSWINDOWS}; aVolumeName: PFileName = nil{$endif}): boolean;
{ ************ Markup (e.g. Emoji) process ************************** }
{ ************ Markup (e.g. HTML or Emoji) process ******************** }
type
/// tune AddHtmlEscapeWiki/AddHtmlEscapeMarkdown wrapper functions process
@ -4565,9 +4582,9 @@ type
// - you should call OrderedIndexRefresh method to ensure it is sorted
OrderedIndexNotSorted: boolean;
/// all TSynValidate instances registered per each field
Filters: TObjectList;
Filters: TSynObjectList;
/// all TSynValidate instances registered per each field
Validates: TObjectList;
Validates: TSynObjectList;
/// low-level binary comparison used by IDSort and TSynTable.IterateJSONValues
// - P1 and P2 must point to the values encoded in our SBF compact binary format
{$ifdef SORTCOMPAREMETHOD}
@ -4723,18 +4740,18 @@ type
// - is defined either as an object either as a record, due to a bug
// in Delphi 2009/2010 compiler (at least): this structure is not initialized
// if defined as an object on the stack, but will be as a record :(
{$ifdef UNICODE}TSynTableData = record{$else}TSynTableData = object{$endif UNICODE}
{$ifdef UNICODE}private{$else}protected{$endif UNICODE}
VType: TVarType;
Filler: array[1..SizeOf(TVarData)-SizeOf(TVarType)-SizeOf(pointer)*2-4] of byte;
{$ifdef USERECORDWITHMETHODS}TSynTableData = record
{$else}TSynTableData = object {$endif UNICODE}
private
VType: cardinal; // defined as cardinal not as word for proper aligment
VID: integer;
VTable: TSynTable;
VValue: TSBFString;
{$ifndef NOVARIANTS}
function GetFieldValue(const FieldName: RawUTF8): Variant; overload;
function GetFieldVarData(FieldName: PUTF8Char; FieldNameLen: PtrInt; var Value: TVarData): boolean;
procedure GetFieldVariant(const FieldName: RawUTF8; var result: Variant);
procedure SetFieldValue(const FieldName: RawUTF8; const Value: Variant); overload;
function GetField(const FieldName: RawUTF8): Variant;
procedure SetField(const FieldName: RawUTF8; const Value: Variant);
{$endif}
/// raise an exception if VTable=nil
procedure CheckVTableInitialized;
@ -4755,13 +4772,13 @@ type
property SBF: TSBFString read VValue;
{$ifndef NOVARIANTS}
/// set or retrieve a field value from a variant data
property Field[const FieldName: RawUTF8]: Variant read GetFieldValue write SetFieldValue;
property Field[const FieldName: RawUTF8]: Variant read GetField write SetField;
/// get a field value for a specified field
// - this method is faster than Field[], because it won't look for the field name
function GetFieldValue(aField: TSynTableFieldProperties): Variant; overload;
function GetFieldValue(aField: TSynTableFieldProperties): Variant;
/// set a field value for a specified field
// - this method is faster than Field[], because it won't look for the field name
procedure SetFieldValue(aField: TSynTableFieldProperties; const Value: Variant); overload;
procedure SetFieldValue(aField: TSynTableFieldProperties; const Value: Variant);
{$ifdef HASINLINE}inline;{$endif}
{$endif}
/// set a field value for a specified field, from SBF-encoded data
@ -5056,6 +5073,10 @@ type
procedure Copy(var Dest: TVarData; const Source: TVarData;
const Indirect: Boolean); override;
end;
/// initialize TSynTableVariantType if needed, and return the correspongind VType
function SynTableVariantVarType: cardinal;
{$endif NOVARIANTS}
const
@ -5109,6 +5130,11 @@ procedure ToSBFStr(const Value: RawByteString; out Result: TSBFString);
implementation
{$ifdef WITH_FASTMM4STATS}
uses
FastMM4; // override OS information by actual FastMM4 status
{$endif WITH_FASTMM4STATS}
{$ifdef FPCLINUX}
uses
termio,
@ -5131,6 +5157,13 @@ uses
var
SynTableVariantType: TCustomVariantType = nil;
function SynTableVariantVarType: cardinal;
begin
if SynTableVariantType=nil then
SynTableVariantType := SynRegisterCustomVariantType(TSynTableVariantType);
result := SynTableVariantType.VarType;
end;
procedure TSynTableVariantType.Clear(var V: TVarData);
begin
//Assert(V.VType=SynTableVariantType.VarType);
@ -5161,7 +5194,7 @@ function TSynTableVariantType.IntSet(const Instance, Value: TVarData;
var aName: RawUTF8;
begin
FastSetString(aName,Name,NameLen);
TSynTableData(Instance).SetFieldValue(aName,Variant(Value));
TSynTableData(Instance).SetField(aName,Variant(Value));
result := true;
end;
@ -5195,7 +5228,7 @@ end;
{ TSynTable }
{$ifdef CPUX86}
function SortQWord(const A,B: QWord): integer;
function SortQWord(const A,B: QWord): integer; {$ifdef FPC} nostackframe; assembler; {$endif}
asm // Delphi x86 compiler is not efficient, and oldest even incorrect
mov ecx, [eax]
mov eax, [eax + 4]
@ -5211,7 +5244,7 @@ asm // Delphi x86 compiler is not efficient, and oldest even incorrect
@p: mov eax, 1
end;
function SortInt64(const A,B: Int64): integer;
function SortInt64(const A,B: Int64): integer; {$ifdef FPC} nostackframe; assembler; {$endif}
asm // Delphi x86 compiler is not efficient at compiling below code
mov ecx, [eax]
mov eax, [eax + 4]
@ -5964,11 +5997,8 @@ end;
function TSynTable.Data(aID: integer; RecordBuffer: pointer; RecordBufferLen: Integer): Variant;
var data: TSynTableData absolute result;
begin
if SynTableVariantType=nil then
SynTableVariantType := SynRegisterCustomVariantType(TSynTableVariantType);
{$ifndef FPC}if data.VType and VTYPE_STATIC<>0 then{$endif}
VarClear(result);
data.VType := SynTableVariantType.VarType;
VarClear(result);
data.VType := SynTableVariantVarType;
data.VID := aID;
data.VTable := self;
pointer(data.VValue) := nil; // avoid GPF
@ -6198,8 +6228,8 @@ var len: integer;
PA: PAnsiChar absolute FieldBuffer;
PU: PUTF8Char absolute FieldBuffer;
tmp: RawByteString;
{$ifndef UNICODE}
WS: WideString;
{$ifndef HASVARUSTRING}
WS: SynUnicode;
{$endif}
begin
case FieldType of
@ -6234,7 +6264,7 @@ begin
tftWinAnsi: begin
len := FromVarUInt32(PB);
if len>0 then
{$ifdef UNICODE}
{$ifdef HASVARUSTRING}
result := WinAnsiToUnicodeString(PA,len)
{$else}
result := CurrentAnsiConvert.AnsiToAnsi(WinAnsiConvert,PA,len)
@ -6244,7 +6274,7 @@ begin
tftUTF8: begin
len := FromVarUInt32(PB);
if len>0 then
{$ifdef UNICODE}
{$ifdef HASVARUSTRING}
result := UTF8DecodeToUnicodeString(PU,len)
{$else} begin
UTF8ToSynUnicode(PU,len,WS);
@ -6292,7 +6322,7 @@ begin
tftCurrency:
Curr64ToStr(PInt64(FieldBuffer)^,result);
tftDouble:
ExtendedToStr(unaligned(PDouble(FieldBuffer)^),DOUBLE_PRECISION,result);
DoubleToStr(unaligned(PDouble(FieldBuffer)^),result);
// some variable-size field value
tftVarUInt32:
UInt32ToUtf8(FromVarUInt32(PB),result);
@ -6850,12 +6880,12 @@ begin
end;
function TSynTableFieldProperties.AddFilterOrValidate(aFilter: TSynFilterOrValidate): TSynFilterOrValidate;
procedure Add(var List: TObjectList);
begin
if List=nil then
List := TObjectList.Create;
List.Add(result);
end;
procedure Add(var List: TSynObjectList);
begin
if List=nil then
List := TSynObjectList.Create;
List.Add(result);
end;
begin
result := aFilter;
if (self=nil) or (result=nil) then
@ -7170,7 +7200,7 @@ begin
soContains: begin
dec(L,ValueLen);
while L>=0 do begin
while (L>=0) and not(byte(SBF^) in IsWord) do begin
while (L>=0) and not(tcWord in TEXT_CHARS[SBF^]) do begin
dec(L);
inc(SBF);
end; // begin of next word reached
@ -7182,7 +7212,7 @@ begin
end else
if StrCompIL(SBF,Value,ValueLen,0)=0 then
exit;
while (L>=0) and (byte(SBF^) in IsWord) do begin
while (L>=0) and (tcWord in TEXT_CHARS[SBF^]) do begin
dec(L);
inc(SBF);
end; // end of word reached
@ -7310,7 +7340,7 @@ begin
B := P;
repeat
inc(P);
until not(ord(P^) in IsJsonIdentifier);
until not (jcJsonIdentifier in JSON_CHARS[P^]);
FastSetString(select.SubField,B,P-B);
fHasSelectSubFields := true;
end;
@ -7440,7 +7470,7 @@ begin
B := P;
repeat
inc(P);
until not(ord(P^) in IsJsonIdentifier);
until not (jcJsonIdentifier in JSON_CHARS[P^]);
FastSetString(Where.SubField,B,P-B);
fWhereHasSubFields := true;
P := GotoNextNotSpace(P);
@ -7719,7 +7749,7 @@ end;
{$ifndef NOVARIANTS}
function TSynTableData.GetFieldValue(const FieldName: RawUTF8): Variant;
function TSynTableData.GetField(const FieldName: RawUTF8): Variant;
begin
GetFieldVariant(FieldName,result);
end;
@ -7779,15 +7809,16 @@ end;
procedure TSynTableData.Init(aTable: TSynTable; aID: Integer);
begin
VTable := aTable;
VType := SynTableVariantVarType;
VID := aID;
VTable := aTable;
VValue := VTable.DefaultRecordData;
{$ifdef UNICODE}FillcharFast(Filler,SizeOf(Filler),0);{$endif}
end;
procedure TSynTableData.Init(aTable: TSynTable; aID: Integer;
RecordBuffer: pointer; RecordBufferLen: integer);
begin
VType := SynTableVariantVarType;
VTable := aTable;
if (RecordBufferLen=0) or (RecordBuffer=nil) then begin
VID := 0;
@ -7799,7 +7830,7 @@ begin
end;
{$ifndef NOVARIANTS}
procedure TSynTableData.SetFieldValue(const FieldName: RawUTF8;
procedure TSynTableData.SetField(const FieldName: RawUTF8;
const Value: Variant);
var F: TSynTableFieldProperties;
begin
@ -8862,7 +8893,7 @@ begin
{$else}
v := NormToUpperAnsi7Byte[ord(p^)]; // 7 bit char uppercase
{$endif}
if not (v in IsWord) then break;
if not (tcWord in TEXT_BYTES[v]) then break;
inc(p);
dec(v,ord('B'));
if v>high(TSoundExValues) then continue;
@ -8905,7 +8936,7 @@ begin
if Values<>nil then
repeat
v := GetNextUTF8Upper(U);
if not (v in IsWord) then break;
if not (tcWord in TEXT_BYTES[v]) then break;
dec(v,ord('B'));
if v>high(TSoundExValues) then continue;
v := Values[v]; // get soundex value
@ -8983,15 +9014,15 @@ begin
repeat
if A^=#0 then exit else
{$ifdef USENORMTOUPPER}
if not(NormToUpperByte[ord(A^)] in IsWord) then break else inc(A);
{$else} if not(ord(A^) in IsWord) then break else inc(A); {$endif}
if not(tcWord in TEXT_CHARS[NormToUpper[A^]]) then break else inc(A);
{$else} if not(tcWord in TEXT_CHARS[A^]) then break else inc(A); {$endif}
until false;
// find beginning of next word
repeat
if A^=#0 then exit else
{$ifdef USENORMTOUPPER}
if NormToUpperByte[ord(A^)] in IsWord then break else inc(A);
{$else} if ord(A^) in IsWord then break else inc(A); {$endif}
if tcWord in TEXT_CHARS[NormToUpper[A^]] then break else inc(A);
{$else} if tcWord in TEXT_CHARS[A^] then break else inc(A); {$endif}
until false;
until false;
end;
@ -9019,7 +9050,7 @@ begin
c := GetNextUTF8Upper(U);
if c=0 then
exit;
until not(c in IsWord);
until not(tcWord in TEXT_BYTES[c]);
// find beginning of next word
repeat
if U=nil then exit;
@ -9027,7 +9058,7 @@ begin
c := GetNextUTF8Upper(U);
if c=0 then
exit;
until c in IsWord;
until tcWord in TEXT_BYTES[c];
U := V;
until U=nil;
end;
@ -9058,9 +9089,9 @@ begin
end;
if next<>nil then begin
{$ifdef USENORMTOUPPER}
while NormToUpperByte[ord(A^)] in IsWord do inc(A); // go to end of word
while tcWord in TEXT_CHARS[NormToUpper[A^]] do inc(A); // go to end of word
{$else}
while ord(A^) in IsWord do inc(A); // go to end of word
while tcWord in TEXT_CHARS[A^] do inc(A); // go to end of word
{$endif}
next^ := A;
end;
@ -9364,7 +9395,7 @@ const TopLevelTLD: array[0..19] of PUTF8Char = (
begin
if IsValidEmail(pointer(value)) then
repeat
DOM := lowercase(copy(value,PosEx('@',value)+1,100));
DOM := lowercase(copy(value,PosExChar('@',value)+1,100));
if length(DOM)>63 then
break; // exceeded 63-character limit of a DNS name
if (ForbiddenDomains<>'') and (FindCSVIndex(pointer(ForbiddenDomains),DOM)>=0) then
@ -10125,7 +10156,7 @@ end;
{$ifdef CPUINTEL} // crc32c SSE4.2 hardware accellerated dword hash
function crc32csse42(buf: pointer): cardinal;
{$ifdef CPUX86}
{$ifdef CPUX86} {$ifdef FPC} nostackframe; assembler; {$endif}
asm
mov edx, eax
xor eax, eax
@ -12329,7 +12360,7 @@ begin
if result=0 then
exit;
count := result;
if count>length(Values) then // only set length is not big enough
if count>length(Values) then // change Values[] length only if not big enough
SetLength(Values,count);
PI := pointer(Values);
fixedsize := ReadVarUInt32;
@ -12394,9 +12425,7 @@ constructor TSynCache.Create(aMaxCacheRamUsed: cardinal; aCaseSensitive: boolean
begin
inherited Create;
fNameValue.Init(aCaseSensitive);
fNameValue.DynArray.Capacity := 200; // some space for future cached entries
fMaxRamUsed := aMaxCacheRamUsed;
fFindLastAddedIndex := -1;
fTimeoutSeconds := aTimeoutSeconds;
end;
@ -12415,41 +12444,30 @@ end;
procedure TSynCache.Add(const aValue: RawUTF8; aTag: PtrInt);
begin
if (self=nil) or (fFindLastAddedIndex<0) or (fFindLastKey='') then
// fFindLastAddedIndex should have been set by a previous call to Find()
if (self=nil) or (fFindLastKey='') then
exit;
ResetIfNeeded;
inc(fRamUsed,length(aValue));
if fFindLastAddedIndex<0 then // Reset occurred in ResetIfNeeded
fNameValue.Add(fFindLastKey,aValue,aTag) else
with fNameValue.List[fFindLastAddedIndex] do begin // at Find() position
Name := fFindLastKey;
Value := aValue;
Tag := aTag;
fFindLastAddedIndex := -1;
fFindLastKey := '';
end;
fNameValue.Add(fFindLastKey,aValue,aTag);
fFindLastKey := '';
end;
function TSynCache.Find(const aKey: RawUTF8; aResultTag: PPtrInt): RawUTF8;
var added: boolean;
var ndx: integer;
begin
result := '';
if self=nil then
exit;
fFindLastKey := aKey;
if aKey='' then
fFindLastAddedIndex := -1 else begin
fFindLastAddedIndex := fNameValue.DynArray.FindHashedForAdding(aKey,added);
if added then
// expect a further call to Add()
fFindLastKey := aKey else
// match key found
with fNameValue.List[fFindLastAddedIndex] do begin
result := Value;
if aResultTag<>nil then
aResultTag^ := Tag;
fFindLastAddedIndex := -1;
end;
exit;
ndx := fNameValue.Find(aKey);
if ndx<0 then
exit;
with fNameValue.List[ndx] do begin
result := Value;
if aResultTag<>nil then
aResultTag^ := Tag;
end;
end;
@ -12483,16 +12501,10 @@ begin
fSafe.Lock;
try
if Count<>0 then begin
if fRamUsed<131072 then // no capacity change for small cache content
fNameValue.Count := 0 else
with fNameValue.DynArray{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do begin
Capacity := 0; // force free all fNameValue.List[] key/value pairs
Capacity := 200; // then reserve some space for future cached entries
end;
fNameValue.DynArray.Clear;
fNameValue.DynArray.ReHash;
result := true; // mark something was flushed
end;
fFindLastAddedIndex := -1; // fFindLastKey should remain untouched for Add()
fRamUsed := 0;
fTimeoutTix := 0;
finally
@ -13700,27 +13712,31 @@ end;
procedure TSynAuthenticationAbstract.AuthenticateUser(const aName, aPassword: RawUTF8);
begin
raise ESynException.CreateFmt('%.AuthenticateUser() is not implemented',[self]);
raise ESynException.CreateUTF8('%.AuthenticateUser() is not implemented',[self]);
end;
procedure TSynAuthenticationAbstract.DisauthenticateUser(const aName: RawUTF8);
begin
raise ESynException.CreateFmt('%.DisauthenticateUser() is not implemented',[self]);
raise ESynException.CreateUTF8('%.DisauthenticateUser() is not implemented',[self]);
end;
function TSynAuthenticationAbstract.CreateSession(const User: RawUTF8; Hash: cardinal): integer;
function TSynAuthenticationAbstract.CheckCredentials(const UserName: RaWUTF8;
Hash: cardinal): boolean;
var password: RawUTF8;
begin
result := GetPassword(UserName,password) and
((ComputeCredential(false,UserName,password)=Hash) or
(ComputeCredential(true,UserName,password)=Hash));
end;
function TSynAuthenticationAbstract.CreateSession(const User: RawUTF8;
Hash: cardinal): integer;
begin
result := 0;
fSafe.Lock;
try
// check the given Hash challenge, against stored credentials
if not GetPassword(User,password) then
if not CheckCredentials(User,Hash) then
exit;
if (ComputeCredential(false,User,password)<>Hash) and
(ComputeCredential(true,User,password)<>Hash) then
exit;
// create the new session
repeat
result := fSessionGenerator;
inc(fSessionGenerator);
@ -14278,7 +14294,7 @@ begin
end;
end;
function VariantVTypeToSQLDBFieldType(VType: word): TSQLDBFieldType;
function VariantVTypeToSQLDBFieldType(VType: cardinal): TSQLDBFieldType;
begin
case VType of
varNull:
@ -14503,11 +14519,16 @@ begin
end;
constructor TJSONWriter.Create(aStream: TStream; Expand, withID: boolean;
const Fields: TSQLFieldIndexDynArray; aBufSize: integer);
const Fields: TSQLFieldIndexDynArray; aBufSize: integer;
aStackBuffer: PTextWriterStackBuffer);
begin
if aStream=nil then
CreateOwnedStream else
inherited Create(aStream,aBufSize);
if aStackBuffer<>nil then
CreateOwnedStream(aStackBuffer^) else
CreateOwnedStream(aBufSize) else
if aStackBuffer<>nil then
inherited Create(aStream,aStackBuffer,SizeOf(aStackBuffer^)) else
inherited Create(aStream,aBufSize);
fExpand := Expand;
fWithID := withID;
fFields := Fields;
@ -15871,7 +15892,7 @@ begin
if aClass=nil then
fClass := TBlockingProcessPoolItem else
fClass := aClass;
fPool := TObjectListLocked.Create(true);
fPool := TSynObjectListLocked.Create;
end;
const
@ -16619,7 +16640,7 @@ var i: integer;
if not withfreespace or not GetDiskInfo(p.mounted,av,fr,tot) then
{$ifdef MSWINDOWS}
FormatShort('%: % (%)',[p.mounted[1],p.name,KB(p.size,nospace)],result) else
FormatShort(F[nospace],[p.mounted[1],p.name,KB(p.size,nospace)],result);
FormatShort(F[nospace],[p.mounted[1],p.name,KB(fr,nospace),KB(tot,nospace)],result);
{$else}
FormatShort('% % (%)',[p.mounted,p.name,KB(p.size,nospace)],result) else
FormatShort(F[nospace],[p.mounted,p.name,KB(fr,nospace),KB(tot,nospace)],result);
@ -17088,7 +17109,7 @@ end;
procedure TSynTimeZone.LoadFromBuffer(const Buffer: RawByteString);
begin
fZones.LoadFromBinary(AlgoSynLZ.Decompress(Buffer),{nohash=}true);
fZones.ReHash(false);
fZones.ReHash;
FreeAndNil(fIds);
FreeAndNil(fDisplays);
end;
@ -17685,7 +17706,7 @@ var W: TTextWriter;
tmp: TTextWriterStackBuffer;
begin
if PosExChar(#$f0,text)=0 then begin
result := text; // no smiley UTF-8 for sure
result := text; // no UTF-8 smiley for sure
exit;
end;
W := TTextWriter.CreateOwnedStream(tmp);

115
lib/dmustache/Synopse.inc
View File

@ -76,11 +76,12 @@
// - it will avoid error like "[DCC Error] E2201 Need imported data reference ($G)
// to access 'VarCopyProc' from unit 'SynCommons'"
// - shall be set at the package options level, and left untouched by default
// - note: you should probably also set "Generate DCUs only" in Project Options
// -> Delphi Compiler -> Output C/C++ -> C/C++ output file generation
{.$define DOPATCHTRTL}
// if defined, the low-level patches made to RecordCopy() low-level function
// as defined in SynCommons.pas will be applied (if applicable to your Delphi
// version) - you should better use it, but we have unset it by default
// if defined, some low-level patches are applied to Delphi or FPC RTL
// - you should better use it, but we have unset it by default
{.$define NEWRTTINOTUSED}
// if defined, the new RTTI (available since Delphi 2010) won't be linked to
@ -103,11 +104,6 @@
{.$define OLDTEXTWRITERFORMAT}
// force TTextWriter.Add(Format) to handle the alternate deprecated $ % tags
{.$define OPT4AMD}
// you may define this to optimize for AMD CPUs - e.g. to use "set of byte"
// which will use BT[mem] opcodes, which are slow on Intel, but fast on AMD
// (with the Delphi x86 compiler, may not be the case for LLVM or FPC)
{.$define FORCE_STRSSE42}
// sse4.2 string instructions may read up to 16 bytes after the actual end buffer
// -> define this if you want StrLen/StrComp/strspn/strcspn to use SSE4.2 opcodes
@ -168,27 +164,29 @@
{$INLINE ON}
{$MINENUMSIZE 1}
{$PACKRECORDS DEFAULT} // force normal alignment
{$PACKSET 1}
{$PACKENUM 1}
{$CODEPAGE UTF8} // otherwise unexpected behavior occurs in most cases
{$undef ENHANCEDRTL} // there is no version of our Enhanced RTL for FPC
{$undef DOPATCHTRTL}
{$define HASINLINE}
{$define HASUINT64}
{$define HASINLINENOTX86}
{$define NODELPHIASM} // ignore low-level System.@LStrFromPCharLen calls
{$define HASAESNI} // should be commented to test project with valgrind
{$define HASTTHREADSTART}
{$define HASINTERFACEASTOBJECT}
{$define EXTENDEDTOSTRING_USESTR} // FloatToText uses str() in FPC
{$define EXTENDEDTOSHORT_USESTR} // FloatToText uses str() in FPC
{$define DOUBLETOSHORT_USEGRISU} // fast double to text
{$define DELPHI5ORFPC}
{$define FPC_OR_PUREPASCAL}
{$define FPC_OR_KYLIX}
{$define FPC_OR_UNICODE}
{$define USERECORDWITHMETHODS}
{$define FPC_OR_DELPHIXE}
{$define FPC_OR_DELPHIXE4}
{$define FPC_ENUMHASINNER}
{$define USE_VTYPE_STATIC} // in our inlined VarClear()
// $if FPC_FULLVERSION>20700 breaks Delphi 6-7 and SynProject :(
{$ifdef VER2_7}
@ -259,25 +257,39 @@
{$define FPCSQLITE3STATIC} // use static/arm-linux\sqlite3.o
{$endif}
{$ifdef CPUAARCH64}
{$ifdef ANDROID}
{$define FPCSQLITE3STATIC} // note: problems with current static/aarch64-linux\sqlite3.o
{$endif}
{$define FPCSQLITE3STATIC} // use:static/aarch64-linux\sqlite3.o
{$endif}
{$endif}
{$ifdef BSD}
// LINUX conditional includes Darwin and BSD family like FreeBSD
{$define LINUX} // not true, but a POSIX/BSD system - see LINUXNOTBSD
{$undef FORCE_STRSSE42} // fails otherwise for sure
{$define ABSOLUTEPASCAL} // NO asm nor redirection (until stabilized)
{$ifdef DARWIN}
{$define FPCSQLITE3STATIC} // we supply Darwin static libs
{$ifdef CPUINTEL}
{$define FPC_PIC} // may have not be defined by the compiler options
{$endif}
{$undef FORCE_STRSSE42} // fails otherwise for sure
{$define ABSOLUTEPASCAL} // NO asm nor redirection (until stabilized)
{$else}
{$define BSDNOTDARWIN} // OSX has some non-standard API calls
{$endif}
{$ifdef FREEBSD}
{$ifdef CPUX86}
{$define FPCSQLITE3STATIC} // we supply i386 static libs
{$endif CPUX86}
{$ifdef CPUX64}
{$define FPCSQLITE3STATIC} // we supply x64 static libs
{$endif CPUX64}
{$endif}
{$ifdef OPENBSD}
{$ifdef CPUX86}
{$define FPCSQLITE3STATIC} // we supply i386 static libs
{$endif CPUX86}
{$ifdef CPUX64}
{$define FPCSQLITE3STATIC} // we supply x64 static libs
{$endif CPUX64}
{$endif}
{$else}
{$ifdef LINUX}
{$define LINUXNOTBSD} // e.g. to disable epoll API
@ -296,15 +308,24 @@
{$define PUREPASCAL} // most asm code is not PIC-safe with global constants
{$endif}
{$ifdef MSWINDOWS}
{$ifdef FPC_X64MM}
{$ifndef FPC_X64MM_WIN} // SynFPCx64MM not yet fully validated on Windows
{$undef FPC_X64MM}
{$endif FPC_X64MM_WIN}
{$endif FPC_X64MM}
{$endif MSWINDOWS}
{$ifdef CPU64}
{$define FPC_64}
{$define PUREPASCAL} // e.g. x64, AARCH64
{$ifdef CPUX64}
{$define CPUINTEL}
{$define FPC_CPUINTEL}
{$ifndef DARWIN}
{$define CPUX64ASM} // Delphi XE4 SSE asm is buggy :(
{$endif DARWIN}
{$ifndef BSD}
{$define CPUX64ASM} // Delphi XE4 or Darwin asm are buggy :(
{$define HASAESNI} // SynCrypto rejected by Darwin asm
{$endif BSD}
{$define FPC_X64} // supports AVX/AVX2/AVX512 - which Delphi doesn't
{$ASMMODE INTEL} // to share asm code with Delphi
{$endif CPUX64}
@ -321,13 +342,24 @@
{$define CPUINTEL}
{$define FPC_CPUINTEL}
{$define FPC_X86}
{$ASMMODE INTEL} // as Delphi expects
{$define TSYNEXTENDED80} // only 32-bit has a true x87 extended type
{$ASMMODE INTEL} // as Delphi expects
{$define HASAESNI} // should be commented to test project with valgrind
{$ifndef FPC_PIC}
{$define CPUX86NOTPIC} // use "absolute" instead of local register
{$endif FPC_PIC}
{$ifndef OPENBSD}
{$define FPC_X86ASM} // if assembler knows popcnt/crc32c opcodes
{$endif OPENBSD}
{$endif CPUX86}
{$endif CPU64}
{$ifdef CPUARM3264}
{$ifdef BSD}
{$undef USE_VTYPE_STATIC} // circumvent bug in VarClear() on BSD + ARM
{$endif BSD}
{$endif CPUARM3264}
{$ifdef ISFPC30}
{$ifndef MSWINDOWS}
// define FPCUSEVERSIONINFO to link low-level executable file information
@ -344,10 +376,7 @@
{$ifdef CPUINTEL}
{$define HASINTERFACERTTI}
{$endif}
{$ifdef CPUARM}
{$define HASINTERFACERTTI}
{$endif}
{$ifdef CPUAARCH64}
{$ifdef CPUARM3264}
{$define HASINTERFACERTTI}
{$endif}
{$endif}
@ -387,23 +416,28 @@
(********************** Delphi Conditionals **********************)
{$define DELPHI_OR_FPC_OLDRTTI}
{$define USE_VTYPE_STATIC} // "and VTYPE_STATIC" test before VarClear()
{$undef FPC_X64MM} // this is a FPC-specific memory manager
{$A+} // force normal alignment
{$ifdef LVCL}
{$define OWNNORMTOUPPER} // NormToUpper[] exists only in our enhanced RTL
{$define NOVARIANTS} // LVCL does not support variants
{$define EXTENDEDTOSTRING_USESTR} // no FloatToText implemented in LVCL
{$endif}
{$define EXTENDEDTOSHORT_USESTR} // no FloatToText implemented in LVCL
{$endif LVCL}
{$ifdef UNICODE}
{$undef ENHANCEDRTL} // Delphi 2009 and up don't have our Enhanced Runtime library
{$define HASVARUSTRING}
{$define HASCODEPAGE}
{$define FPC_OR_UNICODE}
{$define USERECORDWITHMETHODS}
{ due to a bug in Delphi 2009+, we need to fake inheritance of record,
since TDynArrayHashed = object(TDynArray) fails to initialize
http://blog.synopse.info/post/2011/01/29/record-and-object-issue-in-Delphi-2010 }
{$define UNDIRECTDYNARRAY}
{$endif}
{$endif UNICODE}
{$ifndef PUREPASCAL}
{$define CPUINTEL} // Delphi only for Intel by now
@ -413,13 +447,15 @@
{$define CPU64DELPHI}
{$undef CPU32}
{$define PUREPASCAL} // no x86 32 bit asm to be used
{$define EXTENDEDTOSTRING_USESTR} // FloatToText() much slower in x64 mode
{$define EXTENDEDTOSHORT_USESTR} // FloatToText() much slower in x64 mode
{$define DOUBLETOSHORT_USEGRISU} // fast double to text
{$else CPUX64}
{$define CPU32} // Delphi compiler for 32 bit CPU
{$define CPU32DELPHI}
{$undef CPU64}
{$define CPUX86} // for compatibility with older versions of Delphi
{$define CPUX86NOTPIC} // use "absolute" instead of local register
{$define TSYNEXTENDED80} // only 32-bit has a true x87 extended type
{$endif CPUX64}
{$IFDEF CONDITIONALEXPRESSIONS} // Delphi 6 or newer
@ -430,7 +466,7 @@
{$define FPC_OR_KYLIX}
// Kylix 3 will be handled just like Delphi 7
{$undef ENHANCEDRTL} // Enhanced Runtime library not fully tested yet
{$define EXTENDEDTOSTRING_USESTR}
{$define EXTENDEDTOSHORT_USESTR}
{$define DOPATCHTRTL} // nice speed up for server apps
{$define NOVARCOPYPROC}
{$define NOSQLITE3STATIC} // Kylix will use external sqlite3.so
@ -444,7 +480,7 @@
{$define DELPHI6OROLDER}
{$define NOVARCOPYPROC}
{$undef ENHANCEDRTL} // Delphi 6 doesn't have our Enhanced Runtime library
{$define EXTENDEDTOSTRING_USESTR} // no TFormatSettings before Delphi 7
{$define EXTENDEDTOSHORT_USESTR} // no TFormatSettings before Delphi 7
{$else}
{$define ISDELPHI7ANDUP} // Delphi 7 or newer
{$define WITHUXTHEME} // VCL handle UI theming
@ -468,7 +504,7 @@
{$define HASINLINENOTX86}
{$define HASREGION}
{$define HASFASTMM4}
// you can define this so that GetMemoryInfo/TSynMonitorMemory returns
// try to define this so that GetMemoryInfo/TSynMonitorMemory returns
// low-level FastMM4 information
{.$define WITH_FASTMM4STATS}
{$ifend}
@ -483,8 +519,6 @@
{$ifend}
{$if CompilerVersion = 20}
{$define ISDELPHI20092010} // specific compilation issues
// for Delphi 2009 and up, use UNICODE conditional
{$define FPC_OR_UNICODE}
{$ifend}
{$if CompilerVersion = 21}
{$define ISDELPHI20092010} //specific compilation issues
@ -493,7 +527,6 @@
{$define ISDELPHI2010}
{$define ISDELPHI2010_OR_FPC} // eltype2 field
{$define ISDELPHI2010_OR_FPC_NEWRTTI}
{$define FPC_OR_UNICODE}
{$define HASTTHREADSTART}
{$define HASINTERFACEASTOBJECT}
{$ifdef NEWRTTINOTUSED} // option reduce EXE size by disabling much RTTI
@ -557,6 +590,9 @@
{$if CompilerVersion >= 33.0}
{$define ISDELPHI103}
{$ifend}
{$if CompilerVersion >= 34.0}
{$define ISDELPHI104}
{$ifend}
{$ifend CompilerVersion >= 17}
{$ifopt O-} // if we don't expect fast code, don't optimize the framework
{$undef ENHANCEDRTL}
@ -571,7 +607,7 @@
{$define NOVARIANTS}
{$define NOVARCOPYPROC}
{$undef ENHANCEDRTL} // Delphi 5 doesn't have our Enhanced Runtime library
{$define EXTENDEDTOSTRING_USESTR} // no TFormatSettings before Delphi 7
{$define EXTENDEDTOSHORT_USESTR} // no TFormatSettings before Delphi 7
{$undef DOPATCHTRTL}
{$ENDIF CONDITIONALEXPRESSIONS}
@ -630,6 +666,7 @@
{$ifdef ABSOLUTEPASCAL}
{$define ABSOLUTEORPUREPASCAL}
{$define ABSOLUTEPASCALORNOTINTEL}
{$define PUREPASCAL}
{$endif ABSOLUTEPASCAL}
{$ifdef PUREPASCAL}
{$define ABSOLUTEORPUREPASCAL}
@ -651,6 +688,7 @@
{$ifdef CPUX64}
{$if CompilerVersion = 25.0} // exactly XE4
{$define NOSQLITE3STATIC}
// :( to avoid "Fatal: F2084 Internal Error: AV004A7B1F-R03BDA7B0-0"
{$ifend}
{$endif} // other Win32/Win64 Delphi platforms should work as expected
{$endif FPC}
@ -666,11 +704,12 @@
{.$define USELIBCURL} // for testing (no benefit vs WinHTTP)
{$else}
{$define ONLYUSEHTTPSOCKET} // http.sys server is Windows-specific
{$ifndef ANDROID}
// cross-platform libcurl for https -> TCurlHttp and TSQLHttpClientCurl
{$define USELIBCURL}
// cross-platform libcurl for https -> TCurlHttp and TSQLHttpClientCurl
{$define USELIBCURL}
{$ifdef ANDROID}
// for Android, consider using https://github.com/gcesarmza/curl-android-ios
// static libraries and force USELIBCURL in the project conditionals
{$define LIBCURLSTATIC}
{$endif ANDROID}
{$endif MSWINDOWS}

2
lib/dmustache/SynopseCommit.inc
View File

@ -1 +1 @@
'1.18.5770'
'1.18.6186'

BIN
samples/data/ACTIVERECORDDB.FDB
View File

Binary file not shown.

BIN
samples/data/ORDERSMANAGER_FB30.FDB
View File

Binary file not shown.

173
sources/MVCFramework.Commons.pas
View File

@ -45,11 +45,9 @@ uses
{$I dmvcframeworkbuildconsts.inc}
type
TMVCHTTPMethodType = (httpGET, httpPOST, httpPUT, httpDELETE, httpHEAD, httpOPTIONS, httpPATCH,
httpTRACE);
TMVCHTTPMethodType = (httpGET, httpPOST, httpPUT, httpDELETE, httpHEAD, httpOPTIONS, httpPATCH, httpTRACE);
TMVCHTTPMethods = set of TMVCHTTPMethodType;
@ -358,10 +356,9 @@ type
procedure CheckHTTPErrorCode(const AHTTPErrorCode: UInt16);
public
constructor Create(const AMsg: string); overload; virtual;
constructor Create(const AMsg: string; const ADetailedMessage: string;
const AAppErrorCode: UInt16 = 0;
const AHTTPErrorCode: UInt16 = HTTP_STATUS.InternalServerError;
const AErrorItems: TArray<String> = nil); overload; virtual;
constructor Create(const AMsg: string; const ADetailedMessage: string; const AAppErrorCode: UInt16 = 0;
const AHTTPErrorCode: UInt16 = HTTP_STATUS.InternalServerError; const AErrorItems: TArray<String> = nil);
overload; virtual;
constructor Create(const AHTTPErrorCode: UInt16; const AMsg: string); overload; virtual;
constructor Create(const AHTTPErrorCode: UInt16; const AAppErrorCode: Integer; const AMsg: string);
overload; virtual;
@ -590,6 +587,16 @@ type
class function GuidFromString(const AGuidStr: string): TGUID; static;
end;
TMVCHeaders = class(TStringList)
private
function GetValue(const Name: string): string;
procedure SetValue(const Name, Value: string);
public
constructor Create;
function IndexOfName(const Name: string): Integer; override;
property Values[const Name: string]: string read GetValue write SetValue;
end;
TMVCFieldsMapping = TArray<TMVCFieldMap>;
{$SCOPEDENUMS ON}
@ -608,6 +615,9 @@ function URLSafeB64encode(const Value: string; IncludePadding: Boolean; AByteEnc
function URLSafeB64encode(const Value: TBytes; IncludePadding: Boolean): string; overload;
function URLSafeB64Decode(const Value: string; AByteEncoding: IIdTextEncoding = nil): string;
function URLEncode(const aValue: string): String;
function URLDecode(const aValue: string): String;
function ByteToHex(AInByte: Byte): string;
function BytesToHex(ABytes: TBytes): string;
procedure Base64StringToFile(const aBase64String, AFileName: string; const aOverwrite: Boolean = False);
@ -617,9 +627,8 @@ procedure SplitContentMediaTypeAndCharset(const aContentType: string; var aConte
var aContentCharSet: string);
function BuildContentType(const aContentMediaType: string; const aContentCharSet: string): string;
function StrToJSONObject(const aString: String): TJsonObject;
function StrToJSONArray(const aString: String): TJsonArray;
function StrToJSONObject(const AString: String): TJsonObject;
function StrToJSONArray(const AString: String): TJsonArray;
function WrapAsList(const AObject: TObject; AOwnsObject: Boolean = False): IMVCList;
@ -641,22 +650,18 @@ var
const
RESERVED_IPS: array [1 .. 11] of array [1 .. 2] of string = (('0.0.0.0', '0.255.255.255'),
('10.0.0.0', '10.255.255.255'), ('127.0.0.0', '127.255.255.255'),
('169.254.0.0', '169.254.255.255'),
('10.0.0.0', '10.255.255.255'), ('127.0.0.0', '127.255.255.255'), ('169.254.0.0', '169.254.255.255'),
('172.16.0.0', '172.31.255.255'), ('192.0.2.0', '192.0.2.255'), ('192.88.99.0', '192.88.99.255'),
('192.168.0.0', '192.168.255.255'), ('198.18.0.0', '198.19.255.255'),
('224.0.0.0', '239.255.255.255'),
('192.168.0.0', '192.168.255.255'), ('198.18.0.0', '198.19.255.255'), ('224.0.0.0', '239.255.255.255'),
('240.0.0.0', '255.255.255.255'));
type
TMVCParseAuthentication = class
public
class procedure OnParseAuthentication(AContext: TIdContext; const AAuthType, AAuthData: string; var VUsername,
VPassword: string; var VHandled: Boolean);
class procedure OnParseAuthentication(AContext: TIdContext; const AAuthType, AAuthData: string;
var VUsername, VPassword: string; var VHandled: Boolean);
end;
implementation
uses
@ -681,8 +686,7 @@ begin
if AIP.IsEmpty then
Exit(0);
lPieces := AIP.Split(['.']);
Result := (StrToInt(lPieces[0]) * 16777216) + (StrToInt(lPieces[1]) * 65536) +
(StrToInt(lPieces[2]) * 256) +
Result := (StrToInt(lPieces[0]) * 16777216) + (StrToInt(lPieces[1]) * 65536) + (StrToInt(lPieces[2]) * 256) +
StrToInt(lPieces[3]);
end;
@ -709,6 +713,16 @@ begin
Result := TIdEncoderMIME.EncodeString(aValue);
end;
function URLEncode(const aValue: string): String;
begin
Result := TNetEncoding.URL.Encode(aValue);
end;
function URLDecode(const aValue: string): String;
begin
Result := TNetEncoding.URL.Decode(aValue);
end;
function B64Encode(const aValue: TBytes): string; overload;
begin
// Do not use TNetEncoding
@ -753,9 +767,7 @@ begin
begin
Result := lContentMediaType;
end
else
if lContentMediaType.StartsWith('text/') or lContentMediaType.StartsWith('application/')
then
else if lContentMediaType.StartsWith('text/') or lContentMediaType.StartsWith('application/') then
begin
Result := lContentMediaType + ';charset=' + aContentCharSet.ToLower;
end
@ -775,8 +787,7 @@ begin
begin
lContentTypeValues := aContentType.Split([';']);
aContentMediaType := Trim(lContentTypeValues[0]);
if (Length(lContentTypeValues) > 1) and (lContentTypeValues[1].Trim.StartsWith('charset', True))
then
if (Length(lContentTypeValues) > 1) and (lContentTypeValues[1].Trim.StartsWith('charset', True)) then
begin
aContentCharSet := lContentTypeValues[1].Trim.Split(['='])[1].Trim;
end
@ -803,8 +814,8 @@ begin
SetLength(FErrorItems, 0);
end;
constructor EMVCException.Create(const AMsg, ADetailedMessage: string;
const AAppErrorCode, AHTTPErrorCode: UInt16; const AErrorItems: TArray<String>);
constructor EMVCException.Create(const AMsg, ADetailedMessage: string; const AAppErrorCode, AHTTPErrorCode: UInt16;
const AErrorItems: TArray<String>);
begin
Create(AMsg);
CheckHTTPErrorCode(AHTTPErrorCode);
@ -832,8 +843,7 @@ begin
end;
end;
constructor EMVCException.Create(const AHTTPErrorCode: UInt16;
const AAppErrorCode: Integer; const AMsg: string);
constructor EMVCException.Create(const AHTTPErrorCode: UInt16; const AAppErrorCode: Integer; const AMsg: string);
begin
CheckHTTPErrorCode(AHTTPErrorCode);
Create(AMsg);
@ -841,8 +851,7 @@ begin
FAppErrorCode := AAppErrorCode;
end;
constructor EMVCException.CreateFmt(const AHTTPErrorCode: UInt16;
const AMsg: string; const AArgs: array of const);
constructor EMVCException.CreateFmt(const AHTTPErrorCode: UInt16; const AMsg: string; const AArgs: array of const);
begin
inherited CreateFmt(AMsg, AArgs);
FHttpErrorCode := AHTTPErrorCode;
@ -874,8 +883,7 @@ begin
end;
end;
function TMVCCriticalSectionHelper.DoWithLockTimeout(const AAction: TProc; const ATimeOut: UInt32)
: TWaitResult;
function TMVCCriticalSectionHelper.DoWithLockTimeout(const AAction: TProc; const ATimeOut: UInt32): TWaitResult;
begin
Result := Self.WaitFor(ATimeOut);
if (Result = TWaitResult.wrSignaled) then
@ -892,7 +900,7 @@ procedure TMVCConfig.CheckNotFreezed;
begin
if FFreezed then
begin
raise EMVCException.Create('Configuration in freezed - no more changes allowed') at ReturnAddress;
raise EMVCException.Create('Configuration in freezed - no more changes allowed')at ReturnAddress;
end;
end;
@ -938,8 +946,7 @@ var
lStreamReader: TStreamReader;
lSer: TMVCJsonDataObjectsSerializer;
begin
lStreamReader := TStreamReader.Create(TFileStream.Create(AFileName,
fmOpenRead or fmShareDenyWrite), TEncoding.ASCII);
lStreamReader := TStreamReader.Create(TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite), TEncoding.ASCII);
try
lStreamReader.OwnStream;
lConfigString := lStreamReader.ReadToEnd;
@ -986,7 +993,7 @@ var
I: Integer;
lName: string;
begin
for I := 0 to Strings.Count-1 do
for I := 0 to Strings.Count - 1 do
begin
lName := Strings.Names[I];
Add(lName, Strings.Values[lName]);
@ -1135,8 +1142,7 @@ type
end;
const
GURLSafeBase64CodeTable
: string = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_';
GURLSafeBase64CodeTable: string = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_';
{ Do not Localize }
procedure TURLSafeEncode.InitComponent;
@ -1287,8 +1293,7 @@ end;
{ TMVCDecoratorObject }
function TMVCDecoratorObject.Add(const PropName,
PropValue: string): IMVCLinkItem;
function TMVCDecoratorObject.Add(const PropName, PropValue: string): IMVCLinkItem;
begin
fData.Items[PropName] := PropValue;
Result := Self;
@ -1355,8 +1360,7 @@ begin
end;
class procedure TMVCParseAuthentication.OnParseAuthentication(AContext: TIdContext; const AAuthType, AAuthData: string;
var VUsername,
VPassword: string; var VHandled: Boolean);
var VUsername, VPassword: string; var VHandled: Boolean);
begin
VHandled := SameText(LowerCase(AAuthType), 'bearer');
end;
@ -1395,7 +1399,7 @@ var
lIsAlpha: Boolean;
lIsNumber: Boolean;
begin
{TODO -oDanieleT -cGeneral : Make this function faster!}
{ TODO -oDanieleT -cGeneral : Make this function faster! }
lNextUpCase := MakeFirstUpperToo;
lPreviousWasUpperCase := True;
lSB := TStringBuilder.Create;
@ -1407,7 +1411,7 @@ begin
lIsUpperCase := CharInSet(C, ['A' .. 'Z']);
lIsNumber := CharInSet(C, ['0' .. '9']);
lIsAlpha := lIsLowerCase or lIsUpperCase;
if not (lIsAlpha or lIsNumber) then
if not(lIsAlpha or lIsNumber) then
begin
lNextUpCase := True;
lPreviousWasUpperCase := False;
@ -1470,15 +1474,13 @@ begin
lIsNumber := CharInSet(C, ['0' .. '9']);
lIsUnderscore := C = '_';
if (I > 0) and (not lLastWasUnderscore) and
((lIsUpperCase and (lLastWasLowercase or lLastWasNumber)) or
(lIsLowerCase and lLastWasNumber) or
(lIsNumber and (not lLastWasNumber))) then
if (I > 0) and (not lLastWasUnderscore) and ((lIsUpperCase and (lLastWasLowercase or lLastWasNumber)) or
(lIsLowerCase and lLastWasNumber) or (lIsNumber and (not lLastWasNumber))) then
begin
lSB.Append('_');
end;
if not (lLastWasUnderscore and lIsUnderscore) then
if not(lLastWasUnderscore and lIsUnderscore) then
begin
lSB.Append(LowerCase(C));
end;
@ -1492,29 +1494,86 @@ begin
end;
end;
function StrToJSONObject(const aString: String): TJsonObject;
function StrToJSONObject(const AString: String): TJsonObject;
begin
Result := MVCFramework.Serializer.JSONDataObjects.StrToJSONObject(aString);
Result := MVCFramework.Serializer.JsonDataObjects.StrToJSONObject(AString);
end;
function StrToJSONArray(const aString: String): TJsonArray;
function StrToJSONArray(const AString: String): TJsonArray;
begin
Result := MVCFramework.Serializer.JSONDataObjects.StrToJSONArray(aString);
Result := MVCFramework.Serializer.JsonDataObjects.StrToJSONArray(AString);
end;
function WrapAsList(const AObject: TObject; AOwnsObject: Boolean = False): IMVCList;
begin
Result := MVCFramework.DuckTyping.WrapAsList(AObject, AOwnsObject);
end;
{ TMVCHeaders }
constructor TMVCHeaders.Create;
begin
inherited;
NameValueSeparator := ':';
end;
function TMVCHeaders.GetValue(const Name: string): string;
var
i: Integer;
begin
i := IndexOfName(Name);
if i >= 0 then
Result := Trim(Copy(Get(i), Length(Name) + 2, MaxInt))
else
Result := '';
end;
procedure TMVCHeaders.SetValue(const Name, Value: string);
var
i: Integer;
begin
i := IndexOfName(Name);
if Value <> '' then
begin
if i < 0 then
i := Add('');
Put(i, Name + NameValueSeparator + Value);
end
else
begin
if i >= 0 then
Delete(i);
end;
end;
function TMVCHeaders.IndexOfName(const Name: string): Integer;
var
P: Integer;
S: string;
lSub: String;
begin
for Result := 0 to GetCount - 1 do
begin
S := Get(Result);
P := AnsiPos(NameValueSeparator, S);
if (P <> 0) then
begin
lSub := Copy(S, 1, P - 1);
if SameText(lSub, Name) then
begin
Exit;
end;
end;
end;
Result := -1;
end;
initialization
gLock := TObject.Create;
// SGR 2017-07-03 : Initialize decoding table for URLSafe Gb64 encoding
TURLSafeDecode.ConstructDecodeTable(GURLSafeBase64CodeTable,
TURLSafeDecode.GSafeBaseBase64DecodeTable);
TURLSafeDecode.ConstructDecodeTable(GURLSafeBase64CodeTable, TURLSafeDecode.GSafeBaseBase64DecodeTable);
GlobalAppExe := ExtractFileName(GetModuleName(HInstance));
GlobalAppName := ChangeFileExt(GlobalAppExe, EmptyStr);

259
sources/MVCFramework.HTTPSys.WebBrokerBridge.pas
View File

@ -31,6 +31,8 @@
unit MVCFramework.HTTPSys.WebBrokerBridge;
{$DEFINE TRACE}
interface
uses
@ -67,20 +69,12 @@ type
procedure SetServerName(const aName: SockString); override;
end;
TMVCHeaders = class(TStringList)
private
function GetValue(const Name: string): string;
procedure SetValue(const Name, Value: string);
public
constructor Create;
function IndexOfName(const Name: string): Integer; override;
property Values[const Name: string]: string read GetValue write SetValue;
end;
TMVCHTTPSysAppRequest = class(TWebRequest)
private
fRequest: THttpServerRequest;
fHeaders: TMVCHeaders;
fURL: String;
fFullURL: String;
protected
fBody: TBytes;
function GetDateVariable(Index: Integer): TDateTime; override;
@ -206,7 +200,7 @@ begin
fRequest := ARequest;
inherited Create;
fHeaders := TMVCHeaders.Create;
ExtractFields([#13], [], fRequest.InHeaders, fHeaders);
ExtractFields([#13], [], String(fRequest.InHeaders), fHeaders);
// if fRequest.PostDataSize > 0 then
// begin
@ -296,15 +290,12 @@ end;
function TMVCHTTPSysAppRequest.GetRawPathInfo: string;
begin
// Result := fRequest.URI;
raise Exception.Create('DMVCFramework Not Implemented');
Result := GetStringVariable(ReqIDX_PathInfo);
end;
function TMVCHTTPSysAppRequest.GetRemoteIP: string;
begin
Result := fRequest.RemoteIP;
// Result := fRequest.RemoteIP;
// raise Exception.Create('DMVCFramework Not Implemented');
Result := String(fRequest.RemoteIP);
end;
function TMVCHTTPSysAppRequest.GetRawContent: TBytes;
@ -313,20 +304,45 @@ begin
end;
function TMVCHTTPSysAppRequest.GetStringVariable(Index: Integer): string;
var
lIdx: Integer;
begin
case Index of
ReqIDX_Method:
Result := fRequest.Method;
Result := String(fRequest.Method);
// ReqIDX_ProtocolVersion:
// Result := fRequest.Version;
ReqIDX_URL:
Result := fRequest.URL;
begin
if fURL = '' then
begin
fURL := URLDecode(String(fRequest.URL));
end;
Result := fURL;
end;
ReqIDX_Query:
Result := fRequest.FullURL;
begin
if fFullURL = '' then
begin
fFullURL := URLDecode(fRequest.FullURL);
end;
Result := fFullURL.Substring(fFullURL.IndexOf('?') + 1);
end;
ReqIDX_PathInfo:
Result := fRequest.URL;
begin
if fURL = '' then
begin
fURL := URLDecode(String(fRequest.URL));
end;
Result := fURL;
lIdx := Result.IndexOf('?');
if lIdx > -1 then
begin
Result := Result.Substring(0, lIdx);
end;
end;
ReqIDX_PathTranslated:
Result := fRequest.URL;
Result := String(fRequest.URL);
ReqIDX_CacheControl:
Result := fHeaders.Values['Cache-Control']; { do not localize }
ReqIDX_Date:
@ -441,9 +457,9 @@ end;
constructor TMVCHTTPSysAppResponse.Create(AResponse: THttpServerRequest);
begin
inherited Create(nil);
// fRequest := ARequest;
fResponse := AResponse;
fHeaders := TMVCHeaders.Create;
ContentType := BuildContentType(TMVCConstants.DEFAULT_CONTENT_TYPE, TMVCConstants.DEFAULT_CONTENT_CHARSET);
StatusCode := http_status.OK;
end;
@ -455,7 +471,7 @@ end;
function TMVCHTTPSysAppResponse.GetContent: string;
begin
Result := fResponse.OutContent;
Result := String(fResponse.OutContent);
end;
function TMVCHTTPSysAppResponse.GetLogMessage: string;
@ -615,15 +631,9 @@ end;
procedure TMVCHTTPSysAppResponse.SendResponse;
var
lBytes: TBytesStream;
lBuff: PSockString;
lByte: PByte;
lBS: TBytesStream;
lByteArray: TBytes;
lOutContent: SockString;
lSize: Int64;
begin
// raise Exception.Create('not implemented');
if fSent then
Exit;
fSent := True;
@ -636,72 +646,8 @@ begin
ContentStream.Read(lOutContent[1], lSize);
fResponse.OutContent := lOutContent;
end;
fResponse.OutContentType := ContentType;
fResponse.OutContentType := SockString(ContentType);
fResponse.OutCustomHeaders := GetHeaders;
// fResponse.OutContent
// fResponse.OutContentType := 'text/plain';
// fResponse.OutCustomHeaders := 'x-pippo: pluto';
// fResponse.OutContent := 'PIPPO';
// MergeHeaders;
// if (ContentStream = nil) then
// HTTPRequest.WriteString(Content)
// else
// begin
// SendStream(ContentStream);
// ContentStream := nil; // Drop the stream
// end;
// // if (fResponse.ContentType = '') and
// // ((fResponse.ContentText <> '') or (Assigned(FResponseInfo.ContentStream))) and
// // (HTTPApp.DefaultCharSet <> '') then
// // begin
// // // Indicate how to convert UTF16 when write.
// // ContentType := Format('text/html; charset=%s', [HTTPApp.DefaultCharSet]); { Do not Localize }
// // end;
// // fResponse.ContentType := fContentType;
//
// if (ContentStream <> nil) and (ContentStream.Size > 0) then
// begin
// fResponse.StatusCode := StatusCode;
// ContentStream.Position := 0;
// // if TFile.Exists('output.dat') then
// // TFile.Delete('output.dat');
// // var
// // fs := TFileStream.Create('output.dat', fmCreate);
// // try
// // fs.CopyFrom(ContentStream, 0);
// // finally
// // fs.Free;
// // end;
// // ContentStream.Position := 0;
// if ContentStream is TFileStream then
// begin
// var
// l := TMemoryStream.Create;
// l.CopyFrom(ContentStream, 0);
// l.Position := 0;
// SetContentStream(l);
// end;
//
// fResponse.Send(ContentStream, 0, ContentStream.Size,
// procedure(const AConnection: ICrossConnection; const ASuccess: Boolean)
// begin
// // AConnection.SendStream(ContentStream)
// end);
//
// // fResponse.Send(lBytes.Bytes, 0, lBytes.Size,
// // procedure(const AConnection: ICrossConnection; const ASuccess: Boolean)
// // begin
// // lBytes.Free;
// // end);
// // fResponse.SendFile('C:\DEV\dmvcframework\unittests\general\TestServer\bin\www\index.html')
// end
// else
// begin
// fResponse.SendStatus(StatusCode, '');
// end;
end;
procedure TMVCHTTPSysAppResponse.SendStream(AStream: TStream);
@ -733,34 +679,13 @@ end;
procedure TMVCHTTPSysAppResponse.SetContentStream(AValue: TStream);
begin
inherited SetContentStream(AValue);
// fResponse.Header.Add('content-length', AValue.Size.ToString, False);
// FResponseInfo.ContentStream := AValue;
end;
function DoHTTPEncode(const AStr: string): String;
begin
Result := TNetEncoding.URL.Encode(string(AStr));
end;
function TMVCHTTPSysAppResponse.GetHeaders;
function TMVCHTTPSysAppResponse.GetHeaders: SockString;
var
i: Integer;
lSrcCookie: TCookie;
lBuilder: TStringBuilder;
begin
// for i := 0 to Cookies.Count - 1 do
// begin
// lSrcCookie := Cookies[i];
// fResponse.Cookies.AddOrSet(lSrcCookie.Name, lSrcCookie.Value, SecondsBetween(Now, lSrcCookie.Expires),
// lSrcCookie.Path, lSrcCookie.Domain, lSrcCookie.HttpOnly, lSrcCookie.Secure);
// // LDestCookie := FResponseInfo.Cookies.Add;
// // LDestCookie.CookieName := DoHTTPEncode(LSrcCookie.Name);
// // LDestCookie.Value := DoHTTPEncode(LSrcCookie.Value);
// // LDestCookie.Domain := String(LSrcCookie.Domain);
// // LDestCookie.Path := String(LSrcCookie.Path);
// // LDestCookie.Expires := LSrcCookie.Expires;
// // LDestCookie.Secure := LSrcCookie.Secure;
// end;
lBuilder := TStringBuilder.Create(1024);
try
for i := 0 to fHeaders.Count - 1 do
@ -771,8 +696,11 @@ begin
begin
lBuilder.AppendLine(CustomHeaders.Names[i] + ':' + CustomHeaders.ValueFromIndex[i]);
end;
lBuilder.AppendLine('Server: Pippo');
Result := lBuilder.ToString;
for i := 0 to Cookies.Count - 1 do
begin
lBuilder.AppendLine('Set-Cookie: ' + Cookies[i].HeaderValue);
end;
Result := SockString(lBuilder.ToString);
finally
lBuilder.Free;
end;
@ -794,6 +722,7 @@ var
lRequest: TMVCHTTPSysAppRequest;
lResponse: TMVCHTTPSysAppResponse;
begin
Result := http_status.OK;
try
lRequest := TMVCHTTPSysAppRequest.Create(ReqResp);
try
@ -874,19 +803,43 @@ begin
end;
function TMVCHTTPSysWebBrokerBridge.DoHandleRequest(ReqResp: THttpServerRequest): Cardinal;
{$IF defined(TRACE)}
var
lFile: TFileStream;
lDirName, lReqFileName, lRespFileName: string;
const
LINE_BREAK = sLineBreak + sLineBreak + sLineBreak;
{$ENDIF}
begin
lFile := TFile.Create('req.2.dat');
{$IF defined(TRACE)}
lDirName := TPath.Combine(AppPath, 'trace_' + ReqResp.ConnectionID.ToString.PadLeft(10));
lReqFileName := TPath.Combine(lDirName, 'request.txt');
lRespFileName := TPath.Combine(lDirName, 'response.txt');
TDirectory.CreateDirectory(lDirName);
if TFile.Exists(lReqFileName) then
TFile.Delete(lReqFileName);
lFile := TFile.Create(lReqFileName, fmCreate or fmOpenWrite);
try
lFile.Write(ReqResp.InHeaders[1], Length(ReqResp.InHeaders));
lFile.Write(#13#10#13#10#13#10,6);
lFile.Write(LINE_BREAK[1], Length(LINE_BREAK));
lFile.Write(ReqResp.InContent[1], Length(ReqResp.InContent));
finally
lFile.Free;
end;
{$ENDIF}
Result := TMVCHTTPSysWebBrokerBridgeRequestHandler.FWebRequestHandler.Run(ReqResp);
{$IF defined(TRACE)}
if TFile.Exists(lRespFileName) then
TFile.Delete(lRespFileName);
lFile := TFile.Create(lRespFileName, fmCreate or fmOpenWrite);
try
lFile.Write(ReqResp.OutCustomHeaders[1], Length(ReqResp.OutCustomHeaders));
lFile.Write(LINE_BREAK[1], Length(LINE_BREAK));
lFile.Write(ReqResp.OutContent[1], Length(ReqResp.OutContent));
finally
lFile.Free;
end;
{$ENDIF}
end;
procedure TMVCHTTPSysWebBrokerBridge.SetActive(const Value: Boolean);
@ -898,9 +851,10 @@ begin
if Value then
begin
fHttpServer := TMVCHTTPSysServer.Create(False);
fHttpServer.AddUrl('', IntToStr(fDefaultPort), False, '+', True);
fHttpServer.RegisterCompress(CompressDeflate); // our server will deflate html :)
fHttpServer.AddUrl(SockString(''), SockString(IntToStr(fDefaultPort)), False, '+', True);
fHttpServer.RegisterCompress(CompressDeflate);
fHttpServer.OnRequest := DoHandleRequest;
{ TODO -odanielet -cGeneral : Try to find some adaptive and smart number here }
fHttpServer.Clone(31); // will use a thread pool of 32 threads in total
fActive := True;
// // {$IFDEF __CROSS_SSL__}
@ -949,65 +903,6 @@ begin
fServerName := 'DMVCFramework';
end;
{ TMVCHeaders }
constructor TMVCHeaders.Create;
begin
inherited;
NameValueSeparator := ':';
end;
function TMVCHeaders.GetValue(const Name: string): string;
var
i: Integer;
begin
i := IndexOfName(Name);
if i >= 0 then
Result := Trim(Copy(Get(i), Length(Name) + 2, MaxInt))
else
Result := '';
end;
procedure TMVCHeaders.SetValue(const Name, Value: string);
var
i: Integer;
begin
i := IndexOfName(Name);
if Value <> '' then
begin
if i < 0 then
i := Add('');
Put(i, Name + NameValueSeparator + Value);
end
else
begin
if i >= 0 then
Delete(i);
end;
end;
function TMVCHeaders.IndexOfName(const Name: string): Integer;
var
P: Integer;
S: string;
lSub: String;
begin
for Result := 0 to GetCount - 1 do
begin
S := Get(Result);
P := AnsiPos(NameValueSeparator, S);
if (P <> 0) then
begin
lSub := Copy(S, 1, P - 1);
if SameText(lSub, Name) then
begin
Exit;
end;
end;
end;
Result := -1;
end;
initialization
WebReq.WebRequestHandlerProc := MVCHTTPSysWebBrokerBridgeRequestHandler;

38
sources/MVCFramework.Middleware.StaticFiles.pas
View File

@ -73,11 +73,9 @@ type
function SendStaticFileIfPresent(const AContext: TWebContext; const AFileName: string): Boolean;
procedure DoSanityCheck;
public
constructor Create(
const AStaticFilesPath: string = TMVCStaticFilesDefaults.STATIC_FILES_PATH;
constructor Create(const AStaticFilesPath: string = TMVCStaticFilesDefaults.STATIC_FILES_PATH;
const ADocumentRoot: string = TMVCStaticFilesDefaults.DOCUMENT_ROOT;
const AIndexDocument: string = TMVCStaticFilesDefaults.INDEX_DOCUMENT;
const ASPAWebAppSupport: Boolean = True;
const AIndexDocument: string = TMVCStaticFilesDefaults.INDEX_DOCUMENT; const ASPAWebAppSupport: Boolean = True;
const AStaticFilesCharset: string = TMVCStaticFilesDefaults.STATIC_FILES_CONTENT_CHARSET);
destructor Destroy; override;
@ -95,7 +93,9 @@ implementation
uses
System.SysUtils,
System.NetEncoding,
System.IOUtils, System.Classes;
System.IOUtils,
System.Classes,
MVCFramework.Logger;
{ TMVCStaticFilesMiddleware }
@ -119,11 +119,9 @@ begin
fMediaTypes.Add('.gif', TMVCMediaType.IMAGE_GIF);
end;
constructor TMVCStaticFilesMiddleware.Create(
const AStaticFilesPath: string = TMVCStaticFilesDefaults.STATIC_FILES_PATH;
constructor TMVCStaticFilesMiddleware.Create(const AStaticFilesPath: string = TMVCStaticFilesDefaults.STATIC_FILES_PATH;
const ADocumentRoot: string = TMVCStaticFilesDefaults.DOCUMENT_ROOT;
const AIndexDocument: string = TMVCStaticFilesDefaults.INDEX_DOCUMENT;
const ASPAWebAppSupport: Boolean = True;
const AIndexDocument: string = TMVCStaticFilesDefaults.INDEX_DOCUMENT; const ASPAWebAppSupport: Boolean = True;
const AStaticFilesCharset: string = TMVCStaticFilesDefaults.STATIC_FILES_CONTENT_CHARSET);
begin
inherited Create;
@ -186,8 +184,8 @@ begin
// do nothing
end;
procedure TMVCStaticFilesMiddleware.OnBeforeControllerAction(AContext: TWebContext; const AControllerQualifiedClassName,
AActionName: string; var AHandled: Boolean);
procedure TMVCStaticFilesMiddleware.OnBeforeControllerAction(AContext: TWebContext;
const AControllerQualifiedClassName, AActionName: string; var AHandled: Boolean);
begin
// do nothing
end;
@ -213,11 +211,10 @@ begin
Exit;
end;
LogI('File: ' + lPathInfo);
// calculate the actual requested path
if lPathInfo.StartsWith(fStaticFilesPath, True) then
begin
lPathInfo := lPathInfo.Remove(0, fStaticFilesPath.Length);
end;
lPathInfo := lPathInfo.Remove(0, fStaticFilesPath.Length);
lPathInfo := lPathInfo.Replace('/', PathDelim, [rfReplaceAll]);
if lPathInfo.StartsWith(PathDelim) then
begin
@ -227,8 +224,7 @@ begin
{ Now the actual requested path is in lFullPathInfo }
if TMVCStaticContents.IsStaticFile(fDocumentRoot, lPathInfo, lRealFileName,
lIsDirectoryTraversalAttach) then
if TMVCStaticContents.IsStaticFile(fDocumentRoot, lPathInfo, lRealFileName, lIsDirectoryTraversalAttach) then
begin
// check if it's a direct file request
// lIsFileRequest := TMVCStaticContents.IsStaticFile(fDocumentRoot, lPathInfo, lRealFileName,
@ -274,6 +270,14 @@ begin
lFileName := TPath.GetFullPath(TPath.Combine(lFullPathInfo, fIndexDocument));
AHandled := SendStaticFileIfPresent(AContext, lFileName);
end;
if not AHandled then
begin
AContext.Response.StatusCode := HTTP_STATUS.NotFound;
AContext.Response.Content := '404 Not Found';
AHandled := True;
end;
end;
function TMVCStaticFilesMiddleware.SendStaticFileIfPresent(const AContext: TWebContext;

183
sources/MVCFramework.RESTClient.pas
View File

@ -96,6 +96,7 @@ type
fBeforeRequestProc: TBeforeRequestProc;
fRequestCompletedProc: TRequestCompletedProc;
fResponseCompletedProc: TResponseCompletedProc;
fSessionID: string;
procedure DoValidateServerCertificate(const aSender: TObject; const aRequest: TURLRequest;
const aCertificate: TCertificate; var aAccepted: Boolean);
procedure DoBeforeRequest(aRequest: IHTTPRequest);
@ -123,6 +124,8 @@ type
procedure ExecuteAsyncRequest(const aMethod: TMVCHTTPMethodType);
function InternalExecuteRequest(const aMethod: TMVCHTTPMethodType): IMVCRESTResponse;
function ExecuteRequest(const aMethod: TMVCHTTPMethodType): IMVCRESTResponse;
procedure HandleCookies(aCookies: TCookies);
public
constructor Create;
destructor Destroy; override;
@ -320,8 +323,8 @@ type
/// <param name="aOwnsStream">
/// If OwnsStream is true, Stream will be destroyed by IMVCRESTClient.
/// </param>
function AddBody(aBodyStream: TStream; const aOwnsStream: Boolean = True;
const aContentType: string = ''): IMVCRESTClient; overload;
function AddBody(aBodyStream: TStream; const aOwnsStream: Boolean = True; const aContentType: string = '')
: IMVCRESTClient; overload;
/// <summary>
/// Add a body to the requisition
/// </summary>
@ -351,8 +354,8 @@ type
function AddBodyFieldFormData(const aName, aValue: string): IMVCRESTClient; overload;
{$IF defined(RIOORBETTER)}
function AddBodyFieldFormData(const aName: string; aStreamValue: TStream;
const aContentType: string = ''): IMVCRESTClient; overload;
function AddBodyFieldFormData(const aName: string; aStreamValue: TStream; const aContentType: string = '')
: IMVCRESTClient; overload;
{$ENDIF}
/// <summary>
/// Add a field to the x-www-form-urlencoded body. You must set ContentType to application/x-www-form-urlencoded
@ -414,8 +417,8 @@ type
/// <summary>
/// Execute a Patch request.
/// </summary>
function Patch(const aResource: string; aBody: TObject;
const aOwnsBody: Boolean = True): IMVCRESTResponse; overload;
function Patch(const aResource: string; aBody: TObject; const aOwnsBody: Boolean = True): IMVCRESTResponse;
overload;
function Patch(const aResource: string; const aBody: string = '';
const aContentType: string = TMVCMediaType.APPLICATION_JSON): IMVCRESTResponse; overload;
function Patch: IMVCRESTResponse; overload;
@ -466,10 +469,11 @@ type
/// </summary>
TMVCRESTResponse = class(TInterfacedObject, IMVCRESTResponse)
private
fHTTPResponse: IHTTPResponse;
fSuccess: Boolean;
fStatusCode: Integer;
fStatusText: string;
fHeaders: TStrings;
fHeaders: TMVCHeaders;
fCookies: TCookies;
fServer: string;
fContentType: string;
@ -507,7 +511,7 @@ uses
System.NetConsts,
System.NetEncoding,
MVCFramework.Serializer.JsonDataObjects,
System.RegularExpressions;
System.RegularExpressions, IdURI;
{$IF not defined(RIOORBETTER)}
@ -517,8 +521,7 @@ type
function CookieList: TCookies;
end;
{$ENDIF}
{ TMVCRESTClient }
{ TMVCRESTClient }
function TMVCRESTClient.Accept: string;
begin
@ -580,8 +583,8 @@ begin
end;
end;
function TMVCRESTClient.AddBody(aBodyStream: TStream; const aOwnsStream: Boolean;
const aContentType: string): IMVCRESTClient;
function TMVCRESTClient.AddBody(aBodyStream: TStream; const aOwnsStream: Boolean; const aContentType: string)
: IMVCRESTClient;
begin
Result := Self;
@ -620,8 +623,8 @@ end;
{$IF defined(RIOORBETTER)}
function TMVCRESTClient.AddBodyFieldFormData(const aName: string; aStreamValue: TStream;
const aContentType: string): IMVCRESTClient;
function TMVCRESTClient.AddBodyFieldFormData(const aName: string; aStreamValue: TStream; const aContentType: string)
: IMVCRESTClient;
begin
Result := Self;
GetBodyFormData.AddStream(aName, aStreamValue, aContentType);
@ -629,7 +632,6 @@ begin
end;
{$ENDIF}
function TMVCRESTClient.AddBodyFieldURLEncoded(const aName, aValue: string): IMVCRESTClient;
begin
Result := Self;
@ -986,7 +988,6 @@ type
THackURLClient = class(TURLClient);
{$ENDIF}
procedure TMVCRESTClient.DoApplyHeaders;
var
lParam: TMVCRESTParam;
@ -1008,7 +1009,7 @@ begin
fHTTPClient.CustomHeaders[TMVCRESTClientConsts.AUTHORIZATION_HEADER] := fAuthorization;
end;
fHTTPClient.Accept := fAccept;
fHTTPClient.AcceptCharSet := fAcceptCharset;
fHTTPClient.AcceptCharset := fAcceptCharset;
fHTTPClient.AcceptEncoding := fAcceptEncoding;
fHTTPClient.ContentType := fContentType;
end;
@ -1168,8 +1169,7 @@ begin
procedure
begin
fAsyncCompletionHandler(lResponse);
end
);
end);
end
else
begin
@ -1190,8 +1190,7 @@ begin
procedure
begin
fAsyncCompletionHandlerWithError(E);
end
);
end);
end
else
begin
@ -1201,8 +1200,7 @@ begin
end;
end;
ClearAllParams;
end
);
end);
lThread.Start;
end;
@ -1243,8 +1241,8 @@ begin
lResource := fResource;
if not lResource.IsEmpty then
begin
if not Result.EndsWith('/') and
not (lResource.StartsWith('/') or lResource.StartsWith('?') or lResource.StartsWith('#')) then
if not Result.EndsWith('/') and not(lResource.StartsWith('/') or lResource.StartsWith('?') or
lResource.StartsWith('#')) then
begin
Result := Result + '/';
end;
@ -1265,6 +1263,24 @@ begin
fHTTPClient.HandleRedirects := aHandleRedirects;
end;
procedure TMVCRESTClient.HandleCookies(aCookies: TCookies);
var
lCookie: TCookie;
lValue: String;
begin
for lCookie in aCookies do
begin
if SameText(lCookie.Name, 'dtsessionid') then
begin
lValue := TIdURI.URLDecode(lCookie.Value.Trim);
if lValue.Contains('invalid') then
SessionId('')
else
SessionId(lValue);
end;
end;
end;
function TMVCRESTClient.HandleRedirects: Boolean;
begin
Result := fHTTPClient.HandleRedirects;
@ -1331,6 +1347,11 @@ begin
fHTTPClient.ProxySettings := fProxySettings;
lURL := GetFullURL;
if not fSessionID.IsEmpty then
begin
Self.AddCookie(TMVCConstants.SESSION_TOKEN_NAME, SessionId);
end;
DoConvertMVCPathParamsToRESTParams(lURL);
DoApplyPathParams(lURL);
DoApplyQueryParams(lURL);
@ -1348,7 +1369,7 @@ begin
DoBeforeRequest(lRequest);
lResponse := fHTTPClient.Execute(lRequest, nil, []);
HandleCookies(lResponse.Cookies);
lHandled := False;
DoRequestCompleted(lResponse, lHandled);
@ -1407,7 +1428,7 @@ end;
function TMVCRESTClient.Patch(const aResource, aBody: string; const aContentType: string): IMVCRESTResponse;
begin
Resource(aResource);
if not aBody.isEmpty then
if not aBody.IsEmpty then
begin
ClearBody;
AddBody(aBody, aContentType);
@ -1541,8 +1562,8 @@ begin
fHTTPClient.ResponseTimeout := aReadTimeout;
end;
function TMVCRESTClient.RegisterTypeSerializer(const aTypeInfo: PTypeInfo;
aInstance: IMVCTypeSerializer): IMVCRESTClient;
function TMVCRESTClient.RegisterTypeSerializer(const aTypeInfo: PTypeInfo; aInstance: IMVCTypeSerializer)
: IMVCRESTClient;
begin
Result := Self;
fSerializer.RegisterTypeSerializer(aTypeInfo, aInstance);
@ -1561,7 +1582,6 @@ end;
{$IF defined(TOKYOORBETTER)}
function TMVCRESTClient.SecureProtocols: THTTPSecureProtocols;
begin
Result := fHTTPClient.SecureProtocols;
@ -1574,7 +1594,6 @@ begin
end;
{$ENDIF}
function TMVCRESTClient.SerializeObject(aObject: TObject): string;
begin
if ObjectIsList(aObject) then
@ -1584,45 +1603,46 @@ begin
end;
function TMVCRESTClient.SessionId: string;
var
lCookie: TCookie;
lParam: TMVCRESTParam;
// var
// lCookie: TCookie;
// lParam: TMVCRESTParam;
begin
Result := '';
for lParam in fParameters do
begin
if lParam.&Type = TMVCRESTParamType.Cookie then
begin
if SameText(lParam.Name, TMVCConstants.SESSION_TOKEN_NAME) then
begin
Result := lParam.Value;
Break;
end;
end;
end;
if Result.IsEmpty then
begin
for lCookie in fHTTPClient.CookieManager.Cookies do
begin
if SameText(lCookie.Name, TMVCConstants.SESSION_TOKEN_NAME) then
begin
Result := lCookie.Value;
Break;
end;
end;
Result := lCookie.Value;
end;
if Result.Contains('invalid') then
Result := '';
Result := fSessionID;
// Result := '';
//
// for lParam in fParameters do
// begin
// if lParam.&Type = TMVCRESTParamType.Cookie then
// begin
// if SameText(lParam.Name, TMVCConstants.SESSION_TOKEN_NAME) then
// begin
// Result := lParam.Value;
// Break;
// end;
// end;
// end;
//
// if Result.IsEmpty then
// begin
// for lCookie in fHTTPClient.CookieManager.Cookies do
// begin
// if SameText(lCookie.Name, TMVCConstants.SESSION_TOKEN_NAME) then
// begin
// Result := lCookie.Value;
// Break;
// end;
// end;
// Result := lCookie.Value;
// end;
//
// if Result.Contains('invalid') then
// Result := '';
end;
function TMVCRESTClient.SessionId(const aSessionId: string): IMVCRESTClient;
begin
Result := Self;
fSessionID := aSessionId;
AddCookie(TMVCConstants.SESSION_TOKEN_NAME, aSessionId);
end;
@ -1685,8 +1705,8 @@ begin
fResponseCompletedProc := aResponseCompletedProc;
end;
function TMVCRESTClient.SetValidateServerCertificateProc(
aValidateCertificateProc: TValidateServerCertificateProc): IMVCRESTClient;
function TMVCRESTClient.SetValidateServerCertificateProc(aValidateCertificateProc: TValidateServerCertificateProc)
: IMVCRESTClient;
begin
Result := Self;
fValidateServerCertificate := aValidateCertificateProc;
@ -1707,6 +1727,10 @@ end;
function TMVCRESTResponse.Content: string;
begin
if fContent.IsEmpty then
begin
fContent := TMVCRESTClientHelper.GetResponseContentAsString(ContentRawBytes, ContentType);
end;
Result := fContent;
end;
@ -1744,8 +1768,10 @@ end;
constructor TMVCRESTResponse.Create(aHTTPResponse: IHTTPResponse);
begin
fHeaders := TStringList.Create;
SetLength(fContentRawBytes, 0);
inherited Create;
fHTTPResponse := aHTTPResponse;
fHeaders := TMVCHeaders.Create;
// SetLength(fContentRawBytes, 0);
fCookies := TCookies.Create;
FillResponse(aHTTPResponse);
@ -1753,7 +1779,7 @@ end;
destructor TMVCRESTResponse.Destroy;
begin
SetLength(fContentRawBytes, 0);
// SetLength(fContentRawBytes, 0);
FreeAndNil(fHeaders);
FreeAndNil(fCookies);
inherited Destroy;
@ -1773,10 +1799,11 @@ begin
end;
fCookies.AddRange(aHTTPResponse.Cookies.ToArray);
fServer := aHTTPResponse.HeaderValue[TMVCRESTClientConsts.SERVER_HEADER];
fContentRawBytes := TMVCRESTClientHelper.GetResponseContentAsRawBytes(aHTTPResponse.ContentStream,
aHTTPResponse.ContentEncoding);
fContent := TMVCRESTClientHelper.GetResponseContentAsString(fContentRawBytes,
aHTTPResponse.HeaderValue[sContentType]);
fContentRawBytes := [];
// TMVCRESTClientHelper.GetResponseContentAsRawBytes(aHTTPResponse.ContentStream,
// aHTTPResponse.ContentEncoding);
// fContent := TMVCRESTClientHelper.GetResponseContentAsString(fContentRawBytes,
// aHTTPResponse.HeaderValue[sContentType]);
fContentType := aHTTPResponse.HeaderValue[sContentType];
fContentEncoding := aHTTPResponse.ContentEncoding;
fContentLength := aHTTPResponse.ContentLength;
@ -1794,6 +1821,11 @@ end;
function TMVCRESTResponse.ContentRawBytes: TBytes;
begin
if Length(fContentRawBytes) = 0 then
begin
fContentRawBytes := TMVCRESTClientHelper.GetResponseContentAsRawBytes(fHTTPResponse.ContentStream,
fHTTPResponse.ContentEncoding);
end;
Result := fContentRawBytes;
end;
@ -1803,7 +1835,7 @@ var
begin
lStream := TMemoryStream.Create;
try
lStream.Write(fContentRawBytes, Length(fContentRawBytes));
lStream.Write(ContentRawBytes, Length(ContentRawBytes));
lStream.Position := 0;
lStream.SaveToFile(aFileName);
finally
@ -1816,7 +1848,7 @@ begin
if aStream = nil then
raise EMVCRESTClientException.Create('Stream not assigned!');
aStream.Write(fContentRawBytes, Length(fContentRawBytes));
aStream.Write(ContentRawBytes, Length(ContentRawBytes));
end;
function TMVCRESTResponse.Server: string;
@ -1840,7 +1872,6 @@ begin
end;
{$IF not defined(RIOORBETTER)}
{ TCookieManagerHelper }
function TCookieManagerHelper.CookieList: TCookies;

185
sources/MVCFramework.pas
View File

@ -282,8 +282,7 @@ type
property Format: string read FFormat write FFormat;
constructor Create(name: string; Location: TSwagRequestParameterInLocation; AType: TSwagTypeParameter;
APattern: string = '';
AFormat: string = ''); overload;
APattern: string = ''; AFormat: string = ''); overload;
constructor Create(name: string; Location: TSwagRequestParameterInLocation; AType: TClass; APattern: string = '';
AFormat: string = ''); overload;
end;
@ -565,8 +564,7 @@ type
const ASerializationType: TMVCDatasetSerializationType;
const ASerializationAction: TMVCDatasetSerializationAction = nil); overload;
procedure Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList;
const ANameCase: TMVCNameCase;
const ASerializationType: TMVCDatasetSerializationType;
const ANameCase: TMVCNameCase; const ASerializationType: TMVCDatasetSerializationType;
const ASerializationAction: TMVCDatasetSerializationAction = nil); overload;
procedure Render(const ATextWriter: TTextWriter; const AOwns: Boolean = True); overload;
procedure Render(const AStream: TStream; const AOwns: Boolean = True); overload;
@ -597,11 +595,9 @@ type
procedure OnRequest(const AContext: TWebContext; const AControllerQualifiedClassName, AActionName: string;
var AAuthenticationRequired: Boolean);
procedure OnAuthentication(const AContext: TWebContext; const AUserName, APassword: string;
AUserRoles: TList<string>;
var AIsValid: Boolean; const ASessionData: TDictionary<string, string>);
AUserRoles: TList<string>; var AIsValid: Boolean; const ASessionData: TDictionary<string, string>);
procedure OnAuthorization(const AContext: TWebContext; AUserRoles: TList<string>;
const AControllerQualifiedClassName: string;
const AActionName: string; var AIsAuthorized: Boolean);
const AControllerQualifiedClassName: string; const AActionName: string; var AIsAuthorized: Boolean);
end;
TMVCRenderer = class(TMVCBase)
@ -669,8 +665,7 @@ type
procedure Render<T: class>(const AStatusCode: Integer; const ACollection: TObjectList<T>; const AOwns: Boolean;
const ASerializationAction: TMVCSerializationAction<T> = nil); overload;
procedure Render<T: class>(const ACollection: TObjectList<T>; const AOwns: Boolean;
const AType: TMVCSerializationType;
const ASerializationAction: TMVCSerializationAction<T> = nil); overload;
const AType: TMVCSerializationType; const ASerializationAction: TMVCSerializationAction<T> = nil); overload;
procedure Render(const ACollection: IMVCList); overload;
procedure Render(const ACollection: IMVCList; const AType: TMVCSerializationType); overload;
procedure Render(const ATextWriter: TTextWriter; const AOwns: Boolean = True); overload;
@ -692,8 +687,7 @@ type
const ASerializationType: TMVCDatasetSerializationType;
const ASerializationAction: TMVCDatasetSerializationAction = nil); overload;
procedure Render(const ADataSet: TDataSet; const AOwns: Boolean; const AIgnoredFields: TMVCIgnoredList;
const ANameCase: TMVCNameCase;
const ASerializationType: TMVCDatasetSerializationType;
const ANameCase: TMVCNameCase; const ASerializationType: TMVCDatasetSerializationType;
const ASerializationAction: TMVCDatasetSerializationAction = nil); overload;
// SSE Support
procedure RenderSSE(const EventID: string; const EventData: string; EventName: string = '';
@ -813,8 +807,7 @@ type
/// <param name="AActionName">Method name of the matching controller method.</param>
/// <param name="AHandled">If set to True the Request would finished. Response must be set by the implementor. Default value is False.</param>
procedure OnBeforeControllerAction(AContext: TWebContext; const AControllerQualifiedClassName: string;
const AActionName: string;
var AHandled: Boolean);
const AActionName: string; var AHandled: Boolean);
/// <summary>
/// Procedure is called after the specific controller method was called.
/// It is still possible to cancel or to completly modifiy the request.
@ -833,12 +826,10 @@ type
end;
TMVCExceptionHandlerProc = reference to procedure(E: Exception; SelectedController: TMVCController;
WebContext: TWebContext;
var ExceptionHandled: Boolean);
WebContext: TWebContext; var ExceptionHandled: Boolean);
TMVCRouterLogState = (rlsRouteFound, rlsRouteNotFound);
TMVCRouterLogHandlerProc = reference to procedure(const Router: TMVCCustomRouter;
const RouterLogState: TMVCRouterLogState;
const WebContext: TWebContext);
const RouterLogState: TMVCRouterLogState; const WebContext: TWebContext);
TMVCEngine = class(TComponent)
private const
@ -872,8 +863,7 @@ type
procedure FixUpWebModule;
procedure ExecuteBeforeRoutingMiddleware(const AContext: TWebContext; var AHandled: Boolean);
procedure ExecuteBeforeControllerActionMiddleware(const AContext: TWebContext;
const AControllerQualifiedClassName: string;
const AActionName: string; var AHandled: Boolean);
const AControllerQualifiedClassName: string; const AActionName: string; var AHandled: Boolean);
procedure ExecuteAfterControllerActionMiddleware(const AContext: TWebContext; const AActionName: string;
const AHandled: Boolean);
procedure ExecuteAfterRoutingMiddleware(const AContext: TWebContext; const AHandled: Boolean);
@ -893,8 +883,7 @@ type
class procedure ClearSessionCookiesAlreadySet(const ACookies: TCookieCollection); static;
public
constructor Create(const AWebModule: TWebModule; const AConfigAction: TProc<TMVCConfig> = nil;
const ACustomLogger: ILogWriter = nil);
reintroduce;
const ACustomLogger: ILogWriter = nil); reintroduce;
destructor Destroy; override;
function GetSessionBySessionId(const ASessionId: string): TWebSession;
@ -1323,7 +1312,6 @@ constructor TMVCWebRequest.Create(const AWebRequest: TWebRequest;
begin
inherited Create;
FBody := EmptyStr;
// FContentType := TMVCConstants.DEFAULT_CONTENT_TYPE;
FCharset := TMVCConstants.DEFAULT_CONTENT_CHARSET;
FWebRequest := AWebRequest;
FSerializers := ASerializers;
@ -1334,6 +1322,10 @@ end;
procedure TMVCWebRequest.DefineContentType;
begin
SplitContentMediaTypeAndCharset(FWebRequest.GetFieldByName('Content-Type'), FContentMediaType, FCharset);
if FContentMediaType.IsEmpty then
begin
FContentMediaType := TMVCConstants.DEFAULT_CONTENT_TYPE;
end;
FContentType := BuildContentType(FContentMediaType, FCharset);
end;
@ -1732,8 +1724,7 @@ begin
else
LRoles := '';
AWebSession[TMVCConstants.CURRENT_USER_SESSION_KEY] := FUserName + '$$' + DateTimeToISOTimeStamp(FLoggedSince) + '$$'
+ FRealm +
'$$' + LRoles;
+ FRealm + '$$' + LRoles;
end;
procedure TUser.SetCustomData(const Value: TMVCCustomData);
@ -2007,8 +1998,7 @@ begin
end;
function TMVCEngine.AddController(const AControllerClazz: TMVCControllerClazz;
const ACreateAction: TMVCControllerCreateAction;
const AURLSegment: string): TMVCEngine;
const ACreateAction: TMVCControllerCreateAction; const AURLSegment: string): TMVCEngine;
begin
FControllers.Add(TMVCControllerDelegate.Create(AControllerClazz, ACreateAction, AURLSegment));
Result := Self;
@ -2075,15 +2065,14 @@ begin
rlsRouteFound:
begin
Log(TLogLevel.levNormal, Context.Request.HTTPMethodAsString + ':' + Context.Request.PathInfo + ' [' +
Context.Request.ClientIp +
'] -> ' + Sender.GetQualifiedActionName + ' - ' + IntToStr(Context.Response.StatusCode) + ' ' +
Context.Response.ReasonString);
Context.Request.ClientIp + '] -> ' + Sender.GetQualifiedActionName + ' - ' +
IntToStr(Context.Response.StatusCode) + ' ' + Context.Response.ReasonString);
end;
rlsRouteNotFound:
begin
Log(TLogLevel.levNormal, Context.Request.HTTPMethodAsString + ':' + Context.Request.PathInfo + ' [' +
Context.Request.ClientIp +
'] -> {NOT FOUND} - ' + IntToStr(Context.Response.StatusCode) + ' ' + Context.Response.ReasonString);
Context.Request.ClientIp + '] -> {NOT FOUND} - ' + IntToStr(Context.Response.StatusCode) + ' ' +
Context.Response.ReasonString);
end;
else
raise EMVCException.Create('Invalid RouterLogState');
@ -2169,8 +2158,7 @@ begin
if ARequest.ContentLength > FConfigCache_MaxRequestSize then
begin
raise EMVCException.CreateFmt(http_status.RequestEntityTooLarge,
'Request size exceeded the max allowed size [%d KiB] (1)',
[(FConfigCache_MaxRequestSize div 1024)]);
'Request size exceeded the max allowed size [%d KiB] (1)', [(FConfigCache_MaxRequestSize div 1024)]);
end;
{$IFDEF BERLINORBETTER}
@ -2180,8 +2168,7 @@ begin
if ARequest.ContentLength > FConfigCache_MaxRequestSize then
begin
raise EMVCException.CreateFmt(http_status.RequestEntityTooLarge,
'Request size exceeded the max allowed size [%d KiB] (2)',
[(FConfigCache_MaxRequestSize div 1024)]);
'Request size exceeded the max allowed size [%d KiB] (2)', [(FConfigCache_MaxRequestSize div 1024)]);
end;
{$ENDIF}
lParamsTable := TMVCRequestParamsTable.Create;
@ -2199,8 +2186,8 @@ begin
if not lHandled then
begin
if lRouter.ExecuteRouting(ARequest.PathInfo,
lContext.Request.GetOverwrittenHTTPMethod { lContext.Request.HTTPMethod } ,
ARequest.ContentType, ARequest.Accept, FControllers, FConfig[TMVCConfigKey.DefaultContentType],
lContext.Request.GetOverwrittenHTTPMethod { lContext.Request.HTTPMethod } , ARequest.ContentType,
ARequest.Accept, FControllers, FConfig[TMVCConfigKey.DefaultContentType],
FConfig[TMVCConfigKey.DefaultContentCharset], lParamsTable, lResponseContentMediaType,
lResponseContentCharset) then
begin
@ -2222,8 +2209,7 @@ begin
lSelectedController.ApplicationSession := FApplicationSession;
lContext.ParamsTable := lParamsTable;
ExecuteBeforeControllerActionMiddleware(lContext, lRouter.ControllerClazz.QualifiedClassName,
lRouter.MethodToCall.name,
lHandled);
lRouter.MethodToCall.name, lHandled);
if lHandled then
Exit(True);
@ -2323,8 +2309,7 @@ begin
else
begin
SendRawHTTPStatus(lContext, http_status.InternalServerError,
Format('[%s] %s', [EIO.Classname, EIO.Message]),
EIO.Classname);
Format('[%s] %s', [EIO.Classname, EIO.Message]), EIO.Classname);
end;
end;
end;
@ -2333,8 +2318,7 @@ begin
if not CustomExceptionHandling(Ex, lSelectedController, lContext) then
begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")',
[Ex.Classname, Ex.Message, 'Global Action Exception Handler'],
LOGGERPRO_TAG);
[Ex.Classname, Ex.Message, 'Global Action Exception Handler'], LOGGERPRO_TAG);
if Assigned(lSelectedController) then
begin
lSelectedController.ResponseStatus(http_status.InternalServerError);
@ -2356,8 +2340,7 @@ begin
if not CustomExceptionHandling(Ex, lSelectedController, lContext) then
begin
Log.ErrorFmt('[%s] %s (Custom message: "%s")',
[Ex.Classname, Ex.Message, 'After Routing Exception Handler'],
LOGGERPRO_TAG);
[Ex.Classname, Ex.Message, 'After Routing Exception Handler'], LOGGERPRO_TAG);
if Assigned(lSelectedController) then
begin
{ middlewares *must* not raise unhandled exceptions }
@ -2408,8 +2391,7 @@ begin
end;
procedure TMVCEngine.ExecuteBeforeControllerActionMiddleware(const AContext: TWebContext;
const AControllerQualifiedClassName: string;
const AActionName: string; var AHandled: Boolean);
const AControllerQualifiedClassName: string; const AActionName: string; var AHandled: Boolean);
var
Middleware: IMVCMiddleware;
begin
@ -2451,8 +2433,7 @@ begin
end;
procedure TMVCEngine.FillActualParamsForAction(const AContext: TWebContext;
const AActionFormalParams: TArray<TRttiParameter>;
const AActionName: string; var AActualParams: TArray<TValue>);
const AActionFormalParams: TArray<TRttiParameter>; const AActionName: string; var AActualParams: TArray<TValue>);
var
lParamName: string;
I: Integer;
@ -2484,8 +2465,8 @@ begin
on E: Exception do
begin
raise EMVCException.CreateFmt(http_status.BadRequest,
'Invalid Integer value for param [%s] - [CLASS: %s][MSG: %s]',
[AActionFormalParams[I].name, E.Classname, E.Message]);
'Invalid Integer value for param [%s] - [CLASS: %s][MSG: %s]', [AActionFormalParams[I].name, E.Classname,
E.Message]);
end;
end;
tkInt64:
@ -2495,8 +2476,8 @@ begin
on E: Exception do
begin
raise EMVCException.CreateFmt(http_status.BadRequest,
'Invalid Int64 value for param [%s] - [CLASS: %s][MSG: %s]',
[AActionFormalParams[I].name, E.Classname, E.Message]);
'Invalid Int64 value for param [%s] - [CLASS: %s][MSG: %s]', [AActionFormalParams[I].name, E.Classname,
E.Message]);
end;
end;
tkUString:
@ -2595,8 +2576,7 @@ begin
end
else
raise EMVCException.CreateFmt('Invalid type for parameter %s. Allowed types are ' +
ALLOWED_TYPED_ACTION_PARAMETERS_TYPES,
[lParamName]);
ALLOWED_TYPED_ACTION_PARAMETERS_TYPES, [lParamName]);
end
else
begin
@ -2685,8 +2665,7 @@ begin
end;
procedure TMVCEngine.SendRawHTTPStatus(const AContext: TWebContext; const HTTPStatusCode: Integer;
const AReasonString: string;
const AClassName: string);
const AReasonString: string; const AClassName: string);
var
lSer: IMVCSerializer;
lError: TMVCErrorResponse;
@ -2707,7 +2686,8 @@ begin
AContext.Response.SetContentType(BuildContentType(TMVCMediaType.TEXT_HTML,
AContext.Config[TMVCConfigKey.DefaultContentCharset]));
end
else if AContext.Request.ClientPrefer(AContext.Config[TMVCConfigKey.DefaultContentType]) and Serializers.TryGetValue(AContext.Config[TMVCConfigKey.DefaultContentType], lSer) then
else if AContext.Request.ClientPrefer(AContext.Config[TMVCConfigKey.DefaultContentType]) and
Serializers.TryGetValue(AContext.Config[TMVCConfigKey.DefaultContentType], lSer) then
begin
AContext.Response.SetContent(lSer.SerializeObject(lError));
AContext.Response.SetContentType(BuildContentType(AContext.Config[TMVCConfigKey.DefaultContentType],
@ -2717,8 +2697,8 @@ begin
begin
AContext.Response.SetContentType(BuildContentType(TMVCMediaType.TEXT_PLAIN,
AContext.Config[TMVCConfigKey.DefaultContentCharset]));
AContext.Response.SetContent(FConfigCache_ServerSignature + sLineBreak + 'HTTP ' + HTTPStatusCode.ToString + ': ' +
AReasonString);
AContext.Response.SetContent(FConfigCache_ServerSignature + sLineBreak + 'HTTP ' + HTTPStatusCode.ToString + ': '
+ AReasonString);
end;
AContext.Response.SetStatusCode(HTTPStatusCode);
AContext.Response.SetReasonString(AReasonString);
@ -2822,9 +2802,8 @@ begin
begin
AResponse.ContentType := TMVCMediaType.TEXT_PLAIN;
AResponse.Content := Config[TMVCConfigKey.ServerName] + ' ERROR:' + sLineBreak + 'Exception raised of class: ' +
AException.Classname +
sLineBreak + '***********************************************' + sLineBreak + AException.Message + sLineBreak +
'***********************************************';
AException.Classname + sLineBreak + '***********************************************' + sLineBreak +
AException.Message + sLineBreak + '***********************************************';
end;
end;
@ -2936,8 +2915,7 @@ end;
{ TMVCControllerDelegate }
constructor TMVCControllerDelegate.Create(const AClazz: TMVCControllerClazz;
const ACreateAction: TMVCControllerCreateAction;
const AURLSegment: string = '');
const ACreateAction: TMVCControllerCreateAction; const AURLSegment: string = '');
begin
inherited Create;
FClazz := AClazz;
@ -2952,8 +2930,8 @@ begin
Result := TPath.GetExtension(AStaticFileName).ToLower = '.' + AConfig[TMVCConfigKey.DefaultViewFileExtension].ToLower;
end;
class function TMVCStaticContents.IsStaticFile(const AViewPath, AWebRequestPath: string;
out ARealFileName: string; out AIsDirectoryTraversalAttack: Boolean): Boolean;
class function TMVCStaticContents.IsStaticFile(const AViewPath, AWebRequestPath: string; out ARealFileName: string;
out AIsDirectoryTraversalAttack: Boolean): Boolean;
var
lFileName: string;
lWebRoot: string;
@ -3443,8 +3421,7 @@ begin
end;
procedure TMVCRenderer.Render<T>(const ACollection: TObjectList<T>; const AOwns: Boolean;
const AType: TMVCSerializationType;
const ASerializationAction: TMVCSerializationAction<T>);
const AType: TMVCSerializationType; const ASerializationAction: TMVCSerializationAction<T>);
var
lSerializationAction: TMVCSerializationAction;
begin
@ -3589,35 +3566,35 @@ begin
if (GetContext.Response.StatusCode = http_status.OK) then
ResponseStatus(http_status.InternalServerError, AException.Message + ' [' + AException.Classname + ']');
// if (not GetContext.Request.IsAjax) and (GetContext.Request.ClientPrefer(TMVCMediaType.TEXT_HTML)) then
// begin
// SetContentType(TMVCMediaType.TEXT_HTML);
// Render(AException, False);
// exit;
// ResponseStream.Clear;
// ResponseStream.Append
// ('<html><head><style>pre { padding: 15px; color: #000000; background-color: #e0e0e0; }</style></head><body>')
// .Append('<h1>' + Config[TMVCConfigKey.ServerName] + ': Error Raised</h1>')
// .AppendFormat('<pre>HTTP Return Code: %d' + sLineBreak,
// [GetContext.Response.StatusCode]).AppendFormat('HTTP Reason Text: "%s"</pre>',
// [GetContext.Response.ReasonString])
// .Append('<h3><pre>').AppendFormat('Exception Class Name : %s' + sLineBreak, [AException.Classname])
// .AppendFormat('Exception Message : %s' + sLineBreak, [AException.Message]).Append('</pre></h3>');
// if Assigned(AExceptionItems) and (AExceptionItems.Count > 0) then
// begin
// ResponseStream.Append('<h2><pre>');
// for S in AExceptionItems do
// ResponseStream.AppendLine('- ' + S);
// ResponseStream.Append('</pre><h2>');
// end
// else
// begin
// ResponseStream.AppendLine('<pre>No other information available</pre>');
// end;
// ResponseStream.Append('</body></html>');
// RenderResponseStream;
// end
// else
// if (not GetContext.Request.IsAjax) and (GetContext.Request.ClientPrefer(TMVCMediaType.TEXT_HTML)) then
// begin
// SetContentType(TMVCMediaType.TEXT_HTML);
// Render(AException, False);
// exit;
// ResponseStream.Clear;
// ResponseStream.Append
// ('<html><head><style>pre { padding: 15px; color: #000000; background-color: #e0e0e0; }</style></head><body>')
// .Append('<h1>' + Config[TMVCConfigKey.ServerName] + ': Error Raised</h1>')
// .AppendFormat('<pre>HTTP Return Code: %d' + sLineBreak,
// [GetContext.Response.StatusCode]).AppendFormat('HTTP Reason Text: "%s"</pre>',
// [GetContext.Response.ReasonString])
// .Append('<h3><pre>').AppendFormat('Exception Class Name : %s' + sLineBreak, [AException.Classname])
// .AppendFormat('Exception Message : %s' + sLineBreak, [AException.Message]).Append('</pre></h3>');
// if Assigned(AExceptionItems) and (AExceptionItems.Count > 0) then
// begin
// ResponseStream.Append('<h2><pre>');
// for S in AExceptionItems do
// ResponseStream.AppendLine('- ' + S);
// ResponseStream.Append('</pre><h2>');
// end
// else
// begin
// ResponseStream.AppendLine('<pre>No other information available</pre>');
// end;
// ResponseStream.Append('</body></html>');
// RenderResponseStream;
// end
// else
begin
R := TMVCErrorResponse.Create;
try
@ -3701,8 +3678,7 @@ begin
end;
procedure TMVCRenderer.Render(const ADataSet: TDataSet; const AOwns: Boolean;
const ASerializationType: TMVCDatasetSerializationType;
const ASerializationAction: TMVCDatasetSerializationAction);
const ASerializationType: TMVCDatasetSerializationType; const ASerializationAction: TMVCDatasetSerializationAction);
begin
Render(ADataSet, AOwns, [], ASerializationType, ASerializationAction);
end;
@ -3740,8 +3716,8 @@ end;
{ TMVCBaseView }
constructor TMVCBaseViewEngine.Create(const AEngine: TMVCEngine; const AWebContext: TWebContext;
const AViewModel: TMVCViewDataObject;
const AViewDataSets: TObjectDictionary<string, TDataSet>; const AContentType: string);
const AViewModel: TMVCViewDataObject; const AViewDataSets: TObjectDictionary<string, TDataSet>;
const AContentType: string);
begin
inherited Create;
Engine := AEngine;
@ -3781,8 +3757,7 @@ begin
else
begin
lFileName := ExpandFileName(IncludeTrailingPathDelimiter(GetApplicationFileNamePath +
Config.Value[TMVCConfigKey.ViewPath]) +
lFileName);
Config.Value[TMVCConfigKey.ViewPath]) + lFileName);
end;
if FileExists(lFileName) then

386
unittests/general/Several/LiveServerTestU.pas
View File

@ -137,10 +137,10 @@ type
[Test]
procedure TestBasicAuth01;
[Test]
//[Category('this')]
// [Category('this')]
procedure TestEntityWithArrays;
[Test]
//[Category('this')]
// [Category('this')]
procedure TestEntityWithEmptyArrays;
[Test]
procedure TestBasicAuth02;
@ -352,7 +352,7 @@ var
res: IMVCRESTResponse;
begin
res := RESTClient.Get('/logout');
Assert.isTrue(res.StatusCode = HTTP_STATUS.OK, 'Logout Failed');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.OK, 'Logout Failed: ' + res.Content);
end;
procedure TBaseServerTest.Setup;
@ -397,10 +397,7 @@ begin
procedure(E: Exception)
begin
OK := false;
end)
.AddPathParam('par1', 1)
.AddPathParam('par2', 2)
.AddPathParam('par3', 3)
end).AddPathParam('par1', 1).AddPathParam('par2', 2).AddPathParam('par3', 3)
.Delete('/req/with/params/($par1)/($par2)/($par3)');
// wait for thred finish
@ -435,10 +432,7 @@ begin
end,
procedure(E: Exception)
begin
end)
.AddPathParam('par1', 1)
.AddPathParam('par2', 2)
.AddPathParam('par3', 3)
end).AddPathParam('par1', 1).AddPathParam('par2', 2).AddPathParam('par3', 3)
.Get('/req/with/params/($par1)/($par2)/($par3)');
// wait for thred finish
@ -446,7 +440,7 @@ begin
r := evt.WaitFor(2000);
until r = TWaitResult.wrSignaled;
Assert.isTrue(Assigned(j));
Assert.IsTrue(Assigned(j));
Assert.areEqual('1', j.Get('par1').JsonValue.Value);
j.Free;
finally
@ -476,11 +470,7 @@ begin
end,
procedure(E: Exception)
begin
end)
.AddPathParam('par1', 1)
.AddPathParam('par2', 2)
.AddPathParam('par3', 3)
.Post('/echo/($par1)/($par2)/($par3)',
end).AddPathParam('par1', 1).AddPathParam('par2', 2).AddPathParam('par3', 3).Post('/echo/($par1)/($par2)/($par3)',
TSystemJSON.JSONValueToString(System.JSON.TJSONObject.Create(TJSONPair.Create('from client', 'hello world'))));
// wait for thred finish
@ -488,7 +478,7 @@ begin
r := evt.WaitFor(2000);
until r = TWaitResult.wrSignaled;
Assert.isTrue(Assigned(j));
Assert.IsTrue(Assigned(j));
Assert.areEqual('from server', j.Get('echo').JsonValue.Value);
j.Free;
finally
@ -517,11 +507,7 @@ begin
end,
procedure(E: Exception)
begin
end)
.AddPathParam('par1', 1)
.AddPathParam('par2', 2)
.AddPathParam('par3', 3)
.Put('/echo/($par1)/($par2)/($par3)',
end).AddPathParam('par1', 1).AddPathParam('par2', 2).AddPathParam('par3', 3).Put('/echo/($par1)/($par2)/($par3)',
TSystemJSON.JSONValueToString(System.JSON.TJSONObject.Create(System.JSON.TJSONPair.Create('from client',
'hello world'))));
@ -530,7 +516,7 @@ begin
r := evt.WaitFor(2000);
until r = TWaitResult.wrSignaled;
Assert.isTrue(Assigned(j));
Assert.IsTrue(Assigned(j));
Assert.areEqual('from server', j.Get('echo').JsonValue.Value);
j.Free;
finally
@ -543,7 +529,7 @@ var
lRes: IMVCRESTResponse;
begin
RESTClient.SetBasicAuthorization('user1', 'user1');
Assert.AreEqual('Basic dXNlcjE6dXNlcjE=', RESTClient.Authorization);
Assert.areEqual('Basic dXNlcjE6dXNlcjE=', RESTClient.Authorization);
lRes := RESTClient.Get('/private/role1');
Assert.areEqual<Integer>(HTTP_STATUS.OK, lRes.StatusCode);
end;
@ -631,7 +617,7 @@ var
lRes: IMVCRESTResponse;
begin
lRes := RESTClient.Get('/privatecustom/role1');
Assert.AreEqual<Integer>(HTTP_STATUS.Unauthorized, lRes.StatusCode);
Assert.areEqual<Integer>(HTTP_STATUS.Unauthorized, lRes.StatusCode);
Assert.areEqual('/system/users/logged', lRes.HeaderValue('X-LOGIN-URL'));
Assert.areEqual('POST', lRes.HeaderValue('X-LOGIN-METHOD'));
@ -686,14 +672,14 @@ begin
lJSON.AddPair('password', 'user1');
lRes := RESTClient.Accept('text/html').Post('/system/users/logged', TSystemJSON.JSONValueToString(lJSON, false));
SplitContentMediaTypeAndCharset(lRes.ContentType, lContentType, lContentCharset);
Assert.AreEqual(lContentType, TMVCMediaType.APPLICATION_JSON);
Assert.areEqual(lContentType, TMVCMediaType.APPLICATION_JSON);
Assert.areEqual<Integer>(HTTP_STATUS.OK, lRes.StatusCode);
Assert.areEqual('/system/users/logged', lRes.HeaderValue('X-LOGOUT-URL'));
Assert.areEqual('DELETE', lRes.HeaderValue('X-LOGOUT-METHOD'));
Assert.areEqual('{"status":"OK"}', lRes.Content);
lCookieValue := lRes.CookieByName(TMVCConstants.SESSION_TOKEN_NAME).Value;
Assert.AreNotEqual('', lCookieValue, 'Session cookie not returned after login');
Assert.isFalse(lCookieValue.Contains('invalid'), 'Returned an invalid session token');
Assert.IsFalse(lCookieValue.Contains('invalid'), 'Returned an invalid session token');
lRes := RESTClient.Get('/privatecustom/role2');
Assert.areEqual<Integer>(HTTP_STATUS.Forbidden, lRes.StatusCode,
@ -714,7 +700,7 @@ begin
lJSON := System.JSON.TJSONObject.Create;
try
// no request body
lRes := RESTClient.AddBody('',TMVCMediaType.APPLICATION_JSON).Post('/system/users/logged');
lRes := RESTClient.AddBody('', TMVCMediaType.APPLICATION_JSON).Post('/system/users/logged');
Assert.areEqual<Integer>(HTTP_STATUS.BadRequest, lRes.StatusCode,
'Empty request body doesn''t return HTTP 400 Bad Request');
@ -788,7 +774,7 @@ var
lRes: IMVCRESTResponse;
lJSON: System.JSON.TJSONObject;
lLogoutUrl: string;
lPass: Boolean;
lPass: boolean;
lCookie: TCookie;
begin
lJSON := System.JSON.TJSONObject.Create;
@ -801,16 +787,16 @@ begin
lLogoutUrl := lRes.HeaderValue('X-LOGOUT-URL');
lRes := RESTClient.Delete(lLogoutUrl);
lPass := False;
lPass := false;
for lCookie in lRes.Cookies do
begin
if lCookie.Value.Contains('invalid') then
begin
lPass := True;
lPass := true;
Break;
end;
end;
Assert.isTrue(lPass, 'No session cookie cleanup in the response');
Assert.IsTrue(lPass, 'No session cookie cleanup in the response');
finally
lJSON.Free;
end;
@ -830,7 +816,7 @@ begin
Assert.areEqual<Integer>(500, lJSON.I['statuscode'], lJSON.ToJSON());
Assert.areEqual<string>('error', lJSON.S['reasonstring'], lJSON.ToJSON());
Assert.areEqual(0, lJSON.A['items'].Count, lJSON.ToJSON());
Assert.isTrue(lJSON.IsNull('data'), lJSON.ToJSON());
Assert.IsTrue(lJSON.IsNull('data'), lJSON.ToJSON());
finally
lJSON.Free;
end;
@ -851,7 +837,7 @@ begin
Assert.areEqual<Integer>(HTTP_STATUS.BadRequest, lJSON.I['statuscode'], lJSON.ToJSON());
Assert.areEqual<string>('error', lJSON.S['reasonstring'], lJSON.ToJSON());
Assert.areEqual(0, lJSON.A['items'].Count, lJSON.ToJSON());
Assert.isTrue(lJSON.IsNull('data'), lJSON.ToJSON());
Assert.IsTrue(lJSON.IsNull('data'), lJSON.ToJSON());
finally
lJSON.Free;
end;
@ -872,7 +858,7 @@ begin
Assert.areEqual('error', lJSON.S['reasonstring'], lJSON.ToJSON());
Assert.areEqual(999, lJSON.I['apperrorcode'], lJSON.ToJSON());
Assert.areEqual(0, lJSON.A['items'].Count, lJSON.ToJSON());
Assert.isTrue(lJSON.IsNull('data'), lJSON.ToJSON());
Assert.IsTrue(lJSON.IsNull('data'), lJSON.ToJSON());
finally
lJSON.Free;
end;
@ -896,7 +882,7 @@ begin
Assert.areEqual(2, lJSON.A['items'].Count, lJSON.ToJSON());
Assert.areEqual('erritem1', lJSON.A['items'].O[0].S['message'], lJSON.ToJSON());
Assert.areEqual('erritem2', lJSON.A['items'].O[1].S['message'], lJSON.ToJSON());
Assert.isTrue(lJSON.IsNull('data'), lJSON.ToJSON());
Assert.IsTrue(lJSON.IsNull('data'), lJSON.ToJSON());
finally
lJSON.Free;
end;
@ -939,8 +925,8 @@ var
begin
lObj1 := TEntityWithArray.Create;
try
lObj1.Names := ['one','two','three'];
lObj1.Values := [1,2,3];
lObj1.Names := ['one', 'two', 'three'];
lObj1.Values := [1, 2, 3];
lObj1.Booleans := [true, false];
lBody := GetDefaultSerializer.SerializeObject(lObj1);
@ -949,22 +935,22 @@ begin
try
GetDefaultSerializer.DeserializeObject(lRes.Content, lObj2);
Assert.AreEqual(4, Length(lObj2.Names));
Assert.AreEqual(lObj1.Names[0], lObj2.Names[0]);
Assert.AreEqual(lObj1.Names[1], lObj2.Names[1]);
Assert.AreEqual(lObj1.Names[2], lObj2.Names[2]);
Assert.AreEqual('added', lObj2.Names[3]);
Assert.areEqual(4, Length(lObj2.Names));
Assert.areEqual(lObj1.Names[0], lObj2.Names[0]);
Assert.areEqual(lObj1.Names[1], lObj2.Names[1]);
Assert.areEqual(lObj1.Names[2], lObj2.Names[2]);
Assert.areEqual('added', lObj2.Names[3]);
Assert.AreEqual(4, Length(lObj2.Values));
Assert.AreEqual(lObj1.Values[0], lObj2.Values[0]);
Assert.AreEqual(lObj1.Values[1], lObj2.Values[1]);
Assert.AreEqual(lObj1.Values[2], lObj2.Values[2]);
Assert.AreEqual(99, lObj2.Values[3]);
Assert.areEqual(4, Length(lObj2.Values));
Assert.areEqual(lObj1.Values[0], lObj2.Values[0]);
Assert.areEqual(lObj1.Values[1], lObj2.Values[1]);
Assert.areEqual(lObj1.Values[2], lObj2.Values[2]);
Assert.areEqual(99, lObj2.Values[3]);
Assert.AreEqual(3, Length(lObj2.Booleans));
Assert.AreEqual(lObj1.Booleans[0], lObj2.Booleans[0]);
Assert.AreEqual(lObj1.Booleans[1], lObj2.Booleans[1]);
Assert.AreEqual(True, lObj2.Booleans[2]);
Assert.areEqual(3, Length(lObj2.Booleans));
Assert.areEqual(lObj1.Booleans[0], lObj2.Booleans[0]);
Assert.areEqual(lObj1.Booleans[1], lObj2.Booleans[1]);
Assert.areEqual(true, lObj2.Booleans[2]);
finally
lObj2.Free;
end;
@ -983,19 +969,19 @@ begin
try
lBody := GetDefaultSerializer.SerializeObject(lObj1);
lRes := RESTClient.Post('/entitywitharrays', lBody);
lRes := RESTClient.Post('/entitywitharrays', lBody);
lObj2 := TEntityWithArray.Create;
try
GetDefaultSerializer.DeserializeObject(lRes.Content, lObj2);
Assert.AreEqual(1, Length(lObj2.Names));
Assert.AreEqual('added', lObj2.Names[0]);
Assert.areEqual(1, Length(lObj2.Names));
Assert.areEqual('added', lObj2.Names[0]);
Assert.AreEqual(1, Length(lObj2.Values));
Assert.AreEqual(99, lObj2.Values[0]);
Assert.areEqual(1, Length(lObj2.Values));
Assert.areEqual(99, lObj2.Values[0]);
Assert.AreEqual(1, Length(lObj2.Booleans));
Assert.AreEqual(True, lObj2.Booleans[0]);
Assert.areEqual(1, Length(lObj2.Booleans));
Assert.areEqual(true, lObj2.Booleans[0]);
finally
lObj2.Free;
end;
@ -1015,7 +1001,7 @@ begin
try
for I := 0 to lJArr.Count - 1 do
begin
Assert.isTrue(lJArr[I].A[TMVCConstants.HATEOAS_PROP_NAME].Count = 2, '_links doesn''t exists');
Assert.IsTrue(lJArr[I].A[TMVCConstants.HATEOAS_PROP_NAME].Count = 2, '_links doesn''t exists');
Assert.areEqual(lJArr[I].A[TMVCConstants.HATEOAS_PROP_NAME].O[0].S[HATEOAS.REL], 'test0');
Assert.areEqual(lJArr[I].A[TMVCConstants.HATEOAS_PROP_NAME].O[1].S[HATEOAS.REL], 'test1');
end;
@ -1054,7 +1040,7 @@ begin
for I := 0 to lJSONArr.Count - 1 do
begin
lJSONObj := lJSONArr.Items[I] as System.JSON.TJSONObject;
Assert.isFalse(lJSONObj.GetValue<string>('firstname').IsEmpty);
Assert.IsFalse(lJSONObj.GetValue<string>('firstname').IsEmpty);
end;
finally
lJSONArr.Free;
@ -1079,17 +1065,15 @@ begin
for lCompType in CompressionTypes do
begin
RESTClient.AcceptEncoding(lCompType);
lRes := RESTClient
.AddQueryStringParam('count', 100)
.Get('/wrappedpeople');
lRes := RESTClient.AddQueryStringParam('count', 100).Get('/wrappedpeople');
Assert.areEqual(CompressionTypeResult[j], lRes.HeaderValue('Content-Encoding'));
lJSONArr := TMVCJsonDataObjectsSerializer.ParseArray(lRes.Content);
try
for I := 0 to lJSONArr.Count - 1 do
begin
Assert.isFalse(lJSONArr.O[I].S['firstname'].IsEmpty);
Assert.isFalse(lJSONArr.O[I].S['lastname'].IsEmpty);
Assert.isFalse(lJSONArr.O[I].S['dob'].IsEmpty);
Assert.IsFalse(lJSONArr.O[I].S['firstname'].IsEmpty);
Assert.IsFalse(lJSONArr.O[I].S['lastname'].IsEmpty);
Assert.IsFalse(lJSONArr.O[I].S['dob'].IsEmpty);
Assert.areEqual<TJsonDataType>(jdtBool, lJSONArr.O[I].Types['married']);
end;
finally
@ -1128,13 +1112,13 @@ begin
lRes := RESTClient.Accept(TMVCMediaType.TEXT_HTML).Get('/static.html');
Assert.areEqual(404, lRes.StatusCode, '/static.html');
lRes := RESTClient.HandleRedirects(False).Accept(TMVCMediaType.TEXT_HTML).Get('/static');
lRes := RESTClient.HandleRedirects(false).Accept(TMVCMediaType.TEXT_HTML).Get('/static');
Assert.areEqual(301, lRes.StatusCode, '/static');
lRes := RESTClient.Accept(TMVCMediaType.TEXT_HTML).Get('/static/');
Assert.areEqual(200, lRes.StatusCode, '/static/');
lRes := RESTClient.HandleRedirects(False).Accept(TMVCMediaType.TEXT_HTML).Get('/static/folder1');
lRes := RESTClient.HandleRedirects(false).Accept(TMVCMediaType.TEXT_HTML).Get('/static/folder1');
Assert.areEqual(301, lRes.StatusCode, '/static/folder1');
lRes := RESTClient.Accept(TMVCMediaType.TEXT_HTML).Get('/static/folder1/');
@ -1202,8 +1186,7 @@ begin
P.LastName := StringOfChar('*', 1000);
P.DOB := EncodeDate(1979, 1, 1);
P.Married := true;
r := RESTClient.Accept(TMVCMediaType.APPLICATION_JSON)
.Post('/objects', GetDefaultSerializer.SerializeObject(P));
r := RESTClient.Accept(TMVCMediaType.APPLICATION_JSON).Post('/objects', GetDefaultSerializer.SerializeObject(P));
finally
P.Free;
end;
@ -1220,38 +1203,38 @@ begin
Assert.areEqual<Integer>(HTTP_STATUS.OK, lRes.StatusCode, lRes.Content);
lJSON := StrToJSONObject(lRes.Content);
try
Assert.isTrue(lJSON.Contains('ncCamelCase_Single'), lJSON.ToJSON());
Assert.isTrue(lJSON.Contains('ncLowerCase_Single'), lJSON.ToJSON());
Assert.isTrue(lJSON.Contains('ncPascalCase_Single'), lJSON.ToJSON());
Assert.isTrue(lJSON.Contains('ncUpperCase_Single'), lJSON.ToJSON());
Assert.IsTrue(lJSON.Contains('ncCamelCase_Single'), lJSON.ToJSON());
Assert.IsTrue(lJSON.Contains('ncLowerCase_Single'), lJSON.ToJSON());
Assert.IsTrue(lJSON.Contains('ncPascalCase_Single'), lJSON.ToJSON());
Assert.IsTrue(lJSON.Contains('ncUpperCase_Single'), lJSON.ToJSON());
Assert.isTrue(lJSON.Contains('ncCamelCase_List'), lJSON.ToJSON());
Assert.isTrue(lJSON.Contains('ncLowerCase_List'), lJSON.ToJSON());
Assert.isTrue(lJSON.Contains('ncPascalCase_List'), lJSON.ToJSON());
Assert.isTrue(lJSON.Contains('ncUpperCase_List'), lJSON.ToJSON());
Assert.IsTrue(lJSON.Contains('ncCamelCase_List'), lJSON.ToJSON());
Assert.IsTrue(lJSON.Contains('ncLowerCase_List'), lJSON.ToJSON());
Assert.IsTrue(lJSON.Contains('ncPascalCase_List'), lJSON.ToJSON());
Assert.IsTrue(lJSON.Contains('ncUpperCase_List'), lJSON.ToJSON());
Assert.areEqual(jdtObject, lJSON.Types['ncCamelCase_Single']);
Assert.areEqual(jdtObject, lJSON.Types['ncLowerCase_Single']);
Assert.areEqual(jdtObject, lJSON.Types['ncPascalCase_Single']);
Assert.areEqual(jdtObject, lJSON.Types['ncUpperCase_Single']);
Assert.isTrue(lJSON.O['ncCamelCase_Single'].Contains('custNo'), lJSON.O['ncCamelCase_Single'].ToJSON());
Assert.isTrue(lJSON.O['ncLowerCase_Single'].Contains('cust_no'), lJSON.O['ncLowerCase_Single'].ToJSON());
Assert.isTrue(lJSON.O['ncPascalCase_Single'].Contains('CustNo'), lJSON.O['ncPascalCase_Single'].ToJSON());
Assert.isTrue(lJSON.O['ncUpperCase_Single'].Contains('CUST_NO'), lJSON.O['ncUpperCase_Single'].ToJSON());
Assert.IsTrue(lJSON.O['ncCamelCase_Single'].Contains('custNo'), lJSON.O['ncCamelCase_Single'].ToJSON());
Assert.IsTrue(lJSON.O['ncLowerCase_Single'].Contains('cust_no'), lJSON.O['ncLowerCase_Single'].ToJSON());
Assert.IsTrue(lJSON.O['ncPascalCase_Single'].Contains('CustNo'), lJSON.O['ncPascalCase_Single'].ToJSON());
Assert.IsTrue(lJSON.O['ncUpperCase_Single'].Contains('CUST_NO'), lJSON.O['ncUpperCase_Single'].ToJSON());
Assert.areEqual(jdtArray, lJSON.Types['ncCamelCase_List']);
Assert.areEqual(jdtArray, lJSON.Types['ncLowerCase_List']);
Assert.areEqual(jdtArray, lJSON.Types['ncPascalCase_List']);
Assert.areEqual(jdtArray, lJSON.Types['ncUpperCase_List']);
Assert.isTrue(lJSON.A['ncCamelCase_List'][0].ObjectValue.Contains('custNo'),
Assert.IsTrue(lJSON.A['ncCamelCase_List'][0].ObjectValue.Contains('custNo'),
lJSON.A['ncCamelCase_List'][0].ObjectValue.ToJSON());
Assert.isTrue(lJSON.A['ncLowerCase_List'][0].ObjectValue.Contains('cust_no'),
Assert.IsTrue(lJSON.A['ncLowerCase_List'][0].ObjectValue.Contains('cust_no'),
lJSON.A['ncLowerCase_List'][0].ObjectValue.ToJSON());
Assert.isTrue(lJSON.A['ncPascalCase_List'][0].ObjectValue.Contains('CustNo'),
Assert.IsTrue(lJSON.A['ncPascalCase_List'][0].ObjectValue.Contains('CustNo'),
lJSON.A['ncPascalCase_List'][0].ObjectValue.ToJSON());
Assert.isTrue(lJSON.A['ncUpperCase_List'][0].ObjectValue.Contains('CUST_NO'),
Assert.IsTrue(lJSON.A['ncUpperCase_List'][0].ObjectValue.Contains('CUST_NO'),
lJSON.A['ncUpperCase_List'][0].ObjectValue.ToJSON());
finally
@ -1300,8 +1283,7 @@ begin
P.DOB := EncodeDate(1979, 1, 1);
P.Married := true;
try
r := RESTClient.Accept(TMVCMediaType.APPLICATION_JSON)
.Post('/objects', GetDefaultSerializer.SerializeObject(P)
r := RESTClient.Accept(TMVCMediaType.APPLICATION_JSON).Post('/objects', GetDefaultSerializer.SerializeObject(P)
{ Mapper.ObjectToJSONObject(P) }
);
except
@ -1338,10 +1320,7 @@ var
begin
JSON := System.JSON.TJSONObject.Create;
JSON.AddPair('client', 'clientdata');
r := RESTClient
.AddPathParam('par1', 1)
.AddPathParam('par2', 2)
.AddPathParam('par3', 3)
r := RESTClient.AddPathParam('par1', 1).AddPathParam('par2', 2).AddPathParam('par3', 3)
.Post('/echo/($par1)/($par2)/($par3)', TSystemJSON.JSONValueToString(JSON));
JSON := TSystemJSON.StringAsJSONObject(r.Content);
try
@ -1368,16 +1347,14 @@ var
lContentType: string;
lContentCharset: string;
begin
res := RESTClient
.Accept('application/json')
.Post('/testconsumes', TSystemJSON.JSONValueToString(TJSONString.Create('Hello World')),
BuildContentType('application/json', 'utf-8'));
res := RESTClient.Accept('application/json').Post('/testconsumes',
TSystemJSON.JSONValueToString(TJSONString.Create('Hello World')), BuildContentType('application/json', 'utf-8'));
Assert.areEqual<Integer>(HTTP_STATUS.OK, res.StatusCode);
Assert.areEqual('Hello World', res.Content);
SplitContentMediaTypeAndCharset(res.ContentType, lContentType, lContentCharset);
Assert.AreEqual(lContentType, TMVCMediaType.APPLICATION_JSON, True);
Assert.AreEqual(lContentCharset, TMVCCharSet.UTF_8, True);
Assert.areEqual(lContentType, TMVCMediaType.APPLICATION_JSON, true);
Assert.areEqual(lContentCharset, TMVCCharSet.UTF_8, true);
end;
procedure TServerTest.TestProducesConsumes02;
@ -1386,17 +1363,13 @@ var
lContentType: string;
lContentCharset: string;
begin
res := RESTClient
.Accept('text/plain')
.Post('/testconsumes', 'Hello World', 'text/plain');
res := RESTClient.Accept('text/plain').Post('/testconsumes', 'Hello World', 'text/plain');
Assert.areEqual('Hello World', res.Content);
SplitContentMediaTypeAndCharset(res.ContentType, lContentType, lContentCharset);
Assert.AreEqual(lContentType, TMVCMediaType.TEXT_PLAIN, True);
Assert.AreEqual(lContentCharset, TMVCCharSet.UTF_8, True);
Assert.areEqual(lContentType, TMVCMediaType.TEXT_PLAIN, true);
Assert.areEqual(lContentCharset, TMVCCharSet.UTF_8, true);
res := RESTClient
.Accept('text/plain')
.Post('/testconsumes', '{"name": "Daniele"}');
res := RESTClient.Accept('text/plain').Post('/testconsumes', '{"name": "Daniele"}');
Assert.areEqual<Integer>(HTTP_STATUS.NotFound, res.StatusCode);
end;
@ -1406,25 +1379,22 @@ var
lContentType: string;
lContentCharset: string;
begin
res := RESTClient
.Accept(TMVCMediaType.TEXT_PLAIN)
.Post('/testconsumes/textiso8859_1', 'àèéìòù', BuildContentType(TMVCMediaType.TEXT_PLAIN, TMVCCharSet.ISO88591));
res := RESTClient.Accept(TMVCMediaType.TEXT_PLAIN).Post('/testconsumes/textiso8859_1', 'àèéìòù',
BuildContentType(TMVCMediaType.TEXT_PLAIN, TMVCCharSet.ISO88591));
Assert.areEqual<Integer>(HTTP_STATUS.OK, res.StatusCode);
// Assert.AreNotEqual('àèéìòù', res.Content, 'non iso8859-1 text is rendered ok whan should not');
// Assert.AreNotEqual('àèéìòù', res.Content, 'non iso8859-1 text is rendered ok whan should not');
SplitContentMediaTypeAndCharset(res.ContentType, lContentType, lContentCharset);
Assert.AreEqual(lContentType, TMVCMediaType.TEXT_PLAIN);
Assert.AreEqual(lContentCharset, TMVCCharset.ISO88591);
Assert.areEqual(lContentType, TMVCMediaType.TEXT_PLAIN);
Assert.areEqual(lContentCharset, TMVCCharSet.ISO88591);
res := RESTClient
.Accept(TMVCMediaType.TEXT_PLAIN)
.Post('/testconsumes/textiso8859_1', 'this is an iso8859-1 text',
BuildContentType(TMVCMediaType.TEXT_PLAIN, TMVCCharSet.ISO88591));
res := RESTClient.Accept(TMVCMediaType.TEXT_PLAIN).Post('/testconsumes/textiso8859_1', 'this is an iso8859-1 text',
BuildContentType(TMVCMediaType.TEXT_PLAIN, TMVCCharSet.ISO88591));
Assert.areEqual<Integer>(HTTP_STATUS.OK, res.StatusCode);
SplitContentMediaTypeAndCharset(res.ContentType, lContentType, lContentCharset);
Assert.areEqual('this is an iso8859-1 text', res.Content);
Assert.AreEqual(lContentType, TMVCMediaType.TEXT_PLAIN);
Assert.AreEqual(lContentCharset, TMVCCharset.ISO88591);
Assert.areEqual(lContentType, TMVCMediaType.TEXT_PLAIN);
Assert.areEqual(lContentCharset, TMVCCharSet.ISO88591);
end;
procedure TServerTest.TestPUTWithParamsAndJSONBody;
@ -1434,10 +1404,7 @@ var
begin
JSON := System.JSON.TJSONObject.Create;
JSON.AddPair('client', 'clientdata');
r := RESTClient
.AddPathParam('par1', 1)
.AddPathParam('par2', 2)
.AddPathParam('par3', 3)
r := RESTClient.AddPathParam('par1', 1).AddPathParam('par2', 2).AddPathParam('par3', 3)
.Put('/echo/($par1)/($par2)/($par3)', TSystemJSON.JSONValueToString(JSON));
JSON := TSystemJSON.StringAsJSONObject(r.Content);
@ -1456,12 +1423,8 @@ var
begin
JSON := System.JSON.TJSONObject.Create;
JSON.AddPair('client', 'clientdata');
r := RESTClient
.AddHeader(TMVCConstants.X_HTTP_Method_Override, 'PUT')
.AddPathParam('par1', 1)
.AddPathParam('par2', 2)
.AddPathParam('par3', 3)
.Post('/echo/($par1)/($par2)/($par3)', TSystemJSON.JSONValueToString(JSON));
r := RESTClient.AddHeader(TMVCConstants.X_HTTP_Method_Override, 'PUT').AddPathParam('par1', 1).AddPathParam('par2', 2)
.AddPathParam('par3', 3).Post('/echo/($par1)/($par2)/($par3)', TSystemJSON.JSONValueToString(JSON));
JSON := TSystemJSON.StringAsJSONObject(r.Content);
try
@ -1497,10 +1460,7 @@ begin
r := RESTClient.Get('/req/with/params');
Assert.areEqual<Integer>(HTTP_STATUS.NotFound, r.StatusCode, '/req/with/params');
r := RESTClient
.AddPathParam('par1', '1')
.AddPathParam('par2', '2')
.AddPathParam('par3', '3')
r := RESTClient.AddPathParam('par1', '1').AddPathParam('par2', '2').AddPathParam('par3', '3')
.Get('/req/with/params/($par1)/($par2)/($par3)');
Assert.areEqual<Integer>(HTTP_STATUS.OK, r.StatusCode);
@ -1514,25 +1474,15 @@ begin
lJSON.Free;
end;
r := RESTClient
.AddPathParam('par1', 1)
.AddPathParam('par2', 2)
.AddPathParam('par3', 3)
r := RESTClient.AddPathParam('par1', 1).AddPathParam('par2', 2).AddPathParam('par3', 3)
.Post('/req/with/params/($par1)/($par2)/($par3)');
Assert.areEqual<Integer>(HTTP_STATUS.NotFound, r.StatusCode);
r := RESTClient
.AddPathParam('par1', 1)
.AddPathParam('par2', 2)
.AddPathParam('par3', 3)
r := RESTClient.AddPathParam('par1', 1).AddPathParam('par2', 2).AddPathParam('par3', 3)
.Put('/req/with/params/($par1)/($par2)/($par3)');
Assert.areEqual<Integer>(HTTP_STATUS.NotFound, r.StatusCode);
r := RESTClient
.AddPathParam('par1', 1)
.AddPathParam('par2', 2)
.AddPathParam('par3', 3)
r := RESTClient.AddPathParam('par1', 1).AddPathParam('par2', 2).AddPathParam('par3', 3)
.Delete('/req/with/params/($par1)/($par2)/($par3)');
Assert.areEqual<Integer>(HTTP_STATUS.OK, r.StatusCode);
lJSON := TSystemJSON.StringAsJSONObject(r.Content);
@ -1551,13 +1501,10 @@ procedure TServerTest.TestReqWithURLMappedParams(const par1, par2, par3: string)
var
r: IMVCRESTResponse;
begin
r := RESTClient
.AddPathParam('par1', par1)
.AddPathParam('par2', par2)
.AddPathParam('par3', par3)
r := RESTClient.AddPathParam('par1', par1).AddPathParam('par2', par2).AddPathParam('par3', par3)
.Get('/req/with/params/($par1)/($par2)/($par3)');
Assert.areEqual<Integer>(HTTP_STATUS.OK, r.StatusCode,
Format('URL mapped fails for these characters: "%s","%s","%s"', [par1, par2, par3]));
Assert.areEqual<Integer>(HTTP_STATUS.OK, r.StatusCode, Format('URL mapped fails for these characters: "%s","%s","%s"',
[par1, par2, par3]));
end;
procedure TServerTest.TestResponseAccepted;
@ -1567,7 +1514,7 @@ var
begin
r := RESTClient.Post('/responses/accepted');
Assert.areEqual<Integer>(HTTP_STATUS.Accepted, r.StatusCode);
Assert.isTrue(r.StatusText.Contains('Accepted'));
Assert.IsTrue(r.StatusText.Contains('Accepted'));
lJSON := StrToJSONObject(r.Content);
try
Assert.areEqual(2, lJSON.O['task'].Count);
@ -1584,7 +1531,7 @@ var
begin
r := RESTClient.Post('/responses/created');
Assert.areEqual<Integer>(HTTP_STATUS.Created, r.StatusCode);
Assert.isTrue(r.StatusText.Contains('Created'));
Assert.IsTrue(r.StatusText.Contains('Created'));
Assert.IsEmpty(r.Content);
end;
@ -1594,7 +1541,7 @@ var
begin
r := RESTClient.Get('/responses/nocontent');
Assert.areEqual<Integer>(HTTP_STATUS.NoContent, r.StatusCode);
Assert.isTrue(r.StatusText.Contains('No Content'));
Assert.IsTrue(r.StatusText.Contains('No Content'));
Assert.IsEmpty(r.Content);
end;
@ -1636,17 +1583,17 @@ begin
lNullableTest := TNullablesTest.Create();
try
lSer.DeserializeObject(lRes.Content, lNullableTest);
Assert.isFalse(lNullableTest.f_int2.HasValue);
Assert.isFalse(lNullableTest.f_int4.HasValue);
Assert.isFalse(lNullableTest.f_int8.HasValue);
Assert.isFalse(lNullableTest.f_date.HasValue);
Assert.isFalse(lNullableTest.f_time.HasValue);
Assert.isFalse(lNullableTest.f_datetime.HasValue);
Assert.isFalse(lNullableTest.f_bool.HasValue);
Assert.isFalse(lNullableTest.f_float4.HasValue);
Assert.isFalse(lNullableTest.f_float8.HasValue);
Assert.isFalse(lNullableTest.f_string.HasValue);
Assert.isFalse(lNullableTest.f_currency.HasValue);
Assert.IsFalse(lNullableTest.f_int2.HasValue);
Assert.IsFalse(lNullableTest.f_int4.HasValue);
Assert.IsFalse(lNullableTest.f_int8.HasValue);
Assert.IsFalse(lNullableTest.f_date.HasValue);
Assert.IsFalse(lNullableTest.f_time.HasValue);
Assert.IsFalse(lNullableTest.f_datetime.HasValue);
Assert.IsFalse(lNullableTest.f_bool.HasValue);
Assert.IsFalse(lNullableTest.f_float4.HasValue);
Assert.IsFalse(lNullableTest.f_float8.HasValue);
Assert.IsFalse(lNullableTest.f_string.HasValue);
Assert.IsFalse(lNullableTest.f_currency.HasValue);
{ TODO -oDanieleT -cGeneral : Compare streams too }
// Assert.AreEqual('0123456789', lNullableTest.f_blob.Value, 0);
finally
@ -1700,7 +1647,7 @@ begin
lRes := RESTClient.Accept(TMVCMediaType.TEXT_HTML).Get('/static/');
Assert.areEqual(200, lRes.StatusCode, '/static/');
lRes := RESTClient.HandleRedirects(False).Accept(TMVCMediaType.TEXT_HTML).Get('/static');
lRes := RESTClient.HandleRedirects(false).Accept(TMVCMediaType.TEXT_HTML).Get('/static');
Assert.areEqual(301, lRes.StatusCode, '/static');
Assert.areEqual('/static/', lRes.HeaderValue('Location'), 'Wrong redirect');
end;
@ -1722,7 +1669,7 @@ begin
begin
lUrl := '..\' + lUrl;
lRes := RESTClient.Accept(TMVCMediaType.TEXT_HTML).Get('/static/' + lUrl);
Assert.areEqual(404, lRes.StatusCode, 'Fail with: ' + '/static/' + lUrl);
Assert.IsTrue((lRes.StatusCode = 403) or (lRes.StatusCode = 404), 'Fail with: ' + '/static/' + lUrl);
end;
end;
@ -1733,17 +1680,17 @@ var
lUrl: string;
begin
lRes := RESTClient.Accept(TMVCMediaType.TEXT_HTML).Get('/static/..\..\donotdeleteme.txt');
Assert.areEqual(404, lRes.StatusCode);
Assert.IsTrue((lRes.StatusCode = 404) or (lRes.StatusCode = 403));
lRes := RESTClient.Accept(TMVCMediaType.TEXT_HTML).Get('/static/../../donotdeleteme.txt');
Assert.areEqual(404, lRes.StatusCode);
Assert.IsTrue((lRes.StatusCode = 404) or (lRes.StatusCode = 403));
lUrl := 'Windows\win.ini';
for I := 1 to 30 do
begin
lUrl := '..\' + lUrl;
lRes := RESTClient.Accept(TMVCMediaType.TEXT_HTML).Get('/static/' + lUrl);
Assert.areEqual(404, lRes.StatusCode, 'Fail with: ' + '/static/' + lUrl);
Assert.IsTrue((lRes.StatusCode = 404) or (lRes.StatusCode = 403), 'Fail with: ' + '/static/' + lUrl);
end;
end;
@ -1852,23 +1799,29 @@ var
c1: IMVCRESTClient;
res: IMVCRESTResponse;
S: string;
lC: TCookie;
begin
c1 := TMVCRESTClient.New.BaseURL(TEST_SERVER_ADDRESS, 9999);
c1.Accept(TMVCMediaType.APPLICATION_JSON);
res := c1.Post('/session/daniele teti'); // imposto un valore in sessione
S := res.HeaderValue('Set-Cookie');
Assert.isFalse(S.Contains('Expires'), 'Session cookie contains "expires" attribute');
// S := res.HeaderValue('Set-Cookie');
lC := res.CookieByName('dtsessionid');
Assert.IsFalse(S.Contains('Expires'), 'Session cookie contains "expires" attribute');
c1.AddCookie('dtsessionid', lC.Value);
res := c1.Get('/session'); // rileggo il valore dalla sessione
Assert.areEqual('daniele teti', res.Content);
c1.Accept(TMVCMediaType.TEXT_PLAIN);
c1.AddCookie('dtsessionid', lC.Value);
res := c1.Get('/session');
// rileggo il valore dalla sessione
Assert.areEqual('daniele teti', res.Content);
// aggiungo altri cookies
c1.AddCookie('dtsessionid', lC.Value);
res := c1.Get('/lotofcookies'); // rileggo il valore dalla sessione
Assert.areEqual<Integer>(HTTP_STATUS.OK, res.StatusCode);
c1.Accept(TMVCMediaType.TEXT_PLAIN);
c1.AddCookie('dtsessionid', lC.Value);
res := c1.Get('/session'); // rileggo il valore dalla sessione
Assert.areEqual('daniele teti', res.Content);
end;
@ -1903,9 +1856,9 @@ begin
{ directory traversal attacks receive always 404 }
lUrl := '..\' + lUrl;
lRes := RESTClient.Accept(TMVCMediaType.TEXT_HTML).Get('/spa/' + lUrl);
Assert.areEqual(404, lRes.StatusCode);
Assert.Contains(lRes.Content, '[EMVCException] Not Found', true);
Assert.Contains(lRes.Content, '<p>HTTP 404</p>', true);
Assert.IsTrue((404 = lRes.StatusCode) or (403 = lRes.StatusCode));
// Assert.Contains(lRes.Content, 'Not Found', true);
// Assert.Contains(lRes.Content, '404', true);
end;
end;
@ -1941,7 +1894,7 @@ var
begin
// ----------------------'/typed/all/($ParString)/($ParInteger)/($ParInt64)/($ParSingle)/($ParDouble)/($ParExtended)')');
res := RESTClient.Get('/typed/all/mystring/1234/12345678/12.3/1234.5678/1234.5678');
Assert.isTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
lJObj := TSystemJSON.StringAsJSONObject(res.Content);
try
Assert.areEqual('mystring', lJObj.GetValue('ParString').Value, 'ParString');
@ -1960,7 +1913,7 @@ var
res: IMVCRESTResponse;
begin
res := RESTClient.Get('/typed/booleans/true/false/1/0');
Assert.isTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.areEqual('true.false.true.false', res.Content.ToLower);
end;
@ -1969,7 +1922,7 @@ var
res: IMVCRESTResponse;
begin
res := RESTClient.Get('/typed/double1/1234.5678');
Assert.isTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.areEqual('1234.5678 modified from server', res.Content);
end;
@ -1979,7 +1932,7 @@ var
res: IMVCRESTResponse;
begin
res := RESTClient.Get('/typed/extended1/1234.5678');
Assert.isTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.areEqual('1234.5678 modified from server', res.Content);
end;
@ -1989,7 +1942,7 @@ var
res: IMVCRESTResponse;
begin
res := RESTClient.Get('/typed/int641/12345678');
Assert.isTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.areEqual('12345678 modified from server', res.Content);
end;
@ -1998,7 +1951,7 @@ var
res: IMVCRESTResponse;
begin
res := RESTClient.Get('/typed/integer1/1234');
Assert.isTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.areEqual('1234 modified from server', res.Content);
end;
@ -2007,7 +1960,7 @@ var
res: IMVCRESTResponse;
begin
res := RESTClient.Get('/typed/integer1/boom');
Assert.isTrue(res.StatusCode = HTTP_STATUS.BadRequest, 'Cannot route');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.BadRequest, 'Cannot route');
Assert.Contains(res.Content, 'EConvertError');
Assert.Contains(res.Content, '''boom'' is not a valid');
end;
@ -2017,7 +1970,7 @@ var
res: IMVCRESTResponse;
begin
res := RESTClient.Get('/typed/single1/1234.5');
Assert.isTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.areEqual('1234.5 modified from server', res.Content);
end;
@ -2074,15 +2027,15 @@ var
res: IMVCRESTResponse;
begin
res := RESTClient.Get('/typed/tguid1/{161BEA56-480B-40A8-AF0E-7FDF6B08E121}');
Assert.isTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.areEqual('{161BEA56-480B-40A8-AF0E-7FDF6B08E121} modified from server', res.Content);
res := RESTClient.Get('/typed/tguid1/161BEA56-480B-40A8-AF0E-7FDF6B08E121');
Assert.isTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.areEqual('{161BEA56-480B-40A8-AF0E-7FDF6B08E121} modified from server', res.Content);
res := RESTClient.Get('/typed/tguid1/161BEA56480B40A8AF0E7FDF6B08E121');
Assert.isTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.OK, 'Cannot route');
Assert.areEqual('{161BEA56-480B-40A8-AF0E-7FDF6B08E121} modified from server', res.Content);
end;
@ -2194,7 +2147,7 @@ var
res: IMVCRESTResponse;
begin
res := RESTClient.AddPathParam('username', UserName).Get('/login/{username}');
Assert.isTrue(res.StatusCode = HTTP_STATUS.OK, 'Login Failed');
Assert.IsTrue(res.StatusCode = HTTP_STATUS.OK, 'Login Failed');
end;
{ TJSONRPCServerTest }
@ -2208,7 +2161,8 @@ end;
procedure TJSONRPCServerTest.TestHooks;
begin
var lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'request1');
var
lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'request1');
var
lResp := FExecutor3.ExecuteRequest(lRequest1);
Assert.areEqual('OnBeforeRoutingHook|OnBeforeCallHook|OnAfterCallHook',
@ -2219,11 +2173,12 @@ procedure TJSONRPCServerTest.TestHooksNotif;
var
lResp: IJSONRPCResponse;
begin
var lNotif: IJSONRPCNotification := TJSONRPCNotification.Create('Notif1');
var
lNotif: IJSONRPCNotification := TJSONRPCNotification.Create('Notif1');
lResp := FExecutor3.ExecuteNotification(lNotif);
Assert.areEqual('OnBeforeRoutingHook|OnBeforeCallHook|OnAfterCallHook',
FExecutor3.HTTPResponse.HeaderValue['x-history']);
Assert.isFalse(lResp.IsError);
Assert.IsFalse(lResp.IsError);
Assert.WillRaise(
procedure
begin
@ -2235,10 +2190,11 @@ procedure TJSONRPCServerTest.TestHooksNotifWhenOnAfterCallHookRaisesError;
var
lResp: IJSONRPCResponse;
begin
var lNotif: IJSONRPCNotification := TJSONRPCNotification.Create('error_OnAfterCallHook');
var
lNotif: IJSONRPCNotification := TJSONRPCNotification.Create('error_OnAfterCallHook');
lResp := FExecutor3.ExecuteNotification(lNotif);
Assert.areEqual('', FExecutor3.HTTPResponse.HeaderValue['x-history']);
Assert.isTrue(lResp.IsError);
Assert.IsTrue(lResp.IsError);
Assert.WillNotRaise(
procedure
begin
@ -2250,10 +2206,11 @@ procedure TJSONRPCServerTest.TestHooksNotifWhenOnBeforeCallHookRaisesError;
var
lResp: IJSONRPCResponse;
begin
var lNotif: IJSONRPCNotification := TJSONRPCNotification.Create('error_OnBeforeCallHook');
var
lNotif: IJSONRPCNotification := TJSONRPCNotification.Create('error_OnBeforeCallHook');
lResp := FExecutor3.ExecuteNotification(lNotif);
Assert.areEqual('', FExecutor3.HTTPResponse.HeaderValue['x-history']);
Assert.isTrue(lResp.IsError);
Assert.IsTrue(lResp.IsError);
Assert.WillNotRaise(
procedure
begin
@ -2265,10 +2222,11 @@ procedure TJSONRPCServerTest.TestHooksNotifWhenOnBeforeRoutingHookRaisesError;
var
lResp: IJSONRPCResponse;
begin
var lNotif: IJSONRPCNotification := TJSONRPCNotification.Create('error_OnBeforeRoutingHook');
var
lNotif: IJSONRPCNotification := TJSONRPCNotification.Create('error_OnBeforeRoutingHook');
lResp := FExecutor3.ExecuteNotification(lNotif);
Assert.areEqual('', FExecutor3.HTTPResponse.HeaderValue['x-history']);
Assert.isTrue(lResp.IsError);
Assert.IsTrue(lResp.IsError);
Assert.WillNotRaise(
procedure
begin
@ -2280,38 +2238,42 @@ procedure TJSONRPCServerTest.TestHooksWhenMethodRaisesError;
var
lResp: IJSONRPCResponse;
begin
var lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'RequestWithError');
var
lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'RequestWithError');
lResp := FExecutor3.ExecuteRequest(lRequest1);
Assert.areEqual('OnBeforeRoutingHook|OnBeforeCallHook|OnAfterCallHook|error',
FExecutor3.HTTPResponse.HeaderValue['x-history']);
Assert.isTrue(lResp.IsError, 'Method raised error but response is not an error');
Assert.IsTrue(lResp.IsError, 'Method raised error but response is not an error');
end;
procedure TJSONRPCServerTest.TestHooksWhenOnAfterCallHookRaisesError;
begin
var lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'error_OnAfterCallHook');
var
lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'error_OnAfterCallHook');
var
lResp := FExecutor3.ExecuteRequest(lRequest1);
Assert.isTrue(lResp.IsError, lResp.ToString(true));
Assert.IsTrue(lResp.IsError, lResp.ToString(true));
Assert.areEqual(lResp.Error.ErrMessage, 'error_OnAfterCallHook');
end;
procedure TJSONRPCServerTest.TestHooksWhenOnBeforeCallHookRaisesError;
begin
var lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'error_OnBeforeCallHook');
var
lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'error_OnBeforeCallHook');
var
lResp := FExecutor3.ExecuteRequest(lRequest1);
Assert.isTrue(lResp.IsError, lResp.ToString(true));
Assert.IsTrue(lResp.IsError, lResp.ToString(true));
Assert.areEqual(lResp.Error.ErrMessage, 'error_OnBeforeCallHook');
end;
procedure TJSONRPCServerTest.TestHooksWhenOnBeforeRoutingHookRaisesError;
begin
var lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'error_OnBeforeRoutingHook');
var
lRequest1: IJSONRPCRequest := TJSONRPCRequest.Create(1234, 'error_OnBeforeRoutingHook');
var
lResp := FExecutor3.ExecuteRequest(lRequest1);
Assert.isTrue(lResp.IsError, lResp.ToString(true));
Assert.IsTrue(lResp.IsError, lResp.ToString(true));
Assert.areEqual(lResp.Error.ErrMessage, 'error_OnBeforeRoutingHook');
end;
@ -2323,7 +2285,7 @@ begin
lReq.Method := 'NotifWithError';
var
lResp := FExecutor3.ExecuteNotification(lReq);
Assert.isTrue(lResp.IsError);
Assert.IsTrue(lResp.IsError);
Assert.Contains(lResp.Error.ErrMessage, 'BOOM NOTIF');
end;
@ -2349,7 +2311,7 @@ begin
lResp := FExecutor.ExecuteRequest(lReq);
Assert.IsNotNull(lResp.Error);
Assert.areEqual(-32601, lResp.Error.Code);
Assert.isTrue(lResp.Error.ErrMessage.StartsWith('Method [nonexist] not found.'));
Assert.IsTrue(lResp.Error.ErrMessage.StartsWith('Method [nonexist] not found.'));
end;
procedure TJSONRPCServerTest.TestRequestWithParams_DT_T_ret_DT;
@ -2390,7 +2352,7 @@ begin
lReq.RequestID := 1234;
lRPCResp := FExecutor.ExecuteRequest(lReq);
Assert.isTrue(lRPCResp.IsError);
Assert.IsTrue(lRPCResp.IsError);
Assert.Contains(lRPCResp.Error.ErrMessage, 'cannot find parameter', true);
end;
@ -2445,8 +2407,8 @@ begin
lReq.Method := 'MyRequest';
lReq.RequestID := 1234;
lResp := FExecutor.ExecuteRequest(lReq);
Assert.isFalse(lResp.IsError);
Assert.isTrue(lResp.Result.AsBoolean);
Assert.IsFalse(lResp.IsError);
Assert.IsTrue(lResp.Result.AsBoolean);
end;
procedure TJSONRPCServerTest.TestRequestWithParams_I_I_ret_I;
@ -2536,7 +2498,7 @@ begin
lReq.Params.AddByName('Multiplier', 4);
lReq.RequestID := 1234;
lRPCResp := FExecutor.ExecuteRequest(lReq);
Assert.isFalse(lRPCResp.IsError);
Assert.IsFalse(lRPCResp.IsError);
Assert.areEqual('DanieleDanieleDanieleDaniele', lRPCResp.Result.AsString);
lRPCResp := FExecutor2.ExecuteRequest(lReq);

BIN
unittests/general/Several/bin/pgsql/bin/clusterdb.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/createdb.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/createuser.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/dropdb.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/dropuser.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/ecpg.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/icudt67.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/icuin67.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/icuio67.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/icutu67.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/icuuc67.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/initdb.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/isolationtester.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libcrypto-1_1-x64.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libcurl.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libcurl.lib Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libecpg.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libecpg_compat.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libiconv-2.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libintl-8.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libpgtypes.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libpq.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libssl-1_1-x64.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libwinpthread-1.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libxml2.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/libxslt.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/oid2name.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_archivecleanup.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_basebackup.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_checksums.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_config.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_controldata.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_ctl.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_dump.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_dumpall.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_isolation_regress.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_isready.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_receivewal.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_recvlogical.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_regress.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_regress_ecpg.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_resetwal.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_restore.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_rewind.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_standby.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_test_fsync.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_test_timing.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_upgrade.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_verifybackup.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pg_waldump.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/pgbench.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/postgres.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/psql.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/reindexdb.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/stackbuilder.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/vacuumdb.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/vacuumlo.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/wxbase313u_vc_x64_custom.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/wxbase313u_xml_vc_x64_custom.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/wxbase313ud_net_vc_x64_custom.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/wxmsw313u_adv_vc_x64_custom.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/wxmsw313u_core_vc_x64_custom.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/wxmsw313ud_aui_vc_x64_custom.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/wxmsw313ud_html_vc_x64_custom.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/wxmsw313ud_xrc_vc_x64_custom.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/zic.exe Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/bin/zlib1.dll Normal file
View File

Binary file not shown.

1
unittests/general/Several/bin/pgsql/initdb_sample.bat Normal file
View File

@ -0,0 +1 @@
.\bin\initdb -D .\data -E UTF8 --lc-collate=en_US.UTF8 --lc-ctype=en_US.UTF8 --locale=en_US

BIN
unittests/general/Several/bin/pgsql/lib/_int.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/adminpack.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/amcheck.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/auth_delay.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/auto_explain.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/autoinc.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/bloom.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/bool_plperl.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/btree_gin.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/btree_gist.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/citext.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/cube.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/cyrillic_and_mic.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/dblink.dll Normal file
View File

Binary file not shown.

BIN
unittests/general/Several/bin/pgsql/lib/dict_int.dll Normal file
View File

Binary file not shown.

Some files were not shown because too many files have changed in this diff Show More