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

[+] updated dmustache

Browse Source
This commit is contained in:
Daniele Teti 2021-04-23 10:11:05 +02:00
parent c997d0647e
commit 11c97997b5
12 changed files with 4902 additions and 2587 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

116
contrib/mwAnalytics.pas
View File

@ -1,116 +0,0 @@
unit mwAnalytics;
interface
uses
MVCFramework, MVCFramework.Logger, System.Classes;
type
IFileAnalytics = interface
['{C77426C4-1D34-4B3A-BD21-3C07B7E0B8BD}']
function GetRecentlyUsedAPI() : string;
function GetConsumeAPICount(ControllerName, ActionName : string) : Integer;
end;
TMVCAnalyticsMiddleware = class(TInterfacedObject, IMVCMiddleware, IFileAnalytics)
private
FAnalyticsFileName: string;
FAnalyticsFile: TStringList;
procedure SetAnalyticsFilename(const Value: string);
protected
procedure OnBeforeRouting(Context: TWebContext; var Handled: Boolean);
procedure OnAfterControllerAction(Context: TWebContext; const AActionNAme: string;
const Handled: Boolean);
procedure OnBeforeControllerAction(Context: TWebContext;
const AControllerQualifiedClassName: string; const AActionNAme: string; var Handled: Boolean);
public
property AnalyticsFilename: string read FAnalyticsFileName write SetAnalyticsFilename;
//Own Function
function GetRecentlyUsedAPI : string;
function GetConsumeAPICount(ControllerName, ActionName : string) : Integer;
end;
implementation
uses
System.SysUtils, System.JSON, REST.Json;
{ TMVCAnalyticsMiddleware }
function TMVCAnalyticsMiddleware.GetConsumeAPICount(ControllerName,
ActionName: string): Integer;
begin
Result := 5;
end;
function TMVCAnalyticsMiddleware.GetRecentlyUsedAPI: string;
begin
Result := 'Test'
end;
procedure TMVCAnalyticsMiddleware.OnAfterControllerAction(Context: TWebContext;
const AActionNAme: string; const Handled: Boolean);
begin
//Context.Response.Content := Context.Response.Content + '[][][]' ;
end;
procedure TMVCAnalyticsMiddleware.OnBeforeControllerAction(Context: TWebContext;
const AControllerQualifiedClassName, AActionNAme: string;
var Handled: Boolean);
var
Data : TJSONObject;
CSVFile : TextFile;
ApplicationPath : string;
begin
{AnalyticsFilename := 'analytics.json';
if not Assigned(FAnalyticsFile) then
raise Exception.Create('Analytics: Cannot read or write to file.');
Data := TJSONObject.Create;
Data.AddPair('TimeStamp', DateTimeToStr(Now));
Data.AddPair('IPAddress', Context.Request.ClientIp);
Data.AddPair('ControllerName', AControllerQualifiedClassName);
Data.AddPair('ActionName', AActionNAme);
FAnalyticsFile.Add(Data.ToJSON);
FAnalyticsFile.SaveToFile(FAnalyticsFileName);
Data.Free;}
//Context.Request;
ApplicationPath := ExtractFilePath(GetModuleName(hInstance));
AssignFile(CSVFile, ApplicationPath+'analytics.csv');
if not FileExists('analytics.csv') then
begin
Rewrite(CSVFile);
WriteLn(CSVFile, 'DateTime, IpAddress, ControllerName, ActionName, DomainName, Host');
end;
Append(CSVFile);
WriteLn(CSVFile, DateTimeToStr(Now), ',', Context.Request.ClientIp, ',', AControllerQualifiedClassName, ',',AActionNAme, ',' , Context.Request.RawWebRequest.Referer, ',', Context.Request.RawWebRequest.Host);
CloseFile(CSVFile);
end;
procedure TMVCAnalyticsMiddleware.OnBeforeRouting(Context: TWebContext;
var Handled: Boolean);
begin
end;
procedure TMVCAnalyticsMiddleware.SetAnalyticsFilename(const Value: string);
begin
// create the class if not there
if not Assigned(FAnalyticsFile) then
FAnalyticsFile := TStringList.Create;
// Create the file if it doesn't exist
if not FileExists(Value) then
FAnalyticsFile.SaveToFile(Value)
else
FAnalyticsFile.LoadFromFile(Value);
// assign the name
FAnalyticsFileName := Value;
end;
end.

282
lib/dmustache/ReadMe.txt Normal file
View File

@ -0,0 +1,282 @@
Synopse mORMot framework
An Open Source Client-Server ORM/SOA framework
(c) 2008-2021 Synopse Informatique
https://synopse.info
http://mormot.net
Contributors
Alan Chate
Alexander (sha)
Alexander (volax)
AlexPirate
Alfred Glaenzer (alf)
Andre Heider (dhewg)
Antoine Simard (AntoineGS)
Arnaud Bouchez
ASiwon
Aweste
Bas Schouten
BigStar
BugsDigger
Cheemeng
CoMPi
Damien (ddemars)
Darian Miller
Daniel Kuettner
David Mead (MDW)
Delphinium (louisyeow)
DigDiver
Dominikcz
EgorovAlex
Emanuele (lele9)
Eric Grange
Esmond
Esteban Martin (EMartin)
Eugene Ilyin
Eva Freimann (EVaF)
F-Vicente
Goran Despalatovic (gigo)
Jean-Baptiste Roussia (jbroussia)
Joe (jokusoft)
Johan Bontes
Jordi Tudela
Kevin Chen
Lagodny
Leon Oosthuizen
Macc2010
Maciej Izak (hnb)
Marcos Douglas B. Santos (mdbs99)
Mario Moretti
Marius Maximus (mariuszekpl)
Martin Eckes
Martin Suer
Mapes
Matkov
Maxim Masiutin
Mazinsw
MChaos
Miab3
Michael (EgonHugeist)
Michalis Kamburelis
MilesYou
Mingda
Mr Yang (ysair)
Nicolas Marchand (MC)
Nortg
Nzsolt
Oleg Tretyakov
Ondrej (reddwarf)
Pavel Mashlyakovskii (mpv)
Pierre le Riche
RalfS
Richard6688
Sabbiolina
Sanyin
Sinisa (sinisav)
Sllimr7139
SSoftPro
Stefan (itSDS)
Svetozar Belic (transmogrifix)
Transmogrifix
Uian2000
Vaclav
Vadim Orel
Willo vd Merwe
Win2014
Wloochacz
Wolfgang Ehrhardt
Yoanq
Ysair
Zed
[See below if you upgrade from 1.17 revision]
Synopse mORMot is an Open Source Client-Server ORM SOA MVC framework
for Delphi 6 up to Delphi 10.3 Rio and FPC, targeting Windows/Linux
for servers, and any platform for clients (including mobile or AJAX).
The main features of mORMot are therefore:
- ORM/ODM: objects persistence on almost any database (SQL or NoSQL);
- SOA: organize your business logic into REST services;
- Clients: consume your data or services from any platform, via ORM/SOA APIs;
- Web MVC: publish your ORM/SOA process as responsive Web Applications.
With local or remote access, via an auto-configuring Client-Server REST design.
Due to its modular design, switch from a Client-Server architecture over
HTTP, named pipes or GDI messages into a stand-alone application is just
a matter of mORMot classes initialization.
For instance, the very same executable can even be running stand-alone,
as a server, as a service, or a client, depending on some run-time parameters!
Emphasizing simplicity, speed and versatility, mORMot is a incredibly well
documented Open Source project easy enough to add basic ORM or Client-Server
features to simple applications for hobbyists, or let experienced users
develop scaling and strong service-based projects for their customers, with
the advantages of native code and easy-to-deploy solutions, reducing
deployment cost and increasing ROI.
It provides an Open Source self-sufficient set of units (even Delphi starter
edition is enough) for creating any application, from a stand-alone solution
up to the most complex Domain-Driven Design (DDD):
- Presentation layer featuring MVC UI generation with i18n and reporting
(with pdf export) for rich Delphi clients, MVC web clients (with logic-less
Mustache templates) or rich AJAX clients (via native JSON/REST access);
- Application layer implementing Service Oriented Architecture via
interface-based services (like WCF) and Client-Server ORM (including
method-based services) - following a RESTful model using JSON over several
communication protocols (e.g. HTTP/1.1);
- Domain Model layer handling all the needed business logic in plain Delphi
objects, including high-level managed types like dynamic arrays or records
for Value Objects, dedicated classes for Entities or Aggregates, and variant
storage with late-binding for dynamic documents;
- Data persistence infrastructure layer with ORM operations on direct
Oracle, MS SQL, OleDB, ODBC, ZEOS/ZDBC access or any TDataSet provider (e.g.
FireDAC/AnyDAC, UniDAC, NexusDB, BDE...), with a powerful SQLite3 kernel,
and optional SQL access if needed, with amazing performance and advanced
features like Array DML, auto-generating SQL for SQLite3, Oracle,
Jet/MSAccess, MS SQL, Firebird, DB2, PostgreSQL, MySQL and NexusDB - and
alternative high-speed MongoDB NoSQL database access for ODM persistence;
- Cross-Cutting infrastructure layers for handling data filtering and
validation, security (e.g. Windows authentication or any custom model),
caching, logging and testing (framework uses test-driven approach and
features interface stubbing and mocking).
With mORMot, ORM/ODM is not used only for data persistence of objects (like
in other implementations), but as part of a global n-Tier, Service Oriented
Architecture (SOA), ready to implement Domain-Driven solutions. This
framework is not an ORM on which a transmission layer has been added, like
almost everything existing in Delphi, C# or Java: this is a full Client-Server
ORM/SOA from the ground up.
This really makes the difference.
The business logic of your applications will be easily exposed as Services,
and will be accessible from light clients (written in Delphi or any other
mean, including AJAX).
The SpiderMonkey JavaScript engine has been integrated on the server side
and can be used to define business rules or any process (including MVC web
rendering) - just like node.js, but with a multi-threaded core, and the
full power of our optimized Delphi libraries at hand.
The framework Core is non-visual: you will get everything you need in a
consistent set of classes to be used from code. In order to let you focus
on your business, using mORMot's KISS/DRY/SOC/YAGNI/TDD and Convention Over
Configuration patterns. But you have also some UI units available (including
screen auto-generation, reporting and ribbon GUI), and you can use it from
any RAD, web, or AJAX clients (via JavaScript or Smart Mobile Studio).
No dependency is needed on the client side (no DB driver, or third-party
runtime): it is able to connect via standard HTTP, even through a corporate
proxy or a VPN. Rich Delphi clients can be deployed just by copying and running
a stand-alone small executable, with no installation process. Stream can be
encrypted via HTTS or with proven SHA/AES-256. Endpoints are configured
automatically for each published interface on both server and client sides,
and creating a load-balancing proxy is a matter of one method call.
Speed and scalability has been implemented from the ground up: a genuine
optimized multi-threaded core let a single server handle more than 50,000
concurrent clients, faster than DataSnap, WCF or node.js, and our rich SOA
design is able to implement both vertical and horizontal scalable hosting,
using recognized enterprise-level SQL or NoSQL databases for storage.
Even if mORMot will be more easily used in a project designed from scratch,
it fits very well the purpose of evolving any existing Delphi project, or
creating the server side part of an AJAX application.
Licensed under a disjunctive tri-license giving you the choice of one of
the three following sets of free software/open source licensing terms:
- Mozilla Public License, version 1.1 or later;
- GNU General Public License, version 2.0 or later;
- GNU Lesser General Public License, version 2.1 or later.
This allows the use of our code in as wide a variety of software projects
as possible, while still maintaining copy-left on code we wrote.
Main project page:
http://mORMot.net
Documentation:
https://synopse.info/files/html/Synopse%20mORMot%20Framework%20SAD%201.18.html
Installation:
https://synopse.info/files/html/Synopse%20mORMot%20Framework%20SAD%201.18.html#TITL_113
FAQ:
https://synopse.info/files/html/Synopse%20mORMot%20Framework%20SAD%201.18.html#TITL_123
How to get the source:
https://synopse.info/fossil/wiki?name=Get+the+source
A forum is dedicated to support:
https://synopse.info
A blog is available:
http://blog.synopse.info
Issues and feature requests can be posted (take a look at the forums
and latest unstable version first!):
https://synopse.info/fossil/reportlist
You can also monitor/fork our projects on GitHub:
https://github.com/synopse/mORMot
You may also install it as a Delphinus package: Delphinus-Support
Don't forget to download the documentation (available online or as pdf files,
created by our SynProject tool).
In particular, you should take a look at all general introduction chapters
of the SAD document. It will cover all key-concepts and code modelling
used by the framework.
A developer guide is included in this SAD document, in its 2nd part. You'll
get good practice guidance, presentation of the ORM/SOA approach and other
underlying concepts.
Feel free to contribute by posting enhancements and patches to this
quickly evolving project.
Enjoy!
Some units (e.g. SynPdf, SynGdiPlus, SynBigTable, SynCommons, SynCrypto,
SynDB*, SynSQLite3, SynMongoDB, SynMustache, SynSM, mORMotReport) are used
by mORMot, but do not require the whole framework to be linked.
That is, you can use e.g. only PDF generation, SynDB fast database
access, a static-linked SQLite3 engine, direct MongoDB access, Mustache
templates, SpiderMonkey JavaSCript engine, code-generated reports, or
the TDocVariant, TDynArray, TSynLog classes of SynCommons, without using
the main mORMot units and features (ORM, Client-Server, services, UI).
Some of those units can even be compiled with Delphi 5 (e.g. SynPdf, SynDB).
Quick Steps when upgrading from a previous 1.17 revision:
1) Note that some units where renamed, and some breaking changes introduced
by some enhanced features, therefore a direct update is not possible
2) Erase or rename your whole previous #\Lib directory
3) Download latest 1.18 revision files as stated just above
4) Change your references to mORMot units:
- Add in your uses clause SynLog.pas and/or SynTests.pas if needed;
- Rename in your uses clause any SQLite3Commons reference into mORmot;
- Rename in your uses clause any SQLite3 reference into mORMotSQLite3;
- Rename in your uses clause any other SQlite3* reference into mORMot*;
- Add in one uses clause a link to SynSQLite3Static (for Win32).
5) Consult the units headers about 1.18 for breaking changes, mainly:
- TSQLRecord.ID: TID primary key, TIDDynArray, and TRecordReference are now Int64;
- Renamed Iso8601 low-level structure as TTimeLogBits;
- TJSONSerializerCustomReader/Writer callbacks changed;
- TSQLRestServerCallBackParams replaced by TSQLRestServerURIContext class;
- TSQLRestServerStatic* classes renamed as TSQLRestStorage*;
- rmJSON* enums replaced by TSQLRestRoutingREST/JSON_RPC classes;
- Changed '¤' into '~' character for mORMoti18n language files.

6017
lib/dmustache/SynCommons.pas
View File

File diff suppressed because it is too large Load Diff

638
lib/dmustache/SynFPCLinux.pas
View File

@ -6,7 +6,7 @@ unit SynFPCLinux;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse mORMot framework. Copyright (C) 2021 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
@ -25,7 +25,7 @@ unit SynFPCLinux;
The Initial Developer of the Original Code is Alfred Glaenzer.
Portions created by the Initial Developer are Copyright (C) 2020
Portions created by the Initial Developer are Copyright (C) 2021
the Initial Developer. All Rights Reserved.
Contributor(s):
@ -51,10 +51,17 @@ unit SynFPCLinux;
interface
{$ifndef FPC}
'this unit is for FPC only - do not include it in any Delphi project!'
{$endif FPC}
{$I Synopse.inc} // set proper flags, and define LINUX for BSD and ANDROID
uses
{$ifdef LINUX}
BaseUnix,
UnixType,
{$endif LINUX}
SysUtils;
@ -113,10 +120,26 @@ function GetLastError: longint; inline;
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;
// - will use the system ICU library if available, or the widestringmanager
// - seldom called, unless our proprietary WIN32CASE collation is used in SynSQLite3
function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: PWideChar;
cchCount1: integer; lpString2: PWideChar; cchCount2: integer): integer;
/// compatibility function, wrapping Win32 API text case conversion
function CharUpperBuffW(W: PWideChar; WLen: integer): integer;
/// compatibility function, wrapping Win32 API text case conversion
function CharLowerBuffW(W: PWideChar; WLen: integer): integer;
/// compatibility function, wrapping Win32 MultiByteToWideChar API conversion
// - will use the system ICU library for efficient conversion
function AnsiToWideICU(codepage: cardinal; Source: PAnsiChar; Dest: PWideChar;
SourceChars: PtrInt): PtrInt;
/// compatibility function, wrapping Win32 WideCharToMultiByte API conversion
// - will use the system ICU library for efficient conversion
function WideToAnsiICU(codepage: cardinal; Source: PWideChar; Dest: PAnsiChar;
SourceChars: PtrInt): PtrInt;
/// returns the current UTC time
// - will convert from clock_gettime(CLOCK_REALTIME_COARSE) if available
@ -143,6 +166,9 @@ var
// - under Linux/FPC, this API truncates the name to 16 chars
procedure SetUnixThreadName(ThreadID: TThreadID; const Name: RawByteString);
/// calls mprotect() syscall or clib
function SynMProtect(addr:pointer; size:size_t; prot:integer): longint;
{$ifdef BSD}
function fpsysctlhwint(hwid: cint): Int64;
function fpsysctlhwstr(hwid: cint; var temp: shortstring): pointer;
@ -153,9 +179,16 @@ function fpsysctlhwstr(hwid: cint; var temp: shortstring): pointer;
{$ifdef BSD}
const // see https://github.com/freebsd/freebsd/blob/master/sys/sys/time.h
CLOCK_REALTIME = 0;
{$ifdef OpenBSD}
CLOCK_MONOTONIC = 3;
CLOCK_REALTIME_COARSE = CLOCK_REALTIME; // no faster alternative
CLOCK_MONOTONIC_COARSE = CLOCK_MONOTONIC;
{$else}
CLOCK_MONOTONIC = 4;
CLOCK_REALTIME_COARSE = 10; // named CLOCK_REALTIME_FAST in FreeBSD 8.1+
CLOCK_MONOTONIC_COARSE = 12;
{$endif OPENBSD}
{$else}
const
CLOCK_REALTIME = 0;
@ -202,17 +235,156 @@ procedure SleepHiRes(ms: cardinal);
function UnixKeyPending: boolean;
{$ifdef LINUX}
type
/// the libraries supported by TExternalLibrariesAPI
TExternalLibrary = (
elPThread, elICU {$ifdef LINUXNOTBSD} , elSystemD {$endif});
/// set of libraries supported by TExternalLibrariesAPI
TExternalLibraries = set of TExternalLibrary;
/// implements late-binding of system libraries
// - about systemd: see https://www.freedesktop.org/wiki/Software/systemd
// and http://0pointer.de/blog/projects/socket-activation.html - to get headers
// on debian: `sudo apt install libsystemd-dev && cd /usr/include/systemd`
TExternalLibrariesAPI = object
private
Lock: TRTLCriticalSection;
Loaded: TExternalLibraries;
{$ifdef LINUX}
pthread: pointer;
{$ifdef LINUXNOTBSD}
systemd: pointer;
{$endif LINUXNOTBSD}
{$endif LINUX}
icu, icudata, icui18n: pointer;
procedure LoadIcuWithVersion;
procedure Done;
public
{$ifdef LINUXNOTBSD}
/// customize the name of a thread (truncated to 16 bytes)
// - see https://stackoverflow.com/a/7989973
pthread_setname_np: function(thread: pointer; name: PAnsiChar): longint; cdecl;
/// systemd: returns how many file descriptors have been passed to process
// - if result=1 then socket for accepting connection is SD_LISTEN_FDS_START
sd_listen_fds: function(unset_environment: integer): integer; cdecl;
/// systemd: returns 1 if the file descriptor is an AF_UNIX socket of the specified type and path
sd_is_socket_unix: function(fd, typr, listening: integer;
var path: TFileName; pathLength: PtrUInt): integer; cdecl;
/// systemd: submit simple, plain text log entries to the system journal
// - priority value can be obtained using longint(LOG_TO_SYSLOG[logLevel])
// - WARNING: args strings processed using C printf semantic, so % is a printf
// placeholder and should be either escaped using %% or all formatting args must be passed
sd_journal_print: function(priority: longint; args: array of const): longint; cdecl;
/// systemd: submit array of iov structures instead of the format string to the system journal.
// - each structure should reference one field of the entry to submit.
// - the second argument specifies the number of structures in the array.
sd_journal_sendv: function(const iov: Piovec; n: longint): longint; cdecl;
/// systemd: sends notification to systemd
// - see https://www.freedesktop.org/software/systemd/man/sd_notify.html
// status notification sample: sd.notify(0, 'READY=1');
// watchdog notification: sd.notify(0, 'WATCHDOG=1');
sd_notify: function(unset_environment: longint; state: PUTF8Char): longint; cdecl;
/// systemd: check whether the service manager expects watchdog keep-alive
// notifications from a service
// - if result > 0 then usec contains the notification interval (app should
// notify every usec/2)
sd_watchdog_enabled: function(unset_environment: longint; usec: Puint64): longint; cdecl;
{$endif LINUXNOTBSD}
/// Initialize an ICU text converter for a given encoding
ucnv_open: function (converterName: PAnsiChar; var err: SizeInt): pointer; cdecl;
/// finalize the ICU text converter for a given encoding
ucnv_close: procedure (converter: pointer); cdecl;
/// customize the ICU text converter substitute char
ucnv_setSubstChars: procedure (converter: pointer;
subChars: PAnsiChar; len: byte; var err: SizeInt); cdecl;
/// enable the ICU text converter fallback
ucnv_setFallback: procedure (cnv: pointer; usesFallback: LongBool); cdecl;
/// ICU text conversion from UTF-16 to a given encoding
ucnv_fromUChars: function (cnv: pointer; dest: PAnsiChar; destCapacity: cardinal;
src: PWideChar; srcLength: cardinal; var err: SizeInt): cardinal; cdecl;
/// ICU text conversion from a given encoding to UTF-16
ucnv_toUChars: function (cnv: pointer; dest: PWideChar; destCapacity: cardinal;
src: PAnsiChar; srcLength: cardinal; var err: SizeInt): cardinal; cdecl;
/// ICU UTF-16 text conversion to uppercase
u_strToUpper: function (dest: PWideChar; destCapacity: cardinal;
src: PWideChar; srcLength: cardinal; locale: PAnsiChar;
var err: SizeInt): cardinal; cdecl;
/// ICU UTF-16 text conversion to lowercase
u_strToLower: function (dest: PWideChar; destCapacity: cardinal;
src: PWideChar; srcLength: cardinal; locale: PAnsiChar;
var err: SizeInt): cardinal; cdecl;
/// ICU UTF-16 text comparison
u_strCompare: function (s1: PWideChar; length1: cardinal;
s2: PWideChar; length2: cardinal; codePointOrder: LongBool): cardinal; cdecl;
/// ICU UTF-16 text comparison with options, e.g. for case-insensitive
u_strCaseCompare: function (s1: PWideChar; length1: cardinal;
s2: PWideChar; length2: cardinal; options: cardinal;
var err: SizeInt): cardinal; cdecl;
/// get the ICU data folder
u_getDataDirectory: function: PAnsiChar; cdecl;
/// set the ICU data folder
u_setDataDirectory: procedure(directory: PAnsiChar); cdecl;
/// initialize the ICU library
u_init: procedure(var status: SizeInt); cdecl;
/// Initialize an ICU text converter for a given codepage
// - returns nil if ICU is not available on this system
function ucnv(codepage: cardinal): pointer;
/// thread-safe loading of a system library
// - caller should then check the API function to be not nil
procedure EnsureLoaded(lib: TExternalLibrary);
end;
var
/// late-binding of system libraries
ExternalLibraries: TExternalLibrariesAPI;
{$ifdef LINUXNOTBSD} { the systemd API is Linux-specific }
const
/// The first passed file descriptor is fd 3
SD_LISTEN_FDS_START = 3;
/// low-level libcurl library file name, depending on the running OS
LIBSYSTEMD_PATH = 'libsystemd.so.0';
ENV_INVOCATION_ID: PAnsiChar = 'INVOCATION_ID';
type
/// low-level exception raised during systemd library access
ESystemd = class(Exception);
/// returns true in case process is started by systemd
// - For systemd v232+
function ProcessIsStartedBySystemd: boolean;
/// initialize the libsystemd API
// - do nothing if the library has already been loaded
// - will raise ESsytemd exception on any loading issue
procedure LibSystemdInitialize;
/// returns TRUE if a systemd library is available
// - will load and initialize it, calling LibSystemdInitialize if necessary,
// catching any exception during the process
function SystemdIsAvailable: boolean; inline;
{$endif LINUXNOTBSD}
{$endif LINUX}
implementation
{$ifdef LINUX}
uses
Classes,
Unix,
BaseUnix,
{$ifdef BSD}
sysctl,
{$else}
Linux,
SysCall,
{$endif BSD}
dl;
{$endif LINUX}
@ -226,6 +398,14 @@ procedure DeleteCriticalSection(var cs : TRTLCriticalSection);
begin
{$ifdef LINUXNOTBSD}
if cs.__m_kind<>0 then
{$else}
{$ifdef BSD}
{$ifdef Darwin}
if cs.sig<>0 then
{$else}
if Assigned(cs) then
{$endif Darwin}
{$endif BSD}
{$endif LINUXNOTBSD}
DoneCriticalSection(cs);
end;
@ -372,10 +552,23 @@ 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';
{$else}
// libc's clock_gettime function uses vDSO (avoid syscall) while FPC by default
// is compiled without FPC_USE_LIBC defined and do a syscall each time
// GetTickCount64 fpc 2 494 563 op/sec
// GetTickCount64 libc 119 919 893 op/sec
// note: for high-resolution QueryPerformanceMicroSeconds, calling the kernel
// is also slower
function clock_gettime(clk_id : clockid_t; tp: ptimespec) : cint;
cdecl; external 'c' name 'clock_gettime';
{$endif BSD}
function GetTickCount64: Int64;
@ -402,14 +595,14 @@ end;
procedure QueryPerformanceCounter(out Value: Int64);
var r : TTimeSpec;
begin
clock_gettime(CLOCK_MONOTONIC,@r);
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);
clock_gettime(CLOCK_MONOTONIC, @r);
value := PtrUInt(r.tv_nsec) div C_THOUSAND+r.tv_sec*C_MILLION; // as microseconds
end;
@ -495,19 +688,141 @@ 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));
function CompareStringRTL(a, b: PWideChar; al, bl, flags: integer): integer;
var
U1, U2: UnicodeString;
begin
SetString(U1,a,al);
SetString(U2,b,bl);
result := widestringmanager.CompareUnicodeStringProc(U1,U2,TCompareOptions(flags));
end;
function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: PWideChar;
cchCount1: integer; lpString2: PWideChar; cchCount2: integer): integer;
const
U_COMPARE_CODE_POINT_ORDER = $8000;
var
err: SizeInt;
begin
if cchCount1 < 0 then
cchCount1 := StrLen(lpString1);
if cchCount2 < 0 then
cchCount2 := StrLen(lpString2);
with ExternalLibraries do
begin
if not (elICU in Loaded) then
EnsureLoaded(elICU);
if Assigned(ucnv_open) then
begin
err := 0;
if dwCmpFlags and NORM_IGNORECASE <> 0 then
result := u_strCaseCompare(lpString1, cchCount1, lpString2, cchCount2,
U_COMPARE_CODE_POINT_ORDER, err)
else
result := u_strCompare(lpString1, cchCount1, lpString2, cchCount2, true);
end
else
result := CompareStringRTL(lpString1, lpString2, cchCount1, cchCount2, dwCmpFlags);
end;
inc(result, 2); // caller would make -2 to get regular -1/0/1 comparison values
end;
function CharUpperBuffW(W: PWideChar; WLen: integer): integer;
var
err: SizeInt;
begin
with ExternalLibraries do
begin
if not (elICU in Loaded) then
EnsureLoaded(elICU);
if Assigned(ucnv_open) then
begin
err := 0;
result := u_strToUpper(W, WLen, W, WLen, nil, err);
end
else
result := WLen;
end;
end;
function CharLowerBuffW(W: PWideChar; WLen: integer): integer;
var
err: SizeInt;
begin
with ExternalLibraries do
begin
if not (elICU in Loaded) then
EnsureLoaded(elICU);
if Assigned(ucnv_open) then
begin
err := 0;
result := u_strToLower(W, WLen, W, WLen, nil, err);
end
else
result := WLen;
end;
end;
function AnsiToWideRTL(codepage: cardinal; Source: PAnsiChar; Dest: PWideChar;
SourceChars: PtrInt): PtrInt;
var
tmp: UnicodeString;
begin
widestringmanager.Ansi2UnicodeMoveProc(Source, codepage, tmp, SourceChars);
result := length(tmp);
Move(pointer(tmp)^, Dest^, result * 2);
end;
function AnsiToWideICU(codepage: cardinal; Source: PAnsiChar; Dest: PWideChar;
SourceChars: PtrInt): PtrInt;
var
cnv: pointer;
err: SizeInt;
begin
if codepage = CP_UTF8 then
exit(Utf8ToUnicode(Dest, Source, SourceChars));
cnv := ExternalLibraries.ucnv(codepage);
if cnv = nil then
exit(AnsiToWideRTL(codepage, Source, Dest, SourceChars));
err := 0;
result := ExternalLibraries.ucnv_toUChars(
cnv, Dest, SourceChars, Source, SourceChars, err);
if result < 0 then
result := 0;
ExternalLibraries.ucnv_close(cnv);
end;
function WideToAnsiRTL(codepage: cardinal; Source: PWideChar; Dest: PAnsiChar;
SourceChars: PtrInt): PtrInt;
var
tmp: RawByteString;
begin
widestringmanager.Unicode2AnsiMoveProc(Source, tmp, codepage, SourceChars);
result := length(tmp);
Move(pointer(tmp)^, Dest^, result);
end;
function WideToAnsiICU(codepage: cardinal; Source: PWideChar; Dest: PAnsiChar;
SourceChars: PtrInt): PtrInt;
var
cnv: pointer;
err: SizeInt;
begin
if codepage = CP_UTF8 then
// fallback to RTL
exit(UnicodeToUTF8(Dest, Source, SourceChars));
cnv := ExternalLibraries.ucnv(codepage);
if cnv = nil then
exit(WideToAnsiRTL(codepage, Source, Dest, SourceChars));
err := 0;
result := ExternalLibraries.ucnv_fromUChars(
cnv, Dest, SourceChars * 3, Source, SourceChars, err);
if result < 0 then
result := 0;
ExternalLibraries.ucnv_close(cnv);
end;
function GetFileSize(hFile: cInt; lpFileSizeHigh: PDWORD): DWORD;
var FileInfo: TStat;
begin
@ -536,6 +851,25 @@ begin
// no retry loop on ESysEINTR (as with regular RTL's Sleep)
end;
{$ifdef BSD}
function mprotect(Addr: Pointer; Len: size_t; Prot: Integer): Integer;
{$ifdef Darwin} cdecl external 'libc.dylib' name 'mprotect';
{$else} cdecl external 'libc.so' name 'mprotect'; {$endif}
{$endif BSD}
function SynMProtect(addr: pointer; size: size_t; prot: integer): longint;
begin
result := -1;
{$ifdef UNIX}
{$ifdef BSD}
result := mprotect(addr, size, prot);
{$else}
if Do_SysCall(syscall_nr_mprotect, PtrUInt(addr), size, prot) >= 0 then
result := 0;
{$endif BSD}
{$endif UNIX}
end;
procedure GetKernelRevision;
var uts: UtsName;
P: PAnsiChar;
@ -567,9 +901,11 @@ begin
{$else}
{$ifdef LINUX}
// try Linux kernel 2.6.32+ or FreeBSD 8.1+ fastest clocks
if clock_gettime(CLOCK_REALTIME_COARSE, @tp) = 0 then
if (CLOCK_REALTIME_COARSE <> CLOCK_REALTIME_FAST) and
(clock_gettime(CLOCK_REALTIME_COARSE, @tp) = 0) then
CLOCK_REALTIME_FAST := CLOCK_REALTIME_COARSE;
if clock_gettime(CLOCK_MONOTONIC_COARSE, @tp) = 0 then
if (CLOCK_MONOTONIC_COARSE <> CLOCK_MONOTONIC_FAST) and
(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
@ -580,43 +916,193 @@ begin
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;
{ TExternalLibrariesAPI }
procedure TExternalLibraries.EnsureLoaded;
procedure TExternalLibrariesAPI.LoadIcuWithVersion;
const
NAMES: array[0..12] of string = (
'ucnv_open', 'ucnv_close', 'ucnv_setSubstChars', 'ucnv_setFallback',
'ucnv_fromUChars', 'ucnv_toUChars', 'u_strToUpper', 'u_strToLower',
'u_strCompare', 'u_strCaseCompare', 'u_getDataDirectory',
'u_setDataDirectory', 'u_init');
{$ifdef ANDROID}
// from https://developer.android.com/guide/topics/resources/internationalization
ICU_VER: array[1..13] of string = (
'_3_8', '_4_2', '_44', '_46', '_48', '_50', '_51', '_53', '_55', '_56', '_58', '_60', '_63');
SYSDATA: PAnsiChar = '/system/usr/icu';
{$else}
SYSDATA: PAnsiChar = '';
{$endif ANDROID}
var
i, j: integer;
err: SizeInt;
P: PPointer;
v, vers: string;
data: PAnsiChar;
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}
{$ifdef ANDROID}
for i := high(ICU_VER) downto 1 do
begin
if dlsym(icu, pointer(NAMES[0] + ICU_VER[i])) <> nil then
begin
vers := ICU_VER[i];
break;
end;
{$endif LINUX}
Loaded := true;
end;
if vers <> '' then
{$endif ANDROID}
if dlsym(icu, 'ucnv_open') = nil then
for i := 80 downto 44 do
begin
str(i, v);
if dlsym(icu, pointer('ucnv_open_' + v)) <> nil then
begin
vers := '_' + v;
break;
end;
end;
P := @@ucnv_open;
for i := 0 to high(NAMES) do
begin
P[i] := dlsym(icu, pointer(NAMES[i] + vers));
if P[i] = nil then
begin
@ucnv_open := nil;
exit;
end;
end;
data := u_getDataDirectory;
if (data = nil) or (data^ = #0) then
if SYSDATA <> '' then
u_setDataDirectory(SYSDATA);
err := 0;
u_init(err);
end;
function TExternalLibrariesAPI.ucnv(codepage: cardinal): pointer;
var
s: shortstring;
err: SizeInt;
{$ifdef CPUINTEL}
mask: cardinal;
{$endif CPUINTEL}
begin
if not (elICU in Loaded) then
EnsureLoaded(elICU);
if not Assigned(ucnv_open) then
exit(nil);
str(codepage, s);
Move(s[1], s[3], ord(s[0]));
PWord(@s[1])^ := ord('c') + ord('p') shl 8;
inc(s[0], 3);
s[ord(s[0])] := #0;
{$ifdef CPUINTEL}
mask := GetMXCSR;
SetMXCSR(mask or $0080 {MM_MaskInvalidOp} or $1000 {MM_MaskPrecision});
{$endif CPUINTEL}
err := 0;
result := ucnv_open(@s[1], err);
if result <> nil then
begin
err := 0;
ucnv_setSubstChars(result, '?', 1, err);
ucnv_setFallback(result, true);
end;
{$ifdef CPUINTEL}
SetMXCSR(mask);
{$endif CPUINTEL}
end;
procedure TExternalLibrariesAPI.EnsureLoaded(lib: TExternalLibrary);
var
p: PPointer;
i, j: integer;
const
NAMES: array[0..5] of PAnsiChar = (
'sd_listen_fds', 'sd_is_socket_unix', 'sd_journal_print', 'sd_journal_sendv',
'sd_notify', 'sd_watchdog_enabled');
begin
if lib in Loaded then
exit;
EnterCriticalSection(Lock);
if not (lib in Loaded) then
case lib of
elPThread:
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}
include(Loaded, elPThread);
end;
elICU:
begin
{$ifdef DARWIN}
icu := dlopen('libicuuc.dylib', RTLD_LAZY);
if icu <> nil then
icui18n := dlopen('libicui18n.dylib', RTLD_LAZY);
{$else}
// libicudata should be loaded first because other two depend on it
icudata := dlopen('libicudata.so', RTLD_LAZY);
if icudata <> nil then
begin
icu := dlopen('libicuuc.so', RTLD_LAZY);
if icu <> nil then
icui18n := dlopen('libicui18n.so', RTLD_LAZY);
end;
{$endif DARWIN}
if icui18n = nil then
begin
if icu <> nil then
dlclose(icu);
if icudata <> nil then
dlclose(icudata);
end
else
// ICU append a version prefix to all its functions e.g. ucnv_open_66
LoadIcuWithVersion;
include(Loaded, elICU);
end;
{$ifdef LINUXNOTBSD}
elSystemD:
begin
systemd := dlopen(LIBSYSTEMD_PATH, RTLD_LAZY);
if systemd <> nil then
begin
p := @@sd_listen_fds;
for i := 0 to high(NAMES) do
begin
p^ := dlsym(systemd, NAMES[i]);
if p^ = nil then
begin
p := @@sd_listen_fds;
for j := 0 to i do
begin
p^ := nil;
inc(p);
end;
break;
end;
inc(p);
end;
end;
include(Loaded, elSystemD);
end;
{$endif LINUXNOTBSD}
end;
LeaveCriticalSection(Lock);
end;
procedure TExternalLibraries.Done;
procedure TExternalLibrariesAPI.Done;
begin
EnterCriticalSection(Lock);
if Loaded then begin
if elPThread in Loaded then
begin
{$ifdef LINUX}
{$ifdef LINUXNOTBSD}
@pthread_setname_np := nil;
@ -625,6 +1111,20 @@ begin
dlclose(pthread);
{$endif LINUX}
end;
if elICU in Loaded then
begin
if icui18n <> nil then
dlclose(icui18n);
if icu <> nil then
dlclose(icu);
if icudata <> nil then
dlclose(icudata);
@ucnv_open := nil;
end;
{$ifdef LINUXNOTBSD}
if (elSystemD in Loaded) and (systemd <> nil) then
dlclose(systemd);
{$endif LINUXNOTBSD}
LeaveCriticalSection(Lock);
DeleteCriticalSection(Lock);
end;
@ -633,6 +1133,11 @@ procedure SetUnixThreadName(ThreadID: TThreadID; const Name: RawByteString);
var trunc: array[0..15] of AnsiChar; // truncated to 16 bytes (including #0)
i,L: integer;
begin
{$ifdef LINUXNOTBSD}
if not(elPThread in ExternalLibraries.Loaded) then
ExternalLibraries.EnsureLoaded(elPThread);
if not Assigned(ExternalLibraries.pthread_setname_np) then
exit;
if Name = '' then
exit;
L := 0; // trim unrelevant spaces and prefixes when filling the 16 chars
@ -654,13 +1159,38 @@ begin
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]);
ExternalLibraries.pthread_setname_np(pointer(ThreadID), @trunc[0]);
{$endif LINUXNOTBSD}
end;
{$ifdef LINUXNOTBSD}
function SystemdIsAvailable: boolean;
begin
if not(elSystemD in ExternalLibraries.Loaded) then
ExternalLibraries.EnsureLoaded(elSystemD);
result := Assigned(ExternalLibraries.sd_listen_fds);
end;
function ProcessIsStartedBySystemd: boolean;
begin
result := SystemdIsAvailable and
// note: for example on Ubuntu 20.04 INVOCATION_ID is always defined
// from the other side PPID 1 can be set if we run under docker and started
// by init.d so let's verify both
(fpgetppid() = 1) and (fpGetenv(ENV_INVOCATION_ID) <> nil);
end;
procedure LibSystemdInitialize;
begin
if not SystemdIsAvailable then
raise ESystemd.Create('Impossible to load ' + LIBSYSTEMD_PATH);
end;
{$endif LINUXNOTBSD}
initialization
GetKernelRevision;
InitializeCriticalSection(ExternalLibraries.Lock);

8
lib/dmustache/SynFPCTypInfo.pas
View File

@ -6,7 +6,7 @@ unit SynFPCTypInfo;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse mORMot framework. Copyright (C) 2021 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
@ -25,7 +25,7 @@ unit SynFPCTypInfo;
The Initial Developer of the Original Code is Alfred Glaenzer.
Portions created by the Initial Developer are Copyright (C) 2020
Portions created by the Initial Developer are Copyright (C) 2021
the Initial Developer. All Rights Reserved.
Contributor(s):
@ -53,6 +53,10 @@ unit SynFPCTypInfo;
interface
{$ifndef FPC}
'this unit is for FPC only - do not include it in any Delphi project!'
{$endif FPC}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
uses

26
lib/dmustache/SynLZ.pas
View File

@ -5,7 +5,7 @@ unit SynLZ;
{
This file is part of Synopse SynLZ Compression.
Synopse SynLZ Compression. Copyright (C) 2020 Arnaud Bouchez
Synopse SynLZ Compression. Copyright (C) 2021 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
@ -24,7 +24,7 @@ unit SynLZ;
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
Portions created by the Initial Developer are Copyright (C) 2021
the Initial Developer. All Rights Reserved.
Contributor(s):
@ -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

6
lib/dmustache/SynMustache.pas
View File

@ -6,7 +6,7 @@ unit SynMustache;
{
This file is part of Synopse mORMot framework.
Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez
Synopse mORMot framework. Copyright (C) 2021 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
@ -25,7 +25,7 @@ unit SynMustache;
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
Portions created by the Initial Developer are Copyright (C) 2021
the Initial Developer. All Rights Reserved.
Contributor(s):
@ -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

275
lib/dmustache/SynTable.pas
View File

@ -6,7 +6,7 @@ unit SynTable;
(*
This file is part of Synopse framework.
Synopse framework. Copyright (C) 2020 Arnaud Bouchez
Synopse framework. Copyright (C) 2021 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
@ -25,7 +25,7 @@ unit SynTable;
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
Portions created by the Initial Developer are Copyright (C) 2021
the Initial Developer. All Rights Reserved.
Contributor(s):
@ -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);
@ -7678,7 +7708,7 @@ lim2: if IdemPropNameU(Prop,'LIMIT') then
end else
exit; // incorrect SQL statement
end else
if Prop<>'' then
if (Prop<>'') or not(GotoNextNotSpace(P)^ in [#0, ';']) then
exit else // incorrect SQL statement
break; // reached the end of the statement
end;
@ -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
@ -11156,7 +11187,7 @@ var s: TStream;
begin
if Append and FileExists(aFileName) then begin
s := TFileStream.Create(aFileName,fmOpenWrite);
s.Seek(0,soFromEnd);
s.Seek(0,soEnd);
end else
s := TFileStream.Create(aFileName,fmCreate);
Create(s,BufLen);
@ -11913,7 +11944,7 @@ begin
end else
// file bigger than 2 GB: slower but accurate reading from file
if Data=nil then begin
FileSeek(fMap.FileHandle,soFromCurrent,DataLen);
FileSeek64(fMap.FileHandle,DataLen,soFromCurrent);
result := DataLen;
end else
result := FileRead(fMap.FileHandle,Data^,DataLen) else
@ -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);

119
lib/dmustache/Synopse.inc
View File

@ -1,7 +1,7 @@
{
This file is part of Synopse framework.
Synopse framework. Copyright (C) 2020 Arnaud Bouchez
Synopse framework. Copyright (C) 2021 Arnaud Bouchez
Synopse Informatique - https://synopse.info
*** BEGIN LICENSE BLOCK *****
@ -20,7 +20,7 @@
The Initial Developer of the Original Code is Arnaud Bouchez.
Portions created by the Initial Developer are Copyright (C) 2020
Portions created by the Initial Developer are Copyright (C) 2021
the Initial Developer. All Rights Reserved.
Contributor(s):
@ -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.6272'

BIN
lib/dmustache/deflate.obj Normal file
View File

Binary file not shown.

BIN
lib/dmustache/trees.obj Normal file
View File

Binary file not shown.