/// automated tests for common units of the Synopse mORMot Framework // - this unit is a part of the freeware Synopse mORMot framework, // licensed under a MPL/GPL/LGPL tri-license; version 1.18 unit SynSelfTests; { This file is part of Synopse mORMot framework. Synopse 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 framework. The Initial Developer of the Original Code is Arnaud Bouchez. Portions created by the Initial Developer are Copyright (C) 2020 the Initial Developer. All Rights Reserved. Contributor(s): Alternatively, the contents of this file may be used under the terms of either the GNU General Public License Version 2 or later (the "GPL"), or the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), in which case the provisions of the GPL or the LGPL are applicable instead of those above. If you wish to allow use of your version of this file only under the terms of either the GPL or the LGPL, and not to allow others to use your version of this file under the terms of the MPL, indicate your decision by deleting the provisions above and replace them with the notice and other provisions required by the GPL or the LGPL. If you do not delete the provisions above, a recipient may use your version of this file under the terms of any one of the MPL, the GPL or the LGPL. ***** END LICENSE BLOCK ***** } interface {$I Synopse.inc} // define HASINLINE CPU32 CPU64 {$ifdef ISDELPHIXE} // since Delphi XE, we have unit System.RegularExpressionsAPI available {$define TEST_REGEXP} {$else} // define only if you have unit PCRE.pas installed (not set by default) {.$define TEST_REGEXP} {$endif} uses {$ifdef MSWINDOWS} Windows, {$else} {$ifdef KYLIX3} Types, LibC, SynKylix, {$endif} {$ifdef FPC} SynFPCLinux, BaseUnix, {$endif} {$endif} Classes, SynCrtSock, SynTable, // for TSynTableStatement {$ifndef NOVARIANTS} SynMongoDB, SynMustache, Variants, {$endif} {$ifdef UNICODE} Generics.Collections, {$endif} SysUtils, {$ifndef LVCL} Contnrs, {$ifdef MSWINDOWS} SynOleDB, {$ifndef FPC} SynGdiPlus, SynPdf, {$endif} {$endif} {$endif LVCL} SynEcc, SynDB, SynSQLite3, SynSQLite3Static, SynDBSQLite3, SynDBRemote, SynDBODBC, {$ifndef DELPHI5OROLDER} mORMot, mORMotDB, mORMotSQLite3, mORMotHttpServer, mORMotHttpClient, {$ifndef NOVARIANTS} mORMotMongoDB, mORMotMVC, {$endif} SynBidirSock, mORMotDDD, dddDomCountry, dddDomUserTypes, dddDomUserInterfaces, dddDomAuthInterfaces, dddInfraEmail, dddInfraEmailer, dddInfraAuthRest, dddInfraRepoUser, ECCProcess {$ifdef FPC} in '.\SQLite3\Samples\33 - ECC\ECCProcess.pas' {$endif}, {$endif DELPHI5OROLDER} mORMotService, SynProtoRTSPHTTP, SynProtoRelay, {$ifdef TEST_REGEXP} SynSQLite3RegEx, {$endif TEST_REGEXP} {$ifdef MSWINDOWS} {$ifdef USEZEOS} SynDBZeos, {$endif} {$endif} SynCommons, SynLog, SynTests; { ************ Unit-Testing classes and functions } {$ifndef DELPHI5OROLDER} const {$ifdef MSWINDOWS} HTTP_DEFAULTPORT = '888'; // if this library file is available and USEZEOS conditional is set, will run // TTestExternalDatabase.FirebirdEmbeddedViaODBC // !! download driver from http://www.firebirdsql.org/en/odbc-driver FIREBIRDEMBEDDEDDLL = 'd:\Dev\Lib\SQLite3\Samples\15 - External DB performance\Firebird'+ {$ifdef CPU64}'64'+{$endif=}'\fbembed.dll'; {$else} HTTP_DEFAULTPORT = '8888'; // under Linux, port<1024 needs root user {$endif MSWINDOWS} type // a record mapping used in the test classes of the framework // - this class can be used for debugging purposes, with the database // created by TTestFileBased in mORMotSQLite3.pas // - this class will use 'People' as a table name TSQLRecordPeople = class(TSQLRecord) private fData: TSQLRawBlob; fFirstName: RawUTF8; fLastName: RawUTF8; fYearOfBirth: integer; fYearOfDeath: word; published property FirstName: RawUTF8 read fFirstName write fFirstName; property LastName: RawUTF8 read fLastName write fLastName; property Data: TSQLRawBlob read fData write fData; property YearOfBirth: integer read fYearOfBirth write fYearOfBirth; property YearOfDeath: word read fYearOfDeath write fYearOfDeath; public /// method used to test the Client-Side // ModelRoot/TableName/ID/MethodName RESTful request, i.e. // ModelRoot/People/ID/DataAsHex in this case // - this method calls the supplied TSQLRestClient to retrieve its results, // with the ID taken from the current TSQLRecordPeole instance ID field // - parameters and result types depends on the purpose of the function // - TSQLRestServerTest.DataAsHex published method implements the result // calculation on the Server-Side function DataAsHex(aClient: TSQLRestClientURI): RawUTF8; /// method used to test the Client-Side // ModelRoot/MethodName RESTful request, i.e. ModelRoot/Sum in this case // - this method calls the supplied TSQLRestClient to retrieve its results // - parameters and result types depends on the purpose of the function // - TSQLRestServerTest.Sum published method implements the result calculation // on the Server-Side // - this method doesn't expect any ID to be supplied, therefore will be // called as class function - normally, it should be implement in a // TSQLRestClient descendant, and not as a TSQLRecord, since it does't depend // on TSQLRecordPeople at all // - you could also call the same servce from the ModelRoot/People/ID/Sum URL, // but it won't make any difference) class function Sum(aClient: TSQLRestClientURI; a, b: double; Method2: boolean): double; end; TSQLRecordTest = class(TSQLRecord) private fTest: RawUTF8; fValfloat: double; fValWord: word; fNext: TSQLRecordTest; fInt: int64; fValDate: TDateTime; fData: TSQLRawBlob; fAnsi: WinAnsiString; fUnicode: RawUnicode; {$ifndef NOVARIANTS} fVariant: variant; {$endif} procedure SetInt(const Value: int64); public procedure FillWith(i: Integer); procedure CheckWith(test: TSynTestCase; i: Integer; offset: integer=0; checkblob: boolean=true); published property Int: int64 read fInt write SetInt default 12; property Test: RawUTF8 read fTest write fTest; property Unicode: RawUnicode read fUnicode write fUnicode; property Ansi: WinAnsiString read fAnsi write fAnsi; property ValFloat: double read fValfloat write fValFloat; property ValWord: word read fValWord write fValWord; property ValDate: tdatetime read fValDate write fValDate; property Next: TSQLRecordTest read fNext write fNext; property Data: TSQLRawBlob read fData write fData; {$ifndef NOVARIANTS} property ValVariant: variant read fVariant write fVariant; {$endif} end; {$endif} type /// this test case will test most functions, classes and types defined and // implemented in the SynCommons unit TTestLowLevelCommon = class(TSynTestCase) protected {$ifndef DELPHI5OROLDER} a: array of TSQLRecordPeople; {$endif} fAdd,fDel: RawUTF8; fQuickSelectValues: TIntegerDynArray; function QuickSelectGT(IndexA,IndexB: PtrInt): boolean; procedure intadd(const Sender; Value: integer); procedure intdel(const Sender; Value: integer); published /// the faster CopyRecord function, enhancing the system.pas unit procedure SystemCopyRecord; /// test the TRawUTF8List class procedure _TRawUTF8List; /// test the TDynArray object and methods procedure _TDynArray; /// test the TDynArrayHashed object and methods (dictionary features) // - this test will create an array of 200,000 items to test speed procedure _TDynArrayHashed; /// test the TSynDictionary class procedure _TSynDictionary; /// validate the TSynQueue class procedure _TSynQueue; /// test TObjectListHashed class procedure _TObjectListHashed; /// test TObjectListSorted class procedure _TObjectListSorted; /// test TSynNameValue class procedure _TSynNameValue; /// test TRawUTF8Interning process procedure _TRawUTF8Interning; {$ifndef DELPHI5OROLDER} /// test TObjectDynArrayWrapper class procedure _TObjectDynArrayWrapper; /// test T*ObjArray types and the ObjArray*() wrappers procedure _TObjArray; {$endif DELPHI5OROLDER} {$ifdef CPUINTEL} /// validate our optimized MoveFast/FillCharFast functions procedure CustomRTL; {$endif CPUINTEL} /// test StrIComp() and AnsiIComp() functions procedure FastStringCompare; /// test IdemPropName() and IdemPropNameU() functions procedure _IdemPropName; /// test UrlEncode() and UrlDecode() functions procedure UrlEncoding; /// test our internal fast TGUID process functions procedure _GUID; /// test ParseCommandArguments() function procedure _ParseCommandArguments; /// test IsMatch() function procedure _IsMatch; /// test TExprParserMatch class procedure _TExprParserMatch; /// the Soundex search feature (i.e. TSynSoundex and all related // functions) procedure Soundex; /// low level fast Integer or Floating-Point to/from string conversion // - especially the RawUTF8 or PUTF8Char relative versions procedure NumericalConversions; /// test low-level integer/Int64 functions procedure Integers; /// test crc32c in both software and hardware (SSE4.2) implementations procedure _crc32c; /// test RDRAND Intel x86/x64 opcode if available, or fast gsl_rng_taus2 procedure _Random32; /// test TSynBloomFilter class procedure BloomFilters; /// test DeltaCompress/DeltaExtract functions procedure _DeltaCompress; /// the new fast Currency to/from string conversion procedure Curr64; /// the camel-case / camel-uncase features, used for i18n from Delphi RTII procedure _CamelCase; /// the low-level bit management functions procedure Bits; /// the fast .ini file content direct access procedure IniFiles; /// test UTF-8 and Win-Ansi conversion (from or to, through RawUnicode) procedure _UTF8; /// test UrlEncode() and UrlDecode() functions // - this method use some ISO-8601 encoded dates and times for the testing procedure UrlDecoding; /// test ASCII Baudot encoding procedure BaudotCode; /// the ISO-8601 date and time encoding // - test especially the conversion to/from text procedure Iso8601DateAndTime; /// test the TSynTimeZone class and its cross-platform local time process procedure TimeZones; /// test mime types recognition procedure MimeTypes; /// validates the median computation using the "Quick Select" algorithm procedure QuickSelect; /// test TSynTable class and TSynTableVariantType new variant type procedure _TSynTable; /// test the TSynCache class procedure _TSynCache; /// low-level TSynFilter classes procedure _TSynFilter; /// low-level TSynValidate classes procedure _TSynValidate; /// low-level TSynLogFile class procedure _TSynLogFile; /// client side geniune 64 bit identifiers generation procedure _TSynUniqueIdentifier; end; /// this test case will test most low-level functions, classes and types // defined and implemented in the mORMot.pas unit TTestLowLevelTypes = class(TSynTestCase) {$ifndef NOVARIANTS} protected procedure MustacheTranslate(var English: string); procedure MustacheHelper(const Value: variant; out result: variant); {$endif} published {$ifndef DELPHI5OROLDER} /// some low-level RTTI access // - especially the field type retrieval from published properties procedure RTTI; {$endif} /// some low-level Url encoding from parameters procedure UrlEncoding; /// some low-level JSON encoding/decoding procedure EncodeDecodeJSON; /// HTML generation from Wiki Or Markdown syntax procedure WikiMarkdownToHtml; {$ifndef NOVARIANTS} /// some low-level variant process procedure Variants; /// test the Mustache template rendering unit procedure MustacheRenderer; {$ifndef DELPHI5OROLDER} {$ifndef LVCL} /// variant-based JSON/BSON document process procedure _TDocVariant; /// low-level TDecimal128 decimal value process (as used in BSON) procedure _TDecimal128; /// BSON process (using TDocVariant) procedure _BSON; {$endif LVCL} /// test SELECT statement parsing procedure _TSynTableStatement; /// test advanced statistics monitoring procedure _TSynMonitorUsage; {$endif DELPHI5OROLDER} {$endif NOVARIANTS} end; {$ifndef DELPHI5OROLDER} /// this test case will test some generic classes // defined and implemented in the mORMot.pas unit TTestBasicClasses = class(TSynTestCase) published /// test the TSQLRecord class // - especially SQL auto generation, or JSON export/import procedure _TSQLRecord; /// test the digital signature of records procedure _TSQLRecordSigned; /// test the TSQLModel class procedure _TSQLModel; /// test a full in-memory server over Windows Messages // - Under Linux, URIDll will be used instead due to lack of message loop // - without any SQLite3 engine linked procedure _TSQLRestServerFullMemory; end; {$endif DELPHI5OROLDER} /// this test case will test most functions, classes and types defined and // implemented in the SynZip unit TTestCompression = class(TSynTestCase) protected Data: RawByteString; M: THeapMemoryStream; crc0,crc1: cardinal; public procedure Setup; override; procedure CleanUp; override; published /// direct deflate/inflate functions procedure InMemoryCompression; /// .gzip archive handling procedure GZIPFormat; /// .zip archive handling procedure ZIPFormat; /// SynLZO internal format procedure _SynLZO; /// SynLZ internal format procedure _SynLZ; /// TAlgoCompress classes procedure _TAlgoCompress; end; /// this test case will test most functions, classes and types defined and // implemented in the SynCrypto unit TTestCryptographicRoutines = class(TSynTestCase) public procedure CryptData(dpapi: boolean); published /// Adler32 hashing functions procedure _Adler32; /// MD5 hashing functions procedure _MD5; /// SHA-1 hashing functions procedure _SHA1; /// SHA-256 hashing functions procedure _SHA256; /// SHA-512 hashing functions procedure _SHA512; /// SHA-3 / Keccak hashing functions procedure _SHA3; /// AES encryption/decryption functions procedure _AES256; /// RC4 encryption function procedure _RC4; /// Base-64 encoding/decoding functions procedure _Base64; /// CompressShaAes() using SHA-256 / AES-256-CTR algorithm over SynLZ procedure _CompressShaAes; /// AES-based pseudorandom number generator procedure _TAESPNRG; /// CryptDataForCurrentUser() function procedure _CryptDataForCurrentUser; {$ifdef MSWINDOWS} /// CryptDataForCurrentUserAPI() function procedure _CryptDataForCurrentUserAPI; {$endif MSWINDOWS} {$ifndef NOVARIANTS} /// JWT classes procedure _JWT; {$endif NOVARIANTS} /// compute some performance numbers, mostly against regression procedure Benchmark; end; /// this test case will test ECDH and ECDSA cryptography as implemented // in the SynECC unit TTestECCCryptography = class(TSynTestCase) protected pub: array of TECCPublicKey; priv: array of TECCPrivateKey; sign: array of TECCSignature; hash: TECCHash; published /// avoid regression among platforms and compilers procedure ReferenceVectors; /// ECC private/public keys generation procedure _ecc_make_key; /// ECDSA signature computation procedure _ecdsa_sign; /// ECDSA signature verification procedure _ecdsa_verify; /// ECDH key derivation procedure _ecdh_shared_secret; /// ECDSA certificates chains and digital signatures procedure CertificatesAndSignatures; {$ifndef DELPHI5OROLDER} /// run most commands of the ECC tool procedure ECCCommandLineTool; {$endif} /// ECDHE stream protocol procedure ECDHEStreamProtocol; end; /// this test case will validate several low-level protocols TTestProtocols = class(TSynTestCase) published /// RTSP over HTTP, as implemented in SynProtoRTSPHTTP unit procedure RTSPOverHTTP; end; {$ifdef MSWINDOWS} {$ifndef LVCL} {$ifndef FPC} /// this test case will test most functions, classes and types defined and // implemented in the SynPDF unit TTestSynopsePDF = class(TSynTestCase) published /// create a PDF document, using the PDF Canvas property // - test font handling, especially standard font substitution procedure _TPdfDocument; /// create a PDF document, using a EMF content // - validates the EMF/TMetaFile enumeration, and its conversion into the // PDF content, including PDF-1.5 and page orientation // - this method will produce a .pdf file in the executable directory, // if you want to check out the result (it's simply a curve drawing, with // data from NIST) procedure _TPdfDocumentGDI; end; {$endif} {$endif} {$endif} {$ifndef DELPHI5OROLDER} {$ifndef LVCL} type TCollTest = class(TCollectionItem) private FLength: Integer; FColor: Integer; FName: RawUTF8; published property Color: Integer read FColor write FColor; property Length: Integer read FLength write FLength; property Name: RawUTF8 read FName write FName; end; TCollTestsI = class(TInterfacedCollection) protected class function GetClass: TCollectionItemClass; override; end; {$endif LVCL} type /// a parent test case which will test most functions, classes and types defined // and implemented in the mORMotSQLite3 unit, i.e. the SQLite3 engine itself // - it should not be called directly, but through TTestFileBased, // TTestMemoryBased and TTestMemoryBased children TTestSQLite3Engine = class(TSynTestCase) protected { these values are used internaly by the published methods below } BackupProgressStep: TSQLDatabaseBackupEventStep; // should be the first TempFileName: TFileName; EncryptedFile: boolean; Demo: TSQLDataBase; Req: RawUTF8; JS: RawUTF8; BackupTimer: TPrecisionTimer; function OnBackupProgress(Sender: TSQLDatabaseBackupThread): Boolean; published /// test direct access to the SQLite3 engine // - i.e. via TSQLDataBase and TSQLRequest classes procedure DatabaseDirectAccess; /// test direct access to the Virtual Table features of SQLite3 procedure VirtualTableDirectAccess; /// test the TSQLTableJSON table // - the JSON content generated must match the original data // - a VACCUM is performed, for testing some low-level SQLite3 engine // implementation // - the SortField feature is also tested procedure _TSQLTableJSON; /// test the TSQLRestClientDB, i.e. a local Client/Server driven usage // of the framework // - validates TSQLModel, TSQLRestServer and TSQLRestStorage by checking // the coherency of the data between client and server instances, after // update from both sides // - use all RESTful commands (GET/UDPATE/POST/DELETE...) // - test the 'many to many' features (i.e. TSQLRecordMany) and dynamic // arrays published properties handling // - test dynamic tables procedure _TSQLRestClientDB; {$ifdef TEST_REGEXP} /// check the PCRE-based REGEX function procedure RegexpFunction; {$endif TEST_REGEXP} /// test Master/Slave replication using TRecordVersion field procedure _TRecordVersion; end; /// this test case will test most functions, classes and types defined and // implemented in the mORMotSQLite3 unit, i.e. the SQLite3 engine itself, // with a file-based approach TTestFileBased = class(TTestSQLite3Engine); /// this test case will test most functions, classes and types defined and // implemented in the mORMotSQLite3 unit, i.e. the SQLite3 engine itself, // with a memory-based approach // - this class will also test the TSQLRestStorage class, and its // 100% Delphi simple database engine TTestMemoryBased = class(TTestSQLite3Engine) protected function CreateShardDB(maxshard: Integer): TSQLRestServer; published /// test the TSQLTableWritable table procedure _TSQLTableWritable; /// validate RTREE virtual tables procedure _RTree; /// validate TSQLRestStorageShardDB add operation, with or without batch procedure ShardWrite; /// validate TSQLRestStorageShardDB reading among all sharded databases procedure ShardRead; /// validate TSQLRestStorageShardDB reading after deletion of several shards procedure ShardReadAfterPurge; /// validate TSQLRestStorageShardDB.MaxShardCount implementation procedure _MaxShardCount; end; /// this test case will test most functions, classes and types defined and // implemented in the mORMotSQLite3 unit, i.e. the SQLite3 engine itself, // with a file-based approach // - purpose of this class is to test Write-Ahead Logging for the database TTestFileBasedWAL = class(TTestFileBased); /// this test case will test most functions, classes and types defined and // implemented in the mORMotSQLite3 unit, i.e. the SQLite3 engine itself, // with a file-based approach // - purpose of this class is to test Memory-Mapped I/O for the database TTestFileBasedMemoryMap = class(TTestFileBased); /// this test case will test most functions, classes and types defined and // implemented in the mORMotSQLite3 unit, i.e. the SQLite3 engine itself, // used as a HTTP/1.1 server and client // - test a HTTP/1.1 server and client on the port 888 of the local machine // - require the 'test.db3' SQLite3 database file, as created by TTestFileBased TTestClientServerAccess = class(TSynTestCase) protected { these values are used internaly by the published methods below } Model: TSQLModel; DataBase: TSQLRestServerDB; Server: TSQLHttpServer; Client: TSQLRestClientURI; /// perform the tests of the current Client instance procedure ClientTest; /// release used instances (e.g. http server) and memory procedure CleanUp; override; public /// this could be called as administrator for THttpApiServer to work {$ifdef MSWINDOWS} class function RegisterAddUrl(OnlyDelete: boolean): string; {$endif} published /// initialize a TSQLHttpServer instance // - uses the 'test.db3' SQLite3 database file generated by TTestSQLite3Engine // - creates and validates a HTTP/1.1 server on the port 888 of the local // machine, using the THttpApiServer (using kernel mode http.sys) class // if available procedure _TSQLHttpServer; /// validate the HTTP/1.1 client implementation // - by using a request of all records data procedure _TSQLHttpClient; /// validate the HTTP/1.1 client multi-query implementation with one // connection for the all queries // - this method keep alive the HTTP connection, so is somewhat faster // - it runs 1000 remote SQL queries, and check the JSON data retrieved // - the time elapsed for this step is computed, and displayed on the report procedure HTTPClientKeepAlive; /// validate the HTTP/1.1 client multi-query implementation with one // connection initialized per query // - this method don't keep alive the HTTP connection, so is somewhat slower: // a new HTTP connection is created for every query // - it runs 1000 remote SQL queries, and check the JSON data retrieved // - the time elapsed for this step is computed, and displayed on the report procedure HTTPClientMultiConnect; /// validate the HTTP/1.1 client multi-query implementation with one // connection for the all queries and our proprietary SHA-256 / AES-256-CTR // encryption encoding // - it runs 1000 remote SQL queries, and check the JSON data retrieved // - the time elapsed for this step is computed, and displayed on the report procedure HTTPClientEncrypted; /// validates TSQLRest.SetCustomEncryption process with AES+SHA procedure HTTPClientCustomEncryptionAesSha; /// validates TSQLRest.SetCustomEncryption process with only AES procedure HTTPClientCustomEncryptionAes; /// validates TSQLRest.SetCustomEncryption process with only SHA procedure HTTPClientCustomEncryptionSha; { /// validate the HTTP/1.1 client multi-query implementation with one // connection for all queries, and the THttpServer class instead // of the THttpApiServer kernel mode server procedure HTTPClientKeepAliveDelphi; /// validate the HTTP/1.1 client multi-query implementation with one // connection initialized per query, and the THttpServer class instead // of the THttpApiServer kernel mode server // - this method don't keep alive the HTTP connection, so is somewhat slower: // a new HTTP connection is created for every query procedure HTTPClientMultiConnectDelphi; } {$ifdef MSWINDOWS} /// validate the Named-Pipe client implementation // - it first launch the Server as Named-Pipe // - it then runs 1000 remote SQL queries, and check the JSON data retrieved // - the time elapsed for this step is computed, and displayed on the report procedure NamedPipeAccess; /// validate the Windows Windows Messages based client implementation // - it first launch the Server to handle Windows Messages // - it then runs 1000 remote SQL queries, and check the JSON data retrieved // - the time elapsed for this step is computed, and displayed on the report procedure LocalWindowMessages; /// validate the client implementation, using direct access to the server // - it connects directly the client to the server, therefore use the same // process and memory during the run: it's the fastest possible way of // communicating // - it then runs 1000 remote SQL queries, and check the JSON data retrieved // - the time elapsed for this step is computed, and displayed on the report {$endif} procedure DirectInProcessAccess; /// validate HTTP/1.1 client-server with multiple TSQLRestServer instances procedure HTTPSeveralDBServers; end; /// this class defined two published methods of type TSQLRestServerCallBack in // order to test the Server-Side ModelRoot/TableName/ID/MethodName RESTful model TSQLRestServerTest = class(TSQLRestServerDB) published /// test ModelRoot/People/ID/DataAsHex // - this method is called by TSQLRestServer.URI when a // ModelRoot/People/ID/DataAsHex GET request is provided // - Parameters values are not used here: this service only need aRecord.ID // - SentData is set with incoming data from a PUT method // - if called from ModelRoot/People/ID/DataAsHex with GET or PUT methods, // TSQLRestServer.URI will create a TSQLRecord instance and set its ID // (but won't retrieve its other field values automaticaly) // - if called from ModelRoot/People/DataAsHex with GET or PUT methods, // TSQLRestServer.URI will leave aRecord.ID=0 before launching it // - if called from ModelRoot/DataAsHex with GET or PUT methods, // TSQLRestServer.URI will leave aRecord=nil before launching it // - implementation must return the HTTP error code (e.g. 200 as success) // - Table is overloaded as TSQLRecordPeople here, and still match the // TSQLRestServerCallBack prototype: but you have to check the class // at runtime: it can be called by another similar but invalid URL, like // ModelRoot/OtherTableName/ID/DataAsHex procedure DataAsHex(Ctxt: TSQLRestServerURIContext); /// method used to test the Server-Side ModelRoot/Sum or // ModelRoot/People/Sum Requests with JSON process // - implementation of this method returns the sum of two floating-points, // named A and B, as in the public TSQLRecordPeople.Sum() method, // which implements the Client-Side of this service // - Table nor ID are never used here procedure Sum(Ctxt: TSQLRestServerURIContext); /// method used to test the Server-Side ModelRoot/Sum or // ModelRoot/People/Sum Requests with variant process procedure Sum2(Ctxt: TSQLRestServerURIContext); end; /// a test case which will test most external DB functions of the mORMotDB unit // - the external DB will be in fact a SynDBSQLite3 instance, expecting a // test.db3 SQlite3 file available in the current directory, populated with // some TSQLRecordPeople rows // - note that SQL statement caching at SQLite3 engine level makes those test // 2 times faster: nice proof of performance improvement TTestExternalDatabase = class(TSynTestCase) protected fExternalModel: TSQLModel; fPeopleData: TSQLTable; /// called by ExternalViaREST/ExternalViaVirtualTable and // ExternalViaRESTWithChangeTracking tests method procedure Test(StaticVirtualTableDirect, TrackChanges: boolean); public /// release used instances (e.g. server) and memory procedure CleanUp; override; published {$ifndef LVCL} /// test TQuery emulation class procedure _TQuery; {$endif} /// test SynDB connection remote access via HTTP procedure _SynDBRemote; /// test TSQLDBConnectionProperties persistent as JSON procedure DBPropertiesPersistence; /// initialize needed RESTful client (and server) instances // - i.e. a RESTful direct access to an external DB procedure ExternalRecords; /// check the SQL auto-adaptation features procedure AutoAdaptSQL; /// check the per-db encryption // - the testpass.db3-wal file is not encrypted, but the main // testpass.db3 file will procedure CryptedDatabase; /// test external DB implementation via faster REST calls // - will mostly call directly the TSQLRestStorageExternal instance, // bypassing the Virtual Table mechanism of SQLite3 procedure ExternalViaREST; /// test external DB implementation via slower Virtual Table calls // - using the Virtual Table mechanism of SQLite3 is more than 2 times // slower than direct REST access procedure ExternalViaVirtualTable; /// test external DB implementation via faster REST calls and change tracking // - a TSQLRecordHistory table will be used to store record history procedure ExternalViaRESTWithChangeTracking; {$ifndef CPU64} {$ifndef LVCL} {$ifdef MSWINDOWS} /// test external DB using the JET engine procedure JETDatabase; {$endif} {$endif} {$endif} {$ifdef MSWINDOWS} {$ifdef USEZEOS} /// test external Firebird embedded engine via Zeos/ZDBC (if available) procedure FirebirdEmbeddedViaZDBCOverHTTP; {$endif} {$endif} end; /// a test case for multi-threading abilities of the framework // - will test all direct or remote access protocols with a growing number // of concurrent clients (1,2,5,10,30,50 concurent threads), to ensure // stability, scalibility and safety of the framework TTestMultiThreadProcess = class(TSynTestCase) protected fModel: TSQLModel; fDatabase: TSQLRestServerDB; fTestClass: TSQLRestClass; fThreads: TSynObjectList; fRunningThreadCount: integer; fHttpServer: TSQLHttpServer; fMinThreads: integer; fMaxThreads: integer; fOperationCount: integer; fClientPerThread: integer; fClientOnlyServerIP: RawByteString; fTimer: TPrecisionTimer; procedure DatabaseClose; procedure Test(aClass: TSQLRestClass; aHttp: TSQLHttpServerOptions=HTTP_DEFAULT_MODE; aWriteMode: TSQLRestServerAcquireMode=amLocked); function CreateClient: TSQLRest; public /// create the test case instance constructor Create(Owner: TSynTests; const Ident: string = ''); override; /// release used instances (e.g. server) and memory procedure CleanUp; override; /// if not '', forces the test not to initiate any server and connnect to // the specified server IP address property ClientOnlyServerIP: RawByteString read fClientOnlyServerIP write fClientOnlyServerIP; /// the minimum number of threads used for this test // - is 1 by default property MinThreads: integer read fMinThreads write fMinThreads; /// the maximum number of threads used for this test // - is 50 by default property MaxThreads: integer read fMaxThreads write fMaxThreads; /// how many Add() + Retrieve() operations are performed during each test // - is 200 by default, i.e. 200 Add() plus 200 Retrieve() globally property OperationCount: integer read fOperationCount write fOperationCount; /// how many TSQLRest instance is initialized per thread // - is 1 by default property ClientPerThread: Integer read fClientPerThread write fClientPerThread; published /// initialize fDatabase and create MaxThreads threads for clients procedure CreateThreadPool; /// direct test of its RESTful methods procedure _TSQLRestServerDB; /// test via TSQLRestClientDB instances procedure _TSQLRestClientDB; {$ifdef MSWINDOWS} /// test via TSQLRestClientURINamedPipe instances procedure _TSQLRestClientURINamedPipe; /// test via TSQLRestClientURIMessage instances procedure _TSQLRestClientURIMessage; {$endif} {$ifndef ONLYUSEHTTPSOCKET} /// test via TSQLHttpClientWinHTTP instances over http.sys (HTTP API) server procedure WindowsAPI; {$endif} /// test via TSQLHttpClientWinSock instances over OS's socket API server // - this test won't work within the Delphi IDE debugger procedure SocketAPI; //// test via TSQLHttpClientWebsockets instances procedure Websockets; {$ifdef USELIBCURL} /// test via TSQLHttpClientCurl using libcurl library procedure _libcurl; {$endif} /// test via TSQLRestClientDB instances with AcquireWriteMode=amLocked procedure Locked; /// test via TSQLRestClientDB instances with AcquireWriteMode=amUnlocked procedure Unlocked; {$ifndef LVCL} /// test via TSQLRestClientDB instances with AcquireWriteMode=amMainThread procedure MainThread; {$endif} /// test via TSQLRestClientDB instances with AcquireWriteMode=amBackgroundThread procedure BackgroundThread; end; /// SOA callback definition as expected by TTestBidirectionalRemoteConnection IBidirCallback = interface(IInvokable) ['{5C5818CC-FFBA-445C-82C1-39F45B84520C}'] procedure AsynchEvent(a: integer); function Value: Integer; end; /// SOA service definition as expected by TTestBidirectionalRemoteConnection IBidirService = interface(IInvokable) ['{0984A2DA-FD1F-49D6-ACFE-4D45CF08CA1B}'] function TestRest(a,b: integer; out c: RawUTF8): variant; function TestRestCustom(a: integer): TServiceCustomAnswer; function TestCallback(d: Integer; const callback: IBidirCallback): boolean; procedure LaunchAsynchCallback(a: integer); procedure RemoveCallback; end; TBidirServer = class(TInterfacedObject,IBidirService) protected fCallback: IBidirCallback; // IBidirService implementation methods function TestRest(a,b: integer; out c: RawUTF8): variant; function TestRestCustom(a: integer): TServiceCustomAnswer; function TestCallback(d: Integer; const callback: IBidirCallback): boolean; procedure LaunchAsynchCallback(a: integer); procedure RemoveCallback; public function LaunchSynchCallback: integer; end; /// a test case for all bidirectional remote access, e.g. WebSockets TTestBidirectionalRemoteConnection = class(TSynTestCase) protected fHttpServer: TSQLHttpServer; fServer: TSQLRestServerFullMemory; fBidirServer: TBidirServer; fPublicRelayClientsPort, fPublicRelayPort: SockString; fPublicRelay: TPublicRelay; fPrivateRelay: TPrivateRelay; procedure CleanUp; override; function NewClient(const port: SockString): TSQLHttpClientWebsockets; procedure WebsocketsLowLevel(protocol: TWebSocketProtocol; opcode: TWebSocketFrameOpCode); procedure TestRest(Rest: TSQLRest); procedure TestCallback(Rest: TSQLRest); procedure SOACallbackViaWebsockets(Ajax, Relay: boolean); published /// low-level test of our 'synopsejson' WebSockets JSON protocol procedure WebsocketsJSONProtocol; /// low-level test of our 'synopsebinary' WebSockets binary protocol procedure WebsocketsBinaryProtocol; procedure WebsocketsBinaryProtocolEncrypted; procedure WebsocketsBinaryProtocolCompressed; procedure WebsocketsBinaryProtocolCompressEncrypted; /// launch the WebSockets-ready HTTP server procedure RunHttpServer; /// test the callback mechanism via interface-based services on server side procedure SOACallbackOnServerSide; /// test callbacks via interface-based services over JSON WebSockets procedure SOACallbackViaJSONWebsockets; /// test callbacks via interface-based services over binary WebSockets procedure SOACallbackViaBinaryWebsockets; /// initialize SynProtoRelay tunnelling procedure RelayStart; /// test SynProtoRelay tunnelling over JSON WebSockets procedure RelaySOACallbackViaJSONWebsockets; /// verify ability to reconect from Private Relay to Public Relay procedure RelayConnectionRecreate; /// test SynProtoRelay tunnelling over binary WebSockets procedure RelaySOACallbackViaBinaryWebsockets; /// finalize SynProtoRelay tunnelling procedure RelayShutdown; /// test Master/Slave replication using TRecordVersion field over WebSockets procedure _TRecordVersion; end; type // This is our simple Test data class. Will be mapped to TSQLRecordDDDTest. TDDDTest = class(TSynPersistent) private fDescription: RawUTF8; published property Description: RawUTF8 read fDescription write fDescription; end; TDDDTestObjArray = array of TDDDTest; // The corresponding TSQLRecord for TDDDTest. TSQLRecordDDDTest = class(TSQLRecord) private fDescription: RawUTF8; published property Description: RawUTF8 read fDescription write fDescription; end; // CQRS Query Interface fo TTest IDDDThreadsQuery = interface(ICQRSService) ['{DD402806-39C2-4921-98AA-A575DD1117D6}'] function SelectByDescription(const aDescription: RawUTF8): TCQRSResult; function SelectAll: TCQRSResult; function Get(out aAggregate: TDDDTest): TCQRSResult; function GetAll(out aAggregates: TDDDTestObjArray): TCQRSResult; function GetNext(out aAggregate: TDDDTest): TCQRSResult; function GetCount: integer; end; // CQRS Command Interface for TTest IDDDThreadsCommand = interface(IDDDThreadsQuery) ['{F0E4C64C-B43A-491B-85E9-FD136843BFCB}'] function Add(const aAggregate: TDDDTest): TCQRSResult; function Update(const aUpdatedAggregate: TDDDTest): TCQRSResult; function Delete: TCQRSResult; function DeleteAll: TCQRSResult; function Commit: TCQRSResult; function Rollback: TCQRSResult; end; /// a test case for all shared DDD types and services TTestDDDSharedUnits = class(TSynTestCase) protected published /// test the User modelization types, including e.g. Address procedure UserModel; /// test the Authentication modelization types, and implementation procedure AuthenticationModel; /// test the Email validation process procedure EmailValidationProcess; /// test the CQRS Repository for TUser persistence procedure UserCQRSRepository; end; /// a test case for aggressive multi-threaded DDD ORM test TTestDDDMultiThread = class(TSynTestCase) private // Rest server fRestServer: TSQLRestServerDB; // Http server fHttpServer: TSQLHttpServer; /// will create as many Clients as specified by aClient. // - each client will perform as many Requests as specified by aRequests. // - this function will wait for all Clients until finished. function ClientTest(const aClients, aRequests: integer): boolean; protected /// cleaning up the test procedure CleanUp; override; published /// delete any old Test database on start procedure DeleteOldDatabase; /// start the whole DDD Server (http and rest) procedure StartServer; /// test straight-forward access using 1 thread and 1 client procedure SingleClientTest; /// test concurrent access with multiple clients procedure MultiThreadedClientsTest; end; /// a test class, used by TTestServiceOrientedArchitecture // - to test TPersistent objects used as parameters for remote service calls TComplexNumber = class(TPersistent) private fReal: Double; fImaginary: Double; public /// create an instance to store a complex number constructor Create(aReal, aImaginary: double); reintroduce; published /// the real part of this complex number property Real: Double read fReal write fReal; /// the imaginary part of this complex number property Imaginary: Double read fImaginary write fImaginary; end; /// a record used by IComplexCalculator.EchoRecord TConsultaNav = packed record MaxRows, Row0, RowCount: int64; IsSQLUpdateBack, EOF: boolean; end; /// a record used by IComplexCalculator.GetCustomer TCustomerData = packed record Id: Integer; AccountNum: RawUTF8; Name: RawUTF8; Address: RawUTF8; end; /// a test interface, used by TTestServiceOrientedArchitecture // - to test basic and high-level remote service calls ICalculator = interface(IInvokable) ['{9A60C8ED-CEB2-4E09-87D4-4A16F496E5FE}'] /// add two signed 32 bit integers function Add(n1,n2: integer): integer; /// multiply two signed 64 bit integers function Multiply(n1,n2: Int64): Int64; /// substract two floating-point values function Subtract(n1,n2: double): double; /// convert a currency value into text procedure ToText(Value: Currency; var Result: RawUTF8); /// convert a floating-point value into text function ToTextFunc(Value: double): string; /// swap two by-reference floating-point values // - would validate pointer use instead of XMM1/XMM2 registers under Win64 procedure Swap(var n1,n2: double); // test unaligned stack access function StackIntMultiply(n1,n2,n3,n4,n5,n6,n7,n8,n9,n10: integer): Int64; // test float stack access function StackFloatMultiply(n1,n2,n3,n4,n5,n6,n7,n8,n9,n10: double): Int64; /// do some work with strings, sets and enumerates parameters, // testing also var (in/out) parameters and set as a function result function SpecialCall(Txt: RawUTF8; var Int: integer; var Card: cardinal; field: TSynTableFieldTypes; fields: TSynTableFieldTypes; var options: TSynTableFieldOptions): TSynTableFieldTypes; /// test integer, strings and wide strings dynamic arrays, together with records function ComplexCall(const Ints: TIntegerDynArray; const Strs1: TRawUTF8DynArray; var Str2: TWideStringDynArray; const Rec1: TVirtualTableModuleProperties; var Rec2: TSQLRestCacheEntryValue; Float1: double; var Float2: double): TSQLRestCacheEntryValue; /// validates ArgsInputIsOctetStream raw binary upload function DirectCall(const Data: TSQLRawBlob): integer; /// validates huge RawJSON/RawUTF8 function RepeatJsonArray(const item: RawUTF8; count: integer): RawJSON; function RepeatTextArray(const item: RawUTF8; count: integer): RawUTF8; end; /// a test interface, used by TTestServiceOrientedArchitecture // - to test remote service calls with objects as parameters (its published // properties will be serialized as standard JSON objects) // - since it inherits from ICalculator interface, it will also test // the proper interface inheritance handling (i.e. it will test that // ICalculator methods are also available) IComplexCalculator = interface(ICalculator) ['{8D0F3839-056B-4488-A616-986CF8D4DEB7}'] /// purpose of this method is to substract two complex numbers // - using class instances as parameters procedure Substract(n1,n2: TComplexNumber; out Result: TComplexNumber); /// purpose of this method is to check for boolean handling function IsNull(n: TComplexNumber): boolean; /// this will test the BLOB kind of remote answer function TestBlob(n: TComplexNumber): TServiceCustomAnswer; {$ifndef NOVARIANTS} /// test variant kind of parameters function TestVariants(const Text: RawUTF8; V1: Variant; var V2: variant): variant; {$endif} {$ifndef LVCL} /// test in/out collections procedure Collections(Item: TCollTest; var List: TCollTestsI; out Copy: TCollTestsI); {$endif} /// returns the thread ID running the method on server side function GetCurrentThreadID: PtrUInt; /// validate record transmission function GetCustomer(CustomerId: Integer; out CustomerData: TCustomerData): Boolean; //// validate TSQLRecord transmission procedure FillPeople(var People: TSQLRecordPeople); {$ifdef UNICODE} /// validate simple record transmission // - older Delphi versions (e.g. 6-7) do not allow records without // nested reference-counted types function EchoRecord(const Nav: TConsultaNav): TConsultaNav; {$endif} end; /// a test interface, used by TTestServiceOrientedArchitecture // - to test sicClientDriven implementation pattern: data will remain on // the server until the IComplexNumber instance is out of scope IComplexNumber = interface(IInvokable) ['{29D753B2-E7EF-41B3-B7C3-827FEB082DC1}'] procedure Assign(aReal, aImaginary: double); function GetImaginary: double; function GetReal: double; procedure SetImaginary(const Value: double); procedure SetReal(const Value: double); procedure Add(aReal, aImaginary: double); property Real: double read GetReal write SetReal; property Imaginary: double read GetImaginary write SetImaginary; end; /// a test interface, used by TTestServiceOrientedArchitecture // - to test sicPerUser implementation pattern ITestUser = interface(IInvokable) ['{EABB42BF-FD08-444A-BF9C-6B73FA4C4788}'] function GetContextSessionID: integer; function GetContextSessionUser: integer; function GetContextSessionGroup: integer; end; /// a test interface, used by TTestServiceOrientedArchitecture // - to test sicPerGroup implementation pattern ITestGroup = interface(ITestUser) ['{DCBA5A38-62CC-4A52-8639-E709B31DDCE1}'] end; /// a test interface, used by TTestServiceOrientedArchitecture // - to test sicPerSession implementation pattern ITestSession = interface(ITestUser) ['{5237A687-C0B2-46BA-9F39-BEEA7C3AA6A9}'] end; /// a test interface, used by TTestServiceOrientedArchitecture // - to test threading implementation pattern ITestPerThread = interface(IInvokable) ['{202B6C9F-FCCB-488D-A425-5472554FD9B1}'] function GetContextServiceInstanceID: PtrUInt; function GetThreadIDAtCreation: PtrUInt; function GetCurrentThreadID: PtrUInt; function GetCurrentRunningThreadID: PtrUInt; end; /// a test value object, used by IUserRepository/ISmsSender interfaces // - to test stubing/mocking implementation pattern TUser = record Name: RawUTF8; Password: RawUTF8; MobilePhoneNumber: RawUTF8; ID: Integer; end; /// a test interface, used by TTestServiceOrientedArchitecture // - to test stubing/mocking implementation pattern IUserRepository = interface(IInvokable) ['{B21E5B21-28F4-4874-8446-BD0B06DAA07F}'] function GetUserByName(const Name: RawUTF8): TUser; procedure Save(const User: TUser); end; /// a test interface, used by TTestServiceOrientedArchitecture // - to test stubing/mocking implementation pattern ISmsSender = interface(IInvokable) ['{8F87CB56-5E2F-437E-B2E6-B3020835DC61}'] function Send(const Text, Number: RawUTF8): boolean; end; const IID_ICalculator: TGUID = '{9A60C8ED-CEB2-4E09-87D4-4A16F496E5FE}'; type TTestServiceInstances = record I: ICalculator; CC: IComplexCalculator; CN: IComplexNumber; CU: ITestUser; CG: ITestGroup; CS: ITestSession; CT: ITestPerThread; ExpectedSessionID: integer; ExpectedUserID: integer; ExpectedGroupID: integer; end; /// a test case which will test the interface-based SOA implementation of // the mORMot framework TTestServiceOrientedArchitecture = class(TSynTestCase) protected fModel: TSQLModel; fClient: TSQLRestClientDB; procedure Test(const Inst: TTestServiceInstances; Iterations: Cardinal=700); procedure ClientTest(aRouting: TSQLRestServerURIContextClass; aAsJSONObject: boolean; {$ifndef LVCL}aRunInOtherThread: boolean=false;{$endif} aOptions: TServiceMethodOptions=[]); procedure ClientAlgo(algo: TSQLRestServerAuthenticationSignedURIAlgo); class function CustomReader(P: PUTF8Char; var aValue; out aValid: Boolean{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; class procedure CustomWriter(const aWriter: TTextWriter; const aValue); procedure SetOptions(aAsJSONObject: boolean; aOptions: TServiceMethodOptions); procedure IntSubtractJSON(Ctxt: TOnInterfaceStubExecuteParamsJSON); {$ifndef NOVARIANTS} procedure IntSubtractVariant(Ctxt: TOnInterfaceStubExecuteParamsVariant); procedure IntSubtractVariantVoid(Ctxt: TOnInterfaceStubExecuteParamsVariant); {$endif} /// release used instances (e.g. http server) and memory procedure CleanUp; override; public published /// test the SetWeak/SetWeakZero weak interface functions procedure WeakInterfaces; /// initialize the SOA implementation procedure ServiceInitialization; /// test direct call to the class instance procedure DirectCall; /// test the server-side implementation procedure ServerSide; /// test the client-side implementation in RESTful mode procedure ClientSideREST; /// test the client-side in RESTful mode with values transmitted as JSON objects procedure ClientSideRESTAsJSONObject; /// test the client-side in RESTful mode with full session statistics procedure ClientSideRESTSessionsStats; /// test the client-side implementation of optExecLockedPerInterface procedure ClientSideRESTLocked; {$ifndef LVCL} /// test the client-side implementation of opt*InMainThread option procedure ClientSideRESTMainThread; /// test the client-side implementation of opt*InPerInterfaceThread option procedure ClientSideRESTBackgroundThread; {$endif} /// test the client-side implementation with crc32c URI signature procedure ClientSideRESTSignWithCrc32c; /// test the client-side implementation with xxHash32 URI signature procedure ClientSideRESTSignWithXxhash; /// test the client-side implementation with MD5 URI signature procedure ClientSideRESTSignWithMd5; /// test the client-side implementation with SHA256 URI signature procedure ClientSideRESTSignWithSha256; /// test the client-side implementation with SHA512 URI signature procedure ClientSideRESTSignWithSha512; /// test the client-side implementation using TSQLRestServerAuthenticationNone procedure ClientSideRESTWeakAuthentication; /// test the client-side implementation using TSQLRestServerAuthenticationHttpBasic procedure ClientSideRESTBasicAuthentication; /// test the custom record JSON serialization procedure ClientSideRESTCustomRecordLayout; /// test the client-side in RESTful mode with all calls logged in a table procedure ClientSideRESTServiceLogToDB; /// test the client-side implementation in JSON-RPC mode procedure ClientSideJSONRPC; /// test REStful mode using HTTP client/server communication procedure TestOverHTTP; /// test the security features procedure Security; /// test interface stubbing / mocking procedure MocksAndStubs; end; {$endif DELPHI5OROLDER} implementation uses {$ifndef DELPHI5OROLDER} TestSQL3FPCInterfaces, {$endif} {$ifndef LVCL} SyncObjs, {$endif} {$ifdef MSWINDOWS} PasZip, {$ifndef FPC} {$ifdef ISDELPHIXE2} VCL.Graphics, {$else} Graphics, {$endif} {$endif} {$endif} SynCrypto, SynZip, SynLZO, SynLZ, SynLizard; { TTestLowLevelCommon } procedure TTestLowLevelCommon._CamelCase; var v: RawUTF8; begin v := UnCamelCase('On'); Check(v='On'); v := UnCamelCase('ON'); Check(v='ON'); v := UnCamelCase('OnLine'); Check(v='On line'); v := UnCamelCase('OnLINE'); Check(v='On LINE'); v := UnCamelCase('OnMyLINE'); Check(v='On my LINE'); v := UnCamelCase('On_MyLINE'); Check(v='On - My LINE'); v := UnCamelCase('On__MyLINE'); Check(v='On: My LINE'); v := UnCamelCase('Email1'); Check(v='Email 1'); v := UnCamelCase('Email12'); Check(v='Email 12'); v := UnCamelCase('KLMFlightNumber'); Check(v='KLM flight number'); v := UnCamelCase('GoodBBCProgram'); Check(v='Good BBC program'); end; function GetBitsCount64(const Bits; Count: PtrInt): PtrInt; begin // reference implementation result := 0; while Count>0 do begin dec(Count); if Count in TBits64(Bits) then // bt dword[rdi],edx is slow in such a loop inc(result); // ... but correct :) end; end; function GetBitsCountPurePascal(value: PtrInt): PtrInt; begin result := value; {$ifdef CPU64} result := result-((result shr 1) and $5555555555555555); result := (result and $3333333333333333)+((result shr 2) and $3333333333333333); result := (result+(result shr 4)) and $0f0f0f0f0f0f0f0f; inc(result,result shr 8); // avoid slow multiplication inc(result,result shr 16); inc(result,result shr 32); result := result and $7f; {$else} result := result-((result shr 1) and $55555555); result := (result and $33333333)+((result shr 2) and $33333333); result := (result+(result shr 4)) and $0f0f0f0f; inc(result,result shr 8); inc(result,result shr 16); result := result and $3f; {$endif CPU64} end; procedure TTestLowLevelCommon.Bits; const N = 1000000; procedure TestPopCnt(const ctxt: string); var timer: TPrecisionTimer; i,c: integer; v: QWord; begin CheckEqual(GetBitsCountPtrInt(0),0); CheckEqual(GetBitsCountPtrInt($f),4); CheckEqual(GetBitsCountPtrInt($ff),8); CheckEqual(GetBitsCountPtrInt($fff),12); CheckEqual(GetBitsCountPtrInt($ffff),16); CheckEqual(GetBitsCountPtrInt(-1),POINTERBITS); v := PtrUInt(-1); CheckEqual(GetBitsCount(v,0),0); CheckEqual(GetBitsCount64(v,0),0); for i := 0 to POINTERBITS-1 do begin CheckEqual(GetBitsCountPtrInt(PtrInt(1) shl i),1); if i get true random now end; procedure TTestLowLevelCommon.Curr64; var tmp: string[63]; i, err: Integer; V1: currency; V2: TSynExtended; i64: Int64; v: RawUTF8; begin Check(TruncTo2Digits(1)=1); Check(TruncTo2Digits(1.05)=1.05); Check(TruncTo2Digits(1.051)=1.05); Check(TruncTo2Digits(1.0599)=1.05); Check(TruncTo2Digits(-1)=-1); Check(TruncTo2Digits(-1.05)=-1.05); Check(TruncTo2Digits(-1.051)=-1.05); Check(TruncTo2Digits(-1.0599)=-1.05); Check(SimpleRoundTo2Digits(1)=1); Check(SimpleRoundTo2Digits(1.05)=1.05); Check(SimpleRoundTo2Digits(1.051)=1.05); Check(SimpleRoundTo2Digits(1.0549)=1.05); Check(SimpleRoundTo2Digits(1.0550)=1.05); Check(SimpleRoundTo2Digits(1.0551)=1.06); Check(SimpleRoundTo2Digits(1.0599)=1.06); Check(SimpleRoundTo2Digits(-1)=-1); Check(SimpleRoundTo2Digits(-1.05)=-1.05); Check(SimpleRoundTo2Digits(-1.051)=-1.05); Check(SimpleRoundTo2Digits(-1.0549)=-1.05); Check(SimpleRoundTo2Digits(-1.0550)=-1.05); Check(SimpleRoundTo2Digits(-1.0551)=-1.06); Check(SimpleRoundTo2Digits(-1.0599)=-1.06); Check(StrToCurr64('.5')=5000); Check(StrToCurr64('.05')=500); Check(StrToCurr64('.005')=50); Check(StrToCurr64('.0005')=5); Check(StrToCurr64('.00005')=0); Check(StrToCurr64('0.5')=5000); Check(StrToCurr64('0.05')=500); Check(StrToCurr64('0.005')=50); Check(StrToCurr64('0.0005')=5); Check(StrToCurr64('0.00005')=0); Check(StrToCurr64('1.5')=15000); Check(StrToCurr64('1.05')=10500); Check(StrToCurr64('1.005')=10050); Check(StrToCurr64('1.0005')=10005); Check(StrToCurr64('1.00005')=10000); Check(StrToCurr64(pointer(Curr64ToStr(1)))=1); Check(StrToCurr64(pointer(Curr64ToStr(12)))=12); Check(StrToCurr64(pointer(Curr64ToStr(123)))=123); Check(StrToCurr64(pointer(Curr64ToStr(1234)))=1234); Check(StrToCurr64(pointer(Curr64ToStr(12345)))=12345); Check(StrToCurr64(pointer(Curr64ToStr(123456)))=123456); Check(StrToCurr64(pointer(Curr64ToStr(12340000)))=12340000); Check(StrToCurr64(pointer(Curr64ToStr(12345000)))=12345000); Check(StrToCurr64(pointer(Curr64ToStr(12345600)))=12345600); Check(StrToCurr64(pointer(Curr64ToStr(12345670)))=12345670); Check(StrToCurr64(pointer(Curr64ToStr(12345678)))=12345678); tmp[0] := AnsiChar(Curr64ToPChar(1,@tmp[1])); Check(tmp='0.0001'); tmp[0] := AnsiChar(Curr64ToPChar(12,@tmp[1])); Check(tmp='0.0012'); tmp[0] := AnsiChar(Curr64ToPChar(123,@tmp[1])); Check(tmp='0.0123'); tmp[0] := AnsiChar(Curr64ToPChar(1234,@tmp[1])); Check(tmp='0.1234'); for i := 0 to 5000 do begin if i<500 then V1 := i*3 else V1 := Random*(Int64(MaxInt)*10); if Random(10)<4 then V1 := -V1; v := Curr64ToStr(PInt64(@V1)^); tmp[0] := AnsiChar(Curr64ToPChar(PInt64(@V1)^,@tmp[1])); Check(RawUTF8(tmp)=v); V2 := GetExtended(pointer(v),err); Check(err=0); CheckSame(V1,V2,1E-4); i64 := StrToCurr64(pointer(v)); Check(PInt64(@V1)^=i64); end; end; procedure TTestLowLevelCommon.FastStringCompare; begin Check(CompareText('','')=0); Check(CompareText('abcd','')>0); Check(CompareText('','abcd')<0); Check(StrCompFast(nil,nil)=0); Check(StrCompFast(PAnsiChar('abcD'),nil)=1); Check(StrCompFast(nil,PAnsiChar('ABcd'))=-1); Check(StrCompFast(PAnsiChar('ABCD'),PAnsiChar('ABCD'))=0); Check(StrCompFast(PAnsiChar('ABCD'),PAnsiChar('ABCE'))=-1); Check(StrCompFast(PAnsiChar('ABCD'),PAnsiChar('ABCC'))=1); Check(StrIComp(nil,nil)=0); Check(StrIComp(PAnsiChar('abcD'),nil)=1); Check(StrIComp(nil,PAnsiChar('ABcd'))=-1); Check(StrIComp(PAnsiChar('abcD'),PAnsiChar('ABcd'))=0); Check(StrIComp(PAnsiChar('abcD'),PAnsiChar('ABcF'))= StrComp(PAnsiChar('ABCD'),PAnsiChar('ABCF'))); Check(StrComp(PAnsiChar('ABCD'),PAnsiChar('ABCE'))=-1); Check(StrComp(PAnsiChar('ABCD'),PAnsiChar('ABCC'))=1); Check(StrComp(nil,nil)=0); Check(StrComp(PAnsiChar('ABCD'),PAnsiChar('ABCD'))=0); Check(StrComp(PAnsiChar('ABCD'),PAnsiChar('ABCE'))=-1); Check(StrComp(PAnsiChar('ABCD'),PAnsiChar('ABCC'))=1); Check(SynCommons.AnsiIComp(pointer(PAnsiChar('abcD')),pointer(PAnsiChar('ABcd')))=0); Check(SynCommons.AnsiIComp(pointer(PAnsiChar('abcD')),pointer(PAnsiChar('ABcF')))= StrComp(PAnsiChar('ABCD'),PAnsiChar('ABCF'))); Check(StrIComp(PAnsiChar('abcD'),PAnsiChar('ABcd'))= SynCommons.AnsiIComp(PAnsiChar('abcD'),PAnsiChar('ABcd'))); Check(StrIComp(PAnsiChar('abcD'),PAnsiChar('ABcF'))= SynCommons.AnsiIComp(PAnsiChar('ABCD'),PAnsiChar('ABCF'))); Check(strcspn(PAnsiChar('ab'),PAnsiChar('a'#0))=0); Check(strcspn(PAnsiChar('ab'),PAnsiChar('b'#0))=1); Check(strcspn(PAnsiChar('1234ab'),PAnsiChar('a'#0))=4); Check(strcspn(PAnsiChar('12345ab'),PAnsiChar('a'#0))=5); Check(strcspn(PAnsiChar('123456ab'),PAnsiChar('a'#0))=6); Check(strcspn(PAnsiChar('1234567ab'),PAnsiChar('a'#0))=7); Check(strcspn(PAnsiChar('12345678ab'),PAnsiChar('a'#0))=8); Check(strcspn(PAnsiChar('1234ab'),PAnsiChar('c'#0))=6); Check(strcspnpas(PAnsiChar('ab'),PAnsiChar('a'#0))=0); Check(strcspnpas(PAnsiChar('ab'),PAnsiChar('b'#0))=1); Check(strcspnpas(PAnsiChar('1234ab'),PAnsiChar('a'#0))=4); Check(strcspnpas(PAnsiChar('12345ab'),PAnsiChar('a'#0))=5); Check(strcspnpas(PAnsiChar('123456ab'),PAnsiChar('a'#0))=6); Check(strcspnpas(PAnsiChar('1234567ab'),PAnsiChar('a'#0))=7); Check(strcspnpas(PAnsiChar('12345678ab'),PAnsiChar('a'#0))=8); Check(strcspnpas(PAnsiChar('1234ab'),PAnsiChar('c'#0))=6); Check(strcspnpas(PAnsiChar('12345678901234567ab'),PAnsiChar('cccccccccccccccccccd'))=19); Assert(strspn(PAnsiChar('abcdef'),PAnsiChar('debca'))=5); Assert(strspn(PAnsiChar('baabbaabcd'),PAnsiChar('ab'))=8); Assert(strspnpas(PAnsiChar('abcdef'),PAnsiChar('g'#0))=0); Assert(strspnpas(PAnsiChar('abcdef'),PAnsiChar('a'#0))=1); Assert(strspnpas(PAnsiChar('bbcdef'),PAnsiChar('b'#0))=2); Assert(strspnpas(PAnsiChar('bbcdef'),PAnsiChar('bf'))=2); Assert(strspnpas(PAnsiChar('bcbdef'),PAnsiChar('cb'))=3); Assert(strspnpas(PAnsiChar('baabcd'),PAnsiChar('ab'))=4); Assert(strspnpas(PAnsiChar('abcdef'),PAnsiChar('debca'))=5); Assert(strspnpas(PAnsiChar('baabbaabcd'),PAnsiChar('ab'))=8); Assert(strspnpas(PAnsiChar('baabbaabbaabcd'),PAnsiChar('ab'))=12); Assert(strspnpas(PAnsiChar('baabbaabbaabbabcd'),PAnsiChar('ab'))=15); Assert(strspnpas(PAnsiChar('baabbaabbaabbaabcd'),PAnsiChar('ab'))=16); Assert(strspnpas(PAnsiChar('baabbaabbaababaabcd'),PAnsiChar('ab'))=17); {$ifndef ABSOLUTEPASCAL} {$ifdef CPUINTEL} if cfSSE42 in CpuFeatures then begin Check(strcspnsse42(PAnsiChar('ab'),PAnsiChar('a'#0))=0); Check(strcspnsse42(PAnsiChar('ab'),PAnsiChar('b'#0))=1); Check(strcspnsse42(PAnsiChar('1234ab'),PAnsiChar('a'#0))=4); Check(strcspnsse42(PAnsiChar('12345ab'),PAnsiChar('a'#0))=5); Check(strcspnsse42(PAnsiChar('123456ab'),PAnsiChar('a'#0))=6); Check(strcspnsse42(PAnsiChar('1234567ab'),PAnsiChar('a'#0))=7); Check(strcspnsse42(PAnsiChar('12345678ab'),PAnsiChar('a'#0))=8); Check(strcspnsse42(PAnsiChar('123456789ab'),PAnsiChar('a'#0))=9); Check(strcspnsse42(PAnsiChar('1234ab'),PAnsiChar('c'#0))=6); Check(strcspnsse42(PAnsiChar('123456789012345ab'),PAnsiChar('a'#0))=15); Check(strcspnsse42(PAnsiChar('1234567890123456ab'),PAnsiChar('a'#0))=16); Check(strcspnsse42(PAnsiChar('12345678901234567ab'),PAnsiChar('a'#0))=17); Check(strcspnsse42(PAnsiChar('12345678901234567ab'),PAnsiChar('cccccccccccccca'))=17); Check(strcspnsse42(PAnsiChar('12345678901234567ab'),PAnsiChar('ccccccccccccccca'))=17); Check(strcspnsse42(PAnsiChar('12345678901234567ab'),PAnsiChar('cccccccccccccccca'))=17); Check(strcspnsse42(PAnsiChar('12345678901234567ab'),PAnsiChar('ccccccccccccccccca'))=17); Check(strcspnsse42(PAnsiChar('12345678901234567ab'),PAnsiChar('ccccccccccccccccccca'))=17); Check(strcspnsse42(PAnsiChar('12345678901234567ab'),PAnsiChar('cccccccccccccccccccd'))=19); Check(strspnsse42(PAnsiChar('abcdef'),PAnsiChar('g'#0))=0); Check(strspnsse42(PAnsiChar('abcdef'),PAnsiChar('a'#0))=1); Check(strspnsse42(PAnsiChar('bbcdef'),PAnsiChar('b'#0))=2); Check(strspnsse42(PAnsiChar('bbcdef'),PAnsiChar('bf'))=2); Check(strspnsse42(PAnsiChar('bcbdef'),PAnsiChar('cb'))=3); Check(strspnsse42(PAnsiChar('baabcd'),PAnsiChar('ab'))=4); Check(strspnsse42(PAnsiChar('abcdef'),PAnsiChar('debca'))=5); Check(strspnsse42(PAnsiChar('baabbaabcd'),PAnsiChar('ab'))=8); Check(strspnsse42(PAnsiChar('baabbaabbaabcd'),PAnsiChar('ab'))=12); Check(strspnsse42(PAnsiChar('baabbaabbaabbabcd'),PAnsiChar('ab'))=15); Check(strspnsse42(PAnsiChar('baabbaabbaabbaabcd'),PAnsiChar('ab'))=16); Check(strspnsse42(PAnsiChar('baabbaabbaababaabcd'),PAnsiChar('ab'))=17); end; {$endif CPUINTEL} {$endif ABSOLUTEPASCAL} end; procedure TTestLowLevelCommon.IniFiles; var Content,S,N,V: RawUTF8; Si,Ni,Vi,i,j: integer; P: PUTF8Char; begin Content := ''; Randomize; //RandSeed := 10; for i := 1 to 1000 do begin Si := Random(20); Ni := Random(50); Vi := Si*Ni+Ni; if Si=0 then S := '' else S := 'Section'+{$ifndef ENHANCEDRTL}Int32ToUtf8{$else}IntToStr{$endif}(Si); N := {$ifndef ENHANCEDRTL}Int32ToUtf8{$else}IntToStr{$endif}(Ni); V := {$ifndef ENHANCEDRTL}Int32ToUtf8{$else}IntToStr{$endif}(Vi); UpdateIniEntry(Content,S,N,V); for j := 1 to 5 do Check(FindIniEntry(Content,S,N)=V,'FindIniEntry'); Check(FindIniEntry(Content,S,'no')=''); Check(FindIniEntry(Content,'no',N)=''); end; Check(FileFromString(Content,'test.ini'),'test.ini'); Check(FileSynLZ('test.ini','test.ini.synlz',$ABA51051),'synLZ'); if CheckFailed(FileUnSynLZ('test.ini.synlz','test2.ini',$ABA51051),'unSynLZ') then exit; S := StringFromFile('test2.ini'); Check(S=Content,'test2.ini'); Content := 'abc'#13#10'def'#10'ghijkl'#13'1234567890'; P := pointer(Content); Check(GetNextLine(P,P)='abc'); Check(GetNextLine(P,P)='def'); Check(GetNextLine(P,P)='ghijkl'); Check(GetNextLine(P,P)='1234567890'); Check(P=nil); Check(FindNameValue(pointer(Content),'A')^ = 'b'); Check(FindNameValue(pointer(Content),'AB')^ = 'c'); Check(FindNameValue(pointer(Content),'D')^ = 'e'); Check(FindNameValue(pointer(Content),'1')^ = '2'); Check(FindNameValue(pointer(Content),'GHIJK')^ = 'l'); Check(FindNameValue(pointer(Content),'B') = nil); Check(FindNameValue(pointer(Content),'L') = nil); Check(FindNameValue(pointer(Content),'2') = nil); Check(FindNameValue(pointer(Content),'TOTO') = nil); Check(FindNameValue(Content,'AB',S)); Check(S='c'); Check(FindNameValue(Content,'DEF',S)); Check(S=''); Check(FindNameValue(Content,'G',S)); Check(S='hijkl'); Check(FindNameValue(Content,'1234',S)); Check(S='567890'); Check(not FindNameValue(Content,'H',S)); Check(S=''); end; procedure TTestLowLevelCommon.Soundex; var e: cardinal; PC: PAnsiChar; Soundex: TSynSoundEx; s: WinAnsiString; begin Check(SoundExAnsi(PAnsiChar(' 120 '))=0); if SOUNDEX_BITS=8 then e := $2050206 else e := $2526; Check(SoundExAnsi(PAnsiChar('bonjour'))=e); Check(SoundExAnsi(PAnsiChar(' 123 bonjour. m'),@PC)=e); Check((PC<>nil) and (PC^='.')); s := ' 123 bonjourtreslongmotquidepasse m'; s[15] := #232; s[28] := #233; Check(SoundExAnsi(pointer(s),@PC)<>0); Check((PC<>nil) and (PC^=' ')); Check(SoundExAnsi(PAnsiChar('BOnjour'))=e); Check(SoundExAnsi(PAnsiChar('Bnjr'))=e); Check(SoundExAnsi(PAnsiChar('bonchour'))=e); Check(SoundExAnsi(PAnsiChar('mohammad'))=SoundExAnsi(PAnsiChar('mohhhammeeet'))); if SOUNDEX_BITS=8 then e := $2050206 else e := $25262; Check(SoundExAnsi(PAnsiChar('bonjours'))=e); Check(SoundExAnsi(PAnsiChar('BOnjours'))=e); Check(SoundExAnsi(PAnsiChar('Bnjrs'))=e); Check(SoundExAnsi(PAnsiChar(' 120 '))=0); if SOUNDEX_BITS=8 then e := $2050206 else e := $2526; Check(SoundExUTF8('bonjour')=e); Check(SoundExUTF8(' 123 bonjour. m',@PC)=e); Check((PC<>nil) and (PC^='m')); Check(SoundExUTF8(Pointer(WinAnsiToUTF8(s)),@PC)<>0); Check((PC<>nil) and (PC^='m')); Check(SoundExUTF8('BOnjour')=e); Check(SoundExUTF8('Bnjr')=e); Check(SoundExUTF8('bonchour')=e); Check(SoundExUTF8('mohammad')=SoundExUTF8('mohhhammeeet')); if SOUNDEX_BITS=8 then e := $2050206 else e := $25262; Check(SoundExUTF8('bonjours')=e); Check(SoundExUTF8('BOnjours')=e); Check(SoundExUTF8('Bnjrs')=e); Check(Soundex.Prepare(PAnsiChar('mohamad'),sndxEnglish)); Check(Soundex.Ansi('moi rechercher mohammed ici')); Check(Soundex.UTF8('moi rechercher mohammed ici')); Check(Soundex.Ansi('moi mohammed')); Check(Soundex.UTF8('moi mohammed')); Check(not Soundex.Ansi('moi rechercher mouette ici')); Check(not Soundex.UTF8('moi rechercher mouette ici')); Check(not Soundex.Ansi('moi rechercher mouette')); Check(not Soundex.UTF8('moi rechercher mouette')); end; procedure TTestLowLevelCommon._TRawUTF8List; const MAX=20000; var i,n: integer; L: TRawUTF8List; C: TComponent; Rec: TSynFilterOrValidate; s: RawUTF8; begin L := TRawUTF8List.Create([fObjectsOwned]); try // no hash table involved for i := 0 to MAX do begin C := TComponent.Create(nil); C.Tag := i; Check(L.AddObject(UInt32ToUtf8(i),C)=i); end; Check(L.Count=MAX+1); for i := 0 to MAX do Check(GetInteger(Pointer(L[i]))=i); for i := 0 to MAX do Check(TComponent(L.Objects[i]).Tag=i); Check(L.IndexOf('')<0); Check(L.IndexOf('5')=5); Check(L.IndexOf('999')=999); for i := MAX downto 0 do if i and 1=0 then L.Delete(i); // delete half the array Check(L.Count=MAX div 2); for i := 0 to L.Count-1 do Check(GetInteger(Pointer(L[i]))=TComponent(L.Objects[i]).Tag); Check(L.IndexOf('5')=2); Check(L.IndexOf('6')<0); finally L.Free; end; L := TRawUTF8List.Create([fObjectsOwned,fNoDuplicate,fCaseSensitive]); try // with hash table for i := 1 to MAX do begin Rec := TSynFilterOrValidate.create; Rec.Parameters := Int32ToUTF8(i); Check(L.AddObject(Rec.Parameters,Rec)=i-1); Check(L.IndexOf(Rec.Parameters)=i-1); end; Check(L.IndexOf('')<0); Check(L.IndexOf('abcd')<0); Check(L.Count=MAX); n := 0; for i := 1 to MAX do begin UInt32ToUTF8(i,s); Check(L.IndexOf(s)=n); Check(TSynFilterOrValidate(L.Objects[n]).Parameters=s); if i and 127=0 then Check(L.Delete(s)=n) else inc(n); end; Check(L.Count=n); for i := 1 to MAX do begin UInt32ToUTF8(i,s); Check((L.IndexOf(s)>=0)=(i and 127<>0)); end; L.SaveToFile('utf8list.txt'); L.Clear; Check(L.Count=0); L.LoadFromFile('utf8list.txt'); Check(L.Count=n); for i := 1 to MAX do begin UInt32ToUTF8(i,s); Check((L.IndexOf(s)>=0)=(i and 127<>0)); end; DeleteFile('utf8list.txt'); finally L.Free; end; end; type TCity = record Name: string; Country: string; Latitude: double; Longitude: double; end; TCityDynArray = array of TCity; TAmount = packed record firmID: integer; amount: RawUTF8; end; TAmountCollection = array of TAmount; TAmountI = packed record firmID: integer; amount: integer; end; TAmountICollection = array of TAmountI; procedure TTestLowLevelCommon._TDynArrayHashed; var ACities: TDynArrayHashed; Cities: TCityDynArray; CitiesCount: integer; City: TCity; added: boolean; N: string; i,j: integer; A: TAmount; AI: TAmountI; AmountCollection: TAmountCollection; AmountICollection: TAmountICollection; AmountDA,AmountIDA1,AmountIDA2: TDynArrayHashed; const CITIES_MAX=200000; begin // default Init() will hash and compare binary content before string, i.e. firmID AmountDA.Init(TypeInfo(TAmountCollection), AmountCollection); Check(AmountDA.KnownType=djInteger); Check(@AmountDA.HashElement=@HashInteger); for i := 1 to 100 do begin A.firmID := i; A.amount := UInt32ToUTF8(i); Check(AmountDA.Add(A)=i-1); end; AmountDA.ReHash; for i := 1 to length(AmountCollection) do Check(AmountDA.FindHashed(i)=i-1); // default Init() will hash and compare the WHOLE binary content, i.e. 8 bytes AmountIDA1.Init(TypeInfo(TAmountICollection), AmountICollection); Check(AmountIDA1.KnownType=djInt64); Check(@AmountIDA1.HashElement=@HashInt64); for i := 1 to 100 do begin AI.firmID := i; AI.amount := i*2; Check(AmountIDA1.Add(AI)=i-1); end; AmountIDA1.ReHash; for i := 1 to length(AmountICollection) do begin AI.firmID := i; AI.amount := i*2; Check(AmountIDA1.FindHashed(AI)=i-1); end; AmountIDA1.Clear; // specific hash & compare of the firmID integer first field AmountIDA2.InitSpecific(TypeInfo(TAmountICollection), AmountICollection, djInteger); Check(AmountIDA2.KnownType=djInteger); Check(@AmountIDA2.HashElement=@HashInteger); for i := 1 to 100 do begin AI.firmID := i; AI.amount := i*2; Check(AmountIDA2.Add(AI)=i-1); end; AmountIDA2.ReHash; for i := 1 to length(AmountICollection) do Check(AmountIDA2.FindHashed(i)>=0); // valide generic-like features // see http://docwiki.embarcadero.com/CodeExamples/en/Generics_Collections_TDictionary_(Delphi) ACities.Init(TypeInfo(TCityDynArray),Cities,nil,nil,nil,@CitiesCount); City.Name := 'Iasi'; City.Country := 'Romania'; City.Latitude := 47.16; City.Longitude := 27.58; ACities.Add(City); City.Name := 'London'; City.Country := 'United Kingdom'; City.Latitude := 51.5; City.Longitude := -0.17; ACities.Add(City); City.Name := 'Buenos Aires'; City.Country := 'Argentina'; City.Latitude := 0; City.Longitude := 0; ACities.Add(City); Check(ACities.Count=3); ACities.ReHash; // will use default hash, and search by Name = 1st field City.Name := 'Iasi'; Check(ACities.FindHashedAndFill(City)=0); Check(City.Name='Iasi'); Check(City.Country='Romania'); CheckSame(City.Latitude,47.16); CheckSame(City.Longitude,27.58); Check(ACities.FindHashedAndDelete(City)=0); Check(City.Name='Iasi'); Check(ACities.Scan(City)<0); Check(ACities.FindHashed(City)<0); City.Name := 'Buenos Aires'; City.Country := 'Argentina'; City.Latitude := -34.6; City.Longitude := -58.45; Check(ACities.FindHashedAndUpdate(City,{addifnotexisting=}false)>=0); City.Latitude := 0; City.Longitude := 0; Check(City.Name='Buenos Aires'); Check(ACities.FindHashedAndFill(City)>=0); CheckSame(City.Latitude,-34.6); CheckSame(City.Longitude,-58.45); Check(ACities.FindHashedForAdding(City,added)>=0); Check(not added); City.Name := 'Iasi'; City.Country := 'Romania'; City.Latitude := 47.16; City.Longitude := 27.58; i := ACities.FindHashedForAdding(City,added); Check(added); Check(i>0); if i>0 then begin Check(Cities[i].Name=''); // FindHashedForAdding left void content Cities[i] := City; // should fill Cities[i] content by hand end; Check(ACities.Count=3); Check(City.Name='Iasi'); Check(ACities.FindHashed(City)>=0); // add CITIES_MAX items for i := 1 to 2000 do begin City.Name := IntToString(i); City.Latitude := i*3.14; City.Longitude := i*6.13; Check(ACities.FindHashedAndUpdate(City,true)=i+2,'multiple ReHash'); Check(ACities.FindHashed(City)=i+2); end; ACities.Capacity := CITIES_MAX+30; // will trigger HASH_PO2 for i := 2001 to CITIES_MAX do begin City.Name := IntToString(i); City.Latitude := i*3.14; City.Longitude := i*6.13; if i=8703 then City.Latitude := i*3.14; Check(ACities.FindHashedAndUpdate(City,true)=i+2); Check(ACities.FindHashed(City.Name)=i+2); end; for i := 1 to CITIES_MAX do begin N := IntToString(i); Check(ACities.FindHashed(N)=i+2); end; for i := 1 to CITIES_MAX do begin N := IntToString(i); j := ACities.FindHashed(N); Check(j>=0); if i and 127=0 then begin Check(ACities.FindHashedAndDelete(N)>=0,'delete'); j := ACities.FindHashed(N); Check(j<0); end; end; for i := 1 to CITIES_MAX do begin N := IntToString(i); j := ACities.FindHashed(N); if i and 127=0 then Check(j<0,'deteled') else if not CheckFailed(j>=0,N) then begin Check(Cities[j].Name=N); CheckSame(Cities[j].Latitude,i*3.14); CheckSame(Cities[j].Longitude,i*6.13); end; end; end; type TRec = packed record A: integer; B: byte; C: double; D: Currency; end; TRecs = array of TRec; TProvince = record Name: RawUTF8; Comment: RawUTF8; Year: cardinal; Cities: TCityDynArray; end; TFV = packed record Major, Minor, Release, Build: integer; Main, Detailed: string; BuildDateTime: TDateTime; BuildYear: integer; end; TFVs = array of TFV; TFV2 = packed record V1: TFV; Value: integer; V2: TFV; Text: string; end; TFV2s = array of TFV2; TSynValidates = array of TSynValidate; TDataItem = record Modified: TDateTime; Data: string; end; TDataItems = array of TDataItem; TRawUTF8DynArray1 = type TRawUTF8DynArray; TRawUTF8DynArray2 = array of RawUTF8; function FVSort(const A,B): integer; begin result := SysUtils.StrComp(PChar(pointer(TFV(A).Detailed)),PChar(pointer(TFV(B).Detailed))); end; procedure TTestLowLevelCommon._TDynArray; var AI, AI2: TIntegerDynArray; AU: TRawUTF8DynArray; AR: TRecs; AF: TFVs; AF2: TFV2s; h: cardinal; i,j,k,Len, count,AIcount: integer; U,U2: RawUTF8; P: PUTF8Char; PI: PIntegerArray; AB: TBooleanDynArray; R: TRec; F, F1: TFV; F2: TFV2; City: TCity; Province: TProvince; AV: TSynValidates; V: TSynValidate; AIP, AI2P, AUP, ARP, AFP, ACities, AVP, dyn1,dyn2: TDynArray; dyniter: TDynArrayLoadFrom; B: boolean; dp: TDataItem; dyn1Array,dyn2Array: TDataItems; Test, Test2: RawByteString; ST: TCustomMemoryStream; Index: TIntegerDynArray; W: TTextWriter; JSON_BASE64_MAGIC_UTF8: RawUTF8; const MAGIC: array[0..1] of word = (34,$fff0); procedure Fill(var F: TFV; i: integer); begin F.Major := i; F.Minor := i+1; F.Release := i+2; F.Build := i+3; F.Main := IntToString(i+1000); F.Detailed := IntToString(2000-i); F.BuildDateTime := 36215.12; F.BuildYear := i+2011; end; procedure TestAF2; var i: integer; F1,F2: TFV; begin for i := 0 to AFP.Count-1 do begin Check(AF2[i].Value=i); Check(AF2[i].Text=IntToString(i)); Fill(F1,i*2); Fill(F2,i*2+1); Check(RecordEquals(F1,AF2[i].V1,TypeInfo(TFV))); Check(RecordEquals(F2,AF2[i].V2,TypeInfo(TFV))); end; end; procedure Test64K; var i, E, n: integer; D: TDynArray; IA: TIntegerDynArray; begin D.Init(TypeInfo(TIntegerDynArray),IA,@n); D.Capacity := 16300; for i := 0 to 16256 do begin E := i*5; Check(D.Add(E)=i); Check(IA[i]=i*5); end; Check(D.Count=16257); Check(D.Capacity=16300); Check(length(IA)=D.Capacity); for i := 0 to 16256 do Check(IA[i]=i*5); Check(Hash32(D.SaveTo)=$36937D84); end; procedure TestCities; var i: integer; begin for i := 0 to ACities.Count-1 do with Province.Cities[i] do begin {$ifdef UNICODE} Check(StrToInt(Name)=i); {$else} Check(GetInteger(pointer(Name))=i); {$endif} CheckSame(Latitude,i*3.14); CheckSame(Longitude,i*6.13); end; end; begin h := TypeInfoToHash(TypeInfo(TAmount)); Check(h=$9032161B,'TypeInfoToHash(TAmount)'); h := TypeInfoToHash(TypeInfo(TAmountCollection)); Check(h=$887ED692,'TypeInfoToHash(TAmountCollection)'); h := TypeInfoToHash(TypeInfo(TAmountICollection)); Check(h=$4051BAC,'TypeInfoToHash(TAmountICollection)'); Check(not IsRawUTF8DynArray(nil),'IsRawUTF8DynArray0'); Check(IsRawUTF8DynArray(TypeInfo(TRawUTF8DynArray)),'IsRawUTF8DynArray1'); Check(IsRawUTF8DynArray(TypeInfo(TRawUTF8DynArray1)),'IsRawUTF8DynArray11'); Check(IsRawUTF8DynArray(TypeInfo(TRawUTF8DynArray2)),'IsRawUTF8DynArray12'); Check(not IsRawUTF8DynArray(TypeInfo(TAmount)),'IsRawUTF8DynArray2'); Check(not IsRawUTF8DynArray(TypeInfo(TIntegerDynArray)),'IsRawUTF8DynArray2'); Check(not IsRawUTF8DynArray(TypeInfo(TPointerDynArray)),'IsRawUTF8DynArray3'); Check(not IsRawUTF8DynArray(TypeInfo(TAmountCollection)),'IsRawUTF8DynArray4'); W := TTextWriter.CreateOwnedStream; // validate TBooleanDynArray dyn1.Init(TypeInfo(TBooleanDynArray),AB); SetLength(AB,4); for i := 0 to 3 do AB[i] := i and 1=1; test := dyn1.SaveToJSON; check(test='[false,true,false,true]'); Check(AB<>nil); dyn1.Clear; Check(AB=nil); Check(dyn1.Count=0); Check(dyn1.LoadFromJSON(pointer(test))<>nil); Check(length(AB)=4); Check(dyn1.Count=4); for i := 0 to 3 do Check(AB[i]=(i and 1=1)); Test := dyn1.SaveTo; dyn1.Clear; Check(AB=nil); Check(dyn1.LoadFrom(pointer(test))<>nil); Check(dyn1.Count=4); for i := 0 to 3 do Check(AB[i]=(i and 1=1)); dyn1.Clear; Check(AB=nil); Check(dyn1.LoadFromBinary(test)); Check(dyn1.Count=4); for i := 0 to 3 do Check(AB[i]=(i and 1=1)); Check(dyniter.Init(TypeInfo(TBooleanDynArray),test)); Check(dyniter.Count=4); for i := 0 to 3 do begin Check(dyniter.FirstField(B)); Check(B=(i and 1=1)); B := not B; Check(dyniter.Step(B)); Check(B=(i and 1=1)); end; Check(not dyniter.Step(B)); Check(not dyniter.FirstField(B)); Check(dyniter.CheckHash,'checkhash'); // validate TIntegerDynArray Test64K; AIP.Init(TypeInfo(TIntegerDynArray),AI); for i := 0 to 1000 do begin Check(AIP.Count=i); Check(AIP.Add(i)=i); Check(AIP.Count=i+1); Check(AI[i]=i); end; for i := 0 to 1000 do Check(AIP.IndexOf(i)=i); for i := 0 to 1000 do begin Check(IntegerScanExists(Pointer(AI),i+1,i)); Check(IntegerScanExists(Pointer(AI),AIP.Count,i)); Check(not IntegerScanExists(Pointer(AI),AIP.Count,i+2000)); end; Test := AIP.SaveTo; Check(Hash32(Test)=$924462C); PI := IntegerDynArrayLoadFrom(pointer(Test),AIcount); Check(AIcount=1001); Check(PI<>nil); for i := 0 to 1000 do Check(PI[i]=i); W.AddDynArrayJSON(AIP); U := W.Text; P := pointer(U); for i := 0 to 1000 do Check(GetNextItemCardinal(P)=cardinal(i)); Check(Hash32(U)=$CBDFDAFC,'hash32a'); for i := 0 to 1000 do begin Test2 := AIP.ElemSave(i); Check(length(Test2)=4); k := 0; AIP.ElemLoad(pointer(Test2),k); Check(k=i); Check(AIP.ElemLoadFind(pointer(Test2))=i); end; AIP.Reverse; for i := 0 to 1000 do Check(AI[i]=1000-i); AIP.Clear; Check(AIP.LoadFrom(pointer(Test))<>nil); for i := 0 to 1000 do Check(AIP.IndexOf(i)=i); AIP.Clear; Check(AIP.LoadFromBinary(Test)); for i := 0 to 1000 do Check(AIP.IndexOf(i)=i); for i := 1000 downto 0 do if i and 3=0 then AIP.Delete(i); Check(AIP.Count=750); for i := 0 to 1000 do if i and 3=0 then Check(AIP.IndexOf(i)<0) else Check(AIP.IndexOf(i)>=0); AIP.Clear; Check(AIP.LoadFromJSON(pointer(U))<>nil); for i := 0 to 1000 do Check(AI[i]=i); AIP.Init(TypeInfo(TIntegerDynArray),AI,@AIcount); for i := 0 to 50000 do begin Check(AIP.Count=i,'use of AIcount should reset it to zero'); Check(AIP.Add(i)=i); Check(AIP.Count=i+1); Check(AI[i]=i); end; AIP.Compare := SortDynArrayInteger; AIP.Sort; Check(AIP.Count=50001); for i := 0 to AIP.Count-1 do Check(AIP.Find(i)=i); Test := AIP.SaveTo; Check(Hash32(Test)=$B9F2502A,'hash32b'); AIP.Reverse; for i := 0 to 50000 do Check(AI[i]=50000-i); SetLength(AI,AIcount); AIP.Init(TypeInfo(TIntegerDynArray),AI); AIP.Compare := SortDynArrayInteger; AIP.Sort; Test := AIP.SaveTo; Check(Hash32(Test)=$B9F2502A,'hash32c'); AIP.Reverse; AIP.Slice(AI2,2000,1000); Check(length(AI2)=2000); for i := 0 to 1999 do Check(AI2[i]=49000-i); AIP.AddArray(AI2,1000,2000); Check(AIP.Count=51001); for i := 0 to 50000 do Check(AI[i]=50000-i); for i := 0 to 999 do Check(AI[i+50001]=48000-i); AIP.Count := 50001; AIP.AddArray(AI2); Check(AIP.Count=52001); for i := 0 to 50000 do Check(AI[i]=50000-i); for i := 0 to 1999 do Check(AI[i+50001]=49000-i); AIP.Clear; with DynArray(TypeInfo(TIntegerDynArray),AI) do begin Check(LoadFrom(pointer(Test))<>nil); for i := 0 to Count-1 do Check(AI[i]=i); end; Check(AIP.Count=50001); {$ifndef DELPHI5OROLDER} AI2P.Init(TypeInfo(TIntegerDynArray),AI2); AIP.AddDynArray(AI2P); Check(AIP.Count=52001); for i := 0 to 50000 do Check(AI[i]=i); for i := 0 to 1999 do Check(AI[i+50001]=49000-i); {$endif} // validate TSynValidates (an array of classes is an array of PtrInt) AVP.Init(TypeInfo(TSynValidates),AV); for i := 0 to 1000 do begin Check(AVP.Count=i); PtrInt(V) := i; Check(AVP.Add(V)=i); Check(AVP.Count=i+1); Check(AV[i]=V); end; Check(length(AV)=1001); Check(AVP.Count=1001); for i := 0 to 1000 do begin // untyped const must be the same exact type ! PtrInt(V) := i; Check(AVP.IndexOf(V)=i); end; Test := AVP.SaveTo; Check(Hash32(Test)={$ifdef CPU64}$31484630{$else}$924462C{$endif},'hash32d'); // validate TRawUTF8DynArray AUP.Init(TypeInfo(TRawUTF8DynArray),AU); for i := 0 to 1000 do begin Check(AUP.Count=i); U := UInt32ToUtf8(i+1000); Check(AUP.Add(U)=i); Check(AUP.Count=i+1); Check(AU[i]=U); end; for i := 0 to 1000 do begin U := Int32ToUtf8(i+1000); Check(AUP.IndexOf(U)=i); end; Test := AUP.SaveTo; Check(Hash32(@Test[2],length(Test)-1)=$D9359F89,'hash32e'); // trim Test[1]=ElemSize for i := 0 to 1000 do begin U := Int32ToUtf8(i+1000); Check(RawUTF8DynArrayLoadFromContains(pointer(Test),pointer(U),length(U),false)=i); Check(RawUTF8DynArrayLoadFromContains(pointer(Test),pointer(U),length(U),true)=i); end; for i := 0 to 1000 do begin U := UInt32ToUtf8(i+1000); Test2 := AUP.ElemSave(U); Check(length(Test2)>4); U := ''; AUP.ElemLoad(pointer(Test2),U); Check(GetInteger(pointer(U))=i+1000); Check(AUP.ElemLoadFind(pointer(Test2))=i); end; W.CancelAll; W.AddDynArrayJSON(AUP); W.SetText(U); Check(Hash32(U)=$1D682EF8,'hash32f'); P := pointer(U); if not CheckFailed(P^='[') then inc(P); for i := 0 to 1000 do begin Check(P^='"'); inc(P); Check(GetNextItemCardinal(P)=cardinal(i+1000)); if P=nil then break; end; Check(P=nil); AUP.Clear; Check(AUP.LoadFrom(pointer(Test))-pointer(Test)=length(Test)); for i := 0 to 1000 do Check(GetInteger(pointer(AU[i]))=i+1000); AUP.Clear; Check(AUP.LoadFromBinary(Test)); for i := 0 to 1000 do Check(GetInteger(pointer(AU[i]))=i+1000); Check(dyniter.Init(TypeInfo(TRawUTF8DynArray),pointer(test))); Check(dyniter.Count=1001); for i := 0 to 1000 do begin Check(dyniter.FirstField(U2)); Check(GetInteger(pointer(U2))=i+1000); U2 := ''; Check(dyniter.Step(U2)); Check(GetInteger(pointer(U2))=i+1000); end; Check(not dyniter.Step(U2)); Check(not dyniter.FirstField(U2)); Check(dyniter.CheckHash); AUP.Clear; Check(AUP.LoadFromJSON(pointer(U))<>nil); for i := 0 to 1000 do Check(GetInteger(pointer(AU[i]))=i+1000); for i := 0 to 1000 do begin U := Int32ToUtf8(i+1000); Check(AUP.IndexOf(U)=i); end; for i := 1000 downto 0 do if i and 3=0 then AUP.Delete(i); Check(AUP.Count=750); for i := 0 to 1000 do begin U := Int32ToUtf8(i+1000); if i and 3=0 then Check(AUP.IndexOf(U)<0) else Check(AUP.IndexOf(U)>=0); end; U := 'inserted'; AUP.Insert(500,U); Check(AUP.IndexOf(U)=500); j := 0; for i := 0 to AUP.Count-1 do if i<>500 then begin U := Int32ToUtf8(j+1000); if j and 3=0 then Check(AUP.IndexOf(U)<0) else Check(AUP.IndexOf(U)>=0); inc(j); end; AUP.CreateOrderedIndex(Index,SortDynArrayAnsiString); Check(StrComp(pointer(AU[Index[750]]),pointer(AU[Index[749]]))>0); for i := 1 to AUP.Count-1 do Check(AU[Index[i]]>AU[Index[i-1]]); AUP.Compare := SortDynArrayAnsiString; AUP.Sort; Check(AUP.Sorted); Check(AU[AUP.Count-1]='inserted'); for i := 1 to AUP.Count-1 do Check(AU[i]>AU[i-1]); j := 0; for i := 0 to AUP.Count-1 do if i<>500 then begin U := Int32ToUtf8(j+1000); if j and 3=0 then Check(AUP.Find(U)<0) else Check(AUP.Find(U)>=0); inc(j); end; AUP.Sorted := false; j := 0; for i := 0 to AUP.Count-1 do if i<>500 then begin U := Int32ToUtf8(j+1000); if j and 3=0 then Check(AUP.Find(U)<0) else Check(AUP.Find(U)>=0); inc(j); end; // validate packed binary record (no string inside) ARP.Init(TypeInfo(TRecs),AR); for i := 0 to 1000 do begin Check(ARP.Count=i); R.A := i; R.B := i+1; R.C := i*2.2; R.D := i*3.25; Check(ARP.Add(R)=i); Check(ARP.Count=i+1); end; for i := 0 to 1000 do begin with AR[i] do begin Check(A=i); Check(B=byte(i+1)); CheckSame(C,i*2.2); CheckSame(D,i*3.25); end; R.A := i; R.B := i+1; R.C := i*2.2; R.D := i*3.25; Check(ARP.IndexOf(R)=i); // will work (packed + no ref-counted types inside) end; W.CancelAll; W.AddDynArrayJSON(ARP); U := W.Text; // no check(Hash32(U)) since it is very platform-dependent: LoadFromJSON is enough P := pointer(U); JSON_BASE64_MAGIC_UTF8 := RawUnicodeToUtf8(@MAGIC,2); U2 := RawUTF8('[')+JSON_BASE64_MAGIC_UTF8+RawUTF8(BinToBase64(ARP.SaveTo))+RawUTF8('"]'); Check(U=U2); ARP.Clear; Check(ARP.LoadFromJSON(pointer(U))<>nil); if not CheckFailed(ARP.Count=1001) then for i := 0 to 1000 do with AR[i] do begin Check(A=i); Check(B=byte(i+1)); CheckSame(C,i*2.2); CheckSame(D,i*3.25); end; // validate packed record with strings inside AFP.Init(TypeInfo(TFVs),AF); for i := 0 to 1000 do begin Check(AFP.Count=i); Fill(F,i); Check(AFP.Add(F)=i); Check(AFP.Count=i+1); end; Fill(F,100); Check(RecordEquals(F,AF[100],TypeInfo(TFV))); Len := RecordSaveLength(F,TypeInfo(TFV)); Check(Len=38{$ifdef UNICODE}+length(F.Main)+length(F.Detailed){$endif}); SetLength(Test,Len); Check(RecordSave(F,pointer(Test),TypeInfo(TFV))-pointer(Test)=Len); Fill(F,0); Check(RecordLoad(F,pointer(Test),TypeInfo(TFV))-pointer(Test)=Len); Check(RecordEquals(F,AF[100],TypeInfo(TFV))); Fill(F,0); Check(RecordLoad(F,Test,TypeInfo(TFV))); Check(RecordEquals(F,AF[100],TypeInfo(TFV))); Test := RecordSaveBase64(F,TypeInfo(TFV)); Check(Test<>''); Fill(F,0); Check(RecordLoadBase64(pointer(Test),length(Test),F,TypeInfo(TFV))); Check(RecordEquals(F,AF[100],TypeInfo(TFV))); Test := RecordSaveBase64(F,TypeInfo(TFV),true); Check(Test<>''); Fill(F,0); Check(RecordLoadBase64(pointer(Test),length(Test),F,TypeInfo(TFV),true)); Check(RecordEquals(F,AF[100],TypeInfo(TFV))); for i := 0 to 1000 do with AF[i] do begin Check(Major=i); Check(Minor=i+1); Check(Release=i+2); Check(Build=i+3); Check(Main=IntToString(i+1000)); Check(Detailed=IntToString(2000-i)); CheckSame(BuildDateTime,36215.12); Check(BuildYear=i+2011); end; for i := 0 to 1000 do begin Fill(F,i); Check(AFP.IndexOf(F)=i); end; Test := AFP.SaveTo; Check(Hash32(Test)={$ifdef CPU64}{$ifdef FPC}$3DE22166{$else}$A29C10E{$endif}{$else} {$ifdef UNICODE}$62F9C106{$else}$6AA2215E{$endif}{$endif},'hash32h'); for i := 0 to 1000 do begin Fill(F,i); AFP.ElemCopy(F,F1); Check(AFP.ElemEquals(F,F1)); Test2 := AFP.ElemSave(F); Check(length(Test2)>4); AFP.ElemClear(F); AFP.ElemLoad(pointer(Test2),F); Check(AFP.ElemEquals(F,F1)); Check(AFP.ElemLoadFind(pointer(Test2))=i); Check(AFP.ElemLoadFind(pointer(Test2),PAnsiChar(Test2)+length(Test2))=i); end; W.CancelAll; W.AddDynArrayJSON(AFP); // note: error? ensure TTestLowLevelCommon run after TTestLowLevelTypes // -> otherwise custom serialization is still active with no Build* fields U := W.Text; {$ifdef ISDELPHI2010} // thanks to enhanced RTTI Check(IdemPChar(pointer(U),'[{"MAJOR":0,"MINOR":1,"RELEASE":2,"BUILD":3,'+ '"MAIN":"1000","DETAILED":"2000","BUILDDATETIME":"1999-02-24T02:52:48",'+ '"BUILDYEAR":2011},{"MAJOR":1,"MINOR":2,"RELEASE":3,"BUILD":4,')); Check(Hash32(U)=$74523E0F,'hash32i'); {$else} Check(U='['+JSON_BASE64_MAGIC_UTF8+BinToBase64(Test)+'"]'); {$endif} AFP.Clear; Check(AFP.LoadFrom(pointer(Test))-pointer(Test)=length(Test)); for i := 0 to 1000 do begin Fill(F,i); Check(AFP.IndexOf(F)=i); end; Check(dyniter.Init(TypeInfo(TFVs),pointer(test))); Check(dyniter.Count=1001); for i := 0 to 1000 do begin Check(dyniter.Step(F1)); Fill(F,i); Check(AFP.ElemEquals(F,F1)); end; Check(not dyniter.Step(F1)); Check(dyniter.CheckHash); ST := THeapMemoryStream.Create; AFP.SaveToStream(ST); AFP.Clear; ST.Position := 0; AFP.LoadFromStream(ST); Check(ST.Position=length(Test)); for i := 0 to 1000 do begin Fill(F,i); Check(AFP.IndexOf(F)=i); end; ST.Free; AFP.Clear; Check(AFP.LoadFromJSON(pointer(U))<>nil); for i := 0 to 1000 do begin Fill(F,i); Check(RecordEquals(F,AF[i],AFP.ElemType)); end; for i := 0 to 1000 do begin Fill(F,i); F.BuildYear := 10; Check(AFP.IndexOf(F)<0); F.BuildYear := i+2011; F.Detailed := '??'; Check(AFP.IndexOf(F)<0); end; for i := 1000 downto 0 do if i and 3=0 then AFP.Delete(i); Check(AFP.Count=750); for i := 0 to 1000 do begin Fill(F,i); if i and 3=0 then Check(AFP.IndexOf(F)<0) else Check(AFP.IndexOf(F)>=0); end; Fill(F,5000); AFP.Insert(500,F); Check(AFP.IndexOf(F)=500); j := 0; for i := 0 to AFP.Count-1 do if i<>500 then begin Fill(F,j); if j and 3=0 then Check(AFP.IndexOf(F)<0) else Check(AFP.IndexOf(F)>=0); inc(j); end; Finalize(Index); AFP.CreateOrderedIndex(Index,FVSort); for i := 1 to AUP.Count-1 do Check(AF[Index[i]].Detailed>AF[Index[i-1]].Detailed); AFP.Compare := FVSort; AFP.Sort; for i := 1 to AUP.Count-1 do Check(AF[i].Detailed>AF[i-1].Detailed); j := 0; for i := 0 to AFP.Count-1 do if i<>500 then begin Fill(F,j); if j and 3=0 then Check(AFP.Find(F)<0) else Check(AFP.Find(F)>=0); inc(j); end; W.Free; // validate packed record with records of strings inside AFP.Init(Typeinfo(TFV2s),AF2); for i := 0 to 1000 do begin Fill(F2.V1,i*2); F2.Value := i; Fill(F2.V2,i*2+1); F2.Text := IntToString(i); Check(AFP.Add(F2)=i); end; Check(AFP.Count=1001); TestAF2; Test := AFP.SaveTo; AFP.Clear; Check(AFP.Count=0); Check(AFP.LoadFromBinary(Test)); Check(AFP.Count=1001); TestAF2; // validate https://synopse.info/forum/viewtopic.php?pid=16581#p16581 DP.Modified := Now; DP.Data := '1'; dyn1.Init(TypeInfo(TDataItems),dyn1Array); dyn1.Add(DP); DP.Modified := Now; DP.Data := '2'; dyn2.Init(TypeInfo(TDataItems),dyn2Array); check(dyn2.count=0); dyn2.Add(DP); check(length(dyn2Array)=1); check(dyn2.count=1); dyn2.AddArray(dyn1Array); check(dyn2.count=2); check(dyn2.ElemEquals(dyn2Array[0],DP)); check(dyn2.ElemEquals(dyn2Array[1],dyn1Array[0])); {$ifndef DELPHI5OROLDER} dyn2.AddDynArray(dyn1); check(dyn2.count=3); check(dyn2.ElemEquals(dyn2Array[0],DP)); check(dyn2.ElemEquals(dyn2Array[1],dyn1Array[0])); check(dyn2.ElemEquals(dyn2Array[2],dyn1Array[0])); {$endif} // valide generic-like features // see http://docwiki.embarcadero.com/CodeExamples/en/Generics_Collections_TDictionary_(Delphi) ACities.Init(TypeInfo(TCityDynArray),Province.Cities); City.Name := 'Iasi'; City.Country := 'Romania'; City.Latitude := 47.16; City.Longitude := 27.58; ACities.Add(City); City.Name := 'London'; City.Country := 'United Kingdom'; City.Latitude := 51.5; City.Longitude := -0.17; ACities.Add(City); City.Name := 'Buenos Aires'; City.Country := 'Argentina'; City.Latitude := 0; City.Longitude := 0; ACities.Add(City); Check(ACities.Count=3); ACities.Compare := SortDynArrayString; // will search by Name = 1st field City.Name := 'Iasi'; Check(ACities.FindAndFill(City)=0); Check(City.Name='Iasi'); Check(City.Country='Romania'); CheckSame(City.Latitude,47.16); CheckSame(City.Longitude,27.58); Check(ACities.FindAndDelete(City)=0); Check(City.Name='Iasi'); Check(ACities.Find(City)<0); City.Name := 'Buenos Aires'; City.Country := 'Argentina'; City.Latitude := -34.6; City.Longitude := -58.45; Check(ACities.FindAndUpdate(City)>=0); City.Latitude := 0; City.Longitude := 0; Check(City.Name='Buenos Aires'); Check(ACities.FindAndFill(City)>=0); CheckSame(City.Latitude,-34.6); CheckSame(City.Longitude,-58.45); Check(ACities.FindAndAddIfNotExisting(City)>=0); City.Name := 'Iasi'; City.Country := 'Romania'; City.Latitude := 47.16; City.Longitude := 27.58; Check(ACities.FindAndAddIfNotExisting(City)<0); Check(City.Name='Iasi'); Check(ACities.FindAndUpdate(City)>=0); ACities.Sort; for i := 1 to high(Province.Cities) do Check(Province.Cities[i].Name>Province.Cities[i-1].Name); Check(ACities.Count=3); // complex record test Province.Name := 'Test'; Province.Comment := 'comment'; Province.Year := 1000; Test := RecordSave(Province,TypeInfo(TProvince)); RecordClear(Province,TypeInfo(TProvince)); Check(Province.Name=''); Check(Province.Comment=''); Check(length(Province.Cities)=0); Check(ACities.Count=0); Province.Year := 0; Check(RecordLoad(Province,pointer(Test),TypeInfo(TProvince))^=#0); Check(Province.Name='Test'); Check(Province.Comment='comment'); Check(Province.Year=1000); Check(length(Province.Cities)=3); Check(ACities.Count=3); for i := 1 to high(Province.Cities) do Check(Province.Cities[i].Name>Province.Cities[i-1].Name); Province.Cities := nil; Test := RecordSave(Province,TypeInfo(TProvince)); RecordClear(Province,TypeInfo(TProvince)); Check(Province.Name=''); Check(Province.Comment=''); Check(length(Province.Cities)=0); Check(ACities.Count=0); Check(RecordLoad(Province,pointer(Test),TypeInfo(TProvince))^=#0); Check(Province.Name='Test'); Check(Province.Comment='comment'); Check(Province.Year=1000); Check(length(Province.Cities)=0); Check(ACities.Count=0); // big array test ACities.Init(TypeInfo(TCityDynArray),Province.Cities); ACities.Clear; for i := 0 to 10000 do begin City.Name := IntToString(i); City.Latitude := i*3.14; City.Longitude := i*6.13; Check(ACities.Add(City)=i); end; Check(ACities.Count=Length(Province.Cities)); Check(ACities.Count=10001); TestCities; ACities.Init(TypeInfo(TCityDynArray),Province.Cities,@count); ACities.Clear; for i := 0 to 100000 do begin City.Name := IntToString(i); City.Latitude := i*3.14; City.Longitude := i*6.13; Check(ACities.Add(City)=i); end; Check(ACities.Count=count); TestCities; end; {$ifdef CPUINTEL} function BufEquals(P, n, b: PtrInt): boolean; begin // slower than FillChar, faster than for loop, but fast enough for testing result := false; b := b*{$ifdef CPU32}$01010101{$else}$0101010101010101{$endif}; inc(n,P-SizeOf(P)); if n>=P then repeat if PPtrInt(P)^<>b then exit; inc(PPtrInt(P)); until nbyte(b) then exit; inc(P); until P>=n; result := true; end; function IsBufIncreasing(P: PByteArray; n: PtrInt; b: byte): boolean; var i: PtrInt; begin result := false; for i := 0 to n-1 do if P[i]<>b then exit else inc(b); result := true; end; {$ifndef ABSOLUTEPASCAL} {$ifdef CPUX64} // will define its own self-dispatched SSE2/AVX functions {$define HASCPUIDX64} {$endif} {$endif} procedure TTestLowLevelCommon.CustomRTL; // note: FPC uses the RTL for FillCharFast/MoveFast var buf: RawByteString; procedure Validate(rtl: boolean=false); var i,len,filled,moved: PtrInt; b1,b2: byte; timer: TPrecisionTimer; P: PByteArray; msg: string; cpu: RawUTF8; elapsed: Int64; begin // first validate FillCharFast filled := 0; b1 := 0; len := 1; repeat b2 := (b1+1) and 255; buf[len+1] := AnsiChar(b1); if rtl then FillChar(pointer(buf)^,len,b2) else FillCharFast(pointer(buf)^,len,b2); inc(filled,len); Check(BufEquals(PtrInt(buf),len,b2)); Check(ord(buf[len+1])=b1); b1 := b2; if len<16384 then inc(len) else inc(len,777+len shr 4); until len>=length(buf); // small len makes timer.Resume/Pause unreliable -> single shot measure b1 := 0; len := 1; timer.Start; repeat b2 := (b1+1) and 255; if rtl then FillChar(pointer(buf)^,len,b2) else FillCharFast(pointer(buf)^,len,b2); b1 := b2; if len<16384 then inc(len) else inc(len,777+len shr 4); until len>=length(buf); timer.Stop; {$ifdef HASCPUIDX64} cpu := GetSetName(TypeInfo(TX64CpuFeatures),CPUIDX64); {$endif} if rtl then msg := 'FillChar' else FormatString('FillCharFast [%]',[cpu],msg); NotifyTestSpeed(msg,1,filled,@timer); // validates overlapping forward Move/MoveFast if rtl then msg := 'Move' else FormatString('MoveFast [%]',[cpu],msg); P := pointer(buf); for i := 0 to length(buf)-1 do P[i] := i; // fills with 0,1,2,... Check(IsBufIncreasing(p,length(buf),0)); len := 1; moved := 0; timer.Start; repeat if rtl then Move(P[moved+1],P[moved],len) else MoveFast(p[moved+1],p[moved],len); inc(moved,len); Check(p[moved]=p[moved-1]); inc(len); until moved+len>=length(buf); NotifyTestSpeed(msg,1,moved,@timer); Check(IsBufIncreasing(p,moved,1)); checkEqual(Hash32(buf),2284147540); // forward and backward overlapped moves on small buffers elapsed := 0; moved := 0; for len := 1 to 48 do begin timer.Start; if rtl then for i := 1 to 10000 do begin Move(P[100],P[i],len); Move(P[i],P[100],len); end else for i := 1 to 10000 do begin MoveFast(P[100],P[i],len); MoveFast(P[i],P[100],len); end; inc(moved,20000*len); inc(elapsed,NotifyTestSpeed('%b %',[len,msg],1,20000*len,@timer,{onlylog=}true)); end; timer.FromExternalMicroSeconds(elapsed); NotifyTestSpeed('small %',[msg],1,moved,@timer); checkEqual(Hash32(buf),1635609040); // forward and backward non-overlapped moves on big buffers len := (length(buf)-3200) shr 1; timer.Start; for i := 1 to 25 do if rtl then begin Move(P[len],P[i],len-i*10); Move(P[i],P[len],len-i*10); end else begin MoveFast(p[len],p[i],len-i*10); MoveFast(P[i],P[len],len-i*10); end; NotifyTestSpeed('big %',[msg],1,50*len,@timer); checkEqual(Hash32(buf),818419281); // forward and backward overlapped moves on big buffers len := length(buf)-3200; for i := 1 to 3 do if rtl then begin Move(P[3100],P[i],len-i); Move(P[i],P[3200],len-i); end else begin MoveFast(p[3100],p[i],len-i); MoveFast(P[i],P[3200],len-i); end; checkEqual(Hash32(buf),1646145792); end; {$ifdef HASCPUIDX64} var cpu: TX64CpuFeatures; {$endif} begin SetLength(buf,16 shl 20); // 16MB {$ifdef HASCPUIDX64} // activate and validate SSE2 + AVX branches cpu := CPUIDX64; CPUIDX64 := []; // default SSE2 128-bit process Validate; {$ifdef FPC} // Delphi doesn't support AVX asm if cpuAvx in cpu then begin CPUIDX64 := [cpuAvx]; // AVX 256-bit process Validate; end; {$endif FPC} CPUIDX64 := cpu; // there is no AVX2 move/fillchar (still 256-bit wide) if (cpu<>[]) and (cpu<>[cpuAvx]) and (cpu<>[cpuAvx,cpuAvx2]) then Validate; // no Validate(true): RedirectCode(@System.FillChar,@FillcharFast) {$else} Validate({rtl=}true); Validate(false); {$endif HASCPUIDX64} end; {$endif CPUINTEL} procedure TTestLowLevelCommon.SystemCopyRecord; type TR = record One: integer; S1: AnsiString; Three: byte; S2: WideString; Five: boolean; {$ifndef NOVARIANTS} V: Variant; {$endif} R: Int64Rec; Arr: array[0..10] of AnsiString; Dyn: array of integer; Bulk: array[0..19] of byte; end; var A,B,C: TR; i: integer; begin FillCharFast(A,sizeof(A),0); for i := 0 to High(A.Bulk) do A.Bulk[i] := i; A.S1 := 'one'; A.S2 := 'two'; A.Five := true; A.Three := $33; {$ifndef NOVARIANTS} A.V := 'One Two'; {$endif} A.R.Lo := 10; A.R.Hi := 20; A.Arr[5] := 'five'; SetLength(A.Dyn,10); A.Dyn[9] := 9; B := A; Check(A.One=B.One); Check(A.S1=B.S1); Check(A.Three=B.Three); Check(A.S2=B.S2); Check(A.Five=B.Five); {$ifndef NOVARIANTS} Check(A.V=B.V); {$endif} Check(Int64(A.R)=Int64(B.R)); Check(A.Arr[5]=B.Arr[5]); Check(A.Arr[0]=B.Arr[0]); Check(A.Dyn[9]=B.Dyn[9]); Check(A.Dyn[0]=0); for i := 0 to High(B.Bulk) do Check(B.Bulk[i]=i); for i := 0 to High(B.Bulk) do Check(CompareMem(@A.Bulk,@B.Bulk,i)); for i := 0 to High(B.Bulk) do Check(CompareMemSmall(@A.Bulk,@B.Bulk,i)); for i := 0 to High(B.Bulk) do Check(CompareMemFixed(@A.Bulk,@B.Bulk,i)); FillCharFast(A.Bulk,sizeof(A.Bulk),255); for i := 0 to High(B.Bulk) do Check(CompareMem(@A.Bulk,@B.Bulk,i)=(i=0)); for i := 0 to High(B.Bulk) do Check(CompareMemSmall(@A.Bulk,@B.Bulk,i)=(i=0)); for i := 0 to High(B.Bulk) do Check(CompareMemFixed(@A.Bulk,@B.Bulk,i)=(i=0)); B.Three := 3; B.Dyn[0] := 10; C := B; Check(A.One=C.One); Check(A.S1=C.S1); Check(C.Three=3); Check(A.S2=C.S2); Check(A.Five=C.Five); {$ifndef NOVARIANTS} Check(A.V=C.V); {$endif} Check(Int64(A.R)=Int64(C.R)); Check(A.Arr[5]=C.Arr[5]); Check(A.Arr[0]=C.Arr[0]); Check(A.Dyn[9]=C.Dyn[9]); {Check(A.Dyn[0]=0) bug in original VCL?} Check(C.Dyn[0]=10); end; procedure TTestLowLevelCommon.UrlEncoding; var i,j: integer; s: RawByteString; name,value,utf: RawUTF8; str: string; P: PUTF8Char; GUID2: TGUID; U: TURI; const GUID: TGUID = '{c9a646d3-9c61-4cb7-bfcd-ee2522c8f633}'; procedure Test(const decoded,encoded: RawUTF8); begin Check(UrlEncode(decoded)=encoded); Check(UrlDecode(encoded)=decoded); Check(UrlDecode(PUTF8Char(encoded))=decoded); end; begin str := UTF8ToString(UrlEncode(StringToUTF8('https://test3.diavgeia.gov.gr/doc/'))); check(str='https%3A%2F%2Ftest3.diavgeia.gov.gr%2Fdoc%2F'); Test('abcdef','abcdef'); Test('abcdefyzABCDYZ01239_-.~ ','abcdefyzABCDYZ01239_-.~+'); Test('"Aardvarks lurk, OK?"','%22Aardvarks+lurk%2C+OK%3F%22'); Test('"Aardvarks lurk, OK%"','%22Aardvarks+lurk%2C+OK%25%22'); Test('where=name like :(''Arnaud%'')','where%3Dname+like+%3A%28%27Arnaud%25%27%29'); Check(UrlDecode('where=name%20like%20:(%27Arnaud%%27):')= 'where=name like :(''Arnaud%''):','URI from browser'); P := UrlDecodeNextNameValue('where=name+like+%3A%28%27Arnaud%25%27%29%3A', name,value); Check(P<>nil); Check(P^=#0); Check(name='where'); Check(value='name like :(''Arnaud%''):'); P := UrlDecodeNextNameValue('where%3Dname+like+%3A%28%27Arnaud%25%27%29%3A', name,value); Check(P<>nil); Check(P^=#0); Check(name='where'); Check(value='name like :(''Arnaud%''):'); P := UrlDecodeNextNameValue('where%3Dname+like+%3A%28%27Arnaud%%27%29%3A', name,value); Check(P<>nil); Check(P^=#0); Check(name='where'); Check(value='name like :(''Arnaud%''):','URI from browser'); P := UrlDecodeNextNameValue('name%2Ccom+plex=value',name,value); Check(P<>nil); Check(P^=#0); Check(name='name,com plex'); Check(value='value'); P := UrlDecodeNextNameValue('name%2Ccomplex%3Dvalue',name,value); Check(P<>nil); Check(P^=#0); Check(name='name,complex'); Check(value='value'); for i := 0 to 100 do begin j := i*5; // circumvent weird FPC code generation bug in -O2 mode s := RandomString(j); Check(UrlDecode(UrlEncode(s))=s,string(s)); end; utf := BinToBase64URI(@GUID,sizeof(GUID)); Check(utf='00amyWGct0y_ze4lIsj2Mw'); FillCharFast(GUID2,sizeof(GUID2),0); Check(Base64uriToBin(utf,@GUID2,SizeOf(GUID2))); Check(IsEqualGUID(GUID2,GUID)); Check(IsEqualGUID(@GUID2,@GUID)); Check(U.From('toto.com')); Check(U.URI='http://toto.com/'); Check(U.From('toto.com:123')); Check(U.URI='http://toto.com:123/'); Check(U.From('https://toto.com:123/tata/titi')); Check(U.URI='https://toto.com:123/tata/titi'); Check(U.From('https://toto.com:123/tata/tutu:tete')); Check(U.URI='https://toto.com:123/tata/tutu:tete'); Check(U.From('toto.com/tata/tutu:tete')); Check(U.URI='http://toto.com/tata/tutu:tete'); end; procedure TTestLowLevelCommon._GUID; var i: integer; s: RawByteString; st: string; g,g2: TGUID; const GUID: TGUID = '{c9a646d3-9c61-4cb7-bfcd-ee2522c8f633}'; begin s := GUIDToRawUTF8(GUID); Check(s='{C9A646D3-9C61-4CB7-BFCD-EE2522C8F633}'); Check(TextToGUID(@s[2],@g2)^='}'); Check(IsEqualGUID(g2,GUID)); Check(GUIDToString(GUID)='{C9A646D3-9C61-4CB7-BFCD-EE2522C8F633}'); Check(IsEqualGUID(RawUTF8ToGUID(s),GUID)); for i := 1 to 1000 do begin g.D1 := Random(maxInt); g.D2 := Random(65535); g.D3 := Random(65535); Int64(g.D4) := Int64(Random(maxInt))*Random(maxInt); st := GUIDToString(g); {$ifndef DELPHI5OROLDER} Check(st=SysUtils.GUIDToString(g)); {$endif} Check(IsEqualGUID(StringToGUID(st),g)); s := GUIDToRawUTF8(g); Check(st=UTF8ToString(s)); st[Random(38)+1] := ' '; g2 := StringToGUID(st); Check(IsZero(@g2,sizeof(g2))); Check(TextToGUID(@s[2],@g2)^='}'); Check(IsEqualGUID(g2,g)); Check(IsEqualGUID(@g2,@g)); Check(IsEqualGUID(RawUTF8ToGUID(s),g)); inc(g.D1); Check(not IsEqualGUID(g2,g)); Check(not IsEqualGUID(RawUTF8ToGUID(s),g)); end; {$ifdef ISDELPHI2010} s := RecordSaveJSON(g,TypeInfo(TGUID)); FillCharFast(g2,sizeof(g2),0); Check(RecordLoadJSON(g2,pointer(s),TypeInfo(TGUID))<>nil); Check(IsEqualGUID(g2,g)); {$endif} end; procedure TTestLowLevelCommon._ParseCommandArguments; procedure Test(const cmd: RawUTF8; const expected: array of RawUTF8; const flags: TParseCommands = []; posix: boolean=true); var tmp: RawUTF8; n, i: integer; a: TParseCommandsArgs; begin if checkfailed(ParseCommandArgs(cmd, nil, nil, nil, posix) = flags) then exit; FillcharFast(a, SizeOf(a), 255); check(ParseCommandArgs(cmd, @a, @n, @tmp, posix) = flags); if (flags = []) and not CheckFailed(n = length(expected)) then begin for i := 0 to high(expected) do check(StrComp(pointer(a[i]), pointer(expected[i])) = 0); check(a[n] = nil); end; end; begin Test('', [], [pcInvalidCommand]); Test('one', ['one']); Test('one two', ['one', 'two']); Test(' one two ', ['one', 'two']); Test('"one" two', ['one', 'two']); Test('one "two"', ['one', 'two']); Test('one "two"', ['one', 'two']); Test('one " two"', ['one', ' two']); Test('" one" two', [' one', 'two']); Test(''' one'' two', [' one', 'two']); Test('"one one" two', ['one one', 'two']); Test('one "two two"', ['one', 'two two']); Test('"1 2" "3 4"', ['1 2', '3 4']); Test('"1 '' 2" "3 4"', ['1 '' 2', '3 4']); Test('''1 2'' "3 4"', ['1 2', '3 4']); Test('1 ( "3 4"', [], [pcHasParenthesis]); Test('1 "3 " 4"', [], [pcUnbalancedDoubleQuote]); Test(''' "3 4"', [], [pcUnbalancedSingleQuote]); Test('one|two', [], [pcHasRedirection]); Test('one\|two', ['one|two'], []); Test('"one|two"', ['one|two']); Test('one>two', [], [pcHasRedirection]); Test('one\>two', ['one>two'], []); Test('"one>two"', ['one>two']); Test('one&two', [], [pcHasJobControl]); Test('one\&two', ['one&two'], []); Test('"one&two"', ['one&two']); Test('one`two', [], [pcHasSubCommand]); Test('''one`two''', ['one`two']); Test('one$two', [], [pcHasShellVariable]); Test('''one$two''', ['one$two']); Test('one$(two)', [], [pcHasSubCommand, pcHasParenthesis]); Test('one\$two', ['one$two'], []); Test('''one$(two)''', ['one$(two)']); Test('one*two', [], [pcHasWildcard]); Test('"one*two"', ['one*two']); Test('one*two', [], [pcHasWildcard]); Test('''one*two''', ['one*two']); Test('one\ two', ['one two'], []); Test('one\\two', ['one\two'], []); Test('one\\\\\\two', ['one\\\two'], []); Test('one|two', [], [pcHasRedirection], {posix=}false); Test('one&two', ['one&two'], [], false); Test(''' one'' two', ['''', 'one''', 'two'], [], false); Test('"one" two', ['one', 'two'], [], false); Test('one "two"', ['one', 'two'], [], false); Test('one "two"', ['one', 'two'], [], false); Test('one " two"', ['one', ' two'], [], false); Test('" one" two', [' one', 'two'], [], false); Test('"one one" two', ['one one', 'two'], [], false); end; procedure TTestLowLevelCommon._IsMatch; var i,j: integer; V, cont: RawUTF8; match: TMatch; reuse,isword: boolean; procedure Contains; begin check(match.Match('12')); check(match.Match('12e')); check(match.Match('12er')); check(match.Match('a12')); check(match.Match('a12e')); check(match.Match('ab12')); check(match.Match('ab12er')); check(not match.Match('1')); check(not match.Match('a1')); check(not match.Match('a1b2')); check(not match.Match('1a2')); end; function GL(a,b: PAnsiChar; const c: RawUTF8): boolean; begin // avoid Delphi compiler complains about PUTF8Char/PAnsiChar types result := GetLineContains(pointer(a), pointer(b), pointer(c)); end; begin V := '123456789ABC'#10'DEF0zxy'; Check(GL(@V[1],nil,'1')); Check(GL(@V[1],nil,'C')); Check(GL(@V[1],nil,'89')); Check(not GL(@V[1],nil,'ZX')); Check(GL(@V[14],nil,'ZXY')); Check(not GL(@V[1],nil,'890')); Check(GL(@V[1],@V[21],'89')); Check(GL(@V[14],@V[21],'ZX')); Check(not GL(@V[1],@V[21],'ZX')); Check(GL(@V[14],@V[21],'ZXY')); Check(not GL(@V[1],@V[5],'89')); Check(not GL(@V[1],@V[15],'ZXY')); Check(not GL(@V[14],@V[17],'ZXY')); V := '1234567890123456'#13'1234567890123456789'; for j := 1 to 16 do begin for i := j to 16 do begin CheckEqual(BufferLineLength(@V[j],@V[i]),i-j); CheckEqual(GetLineSize(@V[j],@V[i]),i-j); end; for i := 17 to 34 do begin CheckEqual(BufferLineLength(@V[j],@V[i]),17-j); CheckEqual(GetLineSize(@V[j],@V[i]),17-j); end; CheckEqual(GetLineSize(@V[j],nil),17-j); end; V := '12345678901234561234567890123456'#10'1234567890123456789'; for j := 1 to 32 do begin for i := j to 32 do begin CheckEqual(BufferLineLength(@V[j],@V[i]),i-j); CheckEqual(GetLineSize(@V[j],@V[i]),i-j); end; for i := 33 to 50 do begin CheckEqual(BufferLineLength(@V[j],@V[i]),33-j); CheckEqual(GetLineSize(@V[j],@V[i]),33-j); end; CheckEqual(GetLineSize(@V[j],nil),33-j); end; Check(IsMatch('','',true)); Check(not IsMatch('','toto',true)); Check(not IsMatch('Bidule.pas','',true)); Check(IsMatch('Bidule.pas','Bidule.pas',true)); Check(IsMatch('Bidule.pas','BIDULE.pas',true)); Check(IsMatch('Bidule.pas','Bidule.paS',true)); Check(IsMatch('Bidule.pas','Bidule.pas',false)); Check(not IsMatch('Bidule.pas','bidule.pas',false)); Check(not IsMatch('bidule.pas','bidulE.pas',false)); Check(not IsMatch('bidule.pas','bidule.paS',false)); Check(not IsMatch('bidule.pas','bidule.pa',false)); for i := 0 to 200 do begin V := Int32ToUtf8(i); Check(IsMatch(V,V,false)=IsMatch(V,V,true)); end; Check(IsMatch('test*','test',false)); Check(IsMatch('test*','test',true)); Check(IsMatch('test*','teste',false)); Check(IsMatch('test*','teste',true)); Check(IsMatch('test*','tester',false)); Check(IsMatch('test*','tester',true)); Check(IsMatch('a*','anything',true)); Check(IsMatch('a*','a',true)); Check(IsMatch('*','anything',true)); Check(IsMatch('*.pas','Bidule.pas',true)); Check(IsMatch('*.pas','Bidule.pas',false)); Check(IsMatch('*.PAS','Bidule.pas',true)); Check(not IsMatch('*.PAS','Bidule.pas',false)); Check(IsMatch('*.p?s','Bidule.pas',true)); Check(IsMatch('*.p*S','Bidule.pas',true)); Check(IsMatch('B*.PAS','bidule.pas',true)); Check(IsMatch('*.p?s','bidule.pas',false)); Check(IsMatch('*.p*s','bidule.pas',false)); Check(IsMatch('b*.pas','bidule.pas',false)); Check(not IsMatch('B*.das','Bidule.pas',true)); Check(IsMatch('bidule.*','Bidule.pas',true)); Check(IsMatch('ma?ch.*','match.exe',false)); Check(IsMatch('ma?ch.*','mavch.dat',false)); Check(IsMatch('ma?ch.*','march.on',false)); Check(IsMatch('ma?ch.*','march.',false)); Check(IsMatch('ab*.exyz', 'ab.exyz',true)); Check(IsMatch('ab[ef]xyz', 'abexyz',false)); Check(IsMatch('ab[ef]xyz', 'abexyz',true)); Check(IsMatch('ab*.[ef]xyz', 'abcd.exyz',true)); Check(IsMatch('ab*.[ef]xyz', 'ab.exyz',true)); Check(IsMatch('ab*.[ef]xyz', 'abcd.exyz',true)); Check(IsMatch('ab*.[ef]xyz', 'ab.fxyz',true)); Check(IsMatch('ab*.[ef]xyz', 'abcd.fxyz',true)); check(not IsMatch('ab[cd]e','abdde',false)); check(not IsMatch('ab[cd]ex','abddex',false)); check(not IsMatch('ab*.[cd]e','ab.dde',false)); check(not IsMatch('ab*.[cd]ex','ab.ddex',false)); V := 'this [e-n]s a [!zy]est'; check(not IsMatch(V,V,false)); Check(IsMatch(V,'this is a test',false)); Check(IsMatch(V,'this is a rest',false)); Check(not IsMatch(V,'this is a zest',false)); Check(not IsMatch(V,'this as a test',false)); Check(not IsMatch(V,'this as a rest',false)); for reuse := false to true do begin // ensure very same behavior match.Prepare(V, false, reuse); Check(not match.Match(V)); Check(match.Match('this is a test')); Check(match.Match('this is a rest')); Check(not match.Match('this is a zest')); match.Prepare('test', false, reuse); check(match.Match('test')); check(not match.Match('tes')); check(not match.Match('tests')); check(not match.Match('tesT')); match.Prepare('teST', true, reuse); check(match.Match('test')); check(match.Match('test')); match.Prepare('*', false, reuse); check(match.Match('test')); check(match.Match('tests')); match.Prepare('*', true, reuse); check(match.Match('test')); check(match.Match('tests')); match.Prepare('**', false, reuse); check(match.Match('test')); check(match.Match('tests')); match.Prepare('****', false, reuse); check(match.Match('test')); check(match.Match('tests')); match.Prepare('*.*', false, reuse); check(match.Match('te.st')); check(match.Match('te.st.')); check(match.Match('test.')); check(match.Match('.test')); check(match.Match('.')); check(not match.Match('test')); match.Prepare('*.*', true, reuse); check(match.Match('te.st')); check(match.Match('te.st.')); check(match.Match('test.')); check(match.Match('.test')); check(not match.Match('test')); check(match.Match('.')); match.Prepare('test*', false, reuse); check(match.Match('test')); check(match.Match('tests')); check(match.Match('tester')); check(not match.Match('atest')); check(not match.Match('tes')); check(not match.Match('tEst')); check(not match.Match('tesT')); check(not match.Match('t')); match.Prepare('*test', false, reuse); check(match.Match('test')); check(match.Match('stest')); check(match.Match('attest')); check(not match.Match('est')); check(not match.Match('testa')); check(not match.Match('tes')); check(not match.Match('tEst')); check(not match.Match('tesT')); check(not match.Match('t')); match.Prepare('*t', false, reuse); check(match.Match('t')); check(match.Match('st')); check(match.Match('tt')); check(match.Match('att')); check(not match.Match('s')); check(not match.Match('es')); check(not match.Match('ts')); match.Prepare('**', false, reuse); check(match.Match('') = reuse); check(match.Match('test')); match.Prepare('*test*', false, reuse); check(match.Match('test')); check(match.Match('tests')); check(match.Match('tester')); check(match.Match('atest')); check(match.Match('ateste')); check(match.Match('abtest')); check(match.Match('abtester')); check(not match.Match('tes')); check(not match.Match('ates')); check(not match.Match('tesates')); check(not match.Match('tesT')); check(not match.Match('Teste')); check(not match.Match('TEster')); check(not match.Match('atEst')); check(not match.Match('ateSTe')); match.Prepare('*12*', false, reuse); Contains; if reuse then begin cont := '12'; match.PrepareContains(cont, false); Contains; cont := '12'; match.PrepareContains(cont, true); Contains; end; match.Prepare('*teSt*', true, reuse); check(match.Match('test')); check(match.Match('teste')); check(match.Match('tester')); check(match.Match('atest')); check(match.Match('ateste')); check(match.Match('abtest')); check(match.Match('abtester')); check(match.Match('tesT')); check(match.Match('Teste')); check(match.Match('TEster')); check(match.Match('atEst')); check(match.Match('ateSTe')); check(match.Match('abteST')); check(match.Match('abtEster')); check(not match.Match('tes')); check(not match.Match('ates')); check(not match.Match('tesates')); match.Prepare('*te?t*', true, reuse); check(match.Match('test')); check(match.Match('tezt')); check(match.Match('teste')); check(match.Match('tezte')); check(match.Match('tester')); check(match.Match('atest')); check(match.Match('ateste')); check(not match.Match('tes')); check(not match.Match('tet')); check(not match.Match('ates')); check(not match.Match('tesates')); match.Prepare('?est*', true, reuse); check(match.Match('test')); check(match.Match('test')); check(match.Match('teste')); check(match.Match('tester')); check(not match.Match('tezte')); check(not match.Match('atest')); check(not match.Match('est')); check(not match.Match('este')); check(not match.Match('tes')); check(not match.Match('tet')); check(not match.Match('ates')); check(not match.Match('tesates')); match.Prepare('a*bx*cy*d', false, reuse); check(match.Match('abxcyd')); check(match.Match('a1bxcyd')); check(match.Match('a12bxcyd')); check(match.Match('a123bxcyd')); check(match.Match('abx1cyd')); check(match.Match('abx12cyd')); check(match.Match('abxcy1d')); check(match.Match('abxcy12d')); check(match.Match('abxcy123d')); check(not match.Match('abcyd')); check(not match.Match('abxcyde')); match.Prepare('************************************************'+ '************************************************'+ '**************************************************.*', false, reuse); check(match.MatchThreadSafe('abxcyd.')); check(match.MatchThreadSafe('abxc.yd')); check(match.MatchThreadSafe('abxcy.d')); check(match.MatchThreadSafe('.')); check(match.MatchThreadSafe('.a')); check(match.MatchThreadSafe('.abxcyd')); check(not match.MatchThreadSafe('abxcyd')); end; for i := 32 to 127 do begin SetLength(V,1); V[1] := AnsiChar(i); isword := (tcWord in TEXT_BYTES[i]); Check(IsMatch('[A-Za-z0-9]',V)=isword); Check(IsMatch('[01-456a-zA-Z789]',V)=isword); SetLength(V,3); V[1] := AnsiChar(i); V[2] := AnsiChar(i); V[3] := AnsiChar(i); Check(IsMatch('[A-Za-z0-9]?[A-Za-z0-9]',V)=isword); Check(IsMatch('[A-Za-z0-9]*',V)=isword); Check(IsMatch('[a-z0-9]?[A-Z0-9]',V,true)=isword); Check(IsMatch('[A-Z0-9]*',V,true)=isword); end; end; procedure TTestLowLevelCommon._TExprParserMatch; var s: TExprParserMatch; procedure Test(const expression: RawUTF8; const ok, nok: array of RawUTF8); var i: integer; begin Check(s.Parse(expression) = eprSuccess); for i := 0 to high(ok) do Check(s.Search(ok[i])); for i := 0 to high(nok) do Check(not s.Search(nok[i])); end; begin s := TExprParserMatch.Create({casesensitive=}true); try // &=AND -=WITHOUT +=OR check(s.Parse('') = eprNoExpression); check(s.Parse(' ') = eprNoExpression); check(s.Parse('1+ ') = eprMissingFinalWord); Test('1', ['1', '1 2 3', '2 1'], ['2', '13', '2 3']); Test(' 1 ', ['1', '1 2 3', '2 1'], ['2', '13', '2 3']); Test('1+4', ['1', '1 2 3', '2 1', '2 4 3'], ['2', '13', '2 3', '41']); Test(' 1 + 4 ', ['1', '1 2 3', '2 1', '2 4 3'], ['2', '13', '2 3', '41']); Test('1+4+5', ['1', '1 2 3', '2 1', '2 4 3'], ['2', '13', '2 3', '41']); Test('1+(4+5)', ['1', '1 2 3', '2 1', '2 4 3'], ['2', '13', '2 3', '41']); Test('1+4*+5', ['1', '1 2 3', '2 1', '2 4 3', '41'], ['2', '13', '2 3']); Test('1+(4&555)', ['4 555 3', '555 4', '1', '1 2 3', '2 1'], ['2', '13', '2 3', '41', '4 3', '3 555']); Test('1+(4 555)', ['4 555 3', '555 4', '1', '1 2 3', '2 1'], ['2', '13', '2 3', '41', '4 3', '3 555']); Test('1-4', ['1', '1 2 3', '2 1', '2 1 3'], ['1 4', '4 2 1', '2', '13', '2 3', '41']); Test('1-(4&5)', ['1', '1 2 3', '2 1', '1 4', '1 5'], ['2', '5 2 3 4 1', '2 3', '41', '4 3', '3 5', '1 4 5']); Test('1-(4&(5+6))', ['1', '1 2 3', '2 1', '1 4', '1 5', '1 6'], ['2', '5 2 3 4 1', '2 3', '41', '4 3', '3 5', '1 4 5', '1 4 6']); Test('1 - ( 4 & ( 57 + 6 ) )', ['1', '1 2 3', '2 1', '1 4', '1 57', '1 6'], ['2', '57 2 3 4 1', '2 3', '41', '4 3', '3 5"7', '1 4 57', '1 4 6']); finally s.Free; end; end; procedure TTestLowLevelCommon._Random32; var i: integer; c: array[0..1000] of cardinal; begin for i := 0 to high(c) do c[i] := Random32; QuickSortInteger(@c,0,high(c)); for i := 1 to high(c) do Check(c[i+1]<>c[i],'unique Random32'); Check(Random32(0)=0); for i := 1 to 100000 do Check(Random32(i)nil then while len>0 do begin result := crc32ctab[0,byte(result xor ord(buf^))] xor (result shr 8); dec(len); inc(buf); end; result := not result; end; function Hash32Reference(Data: PCardinal; Len: integer): cardinal; var s1,s2: cardinal; i: integer; begin if Data<>nil then begin s1 := 0; s2 := 0; for i := 1 to Len shr 2 do begin // 4 bytes (DWORD) by loop inc(s1,Data^); inc(s2,s1); inc(Data); end; case Len and 3 of // remaining 0..3 bytes 1: inc(s1,PByte(Data)^); 2: inc(s1,PWord(Data)^); 3: inc(s1,PWord(Data)^ or (PByteArray(Data)^[2] shl 16)); end; inc(s2,s1); result := s1 xor (s2 shl 16); end else result := 0; end; {$ifndef FPC} // RolDWord is an intrinsic function under FPC :) function RolDWord(value: cardinal; count: integer): cardinal; {$ifdef HASINLINE}inline;{$endif} begin result := (value shl count) or (value shr (32-count)); end; {$endif FPC} function xxHash32reference(P: PAnsiChar; len: integer; seed: cardinal = 0): cardinal; const PRIME32_1 = 2654435761; PRIME32_2 = 2246822519; PRIME32_3 = 3266489917; PRIME32_4 = 668265263; PRIME32_5 = 374761393; var c1, c2, c3, c4: cardinal; PLimit, PEnd: PAnsiChar; begin PEnd := P + len; if len >= 16 then begin PLimit := PEnd - 16; c1 := seed + PRIME32_1 + PRIME32_2; c2 := seed + PRIME32_2; c3 := seed; c4 := seed - PRIME32_1; repeat c1 := PRIME32_1 * RolDWord(c1 + PRIME32_2 * PCardinal(P)^, 13); c2 := PRIME32_1 * RolDWord(c2 + PRIME32_2 * PCardinal(P+4)^, 13); c3 := PRIME32_1 * RolDWord(c3 + PRIME32_2 * PCardinal(P+8)^, 13); c4 := PRIME32_1 * RolDWord(c4 + PRIME32_2 * PCardinal(P+12)^, 13); inc(P, 16); until not (P <= PLimit); result := RolDWord(c1, 1) + RolDWord(c2, 7) + RolDWord(c3, 12) + RolDWord(c4, 18); end else result := seed + PRIME32_5; inc(result, len); while P <= PEnd - 4 do begin inc(result, PCardinal(P)^ * PRIME32_3); result := RolDWord(result, 17) * PRIME32_4; inc(P, 4); end; while P < PEnd do begin inc(result, PByte(P)^ * PRIME32_5); result := RolDWord(result, 11) * PRIME32_1; inc(P); end; result := result xor (result shr 15); result := result * PRIME32_2; result := result xor (result shr 13); result := result * PRIME32_3; result := result xor (result shr 16); end; procedure crcblockreference(crc128, data128: PBlock128); var c: cardinal; begin c := crc128^[0] xor data128^[0]; crc128^[0] := crc32ctab[3,byte(c)] xor crc32ctab[2,byte(c shr 8)] xor crc32ctab[1,byte(c shr 16)] xor crc32ctab[0,c shr 24]; c := crc128^[1] xor data128^[1]; crc128^[1] := crc32ctab[3,byte(c)] xor crc32ctab[2,byte(c shr 8)] xor crc32ctab[1,byte(c shr 16)] xor crc32ctab[0,c shr 24]; c := crc128^[2] xor data128^[2]; crc128^[2] := crc32ctab[3,byte(c)] xor crc32ctab[2,byte(c shr 8)] xor crc32ctab[1,byte(c shr 16)] xor crc32ctab[0,c shr 24]; c := crc128^[3] xor data128^[3]; crc128^[3] := crc32ctab[3,byte(c)] xor crc32ctab[2,byte(c shr 8)] xor crc32ctab[1,byte(c shr 16)] xor crc32ctab[0,c shr 24]; end; procedure TTestLowLevelCommon._crc32c; var crc: array[0..10000] of record s: RawByteString; crc: cardinal; end; totallen: Cardinal; procedure Test(hash: THasher; const name: string); var i: Integer; Timer: TPrecisionTimer; a: string[10]; begin Timer.Start; a := '123456789'; Check(hash(0,@a,0)=0); Check(hash(0,@a,1)=$2ACF889D); Check(hash(0,@a,2)=$BD5FE6AF); Check(hash(0,@a,3)=$7F40BC73); Check(hash(0,@a,4)=$13790E51); Check(crc32cBy4(cardinal(not 0),PCardinal(@a)^)=cardinal(not $13790E51),'crc32cBy4'); Check(hash(0,@a,5)=$659AD21); Check(hash(0,@a,6)=$85BF5A8C); Check(hash(0,@a,7)=$8B0FB6FA); Check(hash(0,@a,8)=$2E5336F0); for i := 0 to High(crc) do with crc[i] do Check(hash(0,pointer(s),length(s))=crc); fRunConsole := format('%s %s %s/s',[fRunConsole,name,KB(Timer.PerSec(totallen))]); end; procedure test16(const text: RawUTF8; expected: cardinal); begin Check(crc16(pointer(text),length(text))=expected); end; var i,j: integer; Timer: TPrecisionTimer; c1,c2: cardinal; crc1,crc2: THash128; crcs: THash512Rec; digest: THash256; tmp: RawByteString; hmac32: THMAC_CRC32C; // hmac256: THMAC_CRC256C; begin test16('',$ffff); test16('a',$9d77); test16('ab',$69f0); test16('toto',$e2ca); test16('123456789',$29b1); test16('123456789123456789',$a86d); totallen := 36; tmp := '123456789123456789'; c2 := $12345678; c1 := HMAC_CRC32C(@c2,pointer(tmp),4,length(tmp)); check(c1=$1C3C4B51); hmac32.Init(@c2,4); hmac32.Update(pointer(tmp),length(tmp)); check(hmac32.Done=c1); c2 := $12345678; HMAC_CRC256C(@c2,pointer(tmp),4,length(tmp),digest); check(SHA256DigestToString(digest)='46da01fb9f4a97b5f8ba2c70512bc22aa'+ 'a9b57e5030ced9f5c7c825ab5ec1715'); FillZero(crc2); crcblock(@crc2,PBlock128(PAnsiChar('0123456789012345'))); check(not IsZero(crc2)); check(TBlock128(crc2)[0]=1314793854); check(TBlock128(crc2)[1]=582109780); check(TBlock128(crc2)[2]=1177891908); check(TBlock128(crc2)[3]=4047040040); FillZero(crc1); crcblockreference(@crc1,PBlock128(PAnsiChar('0123456789012345'))); check(not IsZero(crc1)); check(IsEqual(crc1,crc2)); FillZero(crc1); crcblocks(@crc1,PBlock128(PAnsiChar('0123456789012345')),1); check(not IsZero(crc1)); check(IsEqual(crc1,crc2),'crcblocks'); {$ifdef CPUINTEL} FillZero(crc1); crcblockNoSSE42(@crc1,PBlock128(PAnsiChar('0123456789012345'))); check(not IsZero(crc1)); check(IsEqual(crc1,crc2)); {$endif} for i := 0 to high(crcs.b) do crcs.b[i] := i; for j := 1 to 4 do begin FillZero(crc2); crcblockreference(@crc2,@crcs.h0); if j>1 then crcblockreference(@crc2,@crcs.h1); if j>2 then crcblockreference(@crc2,@crcs.h2); if j>3 then crcblockreference(@crc2,@crcs.h3); FillZero(crc1); crcblocks(@crc1,@crcs.h0,j); check(not IsZero(crc1)); check(IsEqual(crc1,crc2),'crcblocks4'); FillZero(crc1); crcblocksfast(@crc1,@crcs.h0,j); check(not IsZero(crc1)); check(IsEqual(crc1,crc2),'crcblocksfast4'); CheckEqual(Hash128Index(@crcs,4,@crcs.r[j-1]),j-1); check(Hash128Index(@crcs,j-1,@crcs.r[j-1])<0); end; CheckEqual(Hash256Index(@crcs,2,@crcs.r[0]),0); check(Hash256Index(@crcs,2,@crcs.r[1])<0); CheckEqual(Hash256Index(@crcs,2,@crcs.r[2]),1); check(Hash256Index(@crcs,2,@crcs.r[3])<0); for i := 0 to 50000 do begin FillZero(crc1); crcblock(@crc1,@digest); check(not IsZero(crc1)); {$ifdef CPUINTEL} FillZero(crc2); crcblockreference(@crc2,@digest); check(not IsZero(crc2)); check(IsEqual(crc1,crc2)); FillZero(crc2); crcblockNoSSE42(@crc2,@digest); check(not IsZero(crc2)); check(IsEqual(crc1,crc2)); {$endif} for j := 0 to high(digest) do inc(digest[j]); end; for i := 0 to High(crc) do with crc[i] do begin j := i shr 3+1; // circumvent weird FPC code generation bug in -O2 mode s := RandomString(j); crc := crc32creference(0,pointer(s),length(s)); inc(totallen,length(s)); c2 := HMAC_CRC32C(@c1,pointer(s),4,length(s)); hmac32.Init(@c1,4); hmac32.Update(pointer(s),length(s)); check(hmac32.Done=c2); end; Test(crc32creference,'pas'); Test(crc32cfast,'fast'); {$ifdef CPUINTEL} {$ifndef Darwin} // Not [yet] working on Darwin if cfSSE42 in CpuFeatures then Test(crc32csse42,'sse42'); {$endif} {$ifdef CPUX64} if (cfSSE42 in CpuFeatures) and (cfAesNi in CpuFeatures) then Test(crc32c,'sse42+aesni'); // use SSE4.2+pclmulqdq instructions on x64 {$endif} {$endif} exit; // code below is speed informative only, without any test Timer.Start; for i := 0 to high(crc) do with crc[i] do fnv32(0,pointer(s),length(s)); fRunConsole := format('%s fnv32 %s %s/s',[fRunConsole,Timer.Stop, KB(Timer.PerSec(totallen))]); end; procedure TTestLowLevelCommon.intadd(const Sender; Value: integer); begin AddToCSV(UInt32ToUtf8(Value),fAdd); end; procedure TTestLowLevelCommon.intdel(const Sender; Value: integer); begin AddToCSV(UInt32ToUtf8(Value),fDel); end; procedure TTestLowLevelCommon.Integers; procedure changes(const old,new,added,deleted: RawUTF8); var o,n: TIntegerDynArray; begin CSVToIntegerDynArray(Pointer(old),o); CSVToIntegerDynArray(Pointer(new),n); fAdd := ''; fDel := ''; NotifySortedIntegerChanges(pointer(o),pointer(n),length(o),length(n),intadd,intdel,self); Check(fAdd = added, 'added'); Check(fDel = deleted, 'deleted'); end; procedure includes(const values, includes, excludes, included, excluded: RawUTF8); procedure includes32; var v, i, e: TIntegerDynArray; begin CSVToIntegerDynArray(Pointer(values),v); CSVToIntegerDynArray(Pointer(excludes),e); ExcludeInteger(v, e, 32); // no sort Check(IntegerDynArrayToCSV(v) = excluded); v := nil; e := nil; CSVToIntegerDynArray(Pointer(values),v); CSVToIntegerDynArray(Pointer(excludes),e); ExcludeInteger(v, e, 2); // sort Check(IntegerDynArrayToCSV(v) = excluded); v := nil; e := nil; CSVToIntegerDynArray(Pointer(values),v); CSVToIntegerDynArray(Pointer(includes),i); IncludeInteger(v, i, 32); // no sort Check(IntegerDynArrayToCSV(v) = included); v := nil; e := nil; CSVToIntegerDynArray(Pointer(values),v); CSVToIntegerDynArray(Pointer(includes),i); IncludeInteger(v, i, 2); // sort Check(IntegerDynArrayToCSV(v) = included); end; procedure includes64; var v, i, e: TInt64DynArray; begin CSVToInt64DynArray(Pointer(values),v); CSVToInt64DynArray(Pointer(excludes),e); ExcludeInt64(v, e, 32); // no sort Check(Int64DynArrayToCSV(v) = excluded); v := nil; e := nil; CSVToInt64DynArray(Pointer(values),v); CSVToInt64DynArray(Pointer(excludes),e); ExcludeInt64(v, e, 2); // sort Check(Int64DynArrayToCSV(v) = excluded); v := nil; e := nil; CSVToInt64DynArray(Pointer(values),v); CSVToInt64DynArray(Pointer(includes),i); IncludeInt64(v, i, 32); // no sort Check(Int64DynArrayToCSV(v) = included); v := nil; e := nil; CSVToInt64DynArray(Pointer(values),v); CSVToInt64DynArray(Pointer(includes),i); IncludeInt64(v, i, 2); // sort Check(Int64DynArrayToCSV(v) = included); end; begin Includes32; Includes64; end; var i32: TIntegerDynArray; i64: TInt64DynArray; i,n: integer; begin check(i32=nil); DeduplicateInteger(i32); check(i32=nil); SetLength(i32,2); i32[0] := 1; QuickSortInteger(i32); check(i32[0]=0); check(i32[1]=1); DeduplicateInteger(i32); check(length(i32)=2); check(i32[0]=0); check(i32[1]=1); i32[0] := 1; DeduplicateInteger(i32); check(length(i32)=1); check(i32[0]=1); SetLength(i32,6); i32[4] := 1; i32[5] := 2; DeduplicateInteger(i32); // (1, 0, 0, 0, 1, 2) check(length(i32)=3); check(i32[0]=0); check(i32[1]=1); check(i32[2]=2); SetLength(i32,6); i32[4] := 3; i32[5] := 3; DeduplicateInteger(i32); // (0, 1, 2, 0, 3, 3) check(length(i32)=4); check(i32[0]=0); check(i32[1]=1); check(i32[2]=2); check(i32[3]=3); for n := 1 to 1000 do begin SetLength(i32,n); for i := 0 to n - 1 do i32[i] := i and 15; DeduplicateInteger(i32); if n < 16 then check(Length(i32) = n) else check(Length(i32) = 16); for i := 0 to high(i32) do check(i32[i] = i); end; changes('','','',''); changes('1','1','',''); changes('','1','1',''); changes('1','','','1'); changes('1,2','1,3','3','2'); changes('2','1,3','1,3','2'); changes('','1,3','1,3',''); changes('1,2,3,4','1,2,3,4','',''); changes('1,2,3,4','1,2,3,4,5','5',''); changes('1,2,3,4','1,3,4','','2'); changes('1,2,3,4','3,4','','1,2'); changes('1,2,3,4','1,4','','2,3'); changes('1,2,3,4','','','1,2,3,4'); changes('1,2,3,4','5,6','5,6','1,2,3,4'); changes('1,2,4','1,3,5,6','3,5,6','2,4'); changes('1,2,4','3,5,6','3,5,6','1,2,4'); includes('1,2,3', '2', '2', '2', '1,3'); includes('1,2,3', '2,3', '2,3', '2,3', '1'); includes('1,2,3', '1,2,3', '1,2,3', '1,2,3', ''); includes('1,2,3', '3,1,2', '3,1,2', '1,2,3', ''); check(i64=nil); DeduplicateInt64(i64); check(i64=nil); SetLength(i64,2); i64[0] := 1; QuickSortInt64(pointer(i64),0,1); check(i64[0]=0); check(i64[1]=1); DeduplicateInt64(i64); check(length(i64)=2); check(i64[0]=0); check(i64[1]=1); i64[0] := 1; DeduplicateInt64(i64); check(length(i64)=1); check(i64[0]=1); SetLength(i64,6); i64[4] := 1; i64[5] := 2; DeduplicateInt64(i64); // (1, 0, 0, 0, 1, 2) check(length(i64)=3); check(i64[0]=0); check(i64[1]=1); check(i64[2]=2); SetLength(i64,6); i64[4] := 3; i64[5] := 3; DeduplicateInt64(i64); // (0, 1, 2, 0, 3, 3) check(length(i64)=4); check(i64[0]=0); check(i64[1]=1); check(i64[2]=2); check(i64[3]=3); for n := 1 to 1000 do begin SetLength(i64,n); for i := 0 to n - 1 do i64[i] := i and 15; DeduplicateInt64(i64); if n < 16 then check(Length(i64) = n) else check(Length(i64) = 16); for i := 0 to high(i64) do check(i64[i] = i); end; end; function TestAddFloatStr(const str: RawUTF8): RawUTF8; var tmp: TTextWriterStackBuffer; begin with TTextWriter.CreateOwnedStream(tmp) do try AddFloatStr(pointer(str)); SetText(result); finally Free; end; end; procedure TTestLowLevelCommon.NumericalConversions; procedure CheckDoubleToShort(v: double; const expected: ShortString); var a: ShortString; d: double; err: integer; begin ExtendedToShort(a,v,DOUBLE_PRECISION); CheckEqual(a,expected,'ExtendedToShort'); DoubleToShort(a,v); CheckEqual(a,expected,'DoubleToShort'); a[ord(a[0])+1] := #0; d := GetExtended(@a[1],err); CheckEqual(err,0); CheckSame(v,d); end; procedure CheckDoubleToShortSame(v: double); var s: string; u: RawUTF8; err: integer; d: double; begin s := DoubleToString(v); val(s,d,err); Check(err=0); CheckSame(d,v); StringToUTF8(s,u); d := GetExtended(pointer(u),err); Check(err=0); CheckSame(d,v); end; var i, j, b, err: integer; juint: cardinal absolute j; k,l: Int64; q: QWord; s,s2: RawUTF8; d,e: double; f: extended; sd,se: single; {$ifndef DELPHI5OROLDER} c: currency; ident: TRawUTF8DynArray; {$endif} {$ifndef NOVARIANTS} vj, vs: variant; {$endif} a,a2: shortstring; u: string; varint: array[0..255] of byte; st: TFastReader; PB,PC: PByte; P: PUTF8Char; crc, u32, n: cardinal; Timer: TPrecisionTimer; begin n := 100000; Timer.Start; crc := 0; d := 3.141592653 / 1.0573623912; for i := 1 to n do begin f := d; j := FloatToText(PChar(@varint),f,{$ifndef FPC}fvExtended,{$endif} ffGeneral,DOUBLE_PRECISION,0); PChar(@varint)[j] := #0; inc(crc,j); d := d * 1.0038265263; end; NotifyTestSpeed('FloatToText ', [Pchar(@varint)], n, crc, @timer); Timer.Start; crc := 0; d := 3.141592653 / 1.0573623912; for i := 1 to n do begin Str(d,a); inc(crc,ord(a[0])); d := d * 1.0038265263; end; NotifyTestSpeed('str ', [a], n, crc, @timer); // a[ord(a[0])+1] := #0; Check(SameValue(GetExtended(pointer(@a[1])),d,0)); Timer.Start; crc := 0; d := 3.141592653 / 1.0573623912; for i := 1 to n do begin DoubleToShort(a,d); inc(crc,ord(a[0])); d := d * 1.0038265263; end; NotifyTestSpeed('DoubleToShort ', [a], n, crc, @timer); a[ord(a[0])+1] := #0; // a[ord(a[0])+1] := #0; Check(SameValue(GetExtended(pointer(@a[1])),d,0)); {$ifdef DOUBLETOSHORT_USEGRISU} Timer.Start; crc := 0; d := 3.141592653 / 1.0573623912; for i := 1 to n do begin DoubleToAscii(C_NO_MIN_WIDTH,-1,d,@a); inc(crc,ord(a[0])); d := d * 1.0038265263; end; NotifyTestSpeed('DoubleToAscii ', [a], n, crc, @timer); // a[ord(a[0])+1] := #0; Check(SameValue(GetExtended(pointer(@a[1])),d,0)); d := 0; DoubleToAscii(C_NO_MIN_WIDTH,-1,d,@a); Check(a='0'); DoubleToAscii(0,DOUBLE_PRECISION,d,@a); Check(a='0'); {$endif DOUBLETOSHORT_USEGRISU} CheckEqual(TestAddFloatStr(''),'0'); CheckEqual(TestAddFloatStr(' 123'),'123'); CheckEqual(TestAddFloatStr(' 1a23'),'1'); CheckEqual(TestAddFloatStr(' 123z'),'123'); CheckEqual(TestAddFloatStr(' 12.3'),'12.3'); CheckEqual(TestAddFloatStr('12.'),'12.'); CheckEqual(TestAddFloatStr(' +12.3'),'+12.3'); CheckEqual(TestAddFloatStr(' -12.3'),'-12.3'); CheckEqual(TestAddFloatStr('12.3e230'),'12.3e230'); CheckEqual(TestAddFloatStr('12.3E230'),'12.3E230'); CheckEqual(TestAddFloatStr('12.3e-230'),'12.3e-230'); CheckEqual(TestAddFloatStr('12.3E-230'),'12.3E-230'); CheckEqual(TestAddFloatStr('12.3e 230'),'12.3e'); CheckEqual(TestAddFloatStr('12.3f230'),'12.3'); CheckEqual(TestAddFloatStr('12.3E23.0'),'12.3E23'); CheckEqual(TestAddFloatStr('-.01'),'-0.01'); // ODBC numeric output CheckEqual(TestAddFloatStr('.0002'),'0.0002'); // ODBC numeric output CheckEqual(OctToBin(''),''); CheckEqual(OctToBin('123'),'123'); CheckEqual(OctToBin('\\123'),'\123'); CheckEqual(OctToBin('12\\3'),'12\3'); CheckEqual(OctToBin('123\\'),'123\'); CheckEqual(OctToBin('123\'),'123'); CheckEqual(OctToBin('\041'),'!'); CheckEqual(OctToBin('a\041'),'a!'); CheckEqual(OctToBin('\041b'),'!b'); CheckEqual(OctToBin('a\041b'),'a!b'); CheckEqual(OctToBin('a\101b\102'),'aAbB'); CheckEqual(OctToBin('a\101\102b'),'aABb'); CheckEqual(OctToBin('a\101\\\102b'),'aA\Bb'); CheckEqual(OctToBin('a\401b\102'),'a'); CheckEqual(OctToBin('a\181b\102'),'a'); CheckEqual(OctToBin('a\10ab\102'),'a'); CheckEqual(OctToBin('a\1'),'a'); CheckEqual(OctToBin('a\10'),'a'); Check(Plural('row',0)='0 row'); Check(Plural('row',1)='1 row'); Check(Plural('row',2)='2 rows'); Check(Plural('row',20)='20 rows'); Check(Plural('row',200000)='200000 rows'); Check(not SameValue(386.0, 386.1)); Check(not SameValue(386.0, 700, 2)); Check(IntToThousandString(0)='0'); Check(IntToThousandString(1)='1'); Check(IntToThousandString(10)='10'); Check(IntToThousandString(100)='100'); Check(IntToThousandString(1000)='1,000'); Check(IntToThousandString(10000)='10,000'); Check(IntToThousandString(100000)='100,000'); Check(IntToThousandString(1000000)='1,000,000'); Check(IntToThousandString(-1)='-1'); Check(IntToThousandString(-10)='-10'); Check(IntToThousandString(-100)='-100'); Check(IntToThousandString(-1000)='-1,000'); Check(IntToThousandString(-10000)='-10,000'); Check(IntToThousandString(-100000)='-100,000'); Check(IntToThousandString(-1000000)='-1,000,000'); Check(UInt3DigitsToUTF8(1)='001'); Check(UInt3DigitsToUTF8(12)='012'); Check(UInt3DigitsToUTF8(123)='123'); Check(UInt4DigitsToUTF8(1)='0001'); Check(UInt4DigitsToUTF8(12)='0012'); Check(UInt4DigitsToUTF8(123)='0123'); Check(UInt4DigitsToUTF8(1234)='1234'); Check(MicroSecToString(0)='0us'); Check(MicroSecToString(QWord(-10))='0us'); Check(MicroSecToString(10)='10us'); Check(MicroSecToString(999)='999us'); Check(MicroSecToString(1000)='1ms'); Check(MicroSecToString(1001)='1ms'); Check(MicroSecToString(1010)='1.01ms'); Check(MicroSecToString(1100)='1.10ms'); Check(MicroSecToString(999999)='999.99ms'); Check(MicroSecToString(1000000)='1s'); Check(MicroSecToString(1000001)='1s'); Check(MicroSecToString(2030001)='2.03s'); Check(MicroSecToString(200000070001)='2d'); Check(KB(-123)='-123 B'); Check(KB(0)='0 B'); Check(KB(123)='123 B'); Check(KB(1023)='1 KB'); Check(KB(1024)='1 KB'); Check(KB(1025)='1 KB'); Check(KB(16383)='16 KB'); Check(KB(16384)='16 KB'); Check(KB(16385)='16 KB'); Check(KB(3*1024*1024-800*1024)='2.2 MB'); Check(KB(3*1024*1024)='3 MB'); Check(KB(3*1024*1024+512*1024)='3.5 MB'); Check(KB(3*1024*1024+1024)='3 MB'); Check(KB(maxInt)='2 GB'); Check(KB(3294963200)='3 GB'); Check(KB(4294963200)='4 GB'); Check(Int64ToUtf8(-maxInt)='-2147483647'); Check(Int64ToUtf8(-1)='-1'); Check(Int64ToUtf8(-9223372036854775807)='-9223372036854775807'); Int64ToUtf8(-maxInt,s); Check(s='-2147483647'); Int64ToUtf8(-1,s); Check(s='-1'); Int64ToUtf8(100,s); Check(s='100'); Int64ToUtf8(-9223372036854775807,s); Check(s='-9223372036854775807'); {$ifdef HASINLINE} // bug with MinInt64 with older versions of Delphi Check(Int64ToUtf8(-9223372036854775808)='-9223372036854775808'); Int64ToUtf8(-9223372036854775808,s); Check(s='-9223372036854775808'); {$endif} Check(Int64ToUTF8(2119852951849248647)='2119852951849248647'); Check(FormatUTF8(' % ',[2119852951849248647])=' 2119852951849248647 '); s := '1234'; d := GetExtended(pointer(s)); CheckSame(d,1234); s := '1234.1'; d := GetExtended(pointer(s)); CheckSame(d,1234.1); s := '12345678901234567890'; d := GetExtended(pointer(s)); CheckSame(d,12345678901234567890.0,0); s := '1234.1234567890123456789'; d := GetExtended(pointer(s)); CheckSame(d,1234.1234567890123456789); s := '.1234'; d := GetExtended(pointer(s)); CheckSame(d,0.1234); s := '.1234e'; d := GetExtended(pointer(s),err); Check(err<>0); s := '.1234e4'; d := GetExtended(pointer(s),err); Check(err=0); CheckSame(d,1234); u := DoubleToString(40640.5028819444); Check(u='40640.5028819444',u); s := '40640.5028a819444'; GetExtended(pointer(s),err); Check(err>0); s := '40640.5028819444'; d := GetExtended(pointer(s),err); Check(err=0); u := DoubleToString(d); Check(u='40640.5028819444',u); e := 40640.5028819444; CheckSame(d,e,1e-11); Check(IsAnsiCompatible('t')); Check(IsAnsiCompatible('te')); Check(IsAnsiCompatible('tes')); Check(IsAnsiCompatible('test')); Check(IsAnsiCompatible('teste')); CheckDoubleToShort(0,'0'); CheckDoubleToShort(1,'1'); CheckDoubleToShort(-1,'-1'); CheckDoubleToShort(0.1,'0.1'); CheckDoubleToShort(0.01,'0.01'); CheckDoubleToShort(0.001,'0.001'); CheckDoubleToShort(0.0001,'0.0001'); CheckDoubleToShort(-0.1,'-0.1'); CheckDoubleToShort(-0.01,'-0.01'); CheckDoubleToShort(-0.001,'-0.001'); CheckDoubleToShort(-0.0001,'-0.0001'); CheckDoubleToShort(1.1,'1.1'); CheckDoubleToShort(1.01,'1.01'); CheckDoubleToShort(1.001,'1.001'); CheckDoubleToShort(1.0001,'1.0001'); CheckDoubleToShort(1.00001,'1.00001'); CheckDoubleToShort(-1.1,'-1.1'); CheckDoubleToShort(-1.01,'-1.01'); CheckDoubleToShort(-1.001,'-1.001'); CheckDoubleToShort(-1.0001,'-1.0001'); CheckDoubleToShort(-1.00001,'-1.00001'); CheckDoubleToShort(7,'7'); CheckDoubleToShort(-7,'-7'); CheckDoubleToShort(0.7,'0.7'); CheckDoubleToShort(0.07,'0.07'); CheckDoubleToShort(0.007,'0.007'); CheckDoubleToShort(0.0007,'0.0007'); CheckDoubleToShort(-0.7,'-0.7'); CheckDoubleToShort(-0.07,'-0.07'); CheckDoubleToShort(-0.007,'-0.007'); CheckDoubleToShort(-0.0007,'-0.0007'); CheckDoubleToShort(7.7,'7.7'); CheckDoubleToShort(7.07,'7.07'); CheckDoubleToShort(7.007,'7.007'); CheckDoubleToShort(7.0007,'7.0007'); CheckDoubleToShort(7.00007,'7.00007'); CheckDoubleToShort(-7.7,'-7.7'); CheckDoubleToShort(-7.07,'-7.07'); CheckDoubleToShort(-7.007,'-7.007'); CheckDoubleToShort(-7.0007,'-7.0007'); CheckDoubleToShort(-7.00007,'-7.00007'); {$ifdef FPC} CheckDoubleToShort(0.00001,'0.00001'); CheckDoubleToShort(-0.00001,'-0.00001'); CheckDoubleToShort(0.00007,'0.00007'); CheckDoubleToShort(-0.00007,'-0.00007'); {$endif FPC} CheckDoubleToShort(11111.1,'11111.1'); CheckDoubleToShort(11111.01,'11111.01'); CheckDoubleToShort(11111.001,'11111.001'); CheckDoubleToShort(11111.0001,'11111.0001'); CheckDoubleToShort(11111.00001,'11111.00001'); CheckDoubleToShort(-11111.1,'-11111.1'); CheckDoubleToShort(-11111.01,'-11111.01'); CheckDoubleToShort(-11111.001,'-11111.001'); CheckDoubleToShort(-11111.0001,'-11111.0001'); CheckDoubleToShort(-11111.00001,'-11111.00001'); CheckDoubleToShort(0.9999999999999997,'1'); CheckDoubleToShort(-0.9999999999999997,'-1'); CheckDoubleToShort(9.999999999999997,'10'); CheckDoubleToShort(-9.999999999999997,'-10'); CheckDoubleToShort(999.9999999999997,'1000'); CheckDoubleToShort(-999.9999999999997,'-1000'); CheckDoubleToShort(22.99999999999997,'23'); CheckDoubleToShort(-22.99999999999997,'-23'); CheckDoubleToShort(999.9999999999933,'999.999999999993'); CheckDoubleToShort(-999.9999999999933,'-999.999999999993'); CheckDoubleToShortSame(3.3495117168); CheckDoubleToShortSame(-3.3495117168); CheckDoubleToShortSame(-3.3495117168e-1); CheckDoubleToShortSame(3.3495117168e-1); CheckDoubleToShortSame(-3.3495117168e-5); CheckDoubleToShortSame(3.3495117168e-5); CheckDoubleToShortSame(-3.3495117168e-10); CheckDoubleToShortSame(3.3495117168e-10); CheckDoubleToShortSame(-3.9999617168e-14); CheckDoubleToShortSame(3.9999617168e-14); CheckDoubleToShortSame(-3.9999617168e-15); CheckDoubleToShortSame(3.9999617168e-15); CheckDoubleToShortSame(12.345678901234); CheckDoubleToShortSame(123.45678901234); CheckDoubleToShortSame(1234.5678901234); Check(Int32ToUtf8(1599638299)='1599638299'); Check(UInt32ToUtf8(1599638299)='1599638299'); Check(Int32ToUtf8(-1599638299)='-1599638299'); Check(Int64ToUTF8(-1271083787498396012)='-1271083787498396012'); {$ifdef FPC} // Delphi doesn't handle correctly such huge constants CheckDoubleToShort(1234567890123456789,'1.2345678901234568E18'); CheckDoubleToShortSame(1234567890123456789); {$endif} s := Int64ToUTF8(242161819595454762); Check(s='242161819595454762'); {$ifndef DELPHI5OROLDER} Check(ScanUTF8('1 2 3',' %',[@i,@j,@d])=0); Check(ScanUTF8('','%d%d%f',[@i,@j,@d])=0); Check(ScanUTF8('1 2 7','%d%d%f',[@i,@j,@d])=3); Check(i=1); Check(j=2); Check(d=7); Check(ScanUTF8('2/3/8.1','%d/%d/%f',[@i,@j,@d])=3); Check(i=2); Check(j=3); CheckSame(d,8.1); Check(ScanUTF8('5 / 6/3','%d/%d / %f',[@i,@j,@d])=3); Check(i=5); Check(j=6); Check(d=3); Check(ScanUTF8('15 25 35','%d%D',[@i,@k,@d])=2); Check(i=15); Check(k=25); Check(d=3); Check(ScanUTF8('1 21 35','%d%d%f',[@i,@j])=2); Check(i=1); Check(j=21); Check(d=3); Check(ScanUTF8(' 10 20 abc ','%d%d%s',[@i,@j,@a])=3); Check(i=10); Check(j=20); Check(a='abc'); Check(ScanUTF8('1 00000002 3.01234 ','%dtoto %x%Ftiti',[@i,@j,@c])=3); Check(i=1); Check(j=2); Check(c=3.0123); Check(ScanUTF8('10 0000000a 77.77 7','%dtoto %x%Ftiti%Uboat',[@i,@j,@c,@crc],@ident)=4); Check(i=10); Check(j=10); Check(c=77.77); Check(crc=7); Check(Length(ident)=4); Check(ident[0]='dtoto'); Check(ident[1]='x'); Check(ident[2]='Ftiti'); Check(ident[3]='Uboat'); {$endif} Check(xxHash32(0,'A',1)=275094093); Check(xxHash32(0,'ABACK',5)=314231639); Check(xxHash32(0,'ABBREVIATIONS',13)=3058487595); Check(xxHash32(0,'LORD',4)=3395586315); Check(xxHash32(0,'MICROINSTRUCTION''S',18)=1576115228); for i := -10000 to 10000 do Check(GetInteger(Pointer(Int32ToUtf8(i)))=i); for i := 0 to 10000 do begin j := i shr 6; // circumvent weird FPC code generation bug in -O2 mode s := RandomString(j); Check(hash32(s)=Hash32Reference(pointer(s),length(s))); Check(kr32(0,pointer(s),length(s))=kr32reference(pointer(s),length(s))); Check(fnv32(0,pointer(s),length(s))=fnv32reference(0,pointer(s),length(s))); crc := crc32creference(0,pointer(s),length(s)); Check(crc32cfast(0,pointer(s),length(s))=crc); Check(crc32c(0,pointer(s),length(s))=crc); if s<>'' then Check(xxhash32(0,pointer(s),length(s))=xxHash32reference(pointer(s),length(s))); j := Random32gsl; str(j,a); s := RawUTF8(a); u := string(a); CheckEqual(OctToBin(s),s); CheckEqual(TestAddFloatStr(s),s); Check(SysUtils.IntToStr(j)=u); s2 := Int32ToUtf8(j); CheckEqual(s2,s); Check(format('%d',[j])=u); Check(GetInteger(pointer(s))=j); {$ifndef DELPHI5OROLDER} CheckEqual(FormatUTF8('%',[j]),s); CheckEqual(FormatUTF8('?',[],[j]),':('+s+'):'); CheckEqual(FormatUTF8('%?',[j]),s+'?'); CheckEqual(FormatUTF8('?%',[j]),'?'+s); CheckEqual(FormatUTF8('?%?',[j]),'?'+s+'?'); CheckEqual(FormatUTF8('?%%?',[j]),'?'+s+'?'); CheckEqual(FormatUTF8('?%?% ',[j]),'?'+s+'? '); CheckEqual(FormatUTF8('?%',[],[j]),':('+s+'):'); CheckEqual(FormatUTF8('%?',[j],[j]),s+':('+s+'):'); CheckEqual(FormatUTF8('%?',[s],[s]),s+':('''+s+'''):'); CheckEqual(FormatUTF8('% ',[j]),s+' '); CheckEqual(FormatUTF8('? ',[],[j]),':('+s+'): '); CheckEqual(FormatUTF8('% %',[j]),s+' '); CheckEqual(FormatUTF8(' % %',[j]),' '+s+' '); CheckEqual(FormatUTF8(' ?? ',[],[j]),' :('+s+'): '); CheckEqual(FormatUTF8('?',[],[j],true),s); CheckEqual(FormatUTF8('?%',[],[j],true),s); CheckEqual(FormatUTF8('? ',[],[j],true),s+' '); CheckEqual(FormatUTF8(' ?? ',[],[j],true),' '+s+' '); CheckEqual(FormatUTF8('?%',[],[s],true),'"'+s+'"'); CheckEqual(FormatUTF8(' ?? ',[],[s],true),' "'+s+'" '); CheckEqual(FormatUTF8('? %',[s],[s],true),'"'+s+'" '+s); {$ifndef NOVARIANTS} vj := variant(j); RawUTF8ToVariant(s,vs); CheckEqual(FormatUTF8(' ?? ',[],[vj],true),' '+s+' '); CheckEqual(FormatUTF8(' ?? ',[],[vj]),' :('''+s+'''): '); CheckEqual(FormatUTF8('% ?',[vj],[vj]),s+' :('''+s+'''):'); CheckEqual(FormatUTF8(' ?? ',[],[vs]),' :('''+s+'''): '); CheckEqual(FormatUTF8('% ?',[vj],[vj]),s+' :('''+s+'''):'); CheckEqual(FormatUTF8('? %',[vj],[vj],true),s+' '+s); CheckEqual(FormatUTF8(' ?? ',[],[vs],true),' "'+s+'" '); CheckEqual(FormatUTF8('? %',[vs],[vj],true),s+' '+s); {$endif} {$endif DELPHI5OROLDER} k := Int64(j)*Random(MaxInt); b := Random(64); s := GetBitCSV(k,b); l := 0; P := pointer(s); SetBitCSV(l,b,P); Check(P=nil); while b>0 do begin dec(b); Check(GetBit(l,b)=GetBit(k,b)); end; str(k,a); s := RawUTF8(a); u := string(a); CheckEqual(TestAddFloatStr(s),s); Check(SysUtils.IntToStr(k)=u); Check(IsAnsiCompatible(s)); Check(Int64ToUtf8(k)=s); Check(IntToString(k)=u); Check(format('%d',[k])=u); {$ifndef DELPHI5OROLDER} Check(FormatUTF8('%',[k])=s); Check(FormatUTF8('?',[],[k])=':('+s+'):'); {$endif} err := 1; l := GetInt64(pointer(s),err); Check((err=0)and(l=k)); SetInt64(pointer(s),l); s := s+'z'; l := GetInt64(pointer(s),err); Check(err<>0); case i of // validate some explicit ToVarUInt32/64 boundaries 9991: j := $00003fff; 9992: j := $00004000; 9993: j := $00004001; 9994: j := $001fffff; 9995: j := $00200000; 9996: j := $00200001; 9997: j := $0fffffff; 9998: j := $10000000; 9999: j := $10000001; end; str(j,a); Check(SysUtils.IntToStr(j)=string(a)); Check(format('%d',[j])=string(a)); Check(format('%.8x',[j])=IntToHex(j,8)); case i of 9990: d := 1E110; 9991: d := 1E-110; 9992: d := 1E210; 9993: d := 1E-210; else d := Random*1E-17-Random*1E-19; end; str(d,a); s := RawUTF8(a); e := GetExtended(Pointer(s),err); Check(SameValue(e,d,0)); // validate str() s := ExtendedToStr(d,DOUBLE_PRECISION); e := GetExtended(Pointer(s),err); Check(SameValue(e,d,0)); e := d; if (i < 9000) or (i > 9999) then begin a[0] := AnsiChar(ExtendedToShort(a,d,DOUBLE_PRECISION)); a2[0] := AnsiChar(DoubleToShort(a2,d)); Check(a=a2); a[0] := AnsiChar(ExtendedToShortNoExp(a,d,DOUBLE_PRECISION)); a2[0] := AnsiChar(DoubleToShortNoExp(a2,d)); Check(a=a2); CheckEqual(TestAddFloatStr(s),s); Check(not SameValue(e+1,d)); sd := d; Check(d=e); Check(SortDynArrayDouble(d,d)=0); Check(SortDynArrayDouble(d,e)=0); se := sd; Check(SortDynArraySingle(sd,sd)=0); Check(SortDynArraySingle(sd,se)=0); end; if d<0 then e := e*0.9 else e := e*1.1; check(d 9999) then begin se := e; Check(SortDynArraySingle(sd,se)=-1); Check(SortDynArraySingle(se,sd)=1); end; PC := ToVarUInt32(juint,@varint); Check(PC<>nil); Check(PtrInt(PC)-PtrInt(@varint)=integer(ToVarUInt32Length(juint))); PB := @varint; Check(PtrUInt(FromVarUint32(PB))=juint); Check(PB=PC); PC := ToVarUInt32(i,@varint); Check(PC<>nil); PB := @varint; Check(PtrInt(FromVarUint32(PB))=i); Check(PB=PC); PB := FromVarUInt32Safe(@varint,PC,u32); Check(PtrInt(u32)=i); Check(PB=PC); PC := ToVarInt32(j,@varint); Check(PC<>nil); PB := @varint; Check(FromVarInt32(PB)=j); Check(PB=PC); PC := ToVarInt32(i-1,@varint); Check(PC<>nil); PB := @varint; Check(FromVarInt32(PB)=i-1); Check(PB=PC); PC := ToVarUInt64(juint,@varint); Check(PC<>nil); Check(PtrInt(PC)-PtrInt(@varint)=integer(ToVarUInt32Length(juint))); PB := @varint; Check(PtrUInt(FromVarUint64(PB))=juint); Check(PB=PC); PB := FromVarUInt64Safe(@varint,PC,q); Check(q=juint); Check(PB=PC); PC := ToVarInt64(k,@varint); Check(PC<>nil); PB := @varint; Check(FromVarInt64(PB)=k); Check(PB=PC); Check(FromVarInt64Value(@varint)=k); PC := ToVarInt64(i,@varint); Check(PC<>nil); PB := @varint; Check(FromVarInt64(PB)=i); Check(PB=PC); if k<0 then k := -k; PC := ToVarUInt64(k,@varint); Check(PC<>nil); PB := @varint; Check(FromVarUint64(PB)=k); Check(PB=PC); PC := ToVarUInt64(i,@varint); Check(PC<>nil); PB := @varint; Check(FromVarUint64(PB)=i); Check(PB=PC); PC := @varint; for n := 0 to 49 do PC := ToVarUInt32(juint+n,PC); check(PC<>nil); st.Init(@varint, PtrInt(PC) - PtrInt(@varint)); check(not st.EOF); for n := 0 to 48 do check(st.VarUInt32 = cardinal(juint+n)); check(not st.EOF); check(st.VarUInt32 = cardinal(juint+49)); check(pointer(st.P) = pointer(PC)); check(st.EOF); st.Init(@varint, PtrInt(PC) - PtrInt(@varint)); check(not st.EOF); for n := 0 to 49 do check(st.VarUInt64 = cardinal(juint+n)); check(pointer(st.P) = pointer(PC)); check(st.EOF); st.Init(@varint, PtrInt(PC) - PtrInt(@varint)); for n := 0 to 48 do st.VarNextInt; check(not st.EOF); check(st.VarUInt32 = cardinal(juint+49)); check(pointer(st.P) = pointer(PC)); check(st.EOF); st.Init(@varint, PtrInt(PC) - PtrInt(@varint)); st.VarNextInt(49); check(not st.EOF); check(st.VarUInt32 = cardinal(juint+49)); check(pointer(st.P) = pointer(PC)); check(st.EOF); end; exit; // code below is speed informative only, without any test Timer.Start; for i := 0 to 99999 do SysUtils.IntToStr(Int64(7777)*Random32gsl); fRunConsole := format('%s SysUtils.IntToStr %s %s/s',[fRunConsole,Timer.Stop, IntToThousandString(Timer.PerSec(100000))]); Timer.Start; RandSeed := 10; for i := 0 to 99999 do StrInt64(@varint[31],Int64(7777)*Random32gsl); fRunConsole := format('%s StrInt64 %s %s/s',[fRunConsole,Timer.Stop, IntToThousandString(Timer.PerSec(100000))]); end; function LowerCaseReference(const S: RawByteString): RawByteString; var Ch: AnsiChar; L: Integer; Source, Dest: PAnsiChar; begin L := Length(S); SetLength(Result, L); Source := Pointer(S); Dest := Pointer(Result); while L<>0 do begin Ch := Source^; if (Ch >= 'A') and (Ch <= 'Z') then Inc(Ch, 32); Dest^ := Ch; Inc(Source); Inc(Dest); Dec(L); end; end; procedure TTestLowLevelCommon.BaudotCode; var u: RawUTF8; b: RawByteString; i,j,k: integer; P: PAnsiChar absolute u; const CHR: array[0..82] of AnsiChar = 'abcdefghijklm nopqrstuvwx yzabcdefghijklm nopqrstuvwx yz012345 6789-''3,!:(+)$?@./; '; begin b := AsciiToBaudot(''); check(b=''); b := AsciiToBaudot('abc'); u := BaudotToAscii(b); check(u='abc'); b := AsciiToBaudot('mORMot.net'); check(BaudotToAscii(b)='mormot.net'); b := b+#0#0#0; u := BaudotToAscii(b); check(u='mormot.net'); b := AsciiToBaudot('https://synopse.info'); u := BaudotToAscii(b); check(u='https://synopse.info'); b := AsciiToBaudot('abcdef 1234 5678'#13#10'ABCD;/23u'#13#10'op @toto.#com'); check(b<>''); u := BaudotToAscii(b); check(u='abcdef 1234 5678'#13#10'abcd;/23u'#13#10'op @toto.com'); for i := 1 to 200 do begin SetLength(u,i); for k := 1 to 50 do begin for j := 0 to i-1 do P[j] := CHR[Random(83)]; b := AsciiToBaudot(u); check(BaudotToAscii(b)=u); end; end; end; procedure TTestLowLevelCommon._UTF8; procedure Test(CP: cardinal; const W: WinAnsiString); var C: TSynAnsiConvert; A: RawByteString; U: RawUTF8; begin C := TSynAnsiConvert.Engine(CP); Check(C.CodePage=CP); U := C.AnsiToUTF8(W); A := C.UTF8ToAnsi(U); if W='' then exit; {$ifdef HASCODEPAGE} {$ifndef FPC} Check(StringCodePage(W)=1252); {$endif} CP := StringCodePage(A); Check(CP=C.CodePage); {$endif} if CP=CP_UTF16 then exit; Check(length(W)=length(A)); {$ifdef FPC} Check(CompareMem(pointer(W),pointer(A),length(W))); {$else} Check(A=W); Check(C.RawUnicodeToAnsi(C.AnsiToRawUnicode(W))=W); {$endif} end; procedure CheckTrimCopy(const S: RawUTF8; start,count: PtrInt); var t: RawUTF8; begin trimcopy(s,start,count,t); checkEqual(t,trim(copy(s,start,count))); end; var i, j, k, len, lenup100, CP, L: integer; W: WinAnsiString; WS: WideString; SU: SynUnicode; str: string; U,U2, res, Up,Up2: RawUTF8; arr: TRawUTF8DynArray; PB: PByte; {$ifndef DELPHI5OROLDER} q: RawUTF8; {$endif} Unic: RawUnicode; WA: Boolean; const ROWIDS: array[0..17] of PUTF8Char = ( 'id','ID','iD','rowid','ROWid','ROWID','rowiD','ROWId', // ok 'id2','id ','idd','i','rowi','row','ROWI','ROW','ROWIDD','ROWID '); IDPU: array[0..15] of PUTF8Char = ( 'anything','t','1','te','tE','TE','tes','test','TeSt','teS','tesT','testE', 'T','T','1','teste'); IDPA: array[0..15] of PAnsiChar = ( nil,'T','1','TE','TE','TE','TES','TEST','TEST','TES','TEST','TESTE', 't','U','2','TESTe'); begin for i := 0 to high(ROWIDS) do Check(isRowID(ROWIDS[i])=(i<8)); U := 'old1,old2,old3'; Check(not RenameInCSV('old','new',U)); Check(RenameInCSV('old1','n1',U)); Check(U='n1,old2,old3'); Check(RenameInCSV('old2','n2',U)); Check(not RenameInCSV('old2','news2',U)); Check(RenameInCSV('old3','news3',U)); Check(U='n1,n2,news3'); Check(RenameInCSV(U,'1-2-3',U,'!')); Check(U='1-2-3'); Check(RenameInCSV('2','bee',U,'-')); Check(RenameInCSV('1','ah',U,'-')); Check(RenameInCSV('3','see',U,'-')); Check(U='ah-bee-see'); for i := 0 to High(IDPU) do Check(IdemPChar(IDPU[i],IDPA[i])=(i<12)); res := '{"result":[{"000001000013":{"00100000000016":[1534510257860,103100,2000,' + '103108,1004,104132],"00100000000026":[1534510257860,12412,2000,12420,1004,12420],' + '"00100000000036":[1534510257860,1378116,2000,1378112,1004,1378112],"00100000000056":' + '[1534510257860,479217551,2000,479217551],"00100000000076":[1534510257860,136079943,' + '2000,136079943,1004,136079944],"00100000000086":[1534510257860,1648800821,2000,' + '1648801020,1004,1648801119],"00100000000096":[1534510257860,87877677,2000,87877678,' + '1004,87877678],"001000000000ec":[1534510257860,1.64,2000,1.64],"001000000000fc":[' + '1534510257860,1.72,2000,1.72],"0010000000010c":[1534510257860,1.64,2000,1.64],"' + '00100000000196":[1534510257860,0,2000,0]}}]}'; i := SynCommons.StrLenPas(@res[1]); check(SynCommons.StrLen(@res[1])=i); res := 'one,two,three'; Check(EndWith('three','THREE')); Check(EndWith(res,'E')); Check(EndWith(res,'THREE')); Check(EndWith(res,',THREE')); Check(not EndWith(res,',THREe')); Check(not EndWith(res,res)); Check(not EndWith('t',',THREe')); Check(not EndWith('thre',',THREe')); Check(EndWithArray(res,[])<0); Check(EndWithArray(res,['E','F'])=0); Check(EndWithArray(res,['ONE','THREE'])=1); Check(EndWithArray(res,['ONE','three','THREE'])=2); Check(EndWithArray(res,['ONE','','THREE'])=1); Check(EndWithArray(res,['ONE','three','THREe'])<0); Check(split(res,',')='one'); Check(split(res,'*')=res); Check(split(res,',',5)='two'); Check(split(res,'*',6)='wo,three'); Check(SynCommons.StrLen(nil)=0); for i := length(res)+1 downto 1 do Check(SynCommons.StrLen(Pointer(@res[i]))=length(res)-i+1); Check(StrLenPas(nil)=0); for i := length(res)+1 downto 1 do Check(StrLenPas(Pointer(@res[i]))=length(res)-i+1); CSVToRawUTF8DynArray(pointer(res),arr); Check(arr[0]='one'); Check(arr[1]='two'); Check(arr[2]='three'); Finalize(arr); CSVToRawUTF8DynArray(res,',','',arr); Check(arr[0]='one'); Check(arr[1]='two'); Check(arr[2]='three'); Finalize(arr); CSVToRawUTF8DynArray('one=?,two=?,three=?','=?,','=?',arr); Check(arr[0]='one'); Check(arr[1]='two'); Check(arr[2]='three'); Finalize(arr); res := '-1,25,0'; CSVToRawUTF8DynArray(pointer(res),arr); check(Length(arr)=3); Check(arr[0]='-1'); Check(arr[1]='25'); Check(arr[2]='0'); Check(AddPrefixToCSV('One,Two,Three','Pre')='PreOne,PreTwo,PreThree'); Check(CSVOfValue('?',3)='?,?,?'); {$ifndef DELPHI5OROLDER} Check(GetUnQuoteCSVItem('"""one,""","two "',1,',','"')='two '); Check(GetUnQuoteCSVItem('''''''one,''''''',0)='''one,'''); Check(GetUnQuoteCSVItem('"""one,',0,',','"')=''); Check(FormatUTF8('abcd',[U],[WS])='abcd'); {$endif} U := QuotedStr('','"'); CheckEqual(U,'""'); U := QuotedStr('abc','"'); CheckEqual(U,'"abc"'); U := QuotedStr('a"c','"'); CheckEqual(U,'"a""c"'); U := QuotedStr('abcd"efg','"'); CheckEqual(U,'"abcd""efg"'); U := QuotedStr('abcd""efg','"'); CheckEqual(U,'"abcd""""efg"'); U := QuotedStr('abcd"e"fg"','"'); CheckEqual(U,'"abcd""e""fg"""'); U := QuotedStr('"abcd"efg','"'); CheckEqual(U,'"""abcd""efg"'); U := QuotedStr('','#'); // also test for custom quote CheckEqual(U,'##'); U := QuotedStr('abc','#'); CheckEqual(U,'#abc#'); U := QuotedStr('a#c','#'); CheckEqual(U,'#a##c#'); U := QuotedStr('abcd#efg','#'); CheckEqual(U,'#abcd##efg#'); U := QuotedStr('abcd##efg','#'); CheckEqual(U,'#abcd####efg#'); U := QuotedStr('abcd#e#fg#','#'); CheckEqual(U,'#abcd##e##fg###'); U := QuotedStr('#abcd#efg','#'); CheckEqual(U,'###abcd##efg#'); for i := 0 to 1000 do begin len := i*5; W := RandomAnsi7(len); Check(length(W)=len); lenup100 := len; if lenup100>100 then lenup100 := 100; str := Ansi7ToString(W); // should be fine on any code page if len>0 then begin Check(length(str)=len); check(PosExString(str[1],str)=1); if str[1]<>str[2] then begin check(PosExString(str[2],str)=2); if (str[1]<>str[2]) and (str[2]<>str[3]) and (str[1]<>str[3]) then check(PosExString(str[3],str)=3); end; for j := 1 to lenup100 do begin check(PosExString(#13,str,j)=0); check(PosExString(str[j],str,j)=j); if (j>1) and (str[j-1]<>str[j]) then check(PosExString(str[j],str,j-1)=j); k := PosExString(str[j],str); check((k>0) and (str[k]=str[j])); end; end else check(PosExString(#0,str)=0); for CP := 1250 to 1258 do Test(CP,W); Test(932,W); Test(949,W); Test(874,W); Test(CP_UTF8,W); L := Length(W); if L and 1<>0 then SetLength(W,L-1); // force exact UTF-16 buffer length Test(CP_UTF16,W); W := WinAnsiString(RandomString(len)); U := WinAnsiToUtf8(W); if len>0 then begin check(PosEx(U[1],U)=1); check(PosExChar(U[1],U)=1); if (len>1) and (U[1]<>U[2]) then begin check(PosEx(U[2],U)=2); check(PosExChar(U[2],U)=2); if (len>2) and (U[1]<>U[2]) and (U[2]<>U[3]) and (U[1]<>U[3]) then begin check(PosEx(U[3],U)=3); check(PosExChar(U[3],U)=3); end; end; end; for j := 1 to lenup100 do begin // validates with offset parameter check(PosEx(#13,U,j)=0); check(PosEx(U[j],U,j)=j); if (j>1) and (U[j-1]<>U[j]) then check(PosEx(U[j],U,j-1)=j); k := PosEx(U[j],U); check((k>0) and (U[k]=U[j])); check(PosExChar(U[j],U)=k); end; Unic := Utf8DecodeToRawUnicode(U); {$ifndef FPC_HAS_CPSTRING} // buggy FPC Check(Utf8ToWinAnsi(U)=W); Check(WinAnsiConvert.UTF8ToAnsi(WinAnsiConvert.AnsiToUTF8(W))=W); Check(WinAnsiConvert.RawUnicodeToAnsi(WinAnsiConvert.AnsiToRawUnicode(W))=W); if CurrentAnsiConvert.InheritsFrom(TSynAnsiFixedWidth) then begin Check(CurrentAnsiConvert.UTF8ToAnsi(CurrentAnsiConvert.AnsiToUTF8(W))=W); Check(CurrentAnsiConvert.RawUnicodeToAnsi(CurrentAnsiConvert.AnsiToRawUnicode(W))=W); end; res := RawUnicodeToUtf8(Unic); Check(res=U); Check(RawUnicodeToWinAnsi(Unic)=W); {$endif FPC_HAS_CPSTRING} WS := UTF8ToWideString(U); Check(length(WS)=length(Unic)shr 1); if WS<>'' then Check(CompareMem(pointer(WS),pointer(Unic),length(WS)*sizeof(WideChar))); Check(integer(Utf8ToUnicodeLength(Pointer(U)))=length(WS)); SU := UTF8ToSynUnicode(U); Check(length(SU)=length(Unic)shr 1); if SU<>'' then Check(CompareMem(pointer(SU),pointer(Unic),length(SU))); WA := IsWinAnsi(pointer(Unic)); Check(IsWinAnsi(pointer(Unic),length(Unic)shr 1)=WA); Check(IsWinAnsiU(pointer(U))=WA); Up := SynCommons.UpperCase(U); Check(SynCommons.UpperCase(SynCommons.LowerCase(U))=Up); Check(UTF8IComp(pointer(U),pointer(U))=0); Check(UTF8IComp(pointer(U),pointer(Up))=0); Check(UTF8ILComp(pointer(U),pointer(U),length(U),length(U))=0); Check(UTF8ILComp(pointer(U),pointer(Up),length(U),length(Up))=0); Check(LowerCase(U)=LowerCaseReference(U)); L := Length(U); SetString(Up,nil,L); SetString(Up2,PAnsiChar(pointer(U)),L); L := UTF8UpperCopy(pointer(Up),pointer(U),L)-pointer(Up); Check(L<=length(U)); Check(ConvertCaseUTF8(Pointer(Up2),NormToUpperByte)=L); if Up<>'' then Check(CompareMem(Pointer(Up),pointer(Up2),L)); if CurrentAnsiConvert.CodePage=CODEPAGE_US then // initial text above is WinAnsiString (CP 1252) Check(StringToUTF8(UTF8ToString(U))=U); Up := UpperCaseUnicode(U); Check(Up=UpperCaseUnicode(LowerCaseUnicode(U))); Check(kr32(0,pointer(U),length(U))=kr32reference(pointer(U),length(U))); if U='' then continue; U2 := QuotedStr(U,'"'); Check(UnQuoteSQLStringVar(pointer(U2),res)<>nil); Check(res=U); Check(not IsZero(pointer(W),length(W))); FillCharFast(pointer(W)^,length(W),0); Check(IsZero(pointer(W),length(W))); Check(FormatUTF8(U,[])=U); {$ifndef DELPHI5OROLDER} res := FormatUTF8(U,[],[]); // Delphi 5 bug with high([])>0 :( Check(length(res)=Length(u)); Check(res=u); Check(FormatUTF8('%',[U])=U); Check(FormatUTF8('%',[U],[])=U); q := ':('+QuotedStr(U)+'):'; Check(FormatUTF8('?',[],[U])=q); res := 'ab'+U; q := 'ab'+q; Check(FormatUTF8('ab%',[U])=res); Check(FormatUTF8('%%',['ab',U])=res); Check(FormatUTF8('ab%',[U],[])=res); Check(FormatUTF8('%%',['ab',U],[])=res); Check(FormatUTF8('ab?',[],[U])=q); Check(FormatUTF8('%?',['ab'],[U])=q); res := res+'cd'; q := q+'cd'; Check(FormatUTF8('ab%cd',[U])=res); Check(FormatUTF8('ab%cd',[U],[])=res); Check(FormatUTF8('a%%cd',['b',U])=res); Check(FormatUTF8('a%%cd',['b',U],[])=res); Check(FormatUTF8('%%%',['ab',U,'cd'])=res); Check(FormatUTF8('ab?cd',[],[U])=q); Check(FormatUTF8('%?cd',['ab'],[U])=q); Check(FormatUTF8('%?%',['ab','cd'],[U])=q); Check(FormatUTF8('%?c%',['ab','d'],[U])=q); Check(FormatUTF8('a%?%d',['b','c'],[U])=q); {$endif} end; SetLength(U, 4); U[1] := #$F0; U[2] := #$A8; U[3] := #$B3; U[4] := #$92; SU := UTF8ToSynUnicode(U); if not CheckFailed(length(SU)=2) then Check(PCardinal(SU)^=$DCD2D863); Check(Utf8ToUnicodeLength(Pointer(U))=2); Check(Utf8FirstLineToUnicodeLength(Pointer(U))=2); U := SynUnicodeToUtf8(SU); if not CheckFailed(length(U)=4) then Check(PCardinal(U)^=$92b3a8f0); U := TSynAnsiConvert.Engine(CP_UTF8).UnicodeBufferToAnsi(pointer(SU), length(SU)); Check(length(U)=4); SetLength(res,10); PB := pointer(res); PB := ToVarString(U,PB); check(PAnsiChar(PB)-pointer(res)=length(U)+1); PB := pointer(res); res := FromVarString(PB); check(res=U); Check(UnQuoteSQLStringVar('"one two"',U)<>nil); Check(U='one two'); Check(UnQuoteSQLStringVar('one two',U)<>nil); Check(U='ne tw'); Check(UnQuoteSQLStringVar('"one "" two"',U)<>nil); Check(U='one " two'); Check(UnQuoteSQLStringVar('"one " two"',U)<>nil); Check(U='one '); Check(UnQuoteSQLStringVar('"one two',U)=nil); Check(UnQuoteSQLStringVar('"one "" two',U)=nil); Check(IsValidEmail('test@synopse.info')); Check(not IsValidEmail('test@ synopse.info')); Check(IsValidEmail('test_two@blog.synopse.info')); Check(IsValidIP4Address('192.168.1.1')); Check(IsValidIP4Address('192.168.001.001')); Check(not IsValidIP4Address('192.158.1. 1')); Check(not IsValidIP4Address('192.158.1.301')); Check(not IsValidIP4Address(' 12.158.1.01')); Check(not IsValidIP4Address('12.158.1.')); Check(not IsValidIP4Address('12.158.1')); {$ifdef MSWINDOWS} Check(FindUnicode(' ABCD DEFG','ABCD',4)); Check(FindUnicode(' ABCD DEFG','DEFG',4)); Check(FindUnicode('ABCD DEFG ','DEFG',4)); Check(FindUnicode('ABCD DEFG ','ABCD',4)); Check(FindUnicode(' abcd defg','ABCD',4)); Check(FindUnicode(' abcd defg','DEFG',4)); Check(FindUnicode('abcd defg ','DEFG',4)); Check(FindUnicode('abcd defg ','ABCD',4)); Check(FindUnicode('ABCD DEFG ','ABCD',4)); Check(FindUnicode(' abcde defg','ABCD',4)); Check(FindUnicode(' abcdf defg','DEFG',4)); Check(FindUnicode('abcdg defg ','DEFG',4)); Check(FindUnicode('abcdh defg ','ABCD',4)); Check(FindUnicode(' abcd defg','ABC',3)); Check(FindUnicode(' abcd defg','DEF',3)); Check(FindUnicode('abcd defg ','DEF',3)); Check(FindUnicode('abcd defg ','ABC',3)); Check(not FindUnicode(' abcd defg','ABC2',4)); Check(not FindUnicode(' abcd defg','DEF2',4)); Check(not FindUnicode('abcd defg ','DEF1',4)); Check(not FindUnicode('abcd defg ','ABC1',4)); Check(UpperCaseUnicode('abcdefABCD')='ABCDEFABCD'); Check(LowerCaseUnicode('abcdefABCD')='abcdefabcd'); {$endif} Check(StringReplaceAll('abcabcabc','toto','toto')='abcabcabc'); Check(StringReplaceAll('abcabcabc','toto','titi')='abcabcabc'); Check(StringReplaceAll('abcabcabc','ab','AB')='ABcABcABc'); Check(StringReplaceAll('abcabcabc','bc','')='aaa'); Check(StringReplaceAll('abcabcabc','bc','B')='aBaBaB'); Check(StringReplaceAll('abcabcabc','bc','bcd')='abcdabcdabcd'); Check(StringReplaceAll('abcabcabc','c','C')='abCabCabC'); Check(StringReplaceAll('abcabcabc',[])='abcabcabc'); Check(StringReplaceAll('abcabcabc',['c'])='abcabcabc'); Check(StringReplaceAll('abcabcabc',['c','C'])='abCabCabC'); Check(StringReplaceAll('abcabcabc',['c','C','a'])='abcabcabc'); Check(StringReplaceAll('abcabcabc',['c','C','toto','titi','ab','AB'])='ABCABCABC'); for i := -10 to 50 do for j := -10 to 50 do begin CheckTrimCopy('',i,j); CheckTrimCopy('1',i,j); CheckTrimCopy('1 ',i,j); CheckTrimCopy(' 1',i,j); CheckTrimCopy(' 1',i,j); CheckTrimCopy('1 ',i,j); CheckTrimCopy('1',i,j); CheckTrimCopy('12',i,j); CheckTrimCopy('123',i,j); CheckTrimCopy(' 234',i,j); CheckTrimCopy(' 234 ',i,j); CheckTrimCopy(' 2 4',i,j); CheckTrimCopy(' 2 4 ',i,j); CheckTrimCopy(' 3 ',i,j); CheckTrimCopy(' 3 7 ',i,j); CheckTrimCopy(' 234 6',i,j); CheckTrimCopy('234 67 ',i,j); CheckTrimCopy(' 234 67 ',i,j); CheckTrimCopy(' 234 67 ',i,maxInt); end; end; procedure TTestLowLevelCommon.Iso8601DateAndTime; procedure Test(D: TDateTime; Expanded: boolean); var s,t: RawUTF8; E,F: TDateTime; I,J: TTimeLogBits; st, s2: TSynSystemTime; P: PUTF8Char; d1, d2: TSynDate; begin s := DateTimeToIso8601(D,Expanded); if Expanded then Check(length(s)=19) else Check(length(s)=15); if Expanded then begin Check(Iso8601CheckAndDecode(Pointer(s),length(s),E)); Check(Abs(D-E)<(1/SecsPerDay)); // we allow 999 ms error end; st.FromDateTime(D); s2.Clear; DecodeDate(D,s2.Year,s2.Month,s2.Day); DecodeTime(D,s2.Hour,s2.Minute,s2.Second,s2.MilliSecond); Check(abs(st.MilliSecond-s2.MilliSecond)<=1); // allow 1 ms rounding error st.MilliSecond := 0; s2.MilliSecond := 0; Check(st.IsEqual(s2)); // ensure conversion matches the RTL's t := st.ToText(Expanded); Check(Copy(t,1,length(s))=s); d1.Clear; check(d1.IsZero); d2.SetMax; check(not d2.IsZero); check(not d1.IsEqual(d2)); check(d1.Compare(d2)<0); check(d2.Compare(d1)>0); t := d2.ToText(false); check(t='99991231'); check(d2.ToText(true)='9999-12-31'); d2.Clear; check(d1.IsEqual(d2)); check(d1.Compare(d2)=0); check(d2.Compare(d1)=0); P := pointer(s); check(d1.ParseFromText(P)); check(P<>nil); check(not d1.IsZero); check(st.IsDateEqual(d1)); t := d1.ToText(Expanded); check(copy(s,1,length(t))=t); d2.Clear; check(d2.IsZero); check(not d1.IsEqual(d2)); check(d1.Compare(d2)>0); check(d2.Compare(d1)<0); check(d2.ToText(Expanded)=''); d2.SetMax; check(not d2.IsZero); check(not d1.IsEqual(d2)); check(d1.Compare(d2)<0); check(d2.Compare(d1)>0); d2 := d1; check(d1.IsEqual(d2)); check(d1.Compare(d2)=0); check(d2.Compare(d1)=0); E := Iso8601ToDateTime(s); Check(Abs(D-E)<(1/SecsPerDay)); // we allow 999 ms error E := Iso8601ToDateTime(s+'Z'); Check(Abs(D-E)<(1/SecsPerDay)); // we allow 999 ms error I.From(D); Check(Iso8601ToTimeLog(s)=I.Value); t := s; t[11] := ''''; // as in SynDB VArray[] quoted parameters J.From(pointer(t),10); Check(I.Value and not(1 shl (6+6+5)-1)=J.Value); I.From(s); t := I.Text(Expanded); if t<>s then // we allow error on time = 00:00:00 -> I.Text = just date Check(I.Value and (1 shl (6+6+5)-1)=0) else Check(true); J.From(E); Check(Int64(I)=Int64(J)); s := TimeToIso8601(D,Expanded); Check(PosEx('.',s)=0); Check(abs(frac(D)-Iso8601ToDateTime(s))<1/SecsPerDay); s := TimeToIso8601(D,Expanded,'T',true); Check(PosEx('.',s)>0); F := Iso8601ToDateTime(s); Check(abs(frac(D)-F)<1/MSecsPerDay,'withms1'); s := DateToIso8601(D,Expanded); Check(trunc(D)=trunc(Iso8601ToDateTime(s))); Check(Abs(D-I.ToDateTime)<(1/SecsPerDay)); E := TimeLogToDateTime(I.Value); Check(Abs(D-E)<(1/SecsPerDay)); s := DateTimeToIso8601(D,Expanded,#0); if Expanded then Check(length(s)=18) else Check(length(s)=14); s := DateTimeToIso8601(D,Expanded,'T',true); Check(PosEx('.',s)>0); if Expanded then Check(length(s)=23) else Check(length(s)=19); F := Iso8601ToDateTime(s); Check(abs(D-F)<1/MSecsPerDay,'withms2'); if Expanded then begin F := 0; Check(Iso8601CheckAndDecode(pointer(s),length(s),F)); Check(abs(D-F)<1/MSecsPerDay,'withms3'); end; end; var i: integer; D: TDateTime; tmp: RawUTF8; b: TTimeLogBits; begin for i := 1700 to 2500 do Check(SynCommons.IsLeapYear(i) = SysUtils.IsLeapYear(i), 'IsLeapYear'); // this will test typically from year 1905 to 2065 D := Now/20+Random*20; // some starting random date/time for i := 1 to 2000 do begin Test(D, true); Test(D, false); D := D+Random*57; // go further a little bit: change date/time end; b.Value := Iso8601ToTimeLog('20150504'); Check(b.Year=2015); Check(b.Month=5); Check(b.Day=4); tmp := b.Text(false); Check(tmp='20150504'); IntervalTextToDateTimeVar('+0 06:03:20',D); CheckSame(D,0.252314,1e-5); D := IntervalTextToDateTime('+1 06:03:20'); CheckSame(D,1.252314,1e-5); CheckSame(IntervalTextToDateTime('-20 06:03:20'),-20.252314,1e-6); Check(DateTimeToIso8601Text(IntervalTextToDateTime('+0 06:03:20'))='T06:03:20'); tmp := DateTimeToIso8601Text(IntervalTextToDateTime('+1 06:03:20')); Check(tmp='1899-12-31T06:03:20'); tmp := DateTimeToIso8601Text(IntervalTextToDateTime('-2 06:03:20')); Check(tmp='1899-12-28T06:03:20'); CheckSame(TimeLogToDateTime(135131870949),41578.477512,1e-5); tmp := '1982-10-30T06:03:20'; Check(Iso8601CheckAndDecode(Pointer(tmp),length(tmp),D)); Check(DateTimeToIso8601(D,true)=tmp); tmp := '1982-10-30'; Check(Iso8601CheckAndDecode(Pointer(tmp),length(tmp),D)); Check(DateToIso8601(D,true)=tmp); tmp := 'T06:03:20'; Check(Iso8601CheckAndDecode(Pointer(tmp),length(tmp),D)); Check(TimeToIso8601(D,true)=tmp); tmp := '1982-10-30 06:03:20'; Check(not Iso8601CheckAndDecode(Pointer(tmp),length(tmp),D)); tmp := 'T06:03:2a'; Check(not Iso8601CheckAndDecode(Pointer(tmp),length(tmp),D)); tmp := '1435051262-45869-63626'; check(Iso8601ToDateTime(tmp)=0); check(Iso8601ToTimelog(tmp)=0); tmp := UnixTimePeriodToString(0); check(tmp='T00:00:00'); tmp := UnixTimePeriodToString(30); check(tmp='T00:00:30'); tmp := UnixTimePeriodToString(SecsPerMin); check(tmp='T00:01:00'); tmp := UnixTimePeriodToString(SecsPerMin*MinsPerHour); check(tmp='T01:00:00'); tmp := UnixTimePeriodToString(SecsPerDay); check(tmp='0000-00-01'); tmp := UnixTimePeriodToString(SecsPerDay*15); check(tmp='0000-00-15'); tmp := UnixTimePeriodToString(SecsPerDay*365); check(tmp='0000-12-31'); tmp := UnixTimePeriodToString(SecsPerDay*366); check(tmp='0001-00-00'); tmp := UnixTimePeriodToString(SecsPerDay*732); check(tmp='0002-00-00'); end; {$ifdef FPC} Function _LocalTimeToUniversal(LT: TDateTime;TZOffset: Integer): TDateTime; begin if (TZOffset > 0) then Result := LT - EncodeTime(TZOffset div 60, TZOffset mod 60, 0, 0) else if (TZOffset < 0) then Result := LT + EncodeTime(Abs(TZOffset) div 60, Abs(TZOffset) mod 60, 0, 0) else Result := LT; end; {$endif} procedure TTestLowLevelCommon.TimeZones; var tz: TSynTimeZone; d: TTimeZoneData; i,bias: integer; hdl,reload: boolean; buf: RawByteString; dt {$ifdef MSWINDOWS},local{$endif}: TDateTime; procedure testBias(year,expected: integer); begin check(tz.GetBiasForDateTime(EncodeDate(year,10,30),'1',bias,hdl)); check(bias=expected); end; begin tz := TSynTimeZone.Create; try check(tz.Zone=nil); FillCharFast(d,sizeof(d),0); for i := 0 to 40 do begin UInt32ToUTF8(i,RawUTF8(d.id)); d.display := 'displayed '+d.id; d.tzi.Bias := i; check(tz.Zones.Add(d)=i,'add some zones'); end; tz.Zones.ReHash; dt := nowutc; for reload := false to true do begin check(tz.Zone<>nil); check(tz.Zones.Count=41); for i := 0 to 40 do begin UInt32ToUTF8(i,RawUTF8(d.id)); check(tz.GetDisplay(d.id)='displayed '+d.id); hdl := true; check(tz.GetBiasForDateTime(dt,d.id,bias,hdl)); check(bias=i); check(not hdl); end; check(not tz.GetBiasForDateTime(dt,'fail',bias,hdl)); buf := tz.SaveToBuffer; tz.Zones.Clear; check(tz.Zone=nil); tz.LoadFromBuffer(buf); end; with tz.Zone[1] do begin SetLength(dyn,4); dyn[0].year := 2000; dyn[0].tzi.bias := 3600; dyn[1].year := 2003; dyn[1].tzi.bias := 3601; dyn[2].year := 2005; dyn[2].tzi.bias := 3602; dyn[3].year := 2006; dyn[3].tzi.bias := 3603; end; testBias(1990,3600); testBias(2000,3600); testBias(2001,3600); testBias(2002,3600); testBias(2003,3601); testBias(2004,3601); testBias(2005,3602); testBias(2006,3603); testBias(2007,3603); testBias(2008,3603); finally tz.Free; end; dt := NowUTC; {$ifdef FPC} CheckSame(_LocalTimeToUniversal(Now(), - GetLocalTimeOffset) - dt, 0, 1E-2, 'NowUTC should not shift or truncate time'); {$endif} sleep(200); Check(not SameValue(dt,NowUTC), 'NowUTC should not truncate time to 5 sec resolution'); {$ifdef MSWINDOWS} tz := TSynTimeZone.CreateDefault; try local := tz.UtcToLocal(dt,'UTC'); check(SameValue(local,dt)); check(tz.GetBiasForDateTime(dt,'UTC',bias,hdl)); check(bias=0); check(not hdl); local := tz.UtcToLocal(dt,'Romance Standard Time'); check(not SameValue(local,dt),'Paris never aligns with London'); check(tz.GetBiasForDateTime(dt,'Romance Standard Time',bias,hdl)); check(hdl); check(bias<0); buf := tz.SaveToBuffer; finally tz.Free; end; tz := TSynTimeZone.Create; try tz.LoadFromBuffer(buf); CheckSame(local,tz.UtcToLocal(dt,'Romance Standard Time')); finally tz.Free; end; {$endif} end; {$IFDEF FPC} {$PUSH} {$ENDIF} {$HINTS OFF} // [dcc64 Hint] H2135 FOR or WHILE loop executes zero times - deleted procedure TTestLowLevelCommon._IdemPropName; function IPNUSL(const s1,s2: RawUTF8; len: integer): boolean; begin result := IdemPropNameUSameLen(pointer(s1),pointer(s2),len); end; const abcde: PUTF8Char = 'ABcdE'; abcdf: PUTF8Char = 'abCDF'; zbcde: PUTF8Char = 'zBcdE'; edf: PUTF8Char = '$a_bc[0]edfghij'; eda: PUTF8Char = '$a_bc[0]"edfghij'; var WinAnsi: WinAnsiString; i: integer; begin Check(IdemPropName('a','A')); Check(not IdemPropName('a','z')); Check(IdemPropName('ab','AB')); Check(IdemPropName('abc','ABc')); Check(IdemPropName('abcD','ABcd')); Check(not IdemPropName('abcD','ABcF')); Check(not IdemPropName('abcD','ABcFG')); Check(not IdemPropName('abcDe','ABcFG')); Check(IdemPropName('abcDe','ABcdE')); Check(not IdemPropName('abcDef','ABcdEe')); Check(IdemPropName('abcDeF','ABcdEF')); Check(IdemPropName('ABCDEF','ABCDEF')); Check(not IdemPropName('abcD','')); Check(not IdemPropName('','ABcFG')); Check(IdemPropName('','')); Check(IdemPropNameU('a','A')); Check(not IdemPropNameU('a','z')); Check(IdemPropNameU('ab','AB')); Check(not IdemPropNameU('abc','ABz')); Check(not IdemPropNameU('zbc','abc')); Check(IdemPropNameU('abc','ABc')); Check(IdemPropNameU('abcD','ABcd')); Check(not IdemPropNameU('abcD','ABcF')); Check(not IdemPropNameU('abcD','ABcFG')); Check(not IdemPropNameU('abcDe','ABcFG')); Check(IdemPropNameU('abcDe','ABcdE')); Check(not IdemPropNameU('abcDef','ABcdEe')); Check(IdemPropNameU('abcDeF','ABcdEF')); Check(IdemPropNameU('ABCDEF','ABCDEF')); Check(not IdemPropNameU('abcD','')); Check(not IdemPropNameU('','ABcFG')); for i := 0 to 100 do Check(IdemPropNameU(RawUTF8(StringOfChar('a',i)),RawUTF8(StringOfChar('A',i)))); Check(UpperCaseU('abcd')='ABCD'); Check(IdemPropNameU('abcDe',abcde,5)); Check(not IdemPropNameU('abcD',abcde,5)); Check(not IdemPropNameU('abcDF',abcde,5)); {$ifndef DELPHI5OROLDER} Check(IdemPropName(abcde,abcde,4,4)); Check(IdemPropName(abcde,abcde,5,5)); Check(not IdemPropName(abcde,abcde,4,5)); Check(not IdemPropName(abcde,abcdf,5,5)); {$endif DELPHI5OROLDER} Check(not IPNUSL('abcD','ABcF',4)); Check(not IPNUSL('abcD','ABcFG',4)); Check(IPNUSL('abcDe','ABcdE',5)); Check(IPNUSL('ABcdE','abCDF',0)); Check(IPNUSL('ABcdE','',0)); Check(IPNUSL('','abCDF',0)); Check(IdemPropNameUSameLen(abcde,abcdf,1)); Check(IdemPropNameUSameLen(abcde,abcdf,2)); Check(IdemPropNameUSameLen(abcde,abcdf,3)); Check(IdemPropNameUSameLen(abcde,abcdf,4)); Check(not IdemPropNameUSameLen(abcde,abcdf,5)); Check(IdemPropNameUSameLen(abcde,zbcde,0)); Check(not IdemPropNameUSameLen(abcde,zbcde,1)); Check(not IdemPropNameUSameLen(abcde,zbcde,2)); Check(not IdemPropNameUSameLen(abcde,zbcde,3)); Check(not IdemPropNameUSameLen(abcde,zbcde,4)); Check(not IdemPropNameUSameLen(abcde,zbcde,5)); Check(FindRawUTF8(['a','bb','cc'],'a')=0); Check(FindRawUTF8(['a','bb','cc'],'cc')=2); Check(FindRawUTF8(['a','bb','cc'],'ab')=-1); Check(FindRawUTF8(['a','bb','cc'],'A')=-1); Check(FindRawUTF8(['a','bb','cc'],'A',false)=0); Check(FindPropName(['a','bb','cc'],'A')=0); Check(FindPropName(['a','bb','cc'],'cC')=2); Check(FindPropName(['a','bb','cc'],'ab')=-1); WinAnsi := 'aecD'; WinAnsi[2] := #$E9; WinAnsi[3] := #$E7; Check(UpperCaseU(WinAnsiToUTF8(WinAnsi))='AECD'); check(not JsonPropNameValid(nil)); check(not JsonPropNameValid(@edf[15])); for i := 14 downto 0 do check(JsonPropNameValid(@edf[i])<>(i in [5,7])); for i := 15 downto 0 do check(JsonPropNameValid(@eda[i])=(i>8)); Check(PosCharAny('ABC','z')=nil); Check(PosCharAny('ABC','A')^='A'); Check(PosCharAny('ABC','B')^='B'); Check(PosCharAny('ABC','C')^='C'); Check(PosCharAny('ABC','az')=nil); Check(PosCharAny('ABC','aA')^='A'); Check(PosCharAny('ABC','bB')^='B'); Check(PosCharAny('ABC','cC')^='C'); Check(PosExChar('z','')=0,'ABC'); Check(PosExChar('z','A')=0,'ABC'); Check(PosExChar('z','ABC')=0,'ABC'); Check(PosExChar('A','A')=1,'ABC'); Check(PosExChar('A','AB')=1,'ABC'); Check(PosExChar('A','ABC')=1,'ABC'); Check(PosExChar('B','ABC')=2,'ABC'); Check(PosExChar('B','AB')=2,'ABC'); Check(PosExChar('C','ABC')=3,'ABC'); end; {$IFDEF FPC} {$POP} {$ELSE} {$HINTS ON} {$ENDIF} procedure TTestLowLevelCommon._TSynTable; var T: TSynTable; procedure Test; begin Check(T.Field[0].Name='currency'); Check(T.Field[0].Offset=0); Check(T.Field[1].Name='double'); Check(T.Field[1].Offset=8); Check(T.Field[2].Name='bool'); Check(T.Field[2].Offset=16); Check(T.FieldVariableOffset=17); Check(T.FieldFromName['TEXT'].Offset=-1); Check(T.FieldFromName['text'].FieldNumber=3); Check(tfoIndex in T.Field[3].Options); Check(T.FieldFromName['VARint'].Name='varint'); Check(T.FieldFromName['VARint'].Name='varint'); Check(T.FieldFromName['VARint'].FieldNumber=4); Check(T.Field[4].Options=[]); Check(T.FieldFromName['ansi'].Offset=-3); Check(T.FieldFromName['ansi'].FieldNumber=5); end; var W: TFileBufferWriter; R: TFileBufferReader; f: THandle; FN: TFileName; {$ifndef NOVARIANTS} data: TSynTableData; rec: Variant; i: integer; V: double; u: SynUnicode; a: WinAnsiString; {$endif NOVARIANTS} begin T := TSynTable.Create('Test'); try Check(T.AddField('One',tftUnknown)=nil); Check(T.AddField('bool',tftBoolean)<>nil); Check(T.AddField('bool',tftBoolean)=nil); Check(T.AddField('double',tftDouble)<>nil); Check(T.AddField('varint',tftVarUInt32)<>nil); Check(T.AddField('text',tftUTF8,[tfoUnique])<>nil); Check(T.AddField('ansi',tftWinAnsi,[])<>nil); Check(T.AddField('currency',tftCurrency)<>nil); Test; FN := ChangeFileExt(ExeVersion.ProgramFileName,'.syntable'); DeleteFile(FN); W := TFileBufferWriter.Create(FN); // manual storage of TSynTable header try T.SaveTo(W); W.Flush; finally W.Free; end; T.Free; f := FileOpen(FN,fmOpenRead); R.Open(f); Check(R.Seek(0)); T := TSynTable.Create('Test'); T.LoadFrom(R); R.Close; Test; {$ifndef NOVARIANTS} try // test TSynTableData data.Init(T); check(data.Field['ID']=0); data.Field['ID'] := 1; check(data.Field['ID']=1); check(data.Field['bool']=false); data.Field['bool'] := 12; check(data.Field['bool']=true); check(data.Field['varint']=0); check(data.Field['double']=0.0); data.Field['varint'] := 100; check(data.Field['varint']=100); data.Field['double'] := 3.1415; CheckSame(data.Field['double'],3.1415); for i := 1 to 100 do begin u := RandomUnicode(i*2); data.Field['text'] := u; check(data.Field['text']=u); a := RandomAnsi7(i*2); data.Field['ansi'] := a; check(data.Field['ansi']=a); // here, ansi is more efficent than text for storage size end; check(data.Field['bool']=true); check(data.Field['varint']=100); check(data.Field['ID']=1); CheckSame(data.Field['double'],3.1415); for i := 1 to 100 do begin data.Field['varint'] := i shl 6; Check(data.Field['varint']=i shl 6,'varlength'); V := random; data.Field['double'] := V; CheckSame(data.Field['double'],V); end; check(data.Field['bool']=true); check(data.Field['text']=u); check(data.Field['ansi']=a); check(data.Field['ID']=1); // test TSynTableVariantType rec := T.Data; check(rec.ID=0); rec.ID := 1; check(rec.ID=1); check(rec.bool=false); rec.bool := 12; check(rec.bool=true); rec.bool := false; check(rec.bool=false); rec.bool := true; check(rec.bool=true); check(rec.varint=0); check(rec.double=0.0); rec.varint := 100; check(rec.varint=100); rec.double := 3.141592654; CheckSame(rec.double,3.141592654); for i := 1 to 100 do begin a := RandomAnsi7(i*2); rec.text := a; check(rec.text=a,'rec.text'); rec.ansi := a; check(rec.ansi=a,'rec.ansi'); end; check(rec.bool=true,'rec.bool'); check(rec.varint=100); check(rec.ID=1); CheckSame(rec.double,3.141592654); for i := 1 to 100 do begin rec.varint := i shl 6; Check(rec.varint=i shl 6,'varlength'); V := random; rec.double := V; CheckSame(rec.double,V); end; check(rec.bool=true); check(rec.text=a); check(rec.ansi=a); check(rec.ID=1); except on E: Exception do // variant error could raise exceptions Check(false,E.Message); end; {$endif NOVARIANTS} FileClose(f); finally T.Free; end; end; procedure TTestLowLevelCommon._TSynCache; var C: TSynCache; s,v: RawUTF8; i: integer; Tag: PtrInt; begin C := TSynCache.Create; try for i := 0 to 100 do begin v := {$ifndef ENHANCEDRTL}Int32ToUtf8{$else}IntToStr{$endif}(i); Tag := 0; s := C.Find(v,@Tag); Check(s=''); Check(Tag=0); C.Add(v+v,i); end; for i := 0 to 100 do begin v := {$ifndef ENHANCEDRTL}Int32ToUtf8{$else}IntToStr{$endif}(i); Check(C.Find(v,@Tag)=v+v); Check(Tag=i); end; finally C.Free; end; end; procedure TTestLowLevelCommon._TSynFilter; type TFilterProcess = function(const Value: RawUTF8): RawUTF8; procedure Test(Filter: TSynFilterClass; Proc: TFilterProcess); var V, Old: RawUTF8; i: integer; begin with Filter.Create do try for i := 0 to 200 do begin V := RandomUTF8(i); Old := V; Process(0,V); Check(V=Proc(Old)); end; finally Free; end; end; begin {$ifndef PUREPASCAL} {$ifndef ENHANCEDRTL} {$ifndef LVCL} {$ifndef FPC} Test(TSynFilterTrim,SynCommons.Trim); {$endif} {$endif} {$endif} {$endif} Test(TSynFilterLowerCase,LowerCase); Test(TSynFilterUpperCase,UpperCase); Test(TSynFilterLowerCaseU,LowerCaseU); Test(TSynFilterUpperCaseU,UpperCaseU); end; procedure TTestLowLevelCommon._TSynValidate; procedure TestValidateLength(const Params: RawUTF8; aMin,aMax: cardinal); var i: cardinal; V: RawUTF8; Msg: string; ok: boolean; valid: TSynValidateText; begin valid := TSynValidateText.Create(Params); try Check(valid.MinLength=aMin); Check(valid.MaxLength=aMax); for i := 0 to 100 do begin V := RandomUTF8(i); Check(Utf8ToUnicodeLength(pointer(V))=i,'Unicode glyph=Ansi char=i'); Msg := ''; ok := (i>=aMin)and(i<=aMax); Check(valid.Process(0,V,Msg)=ok,Msg); Check(Msg=''=ok,Msg); end; finally valid.Free; end; end; var Msg: string; begin with TSynValidateIPAddress.Create do try Check(Process(0,'192.168.1.1',Msg)); Check(Msg=''); Msg := ''; Check(not Process(0,' 192.168.1.1',Msg)); Check(Msg<>''); Msg := ''; Check(not Process(0,'292.168.1.1',Msg)); Check(Msg<>''); Msg := ''; Check(Process(0,'192.168.001.001',Msg)); Check(Msg=''); finally Free; end; with TSynValidateEmail.Create do try Msg := ''; Check(Process(0,'test@synopse.info',Msg)); Check(Msg=''); Msg := ''; Check(not Process(0,'test@ synopse.info',Msg)); Check(Msg<>''); Msg := ''; Check(not Process(0,'test@synopse.delphi',Msg)); Check(Msg<>''); Msg := ''; Check(Process(0,'test_two@blog.synopse.info',Msg)); Check(Msg=''); Msg := ''; Check(Process(0,'test_two@blog.synopse.fr',Msg)); Check(Msg=''); finally Free; end; with TSynValidateEmail.Create('{"ForbiddenDomains":"google.fr,synopse.info"}') do try Msg := ''; Check(Process(0,'test@blog.synopse.fr',Msg)); Check(Process(0,'test@blog.synopse.info',Msg)); Check(not Process(0,'test@synopse.info',Msg)); Msg := ''; Check(Process(0,'test@blog.google.fr',Msg)); Check(not Process(0,'test@google.fr',Msg)); finally Free; end; with TSynValidateEmail.Create('{"AllowedTLD":"com,org,net","ForbiddenTLD":"net"}') do try Msg := ''; Check(Process(0,'test@synopse.com',Msg)); Check(Msg=''); Msg := ''; Check(not Process(0,'test@ synopse.com',Msg)); Check(Msg<>''); Msg := ''; Check(not Process(0,'test@synopse.info',Msg)); Check(Msg<>''); Msg := ''; Check(not Process(0,'test_two@blog.synopse.net',Msg)); Check(Msg<>''); Msg := ''; Check(not Process(0,'test_two@blog.synopse.fr',Msg)); Check(Msg<>''); finally Free; end; with TSynValidatePattern.Create('this [e-n]s a [!zy]est') do try Msg := ''; Check(Process(0,'this is a test',Msg)); Check(Msg=''); Msg := ''; Check(Process(0,'this is a rest',Msg)); Check(Msg=''); Msg := ''; Check(not Process(0,'this is a zest',Msg)); Check(Msg<>''); Msg := ''; Check(not Process(0,'this as a test',Msg)); Check(Msg<>''); Msg := ''; Check(not Process(0,'this as a rest',Msg)); Check(Msg<>''); finally Free; end; TestValidateLength('',1,maxInt); TestValidateLength('{"mAXlength": 10 , "MInLENgtH" : 3 }',3,10); with TSynValidateText.Create do try Msg := ''; MaxLeftTrimCount := 0; Check(Process(0,'one',Msg)); Check(not Process(0,' one',Msg)); MaxRightTrimCount := 0; Check(Process(0,'one',Msg)); Check(not Process(0,' one',Msg)); Check(not Process(0,'one ',Msg)); Msg:= ''; MinAlphaCount := 3; Check(Process(0,'one',Msg)); Check(not Process(0,'on2',Msg)); Msg := ''; MinDigitCount := 2; Check(Process(0,'one12',Msg)); Check(not Process(0,'one2',Msg)); Msg := ''; MinPunctCount := 1; Check(Process(0,'one12_',Msg)); Check(Process(0,'_one12_',Msg)); Check(Process(0,'_one12',Msg)); Check(not Process(0,'one12',Msg)); Msg := ''; MinLowerCount := 3; Check(Process(0,'o12_ne',Msg)); Check(not Process(0,'o12_An',Msg)); Msg := ''; MinUpperCount := 3; Check(Process(0,'o12_neABC',Msg)); Check(not Process(0,'o12_AnBc',Msg)); Msg := ''; MinSpaceCount := 3; Check(Process(0,'o12 _ne AB C',Msg)); Check(not Process(0,'O1 2_A neeB',Msg)); Msg := ''; MaxSpaceCount := 3; Check(Process(0,'o12 _ne AB C',Msg)); Check(not Process(0,'o12 _ ne AB C',Msg)); finally Free; end; with TSynValidatePassword.Create do try Msg := ''; Check(Process(0,'aA3!Z',Msg)); Check(not Process(0,'aA3!',Msg)); Msg := ''; Check(not Process(0,'aA 3!Z',Msg)); finally Free; end; end; procedure TTestLowLevelCommon.UrlDecoding; var i, V: integer; s,t,d: RawUTF8; U: PUTF8Char; begin for i := 1 to 100 do begin s := DateTimeToIso8601(Now/20+Random*20,true); t := UrlEncode(s); Check(UrlDecode(t)=s); d := 'seleCT='+t+'&where='+ {$ifndef ENHANCEDRTL}Int32ToUtf8{$else}IntToStr{$endif}(i); Check(UrlDecodeNeedParameters(pointer(d),'where,select')); Check(not UrlDecodeNeedParameters(pointer(d),'foo,select')); Check(UrlDecodeValue(pointer(d),'SELECT=',t,@U)); Check(t=s,'UrlDecodeValue'); Check(IdemPChar(U,'WHERE='),'Where'); Check(UrlDecodeInteger(U,'WHERE=',V)); Check(V=i); Check(not UrlDecodeValue(pointer(d),'NOTFOUND=',t,@U)); Check(UrlDecodeInteger(U,'WHERE=',V,@U)); Check(U=nil); end; s := '{"b":30,"a":"toto"}'; // temp read-only var for proper overload call CheckEqual(UrlEncodeJsonObject('',s,[]),'?b=30&a=toto'); end; procedure TTestLowLevelCommon.MimeTypes; const MIMES: array[0..49] of TFileName = ( 'png','image/png', 'PNg','image/png', 'gif','image/gif', 'tif','image/tiff', 'tiff','image/tiff', 'jpg','image/jpeg', 'JPG','image/jpeg', 'jpeg','image/jpeg', 'bmp','image/bmp', 'doc','application/msword', 'docx','application/msword', 'htm',HTML_CONTENT_TYPE, 'html',HTML_CONTENT_TYPE, 'HTML',HTML_CONTENT_TYPE, 'css','text/css', 'js','application/javascript', 'ico','image/x-icon', 'pdf','application/pdf', 'PDF','application/pdf', 'Json',JSON_CONTENT_TYPE, 'webp','image/webp', 'manifest','text/cache-manifest', 'appcache','text/cache-manifest', 'h264','video/H264', 'ogg','video/ogg'); BIN: array[0..1] of Cardinal = ( $04034B50,$38464947); BIN_MIME: array[0..1] of RawUTF8 = ( 'application/zip','image/gif'); var i: integer; begin CheckEqual(GetMimeContentType(nil,0,'toto.h264'),'video/H264'); for i := 0 to high(MIMES)shr 1 do CheckEqual(GetMimeContentType(nil,0,'toto.'+MIMES[i*2]),ToUTF8(MIMES[i*2+1])); for i := 0 to high(BIN) do begin CheckEqual(GetMimeContentType(@BIN[i],34,''),BIN_MIME[i]); CheckEqual(GetMimeContentTypeFromBuffer(@BIN[i],34,''),BIN_MIME[i]); end; end; function TTestLowLevelCommon.QuickSelectGT(IndexA,IndexB: PtrInt): boolean; begin result := fQuickSelectValues[IndexA]>fQuickSelectValues[IndexB]; end; procedure TTestLowLevelCommon.QuickSelect; function Median(const CSV: RawUTF8; Expected: integer): integer; var IDA: TIntegerDynArray; begin CSVToIntegerDynArray(pointer(CSV),IDA); result := MedianQuickSelectInteger(pointer(IDA),length(IDA)); Check(result=Expected); end; var n,i,med2,med1,len: integer; tmp: TSynTempBuffer; P: PIntegerArray; begin Median('',0); Median('2',2); Median('3,5,12',5); Median('12,3,5',5); Median('19,10,84,11,23',19); Median('1,3,3,6,7,8,9',6); Median('1,2,3,4,5,6,8,9',4); Median('3,5,7,12,13,14,21,23,23,23,23,29,39,40,56',23); Median('3,13,7,5,21,23,39,23,40,23,14,12,56,23,29',23); Median('3,5,7,12,13,14,21,23,23,23,23,29,40,56',21); Median('3,13,7,5,21,23,23,40,23,14,12,56,23,29',21); for n := 0 to 1000 do begin len := n*2+1; SetLength(fQuickSelectValues,len); P := pointer(fQuickSelectValues); FillIncreasing(P,1,len); med1 := MedianQuickSelect(QuickSelectGT,len,tmp); Check(fQuickSelectValues[med1]=n+1); Check(MedianQuickSelectInteger(P,len)=n+1); for i := 0 to high(fQuickSelectValues) do fQuickSelectValues[i] := Random(MaxInt); med1 := fQuickSelectValues[MedianQuickSelect(QuickSelectGT,len,tmp)]; med2 := MedianQuickSelectInteger(P,len); Check(med1=med2); QuickSortInteger(P,0,len-1); check(med2=fQuickSelectValues[n]); end; end; procedure TTestLowLevelCommon._TSynLogFile; procedure Test(const LOG: RawUTF8; ExpectedDate: TDateTime); var L: TSynLogFile; begin L := TSynLogFile.Create(pointer(LOG),length(LOG)); try Check(L.ExecutableName='D:\Dev\lib\SQLite3\exe\TestSQL3.exe'); Check(L.ExecutableVersion='1.2.3.4'); if trunc(ExpectedDate)=40640 then Check(L.InstanceName='D:\Dev\MyLibrary.dll') else Check(L.InstanceName=''); CheckSame(L.ExecutableDate,ExpectedDate,1/SecsPerDay); Check(L.ComputerHost='MyPC'); Check(L.LevelUsed=[sllEnter,sllLeave,sllDebug]); Check(L.RunningUser='MySelf'); Check(L.CPU='2*0-15-1027'); {$ifdef MSWINDOWS} Check(L.OS=wXP); Check(L.ServicePack=3); Check(not L.Wow64); {$endif} Check(L.Freq=0); CheckSame(L.StartDateTime,40640.502882,1/SecsPerDay); if CheckFailed(L.Count=3) then exit; Check(L.EventLevel[0]=sllEnter); Check(L.EventLevel[1]=sllDebug); CheckSame(L.EventDateTime(1),L.StartDateTime,1/SecsPerDay); Check(L.EventLevel[2]=sllLeave); if CheckFailed(L.LogProcCount=1) then exit; Check(L.LogProc[0].Index=0); Check(L.LogProc[0].Time=10020006); finally L.Free; end; end; var tmp: array[0..512] of AnsiChar; msg: RawUTF8; len: integer; begin FillcharFast(tmp,sizeof(tmp),1); len := SyslogMessage(sfAuth,ssCrit,'test','','',tmp,sizeof(tmp),false); // Check(len=65); // <-- different for every PC, due to PC name differences tmp[len] := #0; Check(IdemPChar(PUTF8Char(@tmp),PAnsiChar('<34>1 '))); Check(PosEx(' - - - test',tmp)=len-10); msg := RawUTF8(StringOfChar('+',300)); len := SyslogMessage(sfLocal4,ssNotice,msg,'proc','msg',tmp,300,false); Check(IdemPChar(PUTF8Char(@tmp),PAnsiChar('<165>1 '))); Check(PosEx(' proc msg - ++++',tmp)>1); Check(len<300,'truncated to avoid buffer overflow'); Check(tmp[len-1]='+'); Check(tmp[len]=#1); Test('D:\Dev\lib\SQLite3\exe\TestSQL3.exe 1.2.3.4 (2011-04-07 11:09:06)'#13#10+ 'Host=MyPC User=MySelf CPU=2*0-15-1027 OS=2.3=5.1.2600 Wow64=0 Freq=3579545 '+ 'Instance=D:\Dev\MyLibrary.dll'#13#10+ 'TSynLog 1.15 LVCL 2011-04-07 12:04:09'#13#10#13#10+ '20110407 12040903 + SQLite3Commons.TSQLRestServer.URI (14163)'#13#10+ '20110407 12040904 debug {"TObjectList(00AF8D00)":["TObjectList(00AF8D20)",'+ '"TObjectList(00AF8D60)","TFileVersion(00ADC0B0)","TSynMapFile(00ACC990)"]}'#13#10+ '20110407 12040915 - SQLite3Commons.TSQLRestServer.URI (14163) 10.020.006', 40640.464653); Test('D:\Dev\lib\SQLite3\exe\TestSQL3.exe 1.2.3.4 (2011-04-08 11:09:06)'#13#10+ 'Host=MyPC User=MySelf CPU=2*0-15-1027 OS=2.3=5.1.2600 Wow64=0 Freq=3579545'#13#10+ 'TSynLog 1.15 LVCL 2011-04-07 12:04:09'#13#10#13#10+ '20110407 12040903 + SQLite3Commons.TSQLRestServer.URI (14163)'#13#10+ '20110407 12040904 debug {"TObjectList(00AF8D00)":["TObjectList(00AF8D20)",'+ '"TObjectList(00AF8D60)","TFileVersion(00ADC0B0)","TSynMapFile(00ACC990)"]}'#13#10+ '20110407 12040915 - SQLite3Commons.TSQLRestServer.URI (14163) 10.020.006', 40641.464653); end; procedure TTestLowLevelCommon._TSynNameValue; const MAX=10000; var nv: TSynNameValue; i: integer; tmp: TSynTempBuffer; begin nv.Init(false); check(nv.Count=0); for i := 1 to MAX do nv.Add(UInt32ToUtf8(i),UInt32ToUtf8(i+MAX)); check(nv.Count=MAX); for i := 1 to MAX do check(nv.Find(UInt32ToUtf8(i))=i-1); for i := MAX+1 to MAX*2 do check(nv.Find(UInt32ToUtf8(i))<0); for i := 1 to MAX do check(nv.Value(UInt32ToUtf8(i))=UInt32ToUtf8(i+MAX)); for i := 1 to MAX do check(nv.Str[UInt32ToUtf8(i)]=UInt32ToUtf8(i+MAX)); nv.InitFromNamesValues(['a','b'],['1','be']); check(nv.Count=2); check(nv.Str['a']='1'); check(nv.Str['b']='be'); check(nv.Str['c']=''); check(nv.ValueInt('a')=1); check(nv.ValueInt('b')=0); check(nv.ValueInt('c')=0); check(nv.AsCSV('=',';')='a=1;b=be;'); check(nv.AsJSON='{"a":"1","b":"be"}'); tmp.Init('{a:10,b:"bee"}'); check(nv.InitFromJSON(tmp.buf)); check(nv.Count=2); check(nv.Str['a']='10'); check(nv.Str['b']='bee'); check(nv.Str['c']=''); check(nv.Int['a']=10); check(nv.Int['b']=0); check(nv.Int['c']=0); check(nv.AsCSV('=',';')='a=10;b=bee;'); check(nv.AsJSON='{"a":"10","b":"bee"}'); check(nv.Delete('b')); check(nv.ValueInt('a')=10); check(nv.Str['b']=''); check(not nv.Delete('b')); check(nv.DeleteByValue('10')=1); check(nv.ValueInt('a')=0); check(nv.DeleteByValue('10')=0); check(nv.Count=0); check(nv.AsCSV('=',';')=''); tmp.Init('{"a":20,b:"bi"]'); check(not nv.InitFromJSON(tmp.buf)); check(nv.Count=0); end; procedure TTestLowLevelCommon._TObjectListHashed; const MAX = 1000000; var obj: TObjectListHashed; i: PtrInt; added: boolean; begin obj := TObjectListHashed.Create(false); try //obj.Hash.Capacity := MAX; // we will test hash size growing abilities Check(obj.Count=0); for i := 0 to MAX do begin obj.Add(pointer(i),added); check(added); end; for i := 0 to obj.Count-1 do Check(obj.IndexOf(obj.List[i])=i); for i := obj.Count-1 downto 0 do if i and 255=0 then obj.Delete(i); // will invalidate hash, but won't rehash now CheckEqual(obj.IndexOf(TObject(255)),254); CheckEqual(obj.IndexOf(TObject(256)),-1); CheckEqual(obj.IndexOf(TObject(512)),-1); for i := 0 to obj.Count-1 do Check(obj.IndexOf(obj.List[i])=i); // will rehash after trigger=32 finally obj.Free; end; end; type TSynPersistentStoreList = class(TObjectListSorted) protected function Compare(Item: TSynPersistentLock; const Value): integer; override; function NewItem(const Value): TSynPersistentLock; override; end; function TSynPersistentStoreList.Compare(Item: TSynPersistentLock; const Value): integer; begin result := StrComp(pointer(TSynPersistentStore(Item).Name),pointer(Value)); end; function TSynPersistentStoreList.NewItem(const Value): TSynPersistentLock; begin result := TSynPersistentStore.Create(RawUTF8(Value)); end; procedure TTestLowLevelCommon._TObjectListSorted; const MAX = 20000; var obj: TSynPersistentStoreList; i, n: integer; v: RawUTF8; item: TSynPersistentStore; added: boolean; begin obj := TSynPersistentStoreList.Create; try n := 0; Check(obj.Count=0); for i := 1 to MAX do begin UInt32ToUtf8(Random32 shr 10,v); item := obj.FindOrAddLocked(v,added); Check(item<>nil); Check(item.Name=v); if added then inc(n); item.Safe.UnLock; end; Check(obj.Count=n); for i := 0 to obj.Count-1 do begin item := obj.FindLocked(TSynPersistentStore(obj.ObjArray[i]).Name); Check(item<>nil); Check(pointer(item)=obj.ObjArray[i]); item.Safe.UnLock; end; finally obj.Free; end; end; procedure TTestLowLevelCommon._TSynUniqueIdentifier; const JAN2015_UNIX = 1420070400; var gen: TSynUniqueIdentifierGenerator; i1,i2: TSynUniqueIdentifierBits; i3: TSynUniqueIdentifier; i: integer; {$ifndef NOVARIANTS}json,{$endif} obfusc: RawUTF8; begin gen := TSynUniqueIdentifierGenerator.Create(10,'toto'); try for i := 1 to 100000 do begin gen.ComputeNew(i1); gen.ComputeNew(i2); check(i1.ProcessID=10); check(i2.ProcessID=10); check(i1.CreateTimeUnix>JAN2015_UNIX); check(i1.CreateTimeUnix<=i2.CreateTimeUnix); check(i1.Value0; UInt32ToUTF8(i,k); check(dict.Exists(k)=exists); if exists then begin v := 0; check(dict.FindAndCopy(k, v)); check(v=i); if i<10000 then begin // FindKeyFromValue() brute force is slow k := ''; check(dict.FindKeyFromValue(v,k)); check(GetInteger(pointer(k))=i); end; end; end; finally dict.Free; end; end; procedure TTestLowLevelCommon._TSynQueue; var o,i,j,k,n: integer; f: TSynQueue; u,v: RawUTF8; savedint: TIntegerDynArray; savedu: TRawUTF8DynArray; begin f := TSynQueue.Create(TypeInfo(TIntegerDynArray)); try for o := 1 to 1000 do begin check(f.Count=0); check(not f.Pending); for i := 1 to o do f.Push(i); check(f.Pending); check(f.Count=o); check(f.Capacity>=o); f.Save(savedint); check(Length(savedint)=o); for i := 1 to o do begin j := -1; check(f.Peek(j)); check(j=i); j := -1; check(f.Pop(j)); check(j=i); end; check(not f.Pending); check(f.Count=0); check(f.Capacity>0); f.Clear; // ensure f.Pop(j) will use leading storage check(not f.Pending); check(f.Count=0); check(f.Capacity=0); check(Length(savedint)=o); for i := 1 to o do check(savedint[i-1]=i); n := 0; for i := 1 to o do if i and 7=0 then begin j := -1; check(f.Pop(j)); check(j and 7<>0); dec(n); end else begin f.Push(i); inc(n); end; check(f.Count=n); check(f.Pending); f.Save(savedint); check(Length(savedint)=n); for i := 1 to n do check(savedint[i-1] and 7<>0); for i := 1 to n do begin j := -1; check(f.Peek(j)); k := -1; check(f.Pop(k)); check(j=k); check(j and 7<>0); end; check(f.Count=0); check(f.Capacity>0); end; finally f.Free; end; f := TSynQueue.Create(TypeInfo(TRawUTF8DynArray)); try for o := 1 to 1000 do begin check(not f.Pending); check(f.Count=0); f.Clear; // ensure f.Pop(j) will use leading storage check(f.Count=0); check(f.Capacity=0); n := 0; for i := 1 to o do if i and 7=0 then begin u := '7'; check(f.Pop(u)); check(GetInteger(pointer(u)) and 7<>0); dec(n); end else begin u := UInt32ToUtf8(i); f.Push(u); inc(n); end; check(f.Pending); check(f.Count=n); f.Save(savedu); check(Length(savedu)=n); for i := 1 to n do check(GetInteger(pointer(savedu[i-1])) and 7<>0); for i := 1 to n do begin u := ''; check(f.Peek(u)); v := ''; check(f.Pop(v)); check(u=v); check(GetInteger(pointer(u)) and 7<>0); end; check(not f.Pending); check(f.Count=0); check(f.Capacity>0); end; check(Length(savedu)=length(savedint)); finally f.Free; end; end; procedure TTestLowLevelCommon._DeltaCompress; var o,n,d,s: RawByteString; i: integer; begin n := RandomTextParagraph(100); d := DeltaCompress(n,o); check(DeltaExtract(d,o,s)=dsSuccess,'delta0'); Check(s=n); d := DeltaCompress(n,s); check(d='='); for i := 1 to 20 do begin o := n; s := RandomTextParagraph(100); case i and 7 of 2: n := n+s; 7: n := s+n; else insert(s,n,i*50); end; d := DeltaCompress(n,o); check(d<>'='); check(length(d)b.Size shl 3); Check(b.HashFunctions=7); Check(b.Inserted=0); CheckLogTimeStart; for i := 1 to SIZ do Check(not b.MayExist(@i,sizeof(i))); CheckLogTime(b.Inserted=0,'MayExists(%)=false',[SIZ]); for i := 1 to 1000 do b.Insert(@i,sizeof(i)); CheckLogTime(b.Inserted=1000,'Insert(%)',[b.Inserted]); sav1000 := b.SaveTo; CheckLogTime(sav1000<>'','b.SaveTo(%) len=%',[b.Inserted,kb(sav1000)]); for i := 1001 to SIZ do b.Insert(@i,sizeof(i)); CheckLogTime(b.Inserted=SIZ,'Insert(%)',[SIZ-1000]); savSIZ := b.SaveTo; CheckLogTime(length(savSIZ)>length(sav1000),'b.SaveTo(%) len=%',[SIZ,kb(savSIZ)]); for i := 1 to SIZ do Check(b.MayExist(@i,sizeof(i))); CheckLogTime(b.Inserted=SIZ,'MayExists(%)=true',[SIZ]); n := 0; for i := SIZ+1 to SIZ+SIZ shr 5 do if b.MayExist(@i,sizeof(i)) then inc(n); falsepositive := (n*100)/(SIZ shr 5); CheckLogTime(falsepositive<1,'falsepositive=%',[falsepositive]); b.Reset; CheckLogTime(b.Inserted=0,'b.Reset',[]); for i := 1 to SIZ do Check(not b.MayExist(@i,sizeof(i))); CheckLogTime(b.Inserted=0,'MayExists(%)=false',[SIZ]); CheckLogTime(b.LoadFrom(sav1000),'b.LoadFrom(%)',[1000]); for i := 1 to 1000 do Check(b.MayExist(@i,sizeof(i))); CheckLogTime(b.Inserted=1000,'MayExists(%)=true',[1000]); finally b.Free; end; CheckLogTime(true,'b.Free',[]); d1 := TSynBloomFilterDiff.Create(savSIZ); try CheckLogTime(true,'d1 := TSynBloomFilterDiff.Create(%)',[SIZ]); CheckSame(d1.FalsePositivePercent,1); Check(d1.Size=SIZ+5000); Check(d1.Bits>d1.Size shl 3); Check(d1.HashFunctions=7); for i := 1 to SIZ do Check(d1.MayExist(@i,sizeof(i))); CheckLogTime(d1.Inserted=SIZ,'MayExists(%)=true',[SIZ]); d2 := TSynBloomFilterDiff.Create; try Check(d2.Revision=0); n := SIZ; for j := 1 to 3 do begin savSiz := d1.SaveToDiff(d2.Revision); CheckLogTime(savSiz<>'','d1.SaveToDiff(%) len=%',[d2.Revision,KB(savSiz)]); Check(d1.DiffKnownRevision(savSIZ)=d1.Revision); Check((d2.Revision=d1.Revision)=(j>1)); CheckLogTime(d2.LoadFromDiff(savSiz),'d2.LoadFromDiff(%)',[n]); Check(d2.Revision=d1.Revision); Check(d2.Size=d1.Size); for i := 1 to n do Check(d2.MayExist(@i,sizeof(i))); CheckLogTime(d2.Inserted=cardinal(n),'MayExists(%)=true',[n]); for i := n+1 to n+1000 do d1.Insert(@i,sizeof(i)); CheckLogTime(d2.Revision<>d1.Revision,'d1.Insert(%)',[1000]); savSiz := d1.SaveToDiff(d2.Revision); CheckLogTime(savSiz<>'','d1.SaveToDiff(%) len=%',[d2.Revision,kb(savSiz)]); Check(d1.DiffKnownRevision(savSIZ)=d1.Revision); Check(d2.Revision<>d1.Revision); CheckLogTime(d2.LoadFromDiff(savSiz),'d2.LoadFromDiff(%)',[n]); Check(d2.Revision=d1.Revision); inc(n,1000); for i := 1 to n do Check(d2.MayExist(@i,sizeof(i))); CheckLogTime(d2.Inserted=cardinal(n),'MayExists(%)=true',[n]); Check(d2.Inserted=cardinal(n)); if j=2 then begin d1.DiffSnapshot; CheckLogTime(d2.Revision=d1.Revision,'d1.DiffSnapshot',[]); end; end; finally d2.Free; CheckLogTime(true,'d2.Free',[]); end; finally d1.Free; CheckLogTime(true,'d1.Free',[]); end; end; {$ifndef DELPHI5OROLDER} type TPersistentAutoCreateFieldsTest = class(TPersistentAutoCreateFields) private fText: RawUTF8; fValue1: TComplexNumber; fValue2: TComplexNumber; public constructor CreateFake; published property Text: RawUTF8 read fText write fText; property Value1: TComplexNumber read fValue1; property Value2: TComplexNumber read fValue2; end; TPersistentAutoCreateFieldsTestObjArray = array of TPersistentAutoCreateFieldsTest; TComplexNumberObjArray = array of TComplexNumber; TObjArrayTest = class(TPersistentAutoCreateFieldsTest) private fValues: TComplexNumberObjArray; published property Values: TComplexNumberObjArray read fValues write fValues; end; TSQLRecordArrayTest = class(TSQLRecord) private fValues: TComplexNumberObjArray; published property Values: TComplexNumberObjArray read fValues write fValues; end; constructor TPersistentAutoCreateFieldsTest.CreateFake; begin inherited Create; Text := 'text'; Value1.Real := 1.5; Value1.Imaginary := 2.5; Value2.Real := 1.7; Value2.Imaginary := 2.7; end; procedure TTestLowLevelCommon._TObjArray; const MAX=200; var i: integer; arr: TPersistentAutoCreateFieldsTestObjArray; test,test2: TObjArrayTest; p: TPersistentAutoCreateFieldsTest; r1,r2: TSQLRecordArrayTest; tmp: RawUTF8; valid: boolean; procedure CheckValues(test: TComplexNumberObjArray); var i: integer; begin Check(length(test)=MAX+1); for i := 0 to MAX do begin CheckSame(test[i].Real,0.5+i); CheckSame(test[i].Imaginary,0.2+i); end; end; begin TJSONSerializer.RegisterObjArrayForJSON( TypeInfo(TPersistentAutoCreateFieldsTestObjArray),TPersistentAutoCreateFieldsTest); try tmp := DynArraySaveJSON(arr,TypeInfo(TPersistentAutoCreateFieldsTestObjArray)); check(tmp='[]'); p := TPersistentAutoCreateFieldsTest.CreateFake; ObjArrayAdd(arr,p); tmp := DynArraySaveJSON(arr,TypeInfo(TPersistentAutoCreateFieldsTestObjArray)); check(tmp='[{"Text":"text","Value1":{"Real":1.5,"Imaginary":2.5},'+ '"Value2":{"Real":1.7,"Imaginary":2.7}}]'); for i := 1 to MAX do begin p := TPersistentAutoCreateFieldsTest.CreateFake; p.Value1.Real := p.Value1.Real+i*1.0; Check(ObjArrayAdd(arr,p)=i); end; tmp := DynArraySaveJSON(arr,TypeInfo(TPersistentAutoCreateFieldsTestObjArray)); ObjArrayClear(arr); Check(length(arr)=0); DynArrayLoadJSON(arr,pointer(tmp),TypeInfo(TPersistentAutoCreateFieldsTestObjArray)); Check(length(arr)=MAX+1); for i := 0 to MAX do begin Check(arr[i].Text='text'); CheckSame(arr[i].Value1.Real,1.5+i); CheckSame(arr[i].Value1.Imaginary,2.5); CheckSame(arr[i].Value2.Real,1.7); CheckSame(arr[i].Value2.Imaginary,2.7); end; finally ObjArrayClear(arr); end; TJSONSerializer.RegisterObjArrayForJSON( TypeInfo(TComplexNumberObjArray),TComplexNumber); test := TObjArrayTest.CreateFake; try for i := 0 to max do ObjArrayAdd(test.fValues,TComplexNumber.Create(0.5+i,0.2+i)); CheckValues(test.Values); tmp := ObjectToJSON(test); finally test.Free; end; r1 := TSQLRecordArrayTest.CreateFrom(tmp); r2 := TSQLRecordArrayTest.CreateFrom(tmp); try check(r1.IDValue=0); check(r2.IDValue=0); CheckValues(r1.Values); CheckValues(r2.Values); check(r1.SameValues(r2)); finally r2.Free; r1.Free; end; test := TObjArrayTest.CreateFake; test2 := TObjArrayTest.CreateFake; try check(ObjectLoadJSON(test,tmp)); CheckValues(test.Values); JSONToObject(test2,pointer(tmp),valid); Check(valid); CheckValues(test2.Values); check(ObjectEquals(test,test2)); finally test2.Free; test.Free; end; end; function TSQLRecordPeopleCompareByFirstName(const A,B): integer; begin result := StrIComp(pointer(TSQLRecordPeople(A).FirstName), pointer(TSQLRecordPeople(B).FirstName)); end; procedure TTestLowLevelCommon._TObjectDynArrayWrapper; const MAX = 10000; var i,j: integer; s: RawUTF8; da: IObjectDynArray; // force the interface to be defined BEFORE the array procedure CheckItem(p: TSQLRecordPeople; i: integer); var s: RawUTF8; begin UInt32ToUtf8(i,s); Check(p.fID=i); Check(p.FirstName='FirstName'+s); Check(p.LastName='LastName'+s); Check(p.Data=''); Check(p.YearOfBirth=i); Check(p.YearOfDeath=i+80); end; begin da := TObjectDynArrayWrapper.Create(a); for i := 1 to MAX do begin UInt32ToUtf8(i,s); Check(da.Add(TSQLRecordPeople.Create(['FirstName'+s,'LastName'+s,i,i+80],i))=i-1); end; Check(da.Count=MAX); for i := 0 to da.Count-1 do CheckItem(a[i],i+1); for i := da.Count-1 downto 0 do if i and 3=0 then da.Delete(i); j := 0; for i := 0 to MAX-1 do if i and 3<>0 then begin CheckItem(a[j],i+1); inc(j); end; Check(j=da.Count); da.Sort(TSQLRecordPeopleCompareByFirstName); for i := 0 to da.Count-1 do CheckItem(a[i],a[i].fID); for i := 1 to da.Count-1 do Check(a[i-1].FirstName0); test.CheckUtf8(ID=i,'id=%=%',[ID,i]); test.Check(Int=i); test.Check(self.Test=Int32ToUtf8(i)); test.Check(Ansi=WinAnsiString(self.Test)); test.Check(Unicode=WinAnsiToRawUnicode(Ansi)); test.Check(ValFloat=i*2.5); test.Check(ValWord=(i+offset) and $ffff); test.Check(ValDate=i+30000); if checkblob then test.Check(Data=self.Test); {$ifndef NOVARIANTS} test.Check(DocVariantType.IsOfType(ValVariant),'var1'); test.Check(VariantSaveJson(ValVariant)='{"id":'+self.Test+'}','var2'); {$endif} end; { TSQLRecordPeople } function TSQLRecordPeople.DataAsHex(aClient: TSQLRestClientURI): RawUTF8; begin Result := aClient.CallBackGetResult('DataAsHex',[],RecordClass,fID); end; class function TSQLRecordPeople.Sum(aClient: TSQLRestClientURI; a, b: double; Method2: boolean): double; var err: integer; const METHOD: array[boolean] of RawUTF8 = ('sum','sum2'); begin Result := GetExtended(pointer(aClient.CallBackGetResult( METHOD[Method2],['a',a,'b',b])),err); end; { TTestLowLevelTypes } {$ifndef NOVARIANTS} procedure TTestLowLevelTypes.Variants; var v: Variant; vd: TVarData absolute v; t: pointer; dt: TDateTime; ni: TNullableInteger; nt: TNullableUTF8Text; begin t := nil; // makes the compiler happy ValueVarToVariant(nil,0,sftBoolean,vd,false,t); Check(not boolean(v)); ValueVarToVariant('0',1,sftBoolean,vd,false,t); Check(not boolean(v)); ValueVarToVariant('false',5,sftBoolean,vd,false,t); Check(not boolean(v)); ValueVarToVariant('1',1,sftBoolean,vd,false,t); Check(boolean(v)); ValueVarToVariant('true',4,sftBoolean,vd,false,t); Check(boolean(v)); GetVariantFromJSON('0',False,v,nil); Check(vd.VType=varInteger); Check(v=0); GetVariantFromJSON('123',False,v,nil); Check(vd.VType=varInteger); Check(v=123); GetVariantFromJSON('0123',False,v,nil); Check(vd.VType=varString); GetVariantFromJSON('-123',False,v,nil); Check(vd.VType=varInteger); Check(v=-123); GetVariantFromJSON('123456789012345678',False,v,nil); Check(vd.VType=varInt64); Check(v=123456789012345678); GetVariantFromJSON('1234567890123456789',False,v,nil); Check(vd.VType=varInt64); Check(v=1234567890123456789); GetVariantFromJSON('12345678901234567890',False,v,nil,true); Check(vd.VType=varDouble); CheckSame(vd.VDouble,12345678901234567890.0,0); GetVariantFromJSON('12345678901234567890',False,v,nil,false); Check(vd.VType=varString); GetVariantFromJSON('-123.1',False,v,nil); Check(vd.VType=varCurrency); Check(v=-123.1); GetVariantFromJSON('-123.12',False,v,nil); Check(vd.VType=varCurrency); Check(v=-123.12); GetVariantFromJSON('-123.123',False,v,nil); Check(vd.VType=varCurrency); Check(v=-123.123); GetVariantFromJSON('123.1234',False,v,nil,false); Check(vd.VType=varCurrency); Check(v=123.1234); GetVariantFromJSON('123.1234',False,v,nil,true); Check(vd.VType=varCurrency); Check(v=123.1234); GetVariantFromJSON('-123.12345',False,v,nil,true); Check(vd.VType=varDouble); CheckSame(v,-123.12345); GetVariantFromJSON('-1.123e12',False,v,nil,true); Check(vd.VType=varDouble); CheckSame(v,-1.123e12); GetVariantFromJSON('-123.123e-2',False,v,nil,true); Check(vd.VType=varDouble); CheckSame(v,-123.123e-2); GetVariantFromJSON('-123.123ee2',False,v,nil,true); Check(vd.VType=varString); Check(v='-123.123ee2'); GetVariantFromJSON('1-123.12',False,v,nil); Check(vd.VType=varString); Check(v='1-123.12'); GetVariantFromJSON('123.',False,v,nil); Check(vd.VType=varString); Check(v='123.'); GetVariantFromJSON('123.abc',False,v,nil); Check(vd.VType=varString); Check(v='123.abc'); GetVariantFromJSON('123.1abc',False,v,nil); Check(vd.VType=varString); Check(v='123.1abc'); GetVariantFromJSON('123.12a',False,v,nil); Check(vd.VType=varString); Check(v='123.12a'); GetVariantFromJSON('123.123a',False,v,nil); Check(vd.VType=varString); Check(v='123.123a'); GetVariantFromJSON('123.1234a',False,v,nil); Check(vd.VType=varString); Check(v='123.1234a'); Check(VariantToDateTime('2016',dt)); CheckSame(dt,42370); Check(VariantToDateTime(2016,dt)); CheckSame(dt,42370); Check(VariantToDateTime('1982/10/30',dt)); CheckSame(dt,30254); Check(not VariantToDateTime('201a',dt)); ni := NullableIntegerNull; Check(NullableIntegerIsEmptyOrNull(ni)); ni := NullableInteger(10); Check(not NullableIntegerIsEmptyOrNull(ni)); Check(NullableIntegerToValue(ni) = 10); nt := NullableUTF8TextNull; Check(NullableUTF8TextIsEmptyOrNull(nt)); nt := NullableUTF8Text('toto'); Check(not NullableUTF8TextIsEmptyOrNull(nt)); Check(NullableUTF8TextToValue(nt) = 'toto'); {$ifndef FPC} // FPC does not allow to mix variant derivated types Check(ni = 10); Check(nt = 'toto'); {$endif} JSONToVariantInPlace(v,nil); Check(vd.VType=varEmpty); v := JSONToVariant(''); Check(vd.VType=varEmpty); v := JSONToVariant('null'); Check(vd.VType=varNull); v := JSONToVariant('false'); Check(not boolean(v)); v := JSONToVariant('true'); Check(boolean(v)); v := JSONToVariant('invalid'); Check(vd.VType=varNull); v := JSONToVariant('0'); Check(vd.VType=varInteger); v := JSONToVariant('123456789012345678'); Check(vd.VType=varInt64); Check(v=123456789012345678); v := JSONToVariant('123.1234'); Check(vd.VType=varCurrency); CheckSame(v,123.1234); v := JSONToVariant('-1E-300',[],true); Check(vd.VType=varDouble); CheckSame(v,-1e-300); v := JSONToVariant('[]'); Check(v._kind=ord(dvArray)); Check(v._count=0); v := JSONToVariant('{ }'); Check(v._kind=ord(dvObject)); Check(v._count=0); v := JSONToVariant('[1,2,3]'); Check(v._kind=ord(dvArray)); Check(v._count=3); v := JSONToVariant(' {"a":10,b:20}'); Check(v._kind=ord(dvObject)); Check(v._count=2); v := JSONToVariant('{"invalid":'); Check(vd.VType=varEmpty); v := JSONToVariant(' "toto\r\ntoto"'); Check(vd.VType=varString); Check(v='toto'#$D#$A'toto'); end; type TMustacheTest = packed record desc: string; template, expected: RawUTF8; data,partials: variant; end; TMustacheTests = packed record tests: array of TMustacheTest; end; const __TMustacheTest = 'desc string template,expected RawUTF8 data,partials variant'; __TMustacheTests = 'tests array of TMustacheTest'; MUSTACHE_SPECS: array[0..4] of TFileName = ('interpolation','comments','sections','inverted','partials'); procedure TTestLowLevelTypes.MustacheRenderer; var mustacheJson: RawByteString; mus: TMustacheTests; mustache: TSynMustache; mustacheJsonFileName: TFileName; doc: variant; html: RawUTF8; helpers: TSynMustacheHelpers; guid: TGUID; spec,i: integer; begin // manual tests mustache := TSynMustache.Parse( 'Hello {{name}}'#13#10'You have just won {{value}} dollars!'); Check(mustache.SectionMaxCount=0); TDocVariant.New(doc); doc.name := 'Chris'; doc.value := 10000; html := mustache.Render(doc); Check(html='Hello Chris'#13#10'You have just won 10000 dollars!'); mustache := TSynMustache.Parse( '{{=<% %>=}}Hello <%name%><%={{ }}=%>'#13#10'You have just won {{& value }} dollars!'); Check(mustache.SectionMaxCount=0); doc := _ObjFast(['name','Chris','value',1000]); html := mustache.Render(doc); Check(html='Hello Chris'#13#10'You have just won 1000 dollars!'); mustache := TSynMustache.Parse( 'Hello {{value.name}}'#13#10'You have just won {{value.value}} dollars!'); Check(mustache.SectionMaxCount=0); html := mustache.RenderJSON('{value:{name:"Chris",value:10000}}'); Check(html='Hello Chris'#13#10'You have just won 10000 dollars!'); mustache := TSynMustache.Parse( '* {{name}}'#13#10'* {{age}}'#13#10'* {{company}}'#13#10'* {{{company}}}'); Check(mustache.SectionMaxCount=0); html := mustache.RenderJson('{name:"Chris",company:"Synopse"}'); Check(html='* Chris'#13#10'* '#13#10'* <b>Synopse</b>'#13#10'* Synopse'); mustache := TSynMustache.Parse( '* {{name}}'#13#10'* {{age}}'#13#10'* {{company}}'#13#10'* {{&company}}'); Check(mustache.SectionMaxCount=0); html := mustache.RenderJson('{name:"Chris",company:"Synopse"}'); Check(html='* Chris'#13#10'* '#13#10'* <b>Synopse</b>'#13#10'* Synopse'); mustache := TSynMustache.Parse('Shown.{{#person}}Never shown!{{/person}}end'); Check(mustache.SectionMaxCount=1); html := mustache.RenderJson('{person:false}'); Check(html='Shown.end'); mustache := TSynMustache.Parse('Shown.{{#person}}Also shown!{{/person}}end'); Check(mustache.SectionMaxCount=1); html := mustache.RenderJSON('{person:true}'); Check(html='Shown.Also shown!end'); html := mustache.RenderJSON('{person:"toto"}'); Check(html='Shown.Also shown!end'); html := mustache.RenderJSON('{person:false}'); Check(html='Shown.end'); mustache := TSynMustache.Parse('Shown.{{#person}}As {{name}}!{{/person}}end{{name}}'); Check(mustache.SectionMaxCount=1); html := mustache.RenderJSON('{person:{age:10,name:"toto"}}'); Check(html='Shown.As toto!end'); mustache := TSynMustache.Parse('Shown.{{^person}}Never shown!{{/person}}end'); Check(mustache.SectionMaxCount=1); html := mustache.RenderJSON('{person:true}'); Check(html='Shown.end'); mustache := TSynMustache.Parse('Shown.{{^person}}Never shown!{{/person}}end'); Check(mustache.SectionMaxCount=1); html := mustache.RenderJSON('{person:{age:10,name:"toto"}}'); Check(html='Shown.end'); mustache := TSynMustache.Parse('Shown.{{^person}}Also shown!{{/person}}end'); Check(mustache.SectionMaxCount=1); html := mustache.RenderJSON('{person:false}'); Check(html='Shown.Also shown!end'); mustache := TSynMustache.Parse('Shown.{{^person}}Also shown!{{/person}}end'); Check(mustache.SectionMaxCount=1); html := mustache.RenderJSON('{person2:2}'); Check(html='Shown.Also shown!end'); Check(helpers=nil,'compiler initialized'); mustache.HelperAdd(helpers, 'jsonhelper', MustacheHelper); mustache := TSynMustache.Parse('{{jsonhelper {a:"a",b:10}}}'); html := mustache.RenderJSON('', nil, helpers); Check(html='a=a,b=10'); mustache := TSynMustache.Parse('{{jsonhelper {a:"b",b:10} }}'); html := mustache.RenderJSON('', nil, helpers); Check(html='a=b,b=10'); mustache := TSynMustache.Parse('{{{jsonhelper {a:"a",b:1}}}}'); html := mustache.RenderJSON('', nil, helpers); check(html='a=a,b=1'); mustache := TSynMustache.Parse('{{jsonhelper {a:1,b:2} }},titi'); html := mustache.RenderJSON('', nil, helpers); Check(html='a=1,b=2,titi'); mustache := TSynMustache.Parse('{{jsonhelper {a:1,nested:{c:{d:[1,2]}},b:10}}}}toto'); html := mustache.RenderJSON('', nil, helpers); Check(html='a=1,b=10}toto'); mustache := TSynMustache.Parse('{{#a}}'#$A'{{one}}'#$A'{{/a}}'#$A); html := mustache.RenderJSON('{a:{one:1}}'); Check(html='1'#$A); mustache := TSynMustache.Parse('{{#a}}{{one}}{{#b}}{{one}}{{two}}{{/b}}{{/a}}'); html := mustache.RenderJSON('{a:{one:1},b:{two:2}}'); Check(html='112'); mustache := TSynMustache.Parse('{{>partial}}'#$A'3'); html := mustache.RenderJSON('{}',TSynMustachePartials.CreateOwned(['partial','1'#$A'2'])); Check(html='1'#$A'23','external partials'); mustache := TSynMustache.Parse('{{partial}}4'); html := mustache.RenderJSON('{name:3}'); Check(html='1'#$A'234','internal partials'); mustache := TSynMustache.Parse( 'My favorite things:'#$A'{{#things}}{{-index}}. {{.}}'#$A'{{/things}}'); Check(mustache.SectionMaxCount=1); html := mustache.RenderJSON('{things:["Peanut butter", "Pen spinning", "Handstands"]}'); Check(html='My favorite things:'#$A'1. Peanut butter'#$A'2. Pen spinning'#$A+ '3. Handstands'#$A,'-index pseudo variable'); mustache := TSynMustache.Parse('{{#things}}{{.}}{{/things}}'); html := mustache.RenderJSON('{things:["one", "two", "three"]}'); check(html='onetwothree'); mustache := TSynMustache.Parse('{{#things}}{{#-first}}{{.}}{{/-first}}{{/things}} {{pi}}'); html := mustache.RenderJSON('{things:["one", "two", "three"],pi:3.1415}'); check(html='one 3.1415'); mustache := TSynMustache.Parse('{{#things}}{{^-first}}, {{/-first}}{{.}}{{/things}}'); html := mustache.RenderJSON('{things:["one", "two", "three"]}'); check(html='one, two, three'); mustache := TSynMustache.Parse('{{#things}}{{.}}{{^-last}}, {{/-last}}{{/things}}'); html := mustache.RenderJSON('{things:["one", "two", "three"]}'); check(html='one, two, three'); mustache := TSynMustache.Parse('{{#things}}{{#-last}}{{.}}{{/-last}}{{/things}}'); html := mustache.RenderJSON('{things:["one", "two", "three"]}'); check(html='three'); mustache := TSynMustache.Parse('{{#things}}{{#-odd}}{{.}}{{/-odd}}{{/things}}'); html := mustache.RenderJSON('{things:["one", "two", "three"]}'); check(html='onethree'); mustache := TSynMustache.Parse( '{{"Hello}} {{name}}'#13#10'{{"You have just won}} {{value}} {{"dollars}}!'); Check(mustache.SectionMaxCount=0); html := mustache.RenderJSON('{name:?,value:?}',[],['Chris',10000],nil,nil,MustacheTranslate); Check(html='Bonjour Chris'#$D#$A'Vous venez de gagner 10000 dollars!'); mustache := TSynMustache.Parse('1+3={{tval}} - is it 4?{{#if tval=4}} yes!{{/if}}'); html := mustache.RenderJSON('{tval:4}',nil,TSynMustache.HelpersGetStandardList); check(html='1+3=4 - is it 4? yes!'); html := mustache.RenderJSON('{tval:5}',nil,TSynMustache.HelpersGetStandardList); check(html='1+3=5 - is it 4?'); mustache := TSynMustache.Parse('{{newguid}}'); html := mustache.RenderJSON('{}',nil,TSynMustache.HelpersGetStandardList); check((html<>'') and (TextToGUID(@html[2],@guid)<>nil)); mustache := TSynMustache.Parse( '

{{header}}

'#$D#$A'{{#items}}'#$D#$A'{{#first}}'#$D#$A+ '
  • {{name}}
    • '#$D#$A'{{/first}}'#$D#$A+ '{{#link}}'#$D#$A'
  • {{name}}
    • '#$D#$A'{{/link}}'#$D#$A+ '{{/items}}'#$D#$A#$D#$A'{{#empty}}'#$D#$A'

    The list is empty.

    '#$D#$A'{{/empty}}'); Check(mustache.SectionMaxCount=2); html := mustache.RenderJSON( '{"header":"Colors","items":[{"name":"red","first":true,"url":"#Red"},'+ '{"name":"green","link":true,"url":"#Green"},{"name":"blue","first":true,'+ '"link":true,"url":"#Blue"}],"empty":true}'); Check(trim(html)= '

    Colors

    '#$D#$A'
  • red
    • '#$D#$A+ '
  • green
    • '#$D#$A'
  • blue
    • '#$D#$A+ '
  • blue
    • '#$D#$A#$D#$A'

    The list is empty.

    '); mustache := TSynMustache.Parse('{{#users}}'#$D#$A'{{^Connected}}'#$D#$A+ '- {{Name}} {{Firstname}} ({{Connected}})
    '#$D#$A'{{/Connected}}'#$D#$A'{{/users}}'); Check(mustache.SectionMaxCount=2); html := mustache.RenderJSON('{"users":['+ '{"RowID":1,"Login":"safr","Firstname":"Frodon","Name":"Sacquet","Alias":"safr","Connected":true,"Resto":0},' + #13#10 + '{"RowID":2,"Login":"saga","Firstname":"Samsagace","Name":"Gamegie","Alias":"saga","Connected":false,"Resto":0},' + #13#10 + '{"RowID":3,"Login":"peto","Firstname":"Peregrin","Name":"Touque","Alias":"peto","Connected":false,"Resto":0},' + #13#10 + '{"RowID":4,"Login":"mebr","Firstname":"Meriadoc","Name":"Brandebouc","Alias":"mebr","Connected":true,"Resto":0}]}'); check(html='- Gamegie Samsagace (false)
    '#$D#$A'- Touque Peregrin (false)
    '#$D#$A); // run official {{mustache}} regression tests suite TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TMustacheTest),__TMustacheTest). Options := [soReadIgnoreUnknownFields]; TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TMustacheTests),__TMustacheTests). Options := [soReadIgnoreUnknownFields]; for spec := 0 to High(MUSTACHE_SPECS) do begin mustacheJsonFileName := MUSTACHE_SPECS[spec]+'.json'; mustacheJson := StringFromFile(mustacheJsonFileName); if mustacheJson='' then begin mustacheJson := HttpGet('https://raw.githubusercontent.com/mustache/spec/'+ 'master/specs/'+StringToAnsi7(mustacheJsonFileName)); FileFromString(mustacheJson,mustacheJsonFileName); end; RecordLoadJSON(mus,pointer(mustacheJson),TypeInfo(TMustacheTests)); Check(length(mus.tests)>5); for i := 0 to high(mus.tests) do with mus.Tests[i] do begin if PosEx(' {{>partial}}',template)>0 then continue; // we don't indent each line of the expanded partials (yet) mustache := TSynMustache.Parse(template); html := mustache.Render(data,TSynMustachePartials.CreateOwned(partials)); Check(html=expected,desc); end; end; TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TMustacheTest),''); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TMustacheTests),''); end; procedure TTestLowLevelTypes.MustacheTranslate(var English: string); begin if English='Hello' then English := 'Bonjour' else if English='You have just won' then English := 'Vous venez de gagner'; end; procedure TTestLowLevelTypes.MustacheHelper(const Value: variant; out result: variant); begin with _Safe(Value)^ do result := RawUTF8ToVariant(FormatUTF8('a=%,b=%',[U['a'],I['b']])); end; {$endif NOVARIANTS} {$endif DELPHI5OROLDER} {$ifdef UNICODE} {$WARNINGS OFF} // don't care about implicit string cast in tests {$endif} {$ifndef LVCL} {$ifndef DELPHI5OROLDER} type TCollTests = class(TInterfacedCollection) private function GetCollItem(Index: Integer): TCollTest; protected class function GetClass: TCollectionItemClass; override; public function Add: TCollTest; property Item[Index: Integer]: TCollTest read GetCollItem; default; end; TMyCollection = class(TCollection); TCollTst = class(TPersistent) private fColl: TCollTests; fTCollTest: TCollTest; fStr: TStringList; procedure SetColl(const Value: TCollTests); public constructor Create; destructor Destroy; override; published property One: TCollTest read fTCollTest write fTCollTest; property Coll: TCollTests read fColl write SetColl; property Str: TStringList read fStr write fStr; end; TCollTstDynArray = class(TCollTst) private fInts: TIntegerDynArray; fTimeLog: TTimeLogDynArray; fFileVersions: TFVs; class function FVReader(P: PUTF8Char; var aValue; out aValid: Boolean {$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; class procedure FVWriter(const aWriter: TTextWriter; const aValue); class function FVReader2(P: PUTF8Char; var aValue; out aValid: Boolean {$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; class procedure FVWriter2(const aWriter: TTextWriter; const aValue); class function FVClassReader(const aValue: TObject; aFrom: PUTF8Char; var aValid: Boolean; aOptions: TJSONToObjectOptions): PUTF8Char; class procedure FVClassWriter(const aSerializer: TJSONSerializer; aValue: TObject; aOptions: TTextWriterWriteObjectOptions); published property Ints: TIntegerDynArray read fInts write fInts; property TimeLog: TTimeLogDynArray read fTimeLog write fTimeLog; property FileVersion: TFVs read fFileVersions write fFileVersions; end; { TCollTstDynArray} class function TCollTstDynArray.FVReader(P: PUTF8Char; var aValue; out aValid: Boolean{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; var V: TFV absolute aValue; begin // '[1,2001,3001,4001,"1","1001"],[2,2002,3002,4002,"2","1002"],...' aValid := false; result := nil; if (P=nil) or (P^<>'[') then exit; inc(P); V.Major := GetNextItemCardinal(P); V.Minor := GetNextItemCardinal(P); V.Release := GetNextItemCardinal(P); V.Build := GetNextItemCardinal(P); V.Main := UTF8ToString(GetJSONField(P,P)); V.Detailed := UTF8ToString(GetJSONField(P,P)); if P=nil then exit; aValid := true; result := P; // ',' or ']' for last item of array end; class procedure TCollTstDynArray.FVWriter(const aWriter: TTextWriter; const aValue); var V: TFV absolute aValue; begin aWriter.Add('[%,%,%,%,"%","%"]', [V.Major,V.Minor,V.Release,V.Build,V.Main,V.Detailed],twJSONEscape); end; class function TCollTstDynArray.FVReader2(P: PUTF8Char; var aValue; out aValid: Boolean{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; var V: TFV absolute aValue; Values: array[0..5] of TValuePUTF8Char; begin // '{"Major":1,"Minor":2001,"Release":3001,"Build":4001,"Main":"1","Detailed":"1001"},.. aValid := false; result := JSONDecode(P,['Major','Minor','Release','Build','Main','Detailed'],@Values); if result=nil then exit; // result^ = ',' or ']' for last item of array V.Major := Values[0].ToInteger; V.Minor := Values[1].ToInteger; V.Release := Values[2].ToInteger; V.Build := Values[3].ToInteger; V.Main := Values[4].ToString; V.Detailed := Values[5].ToString; aValid := true; end; class procedure TCollTstDynArray.FVWriter2(const aWriter: TTextWriter; const aValue); var V: TFV absolute aValue; begin aWriter.AddJSONEscape(['Major',V.Major,'Minor',V.Minor,'Release',V.Release, 'Build',V.Build,'Main',V.Main,'Detailed',V.Detailed]); end; class function TCollTstDynArray.FVClassReader(const aValue: TObject; aFrom: PUTF8Char; var aValid: Boolean; aOptions: TJSONToObjectOptions): PUTF8Char; var V: TFileVersion absolute aValue; Values: array[0..5] of TValuePUTF8Char; begin // '{"Major":2,"Minor":2002,"Release":3002,"Build":4002,"Main":"2","BuildDateTime":"1911-03-15"}' result := JSONDecode(aFrom,['Major','Minor','Release','Build','Main','BuildDateTime'],@Values); aValid := (result<>nil); if aValid then begin V.Major := Values[0].ToInteger; V.Minor := Values[1].ToInteger; V.Release := Values[2].ToInteger; V.Build := Values[3].ToInteger; V.Main := Values[4].ToString; V.BuildDateTime := Iso8601ToDateTimePUTF8Char(Values[5].Value,Values[5].ValueLen); end; end; class procedure TCollTstDynArray.FVClassWriter(const aSerializer: TJSONSerializer; aValue: TObject; aOptions: TTextWriterWriteObjectOptions); var V: TFileVersion absolute aValue; begin aSerializer.AddJSONEscape(['Major',V.Major,'Minor',V.Minor,'Release',V.Release, 'Build',V.Build,'Main',V.Main,'BuildDateTime',DateTimeToIso8601Text(V.BuildDateTime)]); end; { TCollTests } function TCollTests.Add: TCollTest; begin result := inherited Add as TCollTest; end; class function TCollTests.GetClass: TCollectionItemClass; begin result := TCollTest; end; function TCollTests.GetCollItem(Index: Integer): TCollTest; begin result := Items[Index] as TCollTest; end; { TCollTst } constructor TCollTst.Create; begin inherited; fColl := TCollTests.Create; fTCollTest := TCollTest.Create(nil); end; destructor TCollTst.Destroy; begin fColl.Free; fTCollTest.Free; fStr.Free; inherited; end; procedure TCollTst.SetColl(const Value: TCollTests); begin fColl.Free; fColl := Value; end; {$endif DELPHI5OROLDER} {$endif LVCL} type {$M+} // TPersistent has no RTTI for LVCL! TPersistentToJSON = class(TPersistent) protected fName: RawUTF8; fEnum: TSynBackgroundThreadProcessStep; fSets: TSynBackgroundThreadProcessSteps; published property Name: RawUTF8 read fName write fName; property Enum: TSynBackgroundThreadProcessStep read fEnum write fEnum default flagIdle; property Sets: TSynBackgroundThreadProcessSteps read fSets write fSets default []; end; {$M-} {$ifdef DELPHI5OROLDER} // mORMot.pas not linked yet TSQLRestCacheEntryValue = packed record /// corresponding ID ID: Int64; /// GetTickCount64 shr 9 timestamp when this cached value was stored // - resulting time period has therefore a resolution of 512 ms, and // overflows after 70 years without computer reboot // - equals 0 when there is no JSON value cached Timestamp512: cardinal; /// some associated unsigned integer value // - not used by TSQLRestCache, but available at TSQLRestCacheEntry level Tag: cardinal; /// JSON encoded UTF-8 serialization of the record JSON: RawUTF8; end; {$else} TRange = record Min, Max: Integer; end; TOffense = record Damage, AttackSpeed: TRange; end; TEnemy = class(TSynPersistent) private fEnabled: Boolean; fName: string; function GetOffense: RawJSON; procedure SetOffense(Value: RawJSON); public Off: TOffense; published property Enabled: Boolean read fEnabled write fEnabled; property Name: string read fName write fName; property Offense: RawJSON read GetOffense write SetOffense; end; function TEnemy.GetOffense: RawJSON; begin result := JSONEncode([ 'damage','{','min',Off.Damage.Min,'max',Off.Damage.Max,'}', 'attackspeed','{','min',Off.AttackSpeed.Min,'max',Off.AttackSpeed.Max,'}']); end; procedure RangeFromJSON(out Range: TRange; JSON: PUTF8Char); var V: array[0..1] of TValuePUTF8Char; begin JSONDecode(JSON, ['min', 'max'],@V); Range.Min := V[0].ToInteger; Range.Max := V[1].ToInteger; end; procedure TEnemy.SetOffense(Value: RawJSON); var V: array[0..1] of TValuePUTF8Char; begin JSONDecode(Value,['damage','attackspeed'],@V,true); RangeFromJSON(Off.Damage, V[0].Value); RangeFromJSON(Off.AttackSpeed, V[1].Value); end; {$endif} type TTestCustomJSONRecord = packed record A,B,C: integer; D: RawUTF8; E: record E1,E2: double; end; F: TDateTime; end; TTestCustomJSONArray = packed record A,B,C: byte; D: RawByteString; E: array of record E1: double; E2: string; end; F: TDateTime; end; TTestCustomJSONArrayWithoutF = packed record A,B,C: byte; D: RawByteString; E: array of record E1: double; E2: string; end; end; TTestCustomJSONArraySimpleArray = packed record F: RawUTF8; G: array of RawUTF8; end; TTestCustomJSONArraySimple = packed record A,B: Int64; C: array of TGUID; D: RawUTF8; E: array of TTestCustomJSONArraySimpleArray; H: RawUTF8; end; {$ifndef NOVARIANTS} TTestCustomJSONArrayVariant = packed record A,B: Int64; C: array of variant; D: RawUTF8; end; {$endif} TTestCustomJSONGitHub = packed record name: RawUTF8; id: cardinal; description: RawUTF8; fork: boolean; owner: record login: RawUTF8; id: currency; end; end; TTestCustomJSONGitHubs = array of TTestCustomJSONGitHub; TTestCustomJSON2Title = packed record TITYPE,TIID,TICID,TIDSC30,TIORDER,TIDEL: RawUTF8; end; TTestCustomJSON2Trans = packed record TRTYPE: RawUTF8; TRDATE: TDateTime; TRAA: RawUTF8; TRCAT1, TRCAT2, TRCAT3, TRACID: TTestCustomJSON2Title; TRRMK: RawUTF8; end; TTestCustomJSON2 = packed record Transactions: array of TTestCustomJSON2Trans; end; TTestCustomDiscogs = packed record pagination: record per_page, items, page: Integer; end; releases: array of record status, title, format, _label, artist: RawUTF8; // label is a keyword year, id: Integer; end; end; TSubAB = packed record a: RawUTF8; b: integer; end; TSubCD = packed record c: byte; d: RawUTF8; end; TAggregate = packed record abArr: array of TSubAB; cdArr: array of TSubCD; end; TNestedDtoObject = class(TSynAutoCreateFields) private FFieldString: RawUTF8; FFieldInteger: integer; FFieldVariant: variant; published property FieldString: RawUTF8 read FFieldString write FFieldString; property FieldInteger: integer read FFieldInteger write FFieldInteger; property FieldVariant: variant read FFieldVariant write FFieldVariant; end; TDtoObject = class(TSynAutoCreateFields) private FFieldNestedObject: TNestedDtoObject; FSomeField: RawUTF8; published property NestedObject: TNestedDtoObject read FFieldNestedObject; property SomeField: RawUTF8 read FSomeField write FSomeField; end; {$ifdef ISDELPHI2010} TStaticArrayOfInt = packed array[1..5] of Integer; TNewRTTI = record Number: integer; StaticArray: array[1..2] of record Name: string; Single: Single; Double: Double; end; Int: TStaticArrayOfInt; end; TBookRecord = packed record name: string; author: record first_name:string; last_name:string; end; end; {$endif} const // convention may be to use __ before the type name __TTestCustomJSONRecord = 'A,B,C integer D RawUTF8 E{E1,E2 double} F TDateTime'; __TTestCustomJSONArray = 'A,B,C byte D RawByteString E[E1 double E2 string] F TDateTime'; __TTestCustomJSONArraySimple = 'A,B Int64 C array of TGUID D RawUTF8 E [F RawUTF8 G array of RawUTF8] H RawUTF8'; __TTestCustomJSONArrayVariant = 'A,B Int64 C array of variant D RawUTF8'; __TTestCustomJSONGitHub = 'name RawUTF8 id cardinal description RawUTF8 '+ 'fork boolean owner{login RawUTF8 id currency}'; __TTestCustomJSON2Title = 'TITYPE,TIID,TICID,TIDSC30,TIORDER,TIDEL RawUTF8'; __TTestCustomJSON2 = 'Transactions [TRTYPE RawUTF8 TRDATE TDateTime TRAA RawUTF8 '+ 'TRCAT1,TRCAT2,TRCAT3,TRACID TTestCustomJSON2Title '+ 'TRRMK RawUTF8]'; __TTestCustomDiscogs = 'pagination{per_page,items,page Integer}'+ 'releases[status,title,format,label,artist RawUTF8 year,id integer]'; __TSQLRestCacheEntryValue = 'ID: Int64; Timestamp512,Tag: cardinal; JSON: RawUTF8'; __TSubAB = 'a : RawUTF8; b : integer;'; __TSubCD = 'c : byte; d : RawUTF8;'; __TAggregate = 'abArr : array of TSubAB; cdArr : array of TSubCD;'; zendframeworkFileName = 'zendframework.json'; discogsFileName = 'discogs.json'; procedure TTestLowLevelTypes.EncodeDecodeJSON; var J,U,U2: RawUTF8; P: PUTF8Char; binary,zendframeworkJson,discogsJson: RawByteString; V: array[0..4] of TValuePUTF8Char; i, a, err: integer; r: Double; Parser: TJSONRecordTextDefinition; JR,JR2: TTestCustomJSONRecord; JA,JA2: TTestCustomJSONArray; JAS: TTestCustomJSONArraySimple; {$ifndef NOVARIANTS} JAV: TTestCustomJSONArrayVariant; GDtoObject: TDtoObject; {$endif} Trans: TTestCustomJSON2; Disco: TTestCustomDiscogs; Cache: TSQLRestCacheEntryValue; {$ifndef DELPHI5OROLDER} peop: TSQLRecordPeople; K: RawUTF8; Valid: boolean; RB: TSQLRawBlob; Enemy: TEnemy; {$ifndef LVCL} Instance: TClassInstance; Coll, C2: TCollTst; MyItem: TCollTest; Comp: TComplexNumber; DA: TDynArray; F: TFV; TLNow: TTimeLog; procedure TestMyColl(MyColl: TMyCollection); begin if CheckFailed(MyColl<>nil) then exit; MyItem := MyColl.Add as TCollTest; Check(MyItem.ClassType=TCollTest); MyItem.Length := 10; MyItem.Color := 20; MyItem.Name := 'ABC'; U := ObjectToJSON(MyColl); CheckEqual(U,'[{"Color":20,"Length":10,"Name":"ABC"}]'); MyColl.Free; end; procedure TCollTstDynArrayTest; var CA: TCollTstDynArray; i: integer; tmp: RawByteString; pu: PUTF8Char; begin CA := TCollTstDynArray.Create; try CA.Str := TStringList.Create; tmp := J; Check(JSONToObject(CA,UniqueRawUTF8(RawUTF8(tmp)),Valid)=nil); Check(Valid); Check(CA.One.Color=2); Check(CA.One.Name='test2'); if not CheckFailed(CA.Coll.Count=1) then Check(CA.Coll[0].Name='test'); Check(CA.One.Length=10); Check(CA.Str.Count=10000); for i := 1 to CA.Str.Count do Check(CA.Str[i-1]=IntToStr(i)); SetLength(CA.fInts,20000); for i := 0 to high(CA.Ints) do CA.Ints[i] := i; U := ObjectToJSON(CA); check(IsValidJSON(U)); finally CA.Free; end; CA := TCollTstDynArray.Create; try CA.Str := TStringList.Create; Check(JSONToObject(CA,pointer(U),Valid)=nil); Check(Valid); Check(CA.Str.Count=10000); for i := 1 to CA.Str.Count do Check(CA.Str[i-1]=IntToStr(i)); Check(length(CA.Ints)=20000); for i := 0 to high(CA.Ints) do CA.Ints[i] := i; SetLength(CA.fTimeLog,CA.Str.Count); TLNow := TimeLogNow and (not 63); for i := 0 to high(CA.TimeLog) do CA.TimeLog[i] := TLNow+i and 31; // and 31 to avoid min:sec rounding U := ObjectToJSON(CA); SetLength(CA.fInts,2); SetLength(CA.fTimeLog,2); Check(JSONToObject(CA,pointer(U),Valid)=nil); Check(Valid); Check(Length(CA.Ints)=20000); Check(Length(CA.TimeLog)=CA.Str.Count); for i := 0 to high(CA.Ints) do Check(CA.Ints[i]=i); for i := 0 to high(CA.TimeLog) do Check(CA.TimeLog[i]=TLNow+i and 31); DA.Init(TypeInfo(TFVs),CA.fFileVersions); for i := 1 to 1000 do begin F.Major := i; F.Minor := i+2000; F.Release := i+3000; F.Build := i+4000; str(i,F.Main); str(i+1000,F.Detailed); DA.Add(F); end; U := ObjectToJSON(CA); check(IsValidJSON(U)); DA.Clear; Check(Length(CA.FileVersion)=0); pu := JSONToObject(CA,pointer(U),Valid); Check(pu=nil); Check(Valid); Check(Length(CA.Ints)=20000); Check(Length(CA.TimeLog)=CA.Str.Count); Check(Length(CA.FileVersion)=1000); for i := 1 to 1000 do with CA.FileVersion[i-1] do begin Check(Major=i); Check(Minor=i+2000); Check(Release=i+3000); Check(Build=i+4000); Check(Main=IntToStr(i)); Check(Detailed=IntToStr(i+1000)); end; finally CA.Free; end; end; procedure TFileVersionTest(Full: boolean); var V,F: TFileVersion; J: RawUTF8; i: integer; Valid: boolean; begin V := TFileVersion.Create('',0,0,0,0); F := TFileVersion.Create('',0,0,0,0); try for i := 1 to 1000 do begin if Full then begin V.Major := i; V.Minor := i+2000; V.Release := i+3000; V.Build := i+4000; str(i,V.Main); end; V.BuildDateTime := 4090.0+i; J := ObjectToJSON(V); check(IsValidJSON(J)); JSONToObject(F,pointer(J),Valid); if CheckFailed(Valid) then continue; if Full then begin Check(F.Major=i); Check(F.Minor=V.Minor); Check(F.Release=V.Release); Check(F.Build=V.Build); Check(F.Main=V.Main); end; CheckSame(V.BuildDateTime,F.BuildDateTime); end; finally F.Free; V.Free; end; end; {$endif} {$endif} procedure ABCD; begin Check(Parser.Root.NestedProperty[0].PropertyName='A'); Check(Parser.Root.NestedProperty[0].PropertyType=ptInteger); Check(Parser.Root.NestedProperty[1].PropertyName='B'); Check(Parser.Root.NestedProperty[1].PropertyType=ptInteger); Check(Parser.Root.NestedProperty[2].PropertyName='C'); Check(Parser.Root.NestedProperty[2].PropertyType=ptInteger); Check(Parser.Root.NestedProperty[3].PropertyName='D'); Check(Parser.Root.NestedProperty[3].PropertyType=ptRawUTF8); end; procedure ABCDE(Typ: TJSONCustomParserRTTIType); begin ABCD; with Parser.Root.NestedProperty[4] do begin Check(PropertyName='E'); Check(PropertyType=Typ); Check(length(NestedProperty)=2); Check(NestedProperty[0].PropertyName='E1'); Check(NestedProperty[0].PropertyType=ptDouble); Check(NestedProperty[1].PropertyName='E2'); Check(NestedProperty[1].PropertyType=ptDouble); end; end; procedure TestGit(Options: TJSONCustomParserSerializationOptions); var i: Integer; U: RawUTF8; s: RawJSON; git,git2: TTestCustomJSONGitHubs; item,value: PUTF8Char; begin if zendframeworkJson='' then exit; // avoid GPF e.g. on Windows XP where https is broken TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSONGitHub), __TTestCustomJSONGitHub).Options := Options; FillCharFast(git,sizeof(git),0); FillCharFast(git2,sizeof(git2),0); U := zendframeworkJson; // need unique string for procedure re-entrance check(IsValidJSON(U)); Check(DynArrayLoadJSON(git,UniqueRawUTF8(U),TypeInfo(TTestCustomJSONGitHubs))<>nil); U := DynArraySaveJSON(git,TypeInfo(TTestCustomJSONGitHubs)); check(IsValidJSON(U)); if soWriteHumanReadable in Options then FileFromString(U,'zendframeworkSaved.json'); Check(length(git)>=30); Check(length(U)>3000); if git[0].id=8079771 then begin Check(git[0].name='Component_ZendAuthentication'); Check(git[0].description='Authentication component from Zend Framework 2'); Check(git[0].owner.login='zendframework'); Check(git[0].owner.id=296074); end; for i := 0 to high(git) do with git[i] do begin item := JSONArrayItem(Pointer(U),i); Check(item<>nil); value := JsonObjectItem(item,'name'); check(value<>nil); GetJSONItemAsRawJSON(value,s); check(IsValidJSON(s)); check(trim(s)='"'+name+'"'); check(GetInteger(JsonObjectByPath(item,'owner.id'))=owner.id); check(GetInteger(JsonObjectByPath(item,'owner.i*'))=owner.id); check(JsonObjectByPath(item,'owner.name')=''); check(JsonObjectsByPath(item,'toto')=''); check(JsonObjectsByPath(item,'toto,titi')=''); check(JsonObjectsByPath(item,'toto,name')='{"name":"'+name+'"}'); check(JsonObjectsByPath(item,'toto,n*')='{"name":"'+name+'"}'); check(JsonObjectsByPath(item,'fork,toto,owner.id,name')= FormatUTF8('{"fork":%,"owner.id":%,"name":"%"}', [BOOL_STR[fork],owner.id,name])); check(JsonObjectsByPath(item,'owner.i*')=FormatUTF8('{"owner.id":%}',[owner.id])); check(JsonObjectsByPath(item,'owner.*')=FormatUTF8( '{"owner.login":"%","owner.id":%}',[owner.login,owner.id])); value := JsonObjectByPath(item,'owner'); GetJSONItemAsRawJSON(value,s); check(IsValidJSON(s)); check(JSONReformat(s,jsonCompact)=FormatUTF8( '{"login":"%","id":%}',[owner.login,owner.id])); end; Check(DynArrayLoadJSON(git2,pointer(U),TypeInfo(TTestCustomJSONGitHubs))<>nil); if not CheckFailed(length(git)=Length(git2)) then for i := 0 to high(git) do begin Check(git[i].name=git2[i].name); Check(git[i].id=git2[i].id); Check(git[i].description=git2[i].description); Check(git[i].fork=git2[i].fork); Check(git[i].owner.login=git2[i].owner.login); Check(git[i].owner.id=git2[i].owner.id); end; TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSONGitHub),''); end; {$ifndef DELPHI5OROLDER} function uct(const s: RawUTF8): TSQLFieldType; begin result := UTF8ContentNumberType(pointer(s)); end; var O,O2: TPersistentToJSON; E: TSynBackgroundThreadProcessStep; EndOfObject: AnsiChar; {$endif} {$ifndef NOVARIANTS} var Va, Vb: Variant; c: currency; {$endif} procedure TestJSONSerialization; var ab0,ab1: TSubAB; cd0,cd1,cd2: TSubCD; agg,agg2: TAggregate; X: RawUTF8; AA,AB: TRawUTF8DynArrayDynArray; i,a{$ifndef NOVARIANTS},v{$endif}: Integer; {$ifdef ISDELPHI2010} nav,nav2: TConsultaNav; nrtti,nrtti2: TNewRTTI; book: TBookRecord; {$endif} begin Finalize(JR); Finalize(JR2); Finalize(JA); Finalize(JA2); FillCharFast(JR,sizeof(JR),0); FillCharFast(JR2,sizeof(JR2),0); FillCharFast(JA,sizeof(JA),0); FillCharFast(JA2,sizeof(JA2),0); U := RecordSaveJSON(JR,TypeInfo(TTestCustomJSONRecord)); CheckEqual(U,'{"A":0,"B":0,"C":0,"D":"","E":{"E1":0,"E2":0},"F":""}'); check(IsValidJSON(U)); X := JSONToXML(U,''); Check(X='00000'); J := JSONToXML(U,'',XMLUTF8_NAMESPACE); CheckEqual(J,XMLUTF8_NAMESPACE+X+''); J := RecordSaveJSON(JA,TypeInfo(TTestCustomJSONArray)); CheckEqual(J,'{"A":0,"B":0,"C":0,"D":null,"E":[],"F":""}'); check(IsValidJSON(J)); X := JSONToXML(J,''); Check(X='000null'); JR2.A := 10; JR2.D := '**'; JR2.F := 1; JR := JR2; RecordLoadJSON(JR2,pointer(U),TypeInfo(TTestCustomJSONRecord)); Check(JR2.A=0); Check(JR2.D=''); Check(JR2.F=0); U := RecordSaveJSON(JR2,TypeInfo(TTestCustomJSONRecord)); CheckEqual(U,'{"A":0,"B":0,"C":0,"D":"","E":{"E1":0,"E2":0},"F":""}'); check(IsValidJSON(U)); U := RecordSaveJSON(JR,TypeInfo(TTestCustomJSONRecord)); CheckEqual(U,'{"A":10,"B":0,"C":0,"D":"**","E":{"E1":0,"E2":0},"F":"1899-12-31"}'); check(IsValidJSON(U)); JA2.A := 10; JA2.D := '**'; SetLength(JA2.E,2); JA2.F := 1; RecordLoadJSON(JA2,pointer(J),TypeInfo(TTestCustomJSONArray)); Check(JA2.A=0); Check(JA2.D=''); check(Length(JA2.E)=0); Check(JA2.F=0); J := RecordSaveJSON(JA2,TypeInfo(TTestCustomJSONArray)); CheckEqual(J,'{"A":0,"B":0,"C":0,"D":null,"E":[],"F":""}'); check(IsValidJSON(J)); JA2.A := 100; JA2.F := 1; J := RecordSaveJSON(JA2,TypeInfo(TTestCustomJSONArray)); CheckEqual(J,'{"A":100,"B":0,"C":0,"D":null,"E":[],"F":"1899-12-31"}'); check(IsValidJSON(J)); SetLength(JA2.E,2); JA2.E[0].E1 := 1; JA2.E[0].E2 := '2'; JA2.E[1].E1 := 3; JA2.E[1].E2 := '4'; J := RecordSaveJSON(JA2,TypeInfo(TTestCustomJSONArray)); CheckEqual(J,'{"A":100,"B":0,"C":0,"D":null,"E":[{"E1":1,"E2":"2"},{"E1":3,"E2":"4"}],"F":"1899-12-31"}'); check(IsValidJSON(J)); X := JSONToXML(J,''); Check(X='10000null12341899-12-31'); RecordLoadJSON(JA,pointer(J),TypeInfo(TTestCustomJSONArray)); Check(RecordSave(JA,TypeInfo(TTestCustomJSONArray))=RecordSave(JA2,TypeInfo(TTestCustomJSONArray))); J := '{"A":0,"B":0,"C":0,"D":null,"E":[{"E1":2,"E2":"3"}],"F":""}'; check(IsValidJSON(J)); RecordLoadJSON(JA,UniqueRawUTF8(J),TypeInfo(TTestCustomJSONArray)); U := RecordSaveJSON(JA,TypeInfo(TTestCustomJSONArray)); Check(length(JA.E)=1); CheckEqual(U,'{"A":0,"B":0,"C":0,"D":null,"E":[{"E1":2,"E2":"3"}],"F":""}'); check(IsValidJSON(U)); X := JSONToXML(U,''); Check(X='000null23'); X := JSONToXML('[1,2,"three"]'); Check(X=''#$D#$A'<0>1<1>2<2>three'); SetLength(AA,100); for i := 0 to high(AA) do begin SetLength(AA[i],random(100)); for a := 0 to high(AA[i]) do begin UInt32ToUtf8(i+a,AA[i,a]); check(IsValidJSON(AA[i,a])); check(IsValidJSON(' '+AA[i,a])); check(IsValidJSON(AA[i,a]+' ')); end; end; binary := DynArraySave(AA,TypeInfo(TRawUTF8DynArrayDynArray)); Check(DynArrayLoad(AB,pointer(binary),TypeInfo(TRawUTF8DynArrayDynArray))<>nil); Check(length(AA)=length(AB)); for i := 0 to high(AA) do begin Check(length(AA[i])=length(AB[i])); for a := 0 to high(AA[i]) do Check(AA[i,a]=AB[i,a]); end; j := DynArraySaveJSON(AA,TypeInfo(TRawUTF8DynArrayDynArray)); check(IsValidJSON(j)); Finalize(AB); Check(DynArrayLoadJSON(AB,pointer(j),TypeInfo(TRawUTF8DynArrayDynArray))<>nil); Check(length(AA)=length(AB)); for i := 0 to high(AA) do begin Check(length(AA[i])=length(AB[i])); for a := 0 to high(AA[i]) do Check(AA[i,a]=AB[i,a]); end; ab0.a := 'AB0'; ab0.b := 0; ab1.a := 'AB1'; ab1.b := 1; cd0.c := 0; cd0.d := 'CD0'; cd1.c := 1; cd1.d := 'CD1'; cd2.c := 2; cd2.d := 'CD2'; SetLength(agg.abArr,2); agg.abArr[0] := ab0; agg.abArr[1] := ab1; SetLength(agg.cdArr,3); agg.cdArr[0] := cd0; agg.cdArr[1] := cd1; agg.cdArr[2] := cd2; u := '{"abArr":[{"a":"AB0","b":0},{"a":"AB1","b":1}],"cdArr":[{"c":0,"d":"CD0"},'+ '{"c":1,"d":"CD1"},{"c":2,"d":"CD2"}]}'; Check(Hash32(u)=$E3AC9C44); check(IsValidJSON(u)); Check(RecordSaveJSON(agg,TypeInfo(TAggregate))=u); RecordLoadJSON(agg2,UniqueRawUTF8(u),TypeInfo(TAggregate)); j := RecordSaveJSON(agg2,TypeInfo(TAggregate)); Check(Hash32(j)=$E3AC9C44); check(IsValidJSON(j)); Finalize(JAS); FillCharFast(JAS,sizeof(JAS),0); U := RecordSaveJSON(JAS,TypeInfo(TTestCustomJSONArraySimple)); CheckEqual(U,'{"A":0,"B":0,"C":[],"D":"","E":[],"H":""}'); check(IsValidJSON(U)); U := '{"a":1,"b":2,"c":["C9A646D3-9C61-4CB7-BFCD-EE2522C8F633",'+ '"3F2504E0-4F89-11D3-9A0C-0305E82C3301"],"d":"4","e":[{"f":"f","g":["g1","g2"]}],"h":"h"}'; J := U; RecordLoadJSON(JAS,UniqueRawUTF8(U),TypeInfo(TTestCustomJSONArraySimple)); Check(JAS.A=1); Check(JAS.B=2); Check(length(JAS.C)=2); Check(GUIDToRawUTF8(JAS.C[0])='{C9A646D3-9C61-4CB7-BFCD-EE2522C8F633}'); Check(GUIDToRawUTF8(JAS.C[1])='{3F2504E0-4F89-11D3-9A0C-0305E82C3301}'); Check(JAS.D='4'); Check(length(JAS.E)=1); Check(JAS.E[0].F='f'); Check(Length(JAS.E[0].G)=2); Check(JAS.E[0].G[0]='g1'); Check(JAS.E[0].G[1]='g2'); Check(JAS.H='h'); U := RecordSaveJSON(JAS,TypeInfo(TTestCustomJSONArraySimple)); Check(SameTextU(J,U)); check(IsValidJSON(U)); {$ifndef NOVARIANTS} Finalize(JAV); FillCharFast(JAV,sizeof(JAV),0); U := RecordSaveJSON(JAV,TypeInfo(TTestCustomJSONArrayVariant)); CheckEqual(U,'{"A":0,"B":0,"C":[],"D":""}'); check(IsValidJSON(U)); assert(DocVariantType<>nil); U := '{"a":1,"b":2,"c":["one",2,2.5,{four:[1,2,3,4]}],"d":"4"}'; check(IsValidJSON(U)); RecordLoadJSON(JAV,UniqueRawUTF8(U),TypeInfo(TTestCustomJSONArrayVariant)); Check(JAV.A=1); Check(JAV.B=2); if not CheckFailed(length(JAV.C)=4) then begin Check(JAV.C[0]='one'); Check(JAV.C[1]=2); CheckSame(JAV.C[2],2.5); Check(JAV.C[3]._Kind=ord(dvObject)); Check(JAV.C[3]._Count=1); Check(JAV.C[3].Name(0)='four'); Check(VariantSaveJSON(JAV.C[3].four)='[1,2,3,4]'); with DocVariantData(JAV.C[3])^ do begin Check(Kind=dvObject); Check(Count=1); Check(Names[0]='four'); Check(Values[0]._Kind=ord(dvArray)); Check(Values[0]._Count=4); with DocVariantData(Values[0])^ do begin Check(Kind=dvArray); Check(Count=4); for v := 0 to Count-1 do Check(Values[v]=v+1); end; end; end; Check(JAV.D='4'); GDtoObject := TDtoObject.Create; U := '{"SomeField":"Test"}'; Check(ObjectLoadJSON(GDtoObject, U, nil, []),'nestedvariant1'); J := ObjectToJSON(GDtoObject, []); CheckEqual(J,'{"NestedObject":{"FieldString":"","FieldInteger":0,'+ '"FieldVariant":null},"SomeField":"Test"}'); J := ObjectToJSON(GDtoObject, [woDontStore0]); CheckEqual(J,U); U := '{"NestedObject":{"FieldVariant":{"a":1,"b":2}},"SomeField":"Test"}'; Check(ObjectLoadJSON(GDtoObject, U, nil, [j2oHandleCustomVariants]),'nestedvariant2'); J := ObjectToJSON(GDtoObject, [woDontStore0,woDontStoreEmptyString]); CheckEqual(J,U); GDtoObject.Free; {$endif NOVARIANTS} Finalize(Cache); FillCharFast(Cache,sizeof(Cache),0); U := RecordSaveJSON(Cache,TypeInfo(TSQLRestCacheEntryValue)); CheckEqual(U,'{"ID":0,"Timestamp512":0,"Tag":0,"JSON":""}'); check(IsValidJSON(U)); Cache.ID := 10; Cache.Timestamp512 := 200; Cache.JSON := 'test'; Cache.Tag := 12; U := RecordSaveJSON(Cache,TypeInfo(TSQLRestCacheEntryValue)); CheckEqual(U,'{"ID":10,"Timestamp512":200,"Tag":12,"JSON":"test"}'); check(IsValidJSON(U)); U := '{"ID":210,"Timestamp512":2200,"JSON":"test2"}'; check(IsValidJSON(U)); RecordLoadJSON(Cache,UniqueRawUTF8(U),TypeInfo(TSQLRestCacheEntryValue)); Check(Cache.ID=210); Check(Cache.Timestamp512=2200); Check(Cache.JSON='test2'); Check(Cache.Tag=12); U := '{ID:220,JSON:"test3",Timestamp512:2300}'; check(IsValidJSON(U)); RecordLoadJSON(Cache,UniqueRawUTF8(U),TypeInfo(TSQLRestCacheEntryValue)); Check(Cache.ID=220); Check(Cache.Timestamp512=2300); Check(Cache.JSON='test3'); Check(Cache.Tag=12); {$ifdef ISDELPHI2010} FillCharFast(nav,sizeof(nav),0); FillCharFast(nav2,sizeof(nav2),1); Check(not CompareMem(@nav,@nav2,sizeof(nav))); Check(nav2.MaxRows<>0); check(nav2.EOF); U := RecordSaveJSON(nav,TypeInfo(TConsultaNav)); J := RecordSaveJSON(nav2,TypeInfo(TConsultaNav)); Check(U<>J); RecordLoadJSON(nav2,UniqueRawUTF8(U),TypeInfo(TConsultaNav)); Check(nav2.MaxRows=0); check(not nav2.EOF); J := RecordSaveJSON(nav2,TypeInfo(TConsultaNav)); CheckEqual(J,RecordSaveJSON(nav,TypeInfo(TConsultaNav))); Check(CompareMem(@nav,@nav2,sizeof(nav))); Finalize(nrtti); FillCharFast(nrtti,sizeof(nrtti),0); U := RecordSaveJSON(nrtti,TypeInfo(TNewRTTI)); CheckEqual(U,'{"Number":0,"StaticArray":[{"Name":"","Single":0,"Double":0},'+ '{"Name":"","Single":0,"Double":0}],"Int":[0,0,0,0,0]}'); Finalize(nrtti2); FillCharFast(nrtti2,sizeof(nrtti2),0); Check(RecordLoadJSON(nrtti2,pointer(U),TypeInfo(TNewRTTI))<>nil); J := RecordSaveJSON(nrtti2,TypeInfo(TNewRTTI)); CheckEqual(J,RecordSaveJSON(nrtti,TypeInfo(TNewRTTI))); nrtti.Number := 1; nrtti.StaticArray[1].Name := 'one'; nrtti.StaticArray[1].Single := 1.5; nrtti.StaticArray[1].Double := 1.7; nrtti.StaticArray[2].Name := 'two'; nrtti.StaticArray[2].Single := 2.5; nrtti.StaticArray[2].Double := 2.7; nrtti.Int[1] := 1; nrtti.Int[2] := 2; nrtti.Int[3] := 3; nrtti.Int[4] := 4; nrtti.Int[5] := 5; U := RecordSaveJSON(nrtti,TypeInfo(TNewRTTI)); CheckEqual(U,'{"Number":1,"StaticArray":[{"Name":"one","Single":1.5,"Double":1.7},'+ '{"Name":"two","Single":2.5,"Double":2.7}],"Int":[1,2,3,4,5]}'); Finalize(nrtti2); FillCharFast(nrtti2,sizeof(nrtti2),0); Check(RecordLoadJSON(nrtti2,pointer(U),TypeInfo(TNewRTTI))<>nil); J := RecordSaveJSON(nrtti2,TypeInfo(TNewRTTI)); CheckEqual(J,RecordSaveJSON(nrtti,TypeInfo(TNewRTTI))); U :='{ "name": "Book the First", "author": { "first_name": "Bob", "last_name": "White" } }'; RecordLoadJSON(Book,UniqueRawUTF8(U),TypeInfo(TBookRecord)); check(Book.name='Book the First'); check(Book.author.first_name='Bob'); Check(Book.author.last_name='White'); {$endif} end; procedure TestGetJsonField(const s,v: RawUTF8; str,error: boolean; eof,next: AnsiChar); var P,d: PUTF8Char; ws: boolean; e: AnsiChar; l: integer; s2: RawUTF8; begin s2 := s; P := UniqueRawUTF8(s2); P := GetJSONField(P,d,@ws,@e,@l); check(error=(d=nil)); if d=nil then exit; check(str=ws); check(eof=e); check(d^=next); check(l=length(v)); check(CompareMem(P,pointer(v),length(v))); end; begin TestGetJsonField('','',false,true,#0,#0); TestGetJsonField('true,false','true',false,false,',','f'); TestGetJsonField('false,1','false',false,false,',','1'); TestGetJsonField('"true",false','true',true,false,',','f'); TestGetJsonField('"",false','',true,false,',','f'); TestGetJsonField('12,false','12',false,false,',','f'); TestGetJsonField('12]','12',false,true,']',#0); TestGetJsonField('12],','12',false,false,']',','); TestGetJsonField('1.2],','1.2',false,false,']',','); TestGetJsonField('1.2 ],','1.2',false,false,']',','); TestGetJsonField('"123"},false','123',true,false,'}',','); TestGetJsonField('"1\\3"},false','1\3',true,false,'}',','); TestGetJsonField('"1\r\n"},false','1'#13#10,true,false,'}',','); TestGetJsonField('"\"3"},false','"3',true,false,'}',','); TestGetJsonField('"\u00013"},false',#1'3',true,false,'}',','); TestGetJsonField('"\u0020"},false',' ',true,false,'}',','); Check(GotoEndOfJSONString(PUTF8Char(PAnsiChar('"toto"')))='"'); Check(GotoEndOfJSONString(PUTF8Char(PAnsiChar('"toto",')))='",'); Check(GotoEndOfJSONString(PUTF8Char(PAnsiChar('"to'#0'to",')))^=#0); Check(GotoEndOfJSONString(PUTF8Char(PAnsiChar('"to\'#0'to",')))^='\'); Check(GotoEndOfJSONString(PUTF8Char(PAnsiChar('"to\"to",')))='",'); Check(GotoEndOfJSONString(PUTF8Char(PAnsiChar('"to\\"to",')))='"to",'); Check(GotoEndOfJSONString(PUTF8Char(PAnsiChar('"to\\\\to",')))='",'); Check(IsString('abc')); Check(IsString('NULL')); Check(IsString('null')); Check(IsString('false')); Check(IsString('FALSE')); Check(IsString('true')); Check(IsString('TRUE')); Check(not IsString('123')); Check(not IsString('0123')); Check(not IsString('0.123')); Check(not IsString('1E19')); Check(not IsString('1.23E1')); Check(not IsString('+0')); Check(IsString('1.23E')); Check(IsString('+')); Check(IsString('-')); Check(IsStringJSON('abc')); Check(IsStringJSON('NULL')); Check(not IsStringJSON('null')); Check(not IsStringJSON('false')); Check(IsStringJSON('FALSE')); Check(not IsStringJSON('true')); Check(IsStringJSON('TRUE')); Check(not IsStringJSON('123')); Check(IsStringJSON('0123')); Check(not IsStringJSON('0.123')); Check(not IsStringJSON('1E19')); Check(not IsStringJSON('1.23E1')); Check(not IsStringJSON('0')); Check(not IsStringJSON('0.1')); Check(not IsStringJSON('-0')); Check(not IsStringJSON('-0.1')); Check(IsStringJSON('+0')); Check(IsStringJSON('1.23E')); Check(IsStringJSON('+')); Check(IsStringJSON('-')); Check(not NeedsJsonEscape('')); Check(not NeedsJsonEscape('a')); Check(not NeedsJsonEscape('ab cd')); Check(not NeedsJsonEscape('13456 ds0')); Check(NeedsJsonEscape('"123')); Check(NeedsJsonEscape('123"567')); Check(NeedsJsonEscape('123"')); Check(NeedsJsonEscape('123\"')); Check(NeedsJsonEscape('123'#1)); Check(NeedsJsonEscape(#10'123')); CheckEqual(QuotedStrJSON(''),'""'); CheckEqual(QuotedStrJSON('a'),'"a"'); CheckEqual(QuotedStrJSON(#30),'"\u001E"'); CheckEqual(QuotedStrJSON('ab'),'"ab"'); CheckEqual(QuotedStrJSON(' a'),'" a"'); CheckEqual(QuotedStrJSON('a"'),'"a\""'); CheckEqual(QuotedStrJSON('a""'),'"a\"\""'); CheckEqual(QuotedStrJSON('""'),'"\"\""'); CheckEqual(QuotedStrJSON('a"b"c'),'"a\"b\"c"'); CheckEqual(QuotedStrJSON('a"b\c'),'"a\"b\\c"'); CheckEqual(QuotedStrJSON('a"b'#10'c'),'"a\"b\nc"'); CheckEqual(QuotedStrJSON('a'#13'b'#8'c'),'"a\rb\bc"'); CheckEqual(QuotedStrJSON('a'#13'b'#1'c'),'"a\rb\u0001c"'); CheckEqual(QuotedStrJSON('a'#13'b'#31'c'),'"a\rb\u001Fc"'); CheckEqual(QuotedStrJSON('a'#13'b'#31),'"a\rb\u001F"'); {$ifndef DELPHI5OROLDER} Check(UTF8ContentType('null')=sftUnknown); Check(UTF8ContentType('0')=sftInteger); Check(UTF8ContentType('123')=sftInteger); Check(UTF8ContentType('0123')=sftUTF8Text); Check(UTF8ContentType('-123')=sftInteger); Check(UTF8ContentType('123.1')=sftCurrency); Check(UTF8ContentType('123.12')=sftCurrency); Check(UTF8ContentType('123.1234')=sftCurrency); Check(UTF8ContentType('123.12345678')=sftFloat); Check(UTF8ContentType('1.13e+12')=sftFloat); Check(UTF8ContentType('1.13e12')=sftFloat); Check(UTF8ContentType('-1.13e-12')=sftFloat); Check(UTF8ContentType('1.13e+120')=sftFloat); Check(UTF8ContentType('1.13E120')=sftFloat); Check(UTF8ContentType('1.13E-120')=sftFloat); Check(UTF8ContentType('1.13E307')=sftFloat); Check(UTF8ContentType('1.13E-323')=sftFloat); Check(UTF8ContentType('1.13e+a3')=sftUTF8Text); Check(UTF8ContentType('1.13e+3a')=sftUTF8Text); Check(UTF8ContentType('1.13e+330')=sftUTF8Text); Check(UTF8ContentType('1.13e330')=sftUTF8Text); Check(UTF8ContentType('1.13e-330')=sftUTF8Text); Check(UTF8ContentType('420014165100E335')=sftUTF8Text); Check(UTF8ContentType('123.')=sftUTF8Text); Check(UTF8ContentType('123.a')=sftUTF8Text); Check(UTF8ContentType('123.1a')=sftUTF8Text); Check(UTF8ContentType('123.1234a')=sftUTF8Text); Check(UTF8ContentType('123-2')=sftUTF8Text); Check(uct('null')=sftUnknown); Check(uct('0')=sftInteger); Check(uct('123')=sftInteger); Check(uct('0123')=sftUTF8Text); Check(uct('-123')=sftInteger); Check(uct('123.1')=sftCurrency); Check(uct('123.12')=sftCurrency); Check(uct('123.12345678')=sftFloat); Check(uct('1.13e+12')=sftFloat); Check(uct('-1.13e-12')=sftFloat); Check(uct('123.')=sftUTF8Text); Check(uct('123.a')=sftUTF8Text); Check(uct('123.1a')=sftUTF8Text); Check(uct('123.1234a')=sftUTF8Text); Check(uct('123-2')=sftUTF8Text); {$endif} J := JSONEncode(['name','john','year',1982,'pi',3.14159]); CheckEqual(J,'{"name":"john","year":1982,"pi":3.14159}'); check(IsValidJSON(J)); JSONDecode(J,['year','pi','john','name'],@V); Check(V[0].Value='1982'); Check(V[1].Value='3.14159'); Check(V[2].Value=nil); Check(V[3].Value='john'); J := '{surrogate:"\uD801\uDC00"}'; // see https://en.wikipedia.org/wiki/CESU-8 check(IsValidJSON(J)); JSONDecode(J,['surrogate'],@V); Check(V[0].ValueLen=4); Check(V[0].Value[0]=#$F0); Check(V[0].Value[1]=#$90); Check(V[0].Value[2]=#$90); Check(V[0].Value[3]=#$80); J := JSONEncode(['name','john','ab','[','a','b',']']); check(IsValidJSON(J)); CheckEqual(J,'{"name":"john","ab":["a","b"]}'); J := JSONEncode(['name','john','ab','[','a','b']); check(IsValidJSON(J)); CheckEqual(J,'{"name":"john","ab":["a","b"]}'); J := JSONEncode(['name','john','ab','[']); check(IsValidJSON(J)); CheckEqual(J,'{"name":"john","ab":[]}'); J := JSONEncode(['name','john','ab','{']); check(IsValidJSON(J)); CheckEqual(J,'{"name":"john","ab":{}}'); J := JSONEncode(['name','john','ab',nil]); check(IsValidJSON(J)); CheckEqual(J,'{"name":"john","ab":null}'); J := JSONEncode(['name','john','ab']); check(IsValidJSON(J)); CheckEqual(J,'{"name":"john"}'); J := JSONEncode(['name','john','{']); check(IsValidJSON(J)); CheckEqual(J,'{"name":"john"}'); J := JSONEncode(['name','john','[']); check(IsValidJSON(J)); CheckEqual(J,'{"name":"john"}'); J := JSONEncode(['name','john','ab','[','a','b',']','pi',3.14159]); check(IsValidJSON(J)); CheckEqual(J,'{"name":"john","ab":["a","b"],"pi":3.14159}'); J := JSONEncode(['doc','{','name','John','year',1982,'}','id',123]); check(IsValidJSON(J)); CheckEqual(J,'{"doc":{"name":"John","year":1982},"id":123}'); J := JSONEncode(['doc','{','name','John','abc','[','a','b','c',']','}','id',123]); check(IsValidJSON(J)); CheckEqual(J,'{"doc":{"name":"John","abc":["a","b","c"]},"id":123}'); {$ifndef NOVARIANTS} J := JSONEncode('{%:{$in:[?,?]}}',['type'],['food','snack']); check(IsValidJSON(J)); CheckEqual(J,'{"type":{"$in":["food","snack"]}}'); Check(JSONEncode('{type:{$in:?}}',[],[_Arr(['food','snack'])])=J); check(IsValidJSON(J)); J := JSONEncode('{name:"John",field:{ "$regex": "acme.*corp", $options: "i" }}',[],[]); CheckEqual(J,'{"name":"John","field":{"$regex":"acme.*corp","$options":"i"}}'); // the below only works if unit SynMongoDB is included in the uses list of the project // for virtual function TryJSONToVariant CheckEqual(JSONEncode('{name:?,field:/%/i}',['acme.*corp'],['John']),J); {$endif} {$ifndef DELPHI5OROLDER} peop := TSQLRecordPeople.Create; try peop.IDValue := 1234; peop.FirstName := 'FN'; peop.LastName := 'LN'; peop.YearOfBirth := 1000; peop.Data := #1#2#3#4; J := ObjectToJSON(peop,[woSQLRawBlobAsBase64]); check(IsValidJSON(J)); check(J[53]=#$EF); check(J[54]=#$BF); check(J[55]=#$B0); J[53] := '1'; J[54] := '2'; J[55] := '3'; check(IsValidJSON(J)); CheckEqual(J,'{"ID":1234,"FirstName":"FN","LastName":"LN",'+ '"Data":"123AQIDBA==","YearOfBirth":1000,"YearOfDeath":0}'); J := ObjectToJSON(peop); check(IsValidJSON(J)); CheckEqual(J,'{"ID":1234,"FirstName":"FN","LastName":"LN",'+ '"Data":"","YearOfBirth":1000,"YearOfDeath":0}'); ClearObject(peop); J := ObjectToJSON(peop); check(IsValidJSON(J)); CheckEqual(J,'{"ID":1234,"FirstName":"","LastName":"",'+ '"Data":"","YearOfBirth":0,"YearOfDeath":0}'); peop.IDValue := -1234; J := ObjectToJSON(peop); check(IsValidJSON(J)); CheckEqual(J,'{"ID":-1234,"FirstName":"","LastName":"",'+ '"Data":"","YearOfBirth":0,"YearOfDeath":0}'); {$ifndef NOVARIANTS} peop.YearOfDeath := 10; peop.LastName := 'john'; TObjectVariant.New(Va,peop); Check(Va.id=TID(-1234)); Check(Va.FirstName=''); Check(Va.LastName='john'); Check(Va.YearOfDeath=10); J := VariantSaveJSON(Va); check(IsValidJSON(J)); CheckEqual(J,'{"ID":-1234,"FirstName":"","LastName":"john","Data":"",'+ '"YearOfBirth":0,"YearOfDeath":10}'); {$endif} finally peop.Free; end; {$endif} for i := 1 to 100 do begin a := Random(maxInt); r := Random; U := RandomUTF8(i); J := JSONEncode(['a',a,'r',r,'u',U]); check(IsValidJSON(J)); JSONDecode(J,['U','R','A','FOO'],@V); V[0].ToUTF8(U2); Check(U2=U); Check(SameValue(GetExtended(V[1].Value,err),r)); Check(not IsString(V[2].Value)); Check(not IsStringJSON(V[2].Value)); Check(V[2].ToInteger=a); Check(V[3].Value=nil); J := BinToBase64WithMagic(U); check(PInteger(J)^ and $00ffffff=JSON_BASE64_MAGIC); {$ifndef DELPHI5OROLDER} RB := BlobToTSQLRawBlob(pointer(J)); check(length(RB)=length(U)); // RB=U is buggy under FPC :( check(CompareMem(pointer(RB),pointer(U),length(U))); Base64MagicToBlob(@J[4],K); RB := BlobToTSQLRawBlob(pointer(K)); check(length(RB)=length(U)); // RB=U is buggy under FPC :( check(CompareMem(pointer(RB),pointer(U),length(U))); { J := TSQLRestServer.JSONEncodeResult([r]); Check(SameValue(GetExtended(pointer(JSONDecode(J)),err),r)); } {$ifndef NOVARIANTS} with TTextWriter.CreateOwnedStream do try AddVariant(a); Add(','); AddVariant(r); Add(','); PInt64(@c)^ := a; AddVariant(c); Add(','); U := Int32ToUTF8(a); AddVariant(U); J := Text; CheckEqual(J,U+','+DoubleToStr(r)+','+DoubleToStr(c)+',"'+U+'"'); P := UniqueRawUTF8(J); P := VariantLoadJSON(Va,P); Check(P<>nil); Check(Va=a); P := VariantLoadJSON(Va,P,nil,nil,true); Check(P<>nil); CheckSame(VariantToDoubleDef(Va),r); P := VariantLoadJSON(Va,P); Check(P<>nil); Check(Va=c); P := VariantLoadJSON(Va,P); Check((P<>nil) and (P^=#0)); Check(Va=U); Vb := VariantLoad(VariantSave(Va),@JSON_OPTIONS[true]); Check(Vb=U); finally Free; end; {$endif} {$endif} end; {$ifndef DELPHI5OROLDER} J := GetJSONObjectAsSQL('{"ID": 1 ,"Name":"Alice","Role":"User","Last Login":null,'+ '"First Login" : null , "Department" : "{\"relPath\":\"317\\\\\",\"revision\":1}" } ]', false, true); U := ' (ID,Name,Role,Last Login,First Login,Department) VALUES '+ '(:(1):,:(''Alice''):,:(''User''):,:(null):,:(null):,:(''{"relPath":"317\\","revision":1}''):)'; CheckEqual(J,U); J := GetJSONObjectAsSQL('{ "Name":"Alice","Role":"User","Last Login":null,'+ '"First Login" : null , "Department" : "{\"relPath\":\"317\\\\\",\"revision\":1}" } ]', false, true,1,true); CheckEqual(J,U); J := GetJSONObjectAsSQL('{ "Name":"Alice","Role":"User","Last Login":null,'+ '"First Login" : null , "Department" : "{\"relPath\":\"317\\\\\",\"revision\":1}" } ]', false, true,1,false); Insert('Row',U,3); CheckEqual(J,U); Delete(U,3,3); J := '{"ID": 1 ,"Name":"Alice","Role":"User","Last Login":null, // comment'#13#10+ '"First Login" : /* to be ignored */ null , "Department" : "{\"relPath\":\"317\\\\\",\"revision\":1}" } ]'; check(not IsValidJSON(J)); RemoveCommentsFromJSON(UniqueRawUTF8(J)); check(not IsValidJSON(J)); check(IsValidJSON('['+J)); J := GetJSONObjectAsSQL(J,false,true); CheckEqual(J,U); J := '{"RowID": 210 ,"Name":"Alice","Role":"User","Last Login":null, // comment'#13#10+ '"First Login" : /* to be ignored */ null , "Department" : "{\"relPath\":\"317\\\\\",\"revision\":1}" } ]'; check(not IsValidJSON(J)); RemoveCommentsFromJSON(UniqueRawUTF8(J)); check(not IsValidJSON(J)); check(IsValidJSON('['+J)); J := GetJSONObjectAsSQL(J,false,true,1,True); CheckEqual(J,U); O := TPersistentToJSON.Create; O2 := TPersistentToJSON.Create; try J := ObjectToJSON(O,[]); check(IsValidJSON(J)); CheckEqual(J,'{"Name":"","Enum":0,"Sets":0}'); J := ObjectToJSON(O,[woDontStoreDefault]); check(IsValidJSON(J)); CheckEqual(J,'{"Name":""}'); J := ObjectToJSON(O,[woStoreClassName]); check(IsValidJSON(J)); CheckEqual(J,'{"ClassName":"TPersistentToJSON","Name":"","Enum":0,"Sets":0}'); J := ObjectToJSON(O,[woHumanReadable]); check(IsValidJSON(J)); CheckEqual(J,'{'#$D#$A#9'"Name": "",'#$D#$A#9'"Enum": "flagIdle",'#$D#$A#9'"Sets": []'#$D#$A'}'); with PTypeInfo(TypeInfo(TSynBackgroundThreadProcessStep))^.EnumBaseType^ do for E := low(E) to high(E) do begin O.fName := Int32ToUTF8(ord(E)); O.fEnum := E; include(O.fSets,E); J := ObjectToJSON(O,[]); check(IsValidJSON(J)); CheckEqual(J,FormatUTF8('{"Name":"%","Enum":%,"Sets":%}',[ord(E),ord(E),byte(O.fSets)])); JSONToObject(O2,pointer(J),valid); Check(Valid); Check(O.Name=O2.Name); Check(O.Enum=O2.Enum); Check(O.Sets=O2.Sets); J := ObjectToJSON(O,[woHumanReadable]); check(IsValidJSON(J)); U := FormatUTF8( '{'#$D#$A#9'"NAME": "%",'#$D#$A#9'"ENUM": "%",'#$D#$A#9'"SETS": ["FLAGIDLE"', [ord(E),UpperCaseU(RawUTF8(GetEnumName(E)^))]); Check(IdemPChar(pointer(J),pointer(U))); JSONToObject(O2,pointer(J),valid); Check(Valid); Check(O.Name=O2.Name); Check(O.Enum=O2.Enum); Check(O.Sets=O2.Sets); Check(ObjectEquals(O,O2)); end; with PTypeInfo(TypeInfo(WordBool))^.EnumBaseType^ do Check(SizeInStorageAsEnum=2); J := ObjectToJSON(O,[woHumanReadable,woHumanReadableFullSetsAsStar]); check(IsValidJSON(J)); CheckEqual(J,'{'#$D#$A#9'"Name": "3",'#$D#$A#9'"Enum": "flagDestroying",'#$D#$A#9'"Sets": ["*"]'#$D#$A'}'); J := ObjectToJSON(O,[woHumanReadable,woHumanReadableFullSetsAsStar,woHumanReadableEnumSetAsComment]); CheckEqual(J,'{'#$D#$A#9'"Name": "3",'#$D#$A#9'"Enum": "flagDestroying", // "flagIdle","flagStarted","flagFinished","flagDestroying"'+ #$D#$A#9'"Sets": ["*"] // "*" or a set of "flagIdle","flagStarted","flagFinished","flagDestroying"'#$D#$A'}'); O2.fName := ''; O2.fEnum := low(E); O2.fSets := []; check(not IsValidJSON(J)); RemoveCommentsFromJSON(UniqueRawUTF8(J)); check(IsValidJSON(J)); JSONToObject(O2,pointer(J),valid); Check(Valid); Check(O.Name=O2.Name); Check(O.Enum=O2.Enum); Check(O.Sets=O2.Sets); Check(ObjectEquals(O,O2)); finally O2.Free; O.Free; end; U := '"filters":[{"name":"name1","value":"value1","comparetype":">"},'+ '{"name":"name2","value":"value2","comparetype":"="}], "Limit":100}'; check(not IsValidJSON(U)); check(IsValidJSON('{'+U)); P := UniqueRawUTF8(U); Check(GetJSONPropName(P)='filters'); Check((P<>nil)and(P^='[')); P := GotoNextJSONItem(P,1,@EndOfObject); Check(EndOfObject=','); Check(GetJSONPropName(P)='Limit'); Check((P<>nil)and(P^='1')); P := GotoNextJSONItem(P,1,@EndOfObject); Check(P<>nil); Check(EndOfObject='}'); check(IsValidJSON('null')); check(IsValidJSON('true')); check(IsValidJSON('false')); check(IsValidJSON(' null')); check(IsValidJSON(' true')); check(IsValidJSON(' false')); check(IsValidJSON('null ')); check(IsValidJSON('true ')); check(IsValidJSON('false ')); check(not IsValidJSON('nulle')); check(not IsValidJSON('trye')); {$ifndef LVCL} C2 := TCollTst.Create; Coll := TCollTst.Create; try U := ObjectToJSON(Coll); check(IsValidJSON(U)); Check(Hash32(U)=$95B54414); Check(ObjectToJSON(C2)=U); Coll.One.Name := 'test"\2'; Coll.One.Color := 1; U := ObjectToJSON(Coll); check(IsValidJSON(U)); Check(Hash32(U)=$CE2C2DED); Check(JSONToObject(C2,pointer(U),Valid)=nil); Check(Valid); U := ObjectToJSON(C2); check(IsValidJSON(U)); Check(Hash32(U)=$CE2C2DED); Coll.Coll.Add.Color := 10; Coll.Coll.Add.Name := 'name'; Check(Coll.Coll.Count=2); U := ObjectToJSON(Coll); check(IsValidJSON(U)); Check(Hash32(U)=$36B02F0E); Check(JSONToObject(C2,pointer(U),Valid)=nil); Check(Valid); Check(C2.Coll.Count=2); U := ObjectToJSON(C2); check(IsValidJSON(U)); Check(Hash32(U)=$36B02F0E); J := ObjectToJSON(Coll,[woHumanReadable]); check(IsValidJSON(U)); Check(Hash32(J)=$9FAFF11F); Check(JSONReformat(J,jsonCompact)=U); Check(JSONReformat('{ "empty": {} }')='{'#$D#$A#9'"empty": {'#$D#$A#9#9'}'#$D#$A'}'); U := ObjectToJSON(Coll,[woStoreClassName]); check(IsValidJSON(U)); CheckEqual(U,'{"ClassName":"TCollTst","One":{"ClassName":"TCollTest","Color":1,'+ '"Length":0,"Name":"test\"\\2"},"Coll":[{"ClassName":"TCollTest","Color":10,'+ '"Length":0,"Name":""},{"ClassName":"TCollTest","Color":0,"Length":0,"Name":"name"}]}'); C2.Coll.Clear; Check(JSONToObject(C2,pointer(U),Valid)=nil); Check(Valid); Check(C2.Coll.Count=2); U := ObjectToJSON(C2); Check(Hash32(U)=$36B02F0E); TJSONSerializer.RegisterClassForJSON([TComplexNumber,TCollTst]); J := '{"ClassName":"TComplexNumber", "Real": 10.3, "Imaginary": 7.92 }'; P := UniqueRawUTF8(J); // make local copy of constant Comp := TComplexNumber(JSONToNewObject(P,Valid)); if not CheckFailed(Comp<>nil) then begin Check(Valid); Check(Comp.ClassType=TComplexNumber); CheckSame(Comp.Real,10.3); CheckSame(Comp.Imaginary,7.92); U := ObjectToJSON(Comp,[woStoreClassName]); check(IsValidJSON(U)); CheckEqual(U,'{"ClassName":"TComplexNumber","Real":10.3,"Imaginary":7.92}'); Comp.Free; end; TJSONSerializer.RegisterCollectionForJSON(TMyCollection,TCollTest); TestMyColl(TMyCollection.Create(TCollTest)); Instance.Init(TMyCollection); TestMyColl(Instance.CreateNew as TMyCollection); C2.Coll.Clear; U := ObjectToJSON(C2); check(IsValidJSON(U)); Check(Hash32(U)=$CE2C2DED); Coll.Coll.BeginUpdate; for i := 1 to 10000 do with Coll.Coll.Add do begin Color := i*3; Length := i*5; Name := Int32ToUtf8(i); end; Coll.Coll.EndUpdate; U := ObjectToJSON(Coll.Coll); check(IsValidJSON(U)); Check(Hash32(U)=$DB782098); C2.Coll.Clear; Check(JSONToObject(C2.fColl,pointer(U),Valid)=nil); Check(Valid); Check(C2.Coll.Count=Coll.Coll.Count); for i := 1 to C2.Coll.Count-2 do with C2.Coll[i+1] do begin Check(Color=i*3); Check(Length=i*5); Check(Name=Int32ToUtf8(i)); end; U := ObjectToJSON(Coll); check(IsValidJSON(U)); Check(length(U)=443103); Check(Hash32(U)=$7EACF12A); C2.One.Name := ''; C2.Coll.Clear; Check(JSONToObject(C2,pointer(U),Valid)=nil); Check(Valid); Check(C2.Coll.Count=Coll.Coll.Count); U := ObjectToJSON(C2); check(IsValidJSON(U)); Check(length(U)=443103); Check(Hash32(U)=$7EACF12A); for i := 1 to C2.Coll.Count-2 do with C2.Coll[i+1] do begin Check(Color=i*3); Check(Length=i*5); Check(Name=Int32ToUtf8(i)); end; Coll.Coll.Clear; Coll.Str := TStringList.Create; Coll.Str.BeginUpdate; for i := 1 to 10000 do Check(Coll.Str.Add(IntToStr(i))=i-1); Coll.Str.EndUpdate; U := ObjectToJSON(Coll); check(IsValidJSON(U)); Check(Hash32(U)=$85926050); J := ObjectToJSON(Coll,[woHumanReadable]); check(IsValidJSON(J)); U2 := JSONReformat(J,jsonCompact); check(IsValidJSON(U2)); Check(U2=U); C2.Str := TStringList.Create; Check(JSONToObject(C2,pointer(U),Valid)=nil); Check(Valid); Check(C2.Str.Count=Coll.Str.Count); for i := 1 to C2.Str.Count do Check(C2.Str[i-1]=IntToStr(i)); J := ObjectToJSON(C2); check(IsValidJSON(J)); Check(Hash32(J)=$85926050); C2.One.Color := 0; C2.One.Name := ''; U := '{"One":{"Color":1,"Length":0,"Name":"test","Unknown":123},"Coll":[]}'; Check(JSONToObject(C2,UniqueRawUTF8(U),Valid,nil,[j2oIgnoreUnknownProperty])=nil,'Ignore unknown'); Check(Valid); Check(C2.One.Color=1); Check(C2.One.Name='test'); C2.One.Color := 0; C2.One.Name := ''; U := '{"One":{"Color":1,"Length":0,"wtf":{"one":1},"Name":"test","Unknown":123},"dummy":null,"Coll":[]}'; check(IsValidJSON(U)); Check(JSONToObject(C2,UniqueRawUTF8(U),Valid,nil,[j2oIgnoreUnknownProperty])=nil,'Ignore unknown'); Check(Valid); Check(C2.One.Color=1); Check(C2.One.Name='test'); U := '{"One":{"Color":1,"Length":0,"Name":"test\"\\2},"Coll":[]}'; Check(IdemPChar(JSONToObject(C2,UniqueRawUTF8(U),Valid),'"TEST'),'invalid JSON'); Check(not Valid); U := '{"One":{"Color":1,"Length":0,"Name":"test\"\\2"},"Coll":[]'; Check(JSONToObject(C2,UniqueRawUTF8(U),Valid)<>nil); Check(not Valid); U := '{"One":{"Color":,"Length":0,"Name":"test\"\\2"},"Coll":[]'; Check(JSONToObject(C2,UniqueRawUTF8(U),Valid)<>nil,'invalid JSON'); Check(not Valid); U := '{"Coll":[{"Color":1,"Length":0,"Name":"test"}],'+ '"One":{"Color":2,"Length":0,"Name":"test2"}}'; Check(JSONToObject(C2,UniqueRawUTF8(U),Valid,nil,[j2oIgnoreUnknownProperty])=nil,'Ignore unknown'); Check(Valid); Check(C2.One.Color=2); Check(C2.One.Name='test2'); Check(C2.Coll.Count=1); Check(C2.Coll[0].Name='test'); C2.One.Length := 10; J := ObjectToJSON(C2); check(IsValidJSON(J)); Check(Hash32(J)=$41281936); // (custom) dynamic array serialization TCollTstDynArrayTest; TTextWriter.RegisterCustomJSONSerializer(TypeInfo(TFVs), TCollTstDynArray.FVReader,TCollTstDynArray.FVWriter); TCollTstDynArrayTest; TTextWriter.RegisterCustomJSONSerializer(TypeInfo(TFVs), TCollTstDynArray.FVReader2,TCollTstDynArray.FVWriter2); TCollTstDynArrayTest; // (custom) class serialization TFileVersionTest(false); TJSONSerializer.RegisterCustomSerializer(TFileVersion, TCollTstDynArray.FVClassReader,TCollTstDynArray.FVClassWriter); TFileVersionTest(true); TJSONSerializer.RegisterCustomSerializer(TFileVersion,nil,nil); TFileVersionTest(false); MyItem := TCollTest.Create(nil); try MyItem.Length := 10; MyItem.Color := 20; MyItem.Name := 'ABC'; J := ObjectToJSON(MyItem); Check(IsValidJSON(J)); CheckEqual(J,'{"Color":20,"Length":10,"Name":"ABC"}'); TJSONSerializer.RegisterCustomSerializerFieldNames( TCollTest,['name','length'],['n','len']); J := ObjectToJSON(MyItem); Check(IsValidJSON(J)); CheckEqual(J,'{"Color":20,"len":10,"n":"ABC"}'); J := ObjectToJSON(C2); Check(IsValidJSON(J)); Check(Hash32(J)=$FFBC77A,'RegisterCustomSerializerFieldNames'); TCollTstDynArrayTest; TJSONSerializer.RegisterCustomSerializerFieldNames(TCollTest,[],[]); J := ObjectToJSON(MyItem); CheckEqual(J,'{"Color":20,"Length":10,"Name":"ABC"}'); J := ObjectToJSON(C2); Check(IsValidJSON(J)); Check(Hash32(J)=$41281936,'unRegisterCustomSerializerFieldNames'); TCollTstDynArrayTest; TJSONSerializer.RegisterCustomSerializerFieldNames(TCollTest,['length'],['']); J := ObjectToJSON(MyItem); Check(IsValidJSON(J)); CheckEqual(J,'{"Color":20,"Name":"ABC"}','remove field'); TJSONSerializer.RegisterCustomSerializerFieldNames(TCollTest,[],[]); J := ObjectToJSON(MyItem); Check(IsValidJSON(J)); CheckEqual(J,'{"Color":20,"Length":10,"Name":"ABC"}'); finally MyItem.Free; end; finally C2.Free; Coll.Free; end; {$endif DELPHI5OROLDER} {$endif LVCL} // test TJSONRecordTextDefinition parsing Parser := TJSONRecordTextDefinition.FromCache(nil,'Int: double'); Check(Length(Parser.Root.NestedProperty)=1); Check(Parser.Root.NestedProperty[0].PropertyName='Int'); Check(Parser.Root.NestedProperty[0].PropertyType=ptDouble); Parser := TJSONRecordTextDefinition.FromCache(nil, 'A , B,C : integer; D: RawUTF8'); Check(Length(Parser.Root.NestedProperty)=4); ABCD; Parser := TJSONRecordTextDefinition.FromCache(nil, 'A,B,C: integer; D: RawUTF8; E: record E1,E2: double; end;'); Check(Length(Parser.Root.NestedProperty)=5); ABCDE(ptRecord); Parser := TJSONRecordTextDefinition.FromCache(nil, 'A,B: integer; C: integer; D: RawUTF8; E: array of record E1,E2: double; end;'); Check(Length(Parser.Root.NestedProperty)=5); ABCDE(ptArray); Parser := TJSONRecordTextDefinition.FromCache(nil, 'A,B,C integer D RawUTF8 E{E1,E2 double}'); Check(Length(Parser.Root.NestedProperty)=5); ABCDE(ptRecord); Parser := TJSONRecordTextDefinition.FromCache(nil, 'A,B,C integer D RawUTF8 E{E1,E2 double}'); Check(Length(Parser.Root.NestedProperty)=5,'from cache'); ABCDE(ptRecord); Parser := TJSONRecordTextDefinition.FromCache(nil, 'A,B,C integer D RawUTF8 E[E1,E2 double]'); Check(Length(Parser.Root.NestedProperty)=5); ABCDE(ptArray); Parser := TJSONRecordTextDefinition.FromCache(nil, 'A,B,C integer D RawUTF8 E[E1,E2 double] F: string'); Check(Length(Parser.Root.NestedProperty)=6); ABCDE(ptArray); Check(Parser.Root.NestedProperty[5].PropertyName='F'); Check(Parser.Root.NestedProperty[5].PropertyType=ptString); Parser := TJSONRecordTextDefinition.FromCache(nil, 'A,B,C integer D RawUTF8 E[E1,E2 double] F: array of string'); Check(Length(Parser.Root.NestedProperty)=6); ABCDE(ptArray); Check(Parser.Root.NestedProperty[5].PropertyName='F'); Check(Parser.Root.NestedProperty[5].PropertyType=ptArray); Check(length(Parser.Root.NestedProperty[5].NestedProperty)=1); Check(Parser.Root.NestedProperty[5].NestedProperty[0].PropertyType=ptString); Parser := TJSONRecordTextDefinition.FromCache(nil, 'A,B,C integer D RawUTF8 E[E1:{E1A:integer E1B:tdatetime E1C TDatetimeMS}E2 double]'); Check(Length(Parser.Root.NestedProperty)=5); ABCD; with Parser.Root.NestedProperty[4] do begin Check(PropertyName='E'); Check(PropertyType=ptArray); Check(length(NestedProperty)=2); Check(NestedProperty[0].PropertyName='E1'); Check(NestedProperty[0].PropertyType=ptRecord); with NestedProperty[0] do begin Check(length(NestedProperty)=3); Check(NestedProperty[0].PropertyName='E1A'); Check(NestedProperty[0].PropertyType=ptInteger); Check(NestedProperty[1].PropertyName='E1B'); Check(NestedProperty[1].PropertyType=ptDateTime); Check(NestedProperty[2].PropertyName='E1C'); Check(NestedProperty[2].PropertyType=ptDateTimeMS); end; Check(NestedProperty[1].PropertyName='E2'); Check(NestedProperty[1].PropertyType=ptDouble); end; {$ifdef ISDELPHI2010} // test JSON serialization defined by Enhanced RTTI TestJSONSerialization; {$endif} // test TJSONRecordTextDefinition JSON serialization TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TSubAB),__TSubAB); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TSubCD),__TSubCD); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TAggregate),__TAggregate); TTextWriter.RegisterCustomJSONSerializerFromText( TypeInfo(TTestCustomJSONRecord),__TTestCustomJSONRecord); TTextWriter.RegisterCustomJSONSerializerFromText( TypeInfo(TTestCustomJSONArray),__TTestCustomJSONArray); TTextWriter.RegisterCustomJSONSerializerFromText( TypeInfo(TTestCustomJSONArraySimple),__TTestCustomJSONArraySimple); {$ifndef NOVARIANTS} TTextWriter.RegisterCustomJSONSerializerFromText( TypeInfo(TTestCustomJSONArrayVariant),__TTestCustomJSONArrayVariant); {$endif} TTextWriter.RegisterCustomJSONSerializerFromText( TypeInfo(TSQLRestCacheEntryValue),__TSQLRestCacheEntryValue); TestJSONSerialization; TestJSONSerialization; // test twice for safety TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TSQLRestCacheEntryValue),''); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TSubAB),''); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TSubCD),''); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TAggregate),''); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSONRecord),''); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSONArray),''); {$ifndef NOVARIANTS} TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSONArrayVariant),''); {$endif} TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSONArraySimple),''); {$ifdef ISDELPHI2010} // test JSON serialization defined by Enhanced RTTI TestJSONSerialization; {$endif} // tests parsing options Parser := TTextWriter.RegisterCustomJSONSerializerFromText( TypeInfo(TTestCustomJSONRecord), copy(__TTestCustomJSONRecord,1,PosEx('}',__TTestCustomJSONRecord))) as TJSONRecordTextDefinition; U := RecordSaveJSON(JR2,TypeInfo(TTestCustomJSONRecord)); Check(IsValidJSON(U)); CheckEqual(U,'{"A":0,"B":0,"C":0,"D":"","E":{"E1":0,"E2":0}}'); U := RecordSaveJSON(JR,TypeInfo(TTestCustomJSONRecord)); Check(IsValidJSON(U)); CheckEqual(U,'{"A":10,"B":0,"C":0,"D":"**","E":{"E1":0,"E2":0}}'); U := '{"B":0,"C":0,"A":10,"D":"**","E":{"E1":0,"E2":20}}'; RecordLoadJSON(JR2,UniqueRawUTF8(U),TypeInfo(TTestCustomJSONRecord)); Check(JR2.A=10); Check(JR2.D='**'); Check(JR2.E.E2=20); Parser.Options := [soReadIgnoreUnknownFields]; U := '{ "A" : 1 , "B" : 2 , "C" : 3 , "D" : "A" , "tobeignored":null,"E": '#13#10+ '{ "E1" : 4, "E2" : 5 } , "tbi" : { "b" : 0 } }'; RecordLoadJSON(JR2,UniqueRawUTF8(U),TypeInfo(TTestCustomJSONRecord)); Check(JR2.A=1); Check(JR2.D='A'); Check(JR2.E.E1=4); Check(JR2.E.E2=5); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSONRecord),''); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSONArrayWithoutF), copy(__TTestCustomJSONArray,1,PosEx(']',__TTestCustomJSONArray))); U := RecordSaveJSON(JA2,TypeInfo(TTestCustomJSONArrayWithoutF)); Check(IsValidJSON(U)); CheckEqual(U,'{"A":100,"B":0,"C":0,"D":null,"E":[{"E1":1,"E2":"2"},{"E1":3,"E2":"4"}]}'); Finalize(JA); FillCharFast(JA,sizeof(JA),0); RecordLoadJSON(JA,pointer(U),TypeInfo(TTestCustomJSONArrayWithoutF)); Check(JA.A=100); Check(JA.D=''); U := RecordSaveJSON(JA,TypeInfo(TTestCustomJSONArrayWithoutF)); Check(IsValidJSON(U)); Check(length(JA.E)=2); CheckEqual(U,'{"A":100,"B":0,"C":0,"D":null,"E":[{"E1":1,"E2":"2"},{"E1":3,"E2":"4"}]}'); JA.D := '1234'; U := RecordSaveJSON(JA,TypeInfo(TTestCustomJSONArrayWithoutF)); Check(IsValidJSON(U)); Check(length(JA.E)=2); Finalize(JA); FillCharFast(JA,sizeof(JA),0); RecordLoadJSON(JA,pointer(U),TypeInfo(TTestCustomJSONArrayWithoutF)); Check(length(JA.E)=2); Check(JA.D='1234'); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSONArrayWithoutF),''); discogsJson := StringFromFile(discogsFileName); if discogsJson='' then begin discogsJson := HttpGet('https://api.discogs.com/artists/45/releases?page=1&per_page=100'); FileFromString(discogsJson,discogsFileName); end; Check(IsValidJSON(discogsJson)); zendframeworkJson := StringFromFile(zendframeworkFileName); if zendframeworkJson='' then begin zendframeworkJson := HttpGet('https://api.github.com/users/zendframework/repos'); FileFromString(zendframeworkJson,zendframeworkFileName); end; Check(IsValidJSON(zendframeworkJson)); TestGit([soReadIgnoreUnknownFields]); TestGit([soReadIgnoreUnknownFields,soWriteHumanReadable]); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSON2Title), __TTestCustomJSON2Title).Options := [soWriteHumanReadable]; TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSON2), __TTestCustomJSON2).Options := [soWriteHumanReadable]; FillCharFast(Trans,sizeof(Trans),0); U := RecordSaveJSON(Trans,TypeInfo(TTestCustomJSON2)); Check(IsValidJSON(U)); CheckEqual(U,'{'#$D#$A#9'"Transactions": []'#$D#$A'}'); for i := 1 to 10 do begin U := '{"transactions":[{"TRTYPE":"INCOME","TRDATE":"2013-12-09 02:30:04","TRAA":"1.23",'+ '"TRCAT1":{"TITYPE":"C1","TIID":"1","TICID":"","TIDSC30":"description1","TIORDER":"0","TIDEL":"false"},'+ '"TRCAT2":{"TITYPE":"C2","TIID":"2","TICID":"","TIDSC30":"description2","TIORDER":"0","TIDEL":"false"},'+ '"TRCAT3":{"TITYPE":"C3","TIID":"3","TICID":"","TIDSC30":"description3","TIORDER":"0","TIDEL":"false"},'+ '"TRRMK":"Remark",'+ '"TRACID":{"TITYPE":"AC","TIID":"4","TICID":"","TIDSC30":"account1","TIORDER":"0","TIDEL":"false"}}]}'; Check(IsValidJSON(U)); RecordLoadJSON(Trans,UniqueRawUTF8(U),TypeInfo(TTestCustomJSON2)); Check(length(Trans.Transactions)=1); Check(Trans.Transactions[0].TRTYPE='INCOME'); Check(Trans.Transactions[0].TRACID.TIDEL='false'); Check(Trans.Transactions[0].TRRMK='Remark'); U := RecordSaveJSON(Trans,TypeInfo(TTestCustomJSON2)); Check(Hash32(U)=$CC7167FC); end; FileFromString(U,'transactions.json'); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSON2Title),''); TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomJSON2),''); Parser := TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomDiscogs), __TTestCustomDiscogs) as TJSONRecordTextDefinition; Parser.Options := [soReadIgnoreUnknownFields]; FillCharFast(Disco,sizeof(Disco),0); Check(PtrUInt(@Disco.releases)-PtrUInt(@Disco)=3*sizeof(integer)); Check(sizeof(Disco.releases[0])=5*sizeof(Pointer)+2*sizeof(integer)); Check(sizeof(Disco)=sizeof(Pointer)+3*sizeof(integer)); U := RecordSaveJSON(Disco,TypeInfo(TTestCustomDiscogs)); CheckEqual(U,'{"pagination":{"per_page":0,"items":0,"page":0},"releases":[]}'); U := JSONReformat(discogsJson,jsonCompact); Check(IsValidJSON(U)); Check(JSONReformat(JSONReformat(discogsJson,jsonHumanReadable),jsonCompact)=U); Check(JSONReformat(JSONReformat(discogsJson,jsonUnquotedPropName),jsonCompact)=U); Check(JSONReformat(JSONReformat(U,jsonUnquotedPropName),jsonCompact)=U); RecordLoadJSON(Disco,pointer(discogsJson),TypeInfo(TTestCustomDiscogs)); Check(length(Disco.releases)<=Disco.pagination.items); for i := 0 to high(Disco.Releases) do Check(Disco.Releases[i].id>0); Parser.Options := [soWriteHumanReadable,soReadIgnoreUnknownFields]; U := RecordSaveJSON(Disco,TypeInfo(TTestCustomDiscogs)); Check(IsValidJSON(U)); FileFromString(U,'discoExtract.json'); Finalize(Disco); FillCharFast(Disco,sizeof(Disco),0); U := '{"pagination":{"per_page":1},"releases":[{"title":"TEST","id":10}]}'; Check(IsValidJSON(U)); RecordLoadJSON(Disco,UniqueRawUTF8(U),TypeInfo(TTestCustomDiscogs)); Check(Disco.pagination.per_page=1); Check(Disco.pagination.page=0); if not CheckFailed(length(Disco.releases)=1) then begin Check(Disco.releases[0].title='TEST'); Check(Disco.releases[0].id=10); end; Finalize(Disco); FillCharFast(Disco,sizeof(Disco),0); U := '{"pagination":{},"releases":[{"Id":10},{"TITle":"blabla"}]}'; Check(IsValidJSON(U)); RecordLoadJSON(Disco,UniqueRawUTF8(U),TypeInfo(TTestCustomDiscogs)); Check(Disco.pagination.per_page=0); Check(Disco.pagination.page=0); if not CheckFailed(length(Disco.releases)=2) then begin Check(Disco.releases[0].title=''); Check(Disco.releases[0].id=10); Check(Disco.releases[1].title='blabla'); Check(Disco.releases[1].id=0); end; U := '{"pagination":{"page":1},"releases":[{"title":"abc","id":2}]}'; Check(IsValidJSON(U)); RecordLoadJSON(Disco,UniqueRawUTF8(U),TypeInfo(TTestCustomDiscogs)); Check(Disco.pagination.per_page=0); Check(Disco.pagination.page=1); if not CheckFailed(length(Disco.releases)=1) then begin Check(Disco.releases[0].title='abc'); Check(Disco.releases[0].id=2); end; TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TTestCustomDiscogs),''); SetString(U,PAnsiChar('true'#0'footer,'),12); Check(IdemPChar(GetJSONField(pointer(U),P),'TRUE')); Check(P=nil); CheckEqual(U,'true'#0'footer,','3cce80e8df'); {$ifndef DELPHI5OROLDER} // validates RawJSON (custom) serialization Enemy := TEnemy.Create; try U := ObjectToJSON(Enemy); Check(IsValidJSON(U)); CheckEqual(U,'{"Enabled":false,"Name":"","Offense":{"damage":{"min":0,"max":0},'+ '"attackspeed":{"min":0,"max":0}}}'); Enemy.Off.Damage.Min := 10; Enemy.Off.AttackSpeed.Max := 100; U := ObjectToJSON(Enemy); Check(IsValidJSON(U)); CheckEqual(U,'{"Enabled":false,"Name":"","Offense":{"damage":{"min":10,"max":0},'+ '"attackspeed":{"min":0,"max":100}}}'); FillcharFast(Enemy.Off, sizeof(Enemy.Off), 0); check(Enemy.Off.Damage.Min = 0); check(Enemy.Off.AttackSpeed.Max = 0); JSONToObject(Enemy, pointer(U), valid); check(valid); check(Enemy.Off.Damage.Min = 10); check(Enemy.Off.AttackSpeed.Max = 100); finally Enemy.Free; end; {$endif} end; procedure TTestLowLevelTypes.WikiMarkdownToHtml; begin // wiki CheckEqual(HtmlEscapeWiki('test'),'

    test

    '); CheckEqual(HtmlEscapeWiki('test'),'

    te<b>st

    '); CheckEqual(HtmlEscapeWiki('t *e* st'),'

    t e st

    '); CheckEqual(HtmlEscapeWiki('t*e*st'),'

    test

    '); CheckEqual(HtmlEscapeWiki('t\*e\*st'),'

    t*e*st

    '); CheckEqual(HtmlEscapeWiki('t\*e*st'),'

    t*est

    '); CheckEqual(HtmlEscapeWiki('t +e+ st'),'

    t e st

    '); CheckEqual(HtmlEscapeWiki('t+e+st'),'

    test

    '); CheckEqual(HtmlEscapeWiki('t `e` st'),'

    t e st

    '); CheckEqual(HtmlEscapeWiki('t`e`st'),'

    test

    '); CheckEqual(HtmlEscapeWiki('https://test'),'

    https://test

    '); CheckEqual(HtmlEscapeWiki('test'#13#10'click on http://coucouc.net toto'), '

    test

    click on http://coucouc.net toto

    '); CheckEqual(HtmlEscapeWiki(':test: :) joy:'),'

    :test: '+EMOJI_UTF8[eSmiley]+' joy:

    '); CheckEqual(HtmlEscapeWiki(':innocent: smile'),'

    '+EMOJI_UTF8[eInnocent]+' smile

    '); CheckEqual(HtmlEscapeWiki(':test: :) a:joy:'),'

    :test: '+EMOJI_UTF8[eSmiley]+' a:joy:

    '); CheckEqual(HtmlEscapeWiki(':test: :)'),'

    :test: '+EMOJI_UTF8[eSmiley]+'

    '); CheckEqual(HtmlEscapeWiki(':test: (:)'),'

    :test: (:)

    '); CheckEqual(HtmlEscapeWiki(':test: :))'),'

    :test: :))

    '); // Markdown CheckEqual(HtmlEscapeMarkdown('test'),'

    test

    '); CheckEqual(HtmlEscapeMarkdown('test'#13#10'toto'),'

    test toto

    '); CheckEqual(HtmlEscapeMarkdown('test'#13#10#13#10'toto'),'

    test

    toto

    '); CheckEqual(HtmlEscapeMarkdown('test'#10#10'toto'),'

    test

    toto

    '); CheckEqual(HtmlEscapeMarkdown('test'#10#10#10'toto'),'

    test

    toto

    '); CheckEqual(HtmlEscapeMarkdown('test'),'

    test

    '); CheckEqual(HtmlEscapeMarkdown('test',[heHtmlEscape]),'

    te<b>st

    '); CheckEqual(HtmlEscapeMarkdown('t *e* st'),'

    t e st

    '); CheckEqual(HtmlEscapeMarkdown('t*e*st'),'

    test

    '); CheckEqual(HtmlEscapeMarkdown('t\*e\*st'),'

    t*e*st

    '); CheckEqual(HtmlEscapeMarkdown('t\*e*st'),'

    t*est

    '); CheckEqual(HtmlEscapeMarkdown('t **e** st'),'

    t e st

    '); CheckEqual(HtmlEscapeMarkdown('t**e**st'),'

    test

    '); CheckEqual(HtmlEscapeMarkdown('t _e_ st'),'

    t e st

    '); CheckEqual(HtmlEscapeMarkdown('t_e_st'),'

    test

    '); CheckEqual(HtmlEscapeMarkdown('t\_e\_st'),'

    t_e_st

    '); CheckEqual(HtmlEscapeMarkdown('t\_e_st'),'

    t_est

    '); CheckEqual(HtmlEscapeMarkdown('t __e__ st'),'

    t e st

    '); CheckEqual(HtmlEscapeMarkdown('t__e__st'),'

    test

    '); CheckEqual(HtmlEscapeMarkdown('t `e` st'),'

    t e st

    '); CheckEqual(HtmlEscapeMarkdown('t`e`st'),'

    test

    '); CheckEqual(HtmlEscapeMarkdown('t***e***st'),'

    test

    '); CheckEqual(HtmlEscapeMarkdown('test'#13#10'click on http://coucouc.net toto'), '

    test click on http://coucouc.net toto

    '); CheckEqual(HtmlEscapeMarkdown('[toto](http://coucou.net) titi'), '

    toto titi

    '); CheckEqual(HtmlEscapeMarkdown('blabla ![img](static/img.jpg) blibli'), '

    blabla img blibli

    '); CheckEqual(HtmlEscapeMarkdown('test'#13#10' a*=10*2'#10' b=20'#13#10'ended'), '

    test

    a*=10*2'#$D#$A'b=20'#$D#$A'

    ended

    '); CheckEqual(HtmlEscapeMarkdown('test'#13#10'``` a*=10*2'#10' b=20'#13#10'```ended'), '

    test

     a*=10*2'#$D#$A'  b=20'#$D#$A'

    ended

    '); CheckEqual(HtmlEscapeMarkdown('*te*st'#13#10'* one'#13#10'* two'#13#10'end'), '

    test

    • one
    • two

    end

    '); CheckEqual(HtmlEscapeMarkdown('+test'#13#10'+ one'#13#10'- two'#13#10'end'), '

    +test

    • one
    • two

    end

    '); CheckEqual(HtmlEscapeMarkdown('1test'#13#10'1. one'#13#10'2. two'#13#10'end'), '

    1test

    1. one
    2. two

    end

    '); CheckEqual(HtmlEscapeMarkdown('1test'#13#10'1. one'#13#10'7. two'#13#10'3. three'#13#10'4end'), '

    1test

    1. one
    2. two
    3. three

    4end

    '); CheckEqual(HtmlEscapeMarkdown('1test'#13#10'1. one'#13#10'2. two'#13#10'+ one'#13#10'- two'#13#10'end'), '

    1test

    1. one
    2. two
    • one
    • two

    end

    '); CheckEqual(HtmlEscapeMarkdown('>test'#13#10'> quote'), '

    >test

    quote

    '); CheckEqual(HtmlEscapeMarkdown('>test'#13#10'> quote1'#10'> quote2'#13#10'end'), '

    >test

    quote1

    quote2

    end

    '); CheckEqual(HtmlEscapeMarkdown(':test: :) joy:'),'

    :test: '+EMOJI_UTF8[eSmiley]+' joy:

    '); CheckEqual(HtmlEscapeMarkdown(':innocent: :joy'),'

    '+EMOJI_UTF8[eInnocent]+' :joy

    '); CheckEqual(HtmlEscapeMarkdown(':test: :)'),'

    :test: '+EMOJI_UTF8[eSmiley]+'

    '); CheckEqual(HtmlEscapeMarkdown(':test: (:)'),'

    :test: (:)

    '); end; {$ifndef DELPHI5OROLDER} {$ifndef LVCL} procedure TTestLowLevelTypes._TDecimal128; procedure Test(const hi,lo: QWord; const expected: RawUTF8; special: TDecimal128SpecialValue=dsvValue); var v,v2: TDecimal128; begin v.Bits.hi := hi; v.Bits.lo := lo; Check(v.ToText=expected); v2.SetZero; Check(v2.FromText(expected)=special); if special<>dsvValue then exit; Check(v2.Equals(v)); Check(v2.ToText=expected); v2.SetZero; if expected[1]<>'-' then Check(v2.FromText('000'+LowerCase(expected))=dsvValue) else Check(v2.FromText(LowerCase(expected))=dsvValue); Check(v2.Equals(v)); end; procedure Test2(const fromvalue, expected: RaWUTF8; h: QWord=0; l: QWord=0); var v: TDecimal128; begin Check(v.FromText(fromvalue)=dsvValue); Check(v.ToText=expected); if (h=0) and (l=0) then exit; Check(v.Bits.lo=l); Check(v.Bits.hi=h); end; var v,v2: TDecimal128; s: TDecimal128SpecialValue; str: RawUTF8; i: integer; o: variant; begin // see https://github.com/mongodb/libbson/blob/master/tests/test-decimal128.c Check(v.FromText('')=dsvError); Check(v.FromText('.')=dsvError); Check(v.FromText('.e')=dsvError); Check(v.FromText('i')=dsvError); Check(v.FromText('invalid')=dsvError); Check(v.FromText('1invalid')=dsvError); Check(v.FromText('E02')=dsvError); Check(v.FromText('E+02')=dsvError); Check(v.FromText('e+02')=dsvError); Check(v.FromText('1E02')=dsvValue); Check(v.FromText('1invalidE02')=dsvError); Check(v.FromText('..1')=dsvError); Check(v.FromText('0')=dsvZero); Check(v.ToText='0'); for s := dsvNan to high(s) do begin v.SetSpecial(s); Check(v.ToText=DECIMAL128_SPECIAL_TEXT[s]); Check(v.IsSpecial=s); if s1000 then inc(v.Bits.c[0],i*7) else v.Bits.c[0] := i; str := v.ToText; Check(str=UInt32ToUTF8(v.Bits.c[0])); if i=0 then continue; Check(v2.FromText(str)=dsvValue); Check(v2.Equals(v)); end; for i := -1000 to 100 do begin v.FromInt32(i); str := v.ToText; Check(str=Int32ToUTF8(i)); if i=0 then continue; Check(v2.FromText(str)=dsvValue); Check(v2.Equals(v)); end; v.FromCurr(0); Check(v.ToText='0.0000'); Check(v.ToCurr=0); v.FromCurr(3.14); Check(v.ToText='3.1400'); for i := -160 to 160 do begin v.FromFloat(i/4); v.ToText(str); Check(GetExtended(pointer(str))*4=i); Check(v.ToFloat*4=i); v.FromCurr(i/16); v.ToText(str); Check(StrToCurr64(pointer(str))=i*625); Check(v.ToCurr*16=i); o := NumberDecimal(i/8); Check(v.FromVariant(o)); Check(v.ToCurr*8=i); end; end; procedure TTestLowLevelTypes._BSON; const BSONAWESOME = '{"BSON":["awesome",5.05,1986]}'; BSONAWESOMEBIN = #$31#0#0#0#4'BSON'#0#$26#0#0#0#2'0'#0#8#0#0#0'awesome'#0+ #1'1'#0'333333'#$14#$40#$10'2'#0#$c2#7#0#0#0#0; BSONID = '507F191E810C19729DE860EA'; REGEX = '{"$regex":"acme.*corp","$options":"i"}'; REGEX2 = '{name:"John",field:/acme.*corp/i}'; procedure CheckRegEx(o: variant); var u,u2: RawUTF8; begin u := VariantSaveMongoJSON(o,modMongoStrict); CheckEqual(u,'{"name":"John","field":'+REGEX+'}'); u2 := VariantSaveMongoJSON(o,modMongoStrict); CheckEqual(u,u2,'call twice'); u2 := VariantSaveJSON(o); CheckEqual(u,u2); u := VariantSaveMongoJSON(o,modMongoShell); CheckEqual(u,REGEX2); end; var o,od,o2,value: variant; d,d2: TDateTime; oid, oid2: TBSONObjectID; oids: array of TBSONObjectID; bsonDat, temp, bin: RawByteString; i,j: integer; b: PByte; elem, item: TBSONElement; iter: TBSONIterator; name,u,u2,u3,json: RawUTF8; arr: TRawUTF8DynArray; st: string; timer: TPrecisionTimer; dec: TDecimal128; procedure CheckElemIsBsonArray; var b: PByte; begin Check(elem.Kind=betArray); Check(elem.Name='BSON'); item.Index := -1; b := elem.Element; BSONParseLength(b,38); Check(b=elem.Data.DocList); while item.FromNext(b) do begin case item.Index of 0: Check(item.ToVariant='awesome'); 1: CheckSame(item.ToVariant,5.05); 2: Check(item.ToVariant=1986); else Check(false); end; end; end; begin // see http://docs.mongodb.org/manual/reference/object-id oid.FromText('507f191e810c19729de860ea'); Check(oid.UnixCreateTime=bswap32($507f191e)); u := oid.ToText; Check(u=BSONID); o := ObjectID('507f191e810c19729de860ea'); Check(TVarData(o).VType=BSONVariantType.VarType); u := string(o); Check(u=BSONID); d2 := Iso8601ToDateTime('2012-10-17T20:46:22'); od := d2; Check(TVarData(od).VType=varDate); {$ifdef FPC} // doesn't allow direct cast from varDate to double :( CheckSame(TVarData(od).VDate,d2); d := double(o); {$else} CheckSame(od,d2); d := o; {$endif} DateTimeToIso8601StringVar(d,'T',st); CheckSame(d,d2,1E-4,st); CheckSame(o,d2,1E-4,st); CheckSame(TBSONVariantData(o).VObjectID.CreateDateTime,d2,1E-4); o2 := o; Check(double(o)=double(o2)); o := ObjectID; Check(Abs(NowUTC-double(o))<0.1); oid.FromText(string(o)); Check(Abs(NowUTC-oid.CreateDateTime)<0.1); oid2.ComputeNew; Check(oid.MachineID.b1=oid2.MachineID.b1); Check(oid.MachineID.b2=oid2.MachineID.b2); Check(oid.MachineID.b3=oid2.MachineID.b3); Check(oid.ProcessID=oid2.ProcessID); o2 := ObjectID; {$ifdef FPC} // FPC bug: sysvartotdatetime doesn't handle custom variants :( Check(double(o2)>=double(o),o); {$else} Check(TDateTime(o2)>=TDateTime(o),o); {$endif} oid2.ComputeNew; j := 100000; timer.Start; for i := 1 to j do begin oid.ComputeNew; Check(not oid.Equal(oid2)); oid2 := oid; Check(oid.Equal(oid2)); end; NotifyTestSpeed('TBSONObjectID.ComputeNew',j,0,@timer); SetLength(oids,300); for i := 0 to high(oids) do begin oids[i].ComputeNew; for j := 0 to i-1 do Check(not oids[i].Equal(oids[j]),'24 bit collision'); end; //Check(GetCurrentProcessId<>oid.ProcessID,'Expected overflow'); o := _JSON('{"double_params":[-12.12345678,-9.9E-15,-9.88E-15,-9E-15]}', [dvoReturnNullForUnknownProperty, dvoAllowDoubleValue]); json := TDocVariantData(o).ToJSON; {$ifndef EXTENDEDTOSHORT_USESTR} check(json='{"double_params":[-12.12345678,-9.9E-15,-9.88E-15,-9E-15]}'); {$endif} CheckSame(double(TDocVariantData(o).A['double_params'].Value[1]),-9.9E-15); // see http://bsonspec.org/#/specification o := _JSON('{"hello": "world"}'); bsonDat := BSON(TDocVariantData(o)); Check(bsonDat=#$16#0#0#0#2'hello'#0#6#0#0#0'world'#0#0); b := pointer(bsonDat); Check(BSONParseLength(b,$16)=length(bsonDat)); Check(elem.FromNext(b)); Check(elem.Kind=betString); Check(elem.Name='hello'); Check(elem.Data.Text='world'); Check(not elem.FromNext(b)); Check(elem.Kind=betEof); u := BSONToJSON(pointer(bsonDat),betDoc,length(bsonDat)); CheckEqual(u,'{"hello":"world"}'); elem.FromDocument(bsonDat); Check(elem.Kind=betDoc); Check(elem.DocItemToVariant('hello',value)); check(value='world'); Check(not elem.DocItemToVariant('hello2',value)); Check(elem.DocItemToRawUTF8('hello')='world'); Check(elem.DocItemToRawUTF8('hello2')=''); Check(elem.DocItemToInteger('hello',1234)=1234); Check(iter.Init(bsonDat)); Check(iter.Next); Check(iter.Item.Kind=betString); Check(iter.Item.Name='hello'); Check(iter.Item.Data.Text='world'); Check(not iter.Next); b := pointer(bsonDat); BSONParseLength(b); Check(BSONParseNextElement(b,name,value)); Check(name='hello'); Check(value='world'); Check(not BSONParseNextElement(b,name,value)); o := _JSON('{"BSON": ["awesome", 5.05, 1986]}'); bsonDat := BSON(TDocVariantData(o)); Check(length(bsonDat)=$31); Check(bsonDat=BSONAWESOMEBIN); b := pointer(bsonDat); Check(BSONParseLength(b,$31)=length(bsonDat)); Check(elem.FromNext(b)); CheckElemIsBsonArray; Check(not elem.FromNext(b)); Check(elem.Kind=betEof); u := BSONToJSON(pointer(bsonDat),betDoc,length(bsonDat)); CheckEqual(u,BSONAWESOME); u := VariantSaveMongoJSON(o,modMongoStrict); CheckEqual(u,BSONAWESOME); u := VariantSaveJSON(o); CheckEqual(u,BSONAWESOME); Check(BSON(['BSON',_Arr(['awesome',5.05, 1986])])=bsonDat); o2 := BSONVariantType[bsonDat]; Check(VariantSaveJSON(o2)=u); o2 := BSONVariant('{"BSON": ["awesome", 5.05, 1986]}'); u := VariantSaveMongoJSON(o2,modMongoStrict); CheckEqual(u,BSONAWESOME); o2 := BSONVariant(['BSON',_Arr(['awesome',5.05, 1986])]); Check(VariantSaveMongoJSON(o2,modMongoStrict)=BSONAWESOME); o2 := BSONVariant(TDocVariantData(o)); Check(VariantSaveMongoJSON(o2,modMongoStrict)=BSONAWESOME); o2 := BSONVariant('{%:[?,?,?]}',['BSON'],['awesome',5.05,1986]); Check(VariantSaveMongoJSON(o2,modMongoStrict)=BSONAWESOME); b := pointer(bsonDat); {$ifndef FPC} Check(o2=BSONAWESOME,'BSONVariant casted to string'); {$endif} u := string(o2); CheckEqual(u,'{BSON:["awesome",5.05,1986]}','TBSONVariant: mongoShell syntax'); BSONParseLength(b); Check(BSONParseNextElement(b,name,value,asDocVariantPerReference)); Check(name='BSON'); elem.FromVariant(name,value,Temp); CheckElemIsBsonArray; Check(not BSONParseNextElement(b,name,value)); o := BSONDocumentToDoc(bsonDat); Check(TVarData(o).VType=DocVariantType.VarType); Check(DocVariantType.IsOfType(o)); Check(o.Name(0)='BSON'); Check(o._(0)._Kind=ord(dvArray)); Check(o.bson._Kind=ord(dvArray)); Check(o.bson._count=3); Check(o.bson._(0)='awesome'); CheckSame(double(o.bson._(1)),5.05); Check(o.bson._(2)=1986); Check(o.dummy=null); Check(o.Exists('bson')); Check(not o.Exists('dummy')); Check(o.NameIndex('bson')=0); Check(o.NameIndex('dummy')<0); DocVariantData(o.bson).ToRawUTF8DynArray(arr); Check(length(arr)=3); Check(RawUTF8ArrayToCSV(arr)='awesome,5.05,1986'); Check(DocVariantData(o.bson).ToJSON='["awesome",5.05,1986]'); u := '{"BSON":["awesome",5.05,1986],"name":"John","one":1.2}'; _JSON(u,o); Check(VariantSaveJson(BSONVariant(u))=u); bsonDat := BSON(TDocVariantData(o)); b := pointer(bsonDat); BSONParseLength(b); Check(BSONParseNextElement(b,name,value)); Check(name='BSON'); elem.FromVariant(name,value,Temp); CheckElemIsBsonArray; Check(BSONParseNextElement(b,name,value)); Check(name='name'); Check(value='John'); elem.FromVariant(name,value,Temp); Check(elem.name='name'); Check(elem.Data.Text='John'); Check(BSONParseNextElement(b,name,value)); Check(name='one'); CheckSame(value,1.2); elem.FromVariant(name,value,Temp); Check(elem.name='one'); CheckSame(unaligned(PDouble(elem.Element)^),1.2); Check(not BSONParseNextElement(b,name,value)); Check(BSONToJSON(pointer(bsonDat),betDoc,length(bsonDat))=u); elem.FromVariant('test',o,Temp); Check(elem.Name='test'); Check(elem.Kind=betDoc); Check(VariantSaveMongoJSON(o,modMongoStrict)=u); Check(VariantSaveMongoJSON('test',modMongoStrict)='"test"'); Check(VariantSaveMongoJSON(1.5,modMongoStrict)='1.5'); Check(VariantSaveMongoJSON(_JSON('{BSON:["awesome",5.05,1986]}'),modMongoStrict)=BSONAWESOME); Check(VariantSaveMongoJSON(_JSONFast('{ BSON : ["awesome", 5.05, 1986] }'),modMongoStrict)=BSONAWESOME); Check(VariantSaveMongoJSON(_JSONFast('{ ''BSON'' : ["awesome", 5.05, 1986] } '),modMongoStrict)=BSONAWESOME); Check(VariantSaveJSON(o)=u); Check(VariantSaveJSON('test')='"test"'); Check(VariantSaveJSON(1.5)='1.5'); Check(VariantSaveJSON(_JSON('{BSON:["awesome",5.05,1986]}'))=BSONAWESOME); Check(VariantSaveJSON(_JSONFast('{ BSON : ["awesome", 5.05, 1986] }'))=BSONAWESOME); Check(VariantSaveJSON(_JSONFast('{ ''BSON'' : ["awesome", 5.05, 1986] } '))=BSONAWESOME); Check(BSON('{BSON:["awesome",5.05,1986]}',[],[])=BSONAWESOMEBIN); Check(BSON('{ BSON : ["awesome", 5.05, 1986] }',[],[])=BSONAWESOMEBIN); Check(BSON('{ ''BSON'' : ["awesome", 5.05, 1986] } ',[],[])=BSONAWESOMEBIN); Check(BSON('{%:[?,?,?]}',['BSON'],['awesome',5.05,1986])=BSONAWESOMEBIN); Check(BSON('{%:?}',['BSON'],[_Arr(['awesome',5.05,1986])])=BSONAWESOMEBIN); Check(BSON(['BSON','[','awesome',5.05,1986,']'])=BSONAWESOMEBIN); Check(BSON(['BSON','[','awesome',5.05,1986])=BSONAWESOMEBIN); o2 := BSONVariantType[bsonDat]; Check(VariantSaveJSON(o2)=u); _Json('{BSON: ["test", 5.05, 1986]}',o); Check(VariantSaveMongoJSON(o,modMongoStrict)='{"BSON":["test",5.05,1986]}'); u := VariantSaveMongoJSON(_Obj(['name','John', 'doc',_Obj(['one',1,'two',_Arr(['one',2])])]),modMongoStrict); CheckEqual(u,'{"name":"John","doc":{"one":1,"two":["one",2]}}'); Check(VariantSaveJson(BSONVariant(u))=u); Check(BSONDocumentToJSON(BSONFieldSelector(['a','b','c']))='{"a":1,"b":1,"c":1}'); Check(BSONDocumentToJSON(BSONFieldSelector('a,b,c'))='{"a":1,"b":1,"c":1}'); Check(VariantSaveMongoJSON(BSONVariantFieldSelector(['a','b','c']),modMongoShell)='{a:1,b:1,c:1}'); Check(VariantSaveMongoJSON(BSONVariantFieldSelector('a,b,c'),modMongoShell)='{a:1,b:1,c:1}'); o := _Obj(['id',ObjectID(BSONID),'name','John','date',variant(d2)]); u := VariantSaveMongoJSON(o,modNoMongo); u2 := FormatUTF8('{"id":"%","name":"John","date":"%"}',[BSONID,st]); CheckEqual(u,u2); u3 := VariantSaveJson(BSONVariant(u)); Check(u3=FormatUTF8('{"id":"%","name":"John","date":{"$date":"%"}}',[BSONID,st])); u3 := VariantSaveMongoJSON(BSONVariant(u),modNoMongo); Check(u3=u); u := VariantSaveMongoJSON(o,modMongoShell); CheckEqual(u,FormatUTF8('{id:ObjectId("%"),name:"John",date:ISODate("%")}',[BSONID,st])); u3 := VariantSaveJson(BSONVariant(u)); u := VariantSaveJSON(o); CheckEqual(u,FormatUTF8('{"id":{"$oid":"%"},"name":"John","date":"%"}',[BSONID,st])); u := VariantSaveMongoJSON(o,modMongoStrict); CheckEqual(u,FormatUTF8('{"id":{"$oid":"%"},"name":"John","date":{"$date":"%"}}',[BSONID,st])); Check(u3=u); _Json(u,o2); u := VariantSaveMongoJSON(o2,modMongoShell); CheckEqual(u,FormatUTF8('{id:ObjectId("%"),name:"John",date:ISODate("%")}',[BSONID,st])); _Json(u,o2); u := VariantSaveMongoJSON(o2,modNoMongo); CheckEqual(u,u2); o2 := _JsonFmt('{ id: objectID( "%" ) , name: "John", date: new date( "%" ) }',[BSONID,st],[]); u := VariantSaveMongoJSON(o2,modNoMongo); CheckEqual(u,u2); o2 := _JsonFmt('{id:objectID(?),name:?,date:ISODate(?)}',[],[BSONID,'John',st]); u := VariantSaveMongoJSON(o2,modNoMongo); CheckEqual(u,u2); u := VariantSaveMongoJSON(o2,modMongoShell); CheckEqual(u,FormatUTF8('{id:ObjectId("%"),name:"John",date:ISODate("%")}',[BSONID,st])); _Json(u,o2); u := VariantSaveMongoJSON(o2,modNoMongo); CheckEqual(u,u2); bin := VariantSave(o2); u := VariantSaveMongoJSON(VariantLoad(bin,@JSON_OPTIONS[true]),modNoMongo); CheckEqual(u,u2); check(VariantSaveMongoJSON(VariantLoad(bin,@JSON_OPTIONS[true]),modNoMongo)=u2,'twice to ensure bin is untouched'); u := VariantSaveMongoJSON(_Json('{id:ObjectId(),name:"John"}'),modNoMongo); Check(IdemPChar(Pointer(u),'{"ID":"'),'ObjectId() constructor '); Check(PosEx('","name":"John"}',u)=32); u2 := VariantSaveMongoJSON(_Json('{id:ObjectId(),name:"John"}'),modNoMongo); Check(u2<>u,'should be genuine'); o := _JSONFmt('{type:{$in:?}}',[],[_Arr(['food','snack'])]); u := VariantSaveJSON(o); CheckEqual(u,'{"type":{"$in":["food","snack"]}}'); u := VariantSaveMongoJSON(o,modMongoShell); CheckEqual(u,'{type:{$in:["food","snack"]}}'); o := _JSON('{"hello": null}'); Check(TVarData(o).VType=DocVariantVType); check(string(o)='{"hello":null}'); o := _JSON('{"hello": world}'); Check(TVarData(o).VType=varEmpty,'invalid JSON content'); CheckRegEx(_Json('{name:"John",field:{ "$regex": "acme.*corp", $options: "i" }}')); CheckRegEx(_Json(REGEX2)); CheckRegEx(_JsonFast('{"name":"John",field:{ "$regex": "acme.*corp", $options: "i" }}')); CheckRegEx(_JsonFast(REGEX2)); temp := BSON(REGEX2); b := pointer(temp); u := BSONToJSON(b,betDoc,0,modMongoStrict); CheckEqual(u,'{"name":"John","field":'+REGEX+'}'); o2 := BSONVariant(REGEX2); Check(string(o2)='{name:"John",field:/acme.*corp/i}','MongoShell in string cast'); Check(VariantSaveJson(o2)=u); temp := BSON('{name:?,field:/%/i}',['acme.*corp'],['John']); b := pointer(temp); u2 := BSONToJSON(b,betDoc,0,modMongoStrict); CheckEqual(u,u2); u := VariantSaveMongoJSON(_Json('{name:"John",date: new date() , field: /acme.*corp/i}'),modMongoStrict); u2 := VariantSaveMongoJSON(_Json('{name:"John",date:new date(),field:/acme.*corp/i}'),modMongoStrict); o := _JSON(u); o2 := _JSON(u2); Check(o.name=o2.name); d := TDateTime(o.date); d2 := TDateTime(o2.date); Check(d>NowUTC-1); Check(d2-d<0.1); u := VariantSaveMongoJSON(o.Field,modMongoStrict); u2 := VariantSaveMongoJSON(o2.Field,modMongoStrict); CheckEqual(u,u2); CheckEqual(u,REGEX); u := VariantSaveMongoJSON(o.Field,modMongoShell); u2 := VariantSaveMongoJSON(o2.Field,modMongoShell); CheckEqual(u,u2); CheckEqual(u,'/acme.*corp/i'); u := VariantSaveMongoJSON(o.Field,modMongoStrict); u2 := VariantSaveMongoJSON(o2.Field,modMongoStrict); CheckEqual(u,u2); CheckEqual(u,REGEX); u := VariantSaveJSON(o.Field); u2 := VariantSaveJSON(o2.Field); CheckEqual(u,u2); CheckEqual(u,REGEX); o := _Json('{ tags: { $in: [ /^be/, /^st/ ] } }'); u := VariantSaveMongoJSON(o,modMongoStrict); CheckEqual(u,'{"tags":{"$in":[{"$regex":"^be","$options":""},{"$regex":"^st","$options":""}]}}'); temp := BSON(u,[],[]); b := pointer(temp); u2 := VariantSaveMongoJSON(o,modMongoShell); Check(u2='{tags:{$in:[/^be/,/^st/]}}'); u := VariantSaveMongoJSON(_Json(u),modMongoShell); CheckEqual(u,u2); u2 := BSONToJSON(b,betDoc,0,modMongoShell); CheckEqual(u,u2); temp := BSON('{id:ObjectId(),doc:{name:?,date:ISODate(?)}}',[],['John',NowUTC]); b := pointer(temp); u := BSONToJSON(b,betDoc,0,modMongoShell); Check(IdemPChar(pointer(u),'{ID:OBJECTID("')); Check(PosEx('"),doc:{name:"John",date:ISODate("',u)>10); u := BSONDocumentToJSON(BSON(['doc','{','name','John','year',1982,'}','id',123])); CheckEqual(u,'{"doc":{"name":"John","year":1982},"id":123}'); u := BSONDocumentToJSON(BSON(['doc','{','name','John','abc','[','a','b','c',']','}','id',123])); CheckEqual(u,'{"doc":{"name":"John","abc":["a","b","c"]},"id":123}'); o2 := NumberDecimal('123.5600'); u := VariantSaveJSON(o2); CheckEqual(u,'{"$numberDecimal":"123.5600"}'); o := _Json('{ num: '+u+'}'); u := VariantSaveMongoJSON(o,modMongoStrict); CheckEqual(u,'{"num":{"$numberDecimal":"123.5600"}}'); u := VariantSaveMongoJSON(o,modMongoShell); CheckEqual(u,'{num:NumberDecimal("123.5600")}'); o := BSONVariant(['num',o2]); u := VariantSaveMongoJSON(o,modMongoStrict); CheckEqual(u,'{"num":{"$numberDecimal":"123.5600"}}'); u := VariantSaveMongoJSON(o,modMongoShell); CheckEqual(u,'{num:NumberDecimal("123.5600")}'); o := _ObjFast(['num',o2]); u := VariantSaveMongoJSON(o,modMongoStrict); CheckEqual(u,'{"num":{"$numberDecimal":"123.5600"}}'); o2 := _JsonFast(u); {$ifdef FPC} // TCustomVariantType.CompareOp not yet supported :( check(string(o)=string(o2),'o=o2'); {$else} check(o=o2,'o=o2'); {$endif} u := VariantSaveMongoJSON(o,modMongoShell); CheckEqual(u,'{num:NumberDecimal("123.5600")}'); o2 := _JsonFast(u); {$ifdef FPC} // TCustomVariantType.CompareOp not yet supported :( check(string(o)=string(o2),'o=o2'); {$else} check(o=o2,'o=o2'); {$endif} temp := BSON(u,[],[]); b := pointer(temp); u2 := BSONToJSON(b,betDoc,0,modMongoShell); CheckEqual(u,u2); u2 := BSONToJSON(b,betDoc,0,modMongoStrict); check(u2='{"num":{"$numberDecimal":"123.5600"}}'); check(dec.FromVariant(o2.num)); check(dec.ToText='123.5600'); o2 := dec.ToVariant; u := VariantSaveJSON(o2); CheckEqual(u,'{"$numberDecimal":"123.5600"}'); end; procedure TTestLowLevelTypes._TDocVariant; procedure CheckDoc(var Doc: TDocVariantData; ExpectedYear: integer=1972); var JSON: RawUTF8; begin if CheckFailed(Doc.VarType=DocVariantVType) then exit; Check(Doc.Kind=dvObject); Check(Doc.Count=2); Check(Doc.Names[0]='name'); Check(Doc.Values[0]='John'); Check(variant(Doc)._kind=ord(dvObject)); Check(variant(Doc).name='John'); Check(variant(Doc).name=Doc.Value['name']); Check(variant(Doc).birthYear=ExpectedYear); Check(variant(Doc).birthYEAR=Doc.Value['birthYear']); Check(variant(Doc)._Count=2); Check(variant(Doc).Name(0)='name'); Check(variant(Doc).Name(1)='birthyear'); Check(variant(Doc)._(0)='John'); Check(variant(Doc)._(1)=ExpectedYear); Check(variant(Doc).Value(0)='John'); Check(variant(Doc).Value(1)=ExpectedYear); JSON := '{"name":"John","birthyear":'+Int32ToUTF8(ExpectedYear)+'}'; Check(Doc.ToJSON=JSON); Check(variant(Doc)._JSON=JSON); Check(variant(Doc)._JSON__=JSON,'pseudo methods use IdemPChar'); Check(VariantSaveMongoJSON(variant(Doc),modMongoStrict)=JSON); Check(VariantToUTF8(variant(Doc))=JSON); Check(Doc.U['name']='John'); Check(Doc.I['birthyear']=ExpectedYear); end; var discogs: RawUTF8; procedure CheckNestedDoc(aOptions: TDocVariantOptions=[]); var JSON, JSON2: RawUTF8; Doc, Doc2: TDocVariantData; Doc2Doc, V, Disco: variant; i: Integer; begin V := _JSON('["one",2,3]',aOptions); Check(V._JSON='["one",2,3]'); Doc.InitObject(['name','John','birthyear',1972],aOptions+[dvoReturnNullForUnknownProperty]); CheckDoc(Doc); Check(Doc.Value['toto']=null); Check(variant(Doc).toto=null); Check(Doc.Value[10]=null); Doc2.InitObject(['id',10, 'doc',_Obj(['name','John','birthyear',1972],aOptions)]); Check(Doc2.Kind=dvObject); Check(variant(Doc2)._kind=ord(dvObject)); Check(Doc2.Count=2); Check(Doc2.Value['id']=10); Check(variant(Doc2).id=10); Check(variant(Doc2).doc._kind=ord(dvObject)); Doc2Doc := variant(Doc2).doc; CheckDoc(DocVariantData(Doc2Doc)^); CheckDoc(DocVariantData(variant(Doc2).doc)^); Doc2Doc := Doc2.GetValueOrRaiseException('doc'); JSON := '{"id":10,"doc":{"name":"John","birthyear":1972}}'; Check(Doc2.ToJSON=JSON); Check(Doc2.I['id']=10); Check(Doc2.O['doc'].U['name']='John'); Check(Doc2.O['doc'].I['birthyear']=1972); //Doc2Doc.birthyear := 1980; variant(DocVariantData(Doc2Doc)^).birthyear := 1980; JSON2 := Doc2.ToJSON; if dvoValueCopiedByReference in aOptions then begin Check(JSON2='{"id":10,"doc":{"name":"John","birthyear":1980}}'); Check(Doc2.O['doc'].I['birthyear']=1980); end else begin Check(JSON2=JSON); Check(Doc2.O['doc'].I['birthyear']=1972); end; _JSON(JSON,V,aOptions); Check(V._count=2); Check(V.id=10); Check(V.doc._kind=ord(dvObject)); Check(V.doc.name='John'); Check(V.doc.birthYear=1972); if discogs<>'' then begin FileFromString(JSONReformat(discogs),ChangeFileExt(discogsFileName,'2.json')); Disco := _JSON(discogs,aOptions); Check(Disco.releases._count<=Disco.pagination.items); for i := 0 to Disco.Releases._count-1 do begin Check(Disco.Releases._(i).id>0); V := Disco.Releases._(i); Check(V._count>0); Check(V.title<>''); end; // if aOptions=[] then // FileFromString(TDocVariantData(Disco).ToJSON,'discoVariant.json'); end; _JSON('[]',V,aOptions); Check(V._kind=ord(dvArray)); Check(V._count=0); _JSON('null',V,aOptions); Check(V._kind=ord(dvObject)); Check(V._count=0); end; procedure DoChange(var oSeasons: variant); var i: integer; oSeason: variant; begin for i := 0 to oSeasons._Count-1 do begin oSeason := oSeasons._(i); oSeason.Name := 'CHANGED !'; oSeason.Extra := 'blabla'; end; end; const MAX=20000; TEST_DATA_1 = '['+ '{"REC_ID":1,"CHANNEL":117,"PHONE":"5004392222,12345678","RELATION_ID":10,' + '"TIMESTAMP_CALL":"2017-10-26T04:48:14"},{"REC_ID":2,"CHANNEL":null,"PHONE":' + '"1234","RELATION_ID":11,"TIMESTAMP_CALL":"2017-10-26T04:48:14"},' + '{"REC_ID":3,"CHANNEL":174,"PHONE":"9149556917","RELATION_ID":12,' + '"TIMESTAMP_CALL":"2017-10-26T04:48:14"}]'; var Doc,Doc2: TDocVariantData; vr: TTVarRecDynArray; i,ndx: PtrInt; V,V1,V2: variant; s,j: RawUTF8; vd: double; vs: single; lTable: TSQLTableJSON; lRefreshed: Boolean; begin Doc.Init; Check(Doc.Kind=dvUndefined); Check(variant(Doc)._kind=ord(dvUndefined)); Doc.AddValue('name','Jonas'); Doc.AddValue('birthyear',1972); Check(Doc.Value['name']='Jonas'); Check(Doc.Value['birthyear']=1972); Check(Doc.U['name']='Jonas'); Check(Doc.I['birthyear']=1972); Doc.Value['name'] := 'John'; Check(Doc.Value['name']='John'); CheckDoc(Doc); Doc.Clear; Doc.InitFast; Check(Doc.Kind=dvUndefined); Check(variant(Doc)._kind=ord(dvUndefined)); Doc.AddValue('name','Jonas'); Doc.AddValue('birthyear',1972); Check(Doc.Value['name']='Jonas'); Check(Doc.Value['birthyear']=1972); Check(Doc.U['name']='Jonas'); Check(Doc.I['birthyear']=1972); Doc.Value['name'] := 'John'; Check(Doc.Value['name']='John'); Check(Doc.U['name']='John'); CheckDoc(Doc); Doc2.InitJSON(Doc.ToJSON); CheckDoc(Doc2); Doc.Clear; Doc.InitArray(['one',2,3.0]); Check(variant(Doc)._kind=ord(dvArray)); Check(variant(Doc)._count=3); if not CheckFailed(Doc.Count=3) then begin Check(Doc.Values[0]='one'); Check(Doc.Values[1]=2); Check(Doc.Values[2]=3.0); Check(Doc.Value[0]='one'); Check(Doc.Value[1]=2); Check(Doc.Value[2]=3.0); for i := 0 to Doc.Count-1 do Check(VariantCompare(Doc.Values[i],Doc.Value[i])=0); end; Check(Doc.ToJSON='["one",2,3]'); Check(Variant(Doc)._JSON='["one",2,3]'); Doc.ToArrayOfConst(vr); s := FormatUTF8('[?,?,?]',[],vr,true); check(s='["one",2,3]'); s := FormatUTF8('[%,%,%]',vr,[],true); check(s='[one,2,3]'); s := FormatUTF8('[?,?,?]',[],Doc.ToArrayOfConst,true); check(s='["one",2,3]'); s := FormatUTF8('[%,%,%]',Doc.ToArrayOfConst,[],true); check(s='[one,2,3]'); V := _JSON(' [ "one" ,2,3 ] '); Check(V._count=3); with TDocVariantData(V) do begin Check(Count=3); Check(Values[0]='one'); Check(Values[1]=2); Check(Values[2]=3.0); end; for i := 0 to V._count-1 do Check(V._(i)=Doc.Values[i]); {$ifdef FPC}TDocVariantData(V).AddItem{$else}V.Add{$endif}(4); Check(V._count=4); for i := 0 to 2 do Check(V._(i)=Doc.Values[i]); Check(V._(3)=4); V._ := 'a5'; Check(V._count=5); for i := 0 to 2 do Check(V._(i)=Doc.Values[i]); Check(V._(3)=4); Check(V._(4)='a5'); Check(V{$ifdef FPC}._JSON{$endif}='["one",2,3,4,"a5"]'); discogs := StringFromFile(discogsFileName); CheckNestedDoc([]); CheckNestedDoc([dvoValueCopiedByReference]); CheckNestedDoc([dvoJSONObjectParseWithinString]); CheckNestedDoc([dvoJSONObjectParseWithinString,dvoValueCopiedByReference]); V1 := _Obj(['name','John','year',1972],[dvoValueCopiedByReference]); V2 := V1; // creates a reference to the V1 instance V2.name := 'James'; // modifies V2.name, but also V1.name Check(V1.name='James'); Check(V2.name='James'); Check(V1{$ifdef FPC}._JSON{$endif}='{"name":"James","year":1972}'); _Unique(V1); // change options of V1 to be by-value V2 := V1; // creates a full copy of the V1 instance V2.name := 'John'; // modifies V2.name, but not V1.name Check(V1.name='James'); Check(V2.name='John'); V1 := _Arr(['root',V2]); // created as by-value by default, as V2 was Check(V1._Count=2); _UniqueFast(V1); // change options of V1 to be by-reference V2 := V1; Check(V1._(1){$ifdef FPC}._JSON{$endif}='{"name":"John","year":1972}'); {$ifdef FPC}TDocVariantData(V1).Values[1]{$else}V1._(1){$endif}.name := 'Jim'; Check(V1{$ifdef FPC}._JSON{$endif}='["root",{"name":"Jim","year":1972}]'); Check(V2{$ifdef FPC}._JSON{$endif}='["root",{"name":"Jim","year":1972}]'); _UniqueFast(V2); // now V1 modifications should not affect V2 Doc.Clear; Doc.Init; for i := 0 to MAX do begin UInt32ToUtf8(i,s); Check(Doc.AddValue(s,s)=i); end; Check(Doc.Count=MAX+1); for i := 0 to MAX do Check(GetInteger(Pointer(Doc.Names[i]))=i); for i := 0 to MAX do Check(Doc.Values[i]=i); Doc2.Clear; check(Doc2.Count=0); s := Doc.ToJSON; CheckEqual(Hash32(s),2110959969,'bigjson'); Doc2.InitJSON(s); check(Doc2.Count=MAX+1); for i := 0 to MAX do Check(Doc2.Values[i]=Doc.Values[i]); for i := MAX downto 0 do if i and 1=0 then Doc.Delete(i); Check(Doc.Count=MAX div 2); check(Doc2.Count=MAX+1); for i := 0 to Doc.Count-1 do Check(Doc.Names[i]=Doc.Values[i]); s := Doc2.ToJSON; CheckEqual(Hash32(s),2110959969,'bigjson2'); Check(TDocVariantData(V1)._[1].U['name']='Jim'); Check(TDocVariantData(V1)._[1].I['year']=1972); {$ifdef FPC}_Safe(V1)^.AddItem{$else}V1.Add{$endif}(3.1415); Check(V1{$ifdef FPC}._JSON{$endif}='["root",{"name":"Jim","year":1972},3.1415]'); {$ifdef FPC}TDocVariantData(V1)._[1]{$else}V1._(1){$endif}.Delete('year'); Check(V1{$ifdef FPC}._JSON{$endif}='["root",{"name":"Jim"},3.1415]'); {$ifdef FPC}TDocVariantData(V1){$else}V1{$endif}.Delete(1); Check(V1{$ifdef FPC}._JSON{$endif}='["root",3.1415]'); TDocVariantData(V2).DeleteByProp('name','JIM',true); Check(V2{$ifdef FPC}._JSON{$endif}='["root",{"name":"Jim","year":1972}]'); TDocVariantData(V2).DeleteByProp('name','JIM',false); Check(V2{$ifdef FPC}._JSON{$endif}='["root"]'); s := '{"Url":"argentina","Seasons":[{"Name":"2011/2012","Url":"2011-2012",'+ '"Competitions":[{"Name":"Ligue1","Url":"ligue-1"},{"Name":"Ligue2","Url":"ligue-2"}]},'+ '{"Name":"2010/2011","Url":"2010-2011","Competitions":[{"Name":"Ligue1","Url":"ligue-1"},'+ '{"Name":"Ligue2","Url":"ligue-2"}]}]}'; Check(Hash32(s)=$BF60E202); V1 := _Json(s); V2 := V1.seasons; DoChange(V2); j := VariantSaveJSON(V1); Check(j<>s); Check(Hash32(j)=$6998B225,'changed'); Check(Hash32(VariantSaveJSON(V2))=$92FEB37B); V1 := _Json(s); V2 := V1.seasons; _Unique(V2); DoChange(V2); Check(VariantSaveJSON(V1)=s); Check(Hash32(VariantSaveJSON(V2))=$92FEB37B); V2 := TDocVariant.NewUnique(V1.Seasons); DoChange(V2); Check(VariantSaveJSON(V1)=s); Check(Hash32(VariantSaveJSON(V2))=$92FEB37B); V2 := _copy(V1.Seasons); DoChange(V2); Check(VariantSaveJSON(V1)=s); Check(Hash32(VariantSaveJSON(V2))=$92FEB37B); s := _Safe(V1.Seasons)^.ToNonExpandedJSON; Check(s='{"fieldCount":3,"rowCount":2,"values":["Name","Url","Competitions",'+ '"2011/2012","2011-2012",[{"Name":"Ligue1","Url":"ligue-1"},{"Name":"Ligue2"'+ ',"Url":"ligue-2"}],"2010/2011","2010-2011",[{"Name":"Ligue1","Url":"ligue-1"}'+ ',{"Name":"Ligue2","Url":"ligue-2"}]]}'); V := _Json('{result:{data:{"1000":"D1", "1001":"D2"}}}'); Check(V.result{$ifdef FPC}._JSON{$endif}='{"data":{"1000":"D1","1001":"D2"}}'); Check(V.result.data.Exists('1000')); Check(V.result.data.Exists('1001')); Check(not V.result.data.Exists('1002')); Check(DocVariantData(V.result.data).Value['1000']='D1'); Check(V.result.data.Value(0)='D1'); Check(V.result.data.Value('1000')='D1'); Check(V.result.data.Value('1001')='D2'); V := _Obj(['Z',10,'name','John','year',1972,'a',1],[]); j := VariantSaveJSON(V); Check(j='{"Z":10,"name":"John","year":1972,"a":1}'); TDocVariantData(V).SortByName; j := VariantSaveJSON(V); Check(j='{"a":1,"name":"John","year":1972,"Z":10}'); TDocVariantData(V).SortByName(@StrComp); j := VariantSaveJSON(V); Check(j='{"Z":10,"a":1,"name":"John","year":1972}'); V := _JsonFast('{"Database":"\u201d\u00c9\u00c3\u00b6\u00b1\u00a2\u00a7\u00ad\u00a5\u00a4"}'); {$ifdef FPC} j := VariantToUTF8(V.Database); {$else} j := V.Database; {$endif} Check((j<>'')and(j[1]=#$E2)and(j[2]=#$80)and(j[3]=#$9D)); v1 := _Arr([]); vs := 1.5; {$ifdef FPC}_Safe(V1)^.AddItem{$else}V1.Add{$endif}(vs); CheckEqual(VariantSaveJSON(v1),'[1.5]','VariantSaveJSON'); vd := 1.7; {$ifdef FPC}_Safe(V1)^.AddItem{$else}V1.Add{$endif}(vd); CheckEqual(VariantSaveJSON(v1),'[1.5,1.7]'); v2 := _obj(['id',1]); Check(VariantSaveJSON(v2)='{"id":1}'); {$ifdef FPC}_Safe(v1)^.AddItem(v2); // FPC does not accept v1.Add(v2) {$else}v1.Add(v2);{$endif} Check(VariantSaveJSON(v1)='[1.5,1.7,{"id":1}]'); s := 'abc'; {$ifdef FPC}_Safe(v1)^.AddItem(s); // FPC does not accept v1.Add(s) {$else}v1.Add(s);{$endif} Check(VariantSaveJSON(v1)='[1.5,1.7,{"id":1},"abc"]'); RawUTF8ToVariant('def',v2); {$ifdef FPC}_Safe(v1)^.AddItem{$else}v1.Add{$endif}(v2); Check(VariantSaveJSON(v1)='[1.5,1.7,{"id":1},"abc","def"]'); Doc.Clear; Doc.InitObjectFromPath('name','toto'); check(Doc.ToJSON='{"name":"toto"}'); Doc.Clear; Doc.InitObjectFromPath('people.age',31); check(Doc.ToJSON='{"people":{"age":31}}'); check(Doc.O['people'].ToJson='{"age":31}'); check(Doc.O['people2'].ToJson='null'); Doc.O_['people2'].AddValue('name','toto'); check(Doc.ToJSON='{"people":{"age":31},"people2":{"name":"toto"}}'); check(Doc.A['arr'].ToJson='null'); Doc.A_['arr'].AddItems([1,2.2,'3']); check(Doc.ToJSON='{"people":{"age":31},"people2":{"name":"toto"},"arr":[1,2.2,"3"]}'); Doc.Clear; check(Doc.A['test'].ToJson='null'); Doc.A_['test']^.AddItems([1,2]); j := Doc.ToJSON; check(j='{"test":[1,2]}'); check(Doc.A['test'].ToJson='[1,2]'); Doc.A_['test']^.AddItems([3,4]); check(Doc.ToJSON='{"test":[1,2,3,4]}'); check(Doc.A['test'].ToJson='[1,2,3,4]'); Doc.Clear; check(not Doc.FlattenAsNestedObject('wrong')); Doc.InitJSON('{"p.a1":5,"p.a2":"dfasdfa"}'); check(not Doc.FlattenAsNestedObject('wrong')); check(Doc.ToJSON='{"p.a1":5,"p.a2":"dfasdfa"}'); check(Doc.FlattenAsNestedObject('p')); check(Doc.ToJSON='{"p":{"a1":5,"a2":"dfasdfa"}}'); check(not Doc.FlattenAsNestedObject('p')); s := '[{"Val1":"blabla","Val2":"bleble"},{"Val1":"blibli","Val2":"bloblo"}]'; v := _Json(s); v1 := _Copy(v._(0)); // expect a true instance for v1.Val1 := ... below check(v1.val1='blabla'); v2 := _Obj([]); // or TDocVariant.New(v2); v2.Val1 := 'blublu'; v2.Val2 := 'blybly'; v1.Val1 := v2.Val1; v1.Val2 := v2.Val2; check(VariantSaveJSON(v1)=VariantSaveJSON(v2)); Doc.Clear; V := _JSON('{"ID": 1,"Notation": "ABC", "Price": 10.1, "CustomNotation": "XYZ"}'); Doc.InitCopy(V, []); Doc.I['ID'] := 2; Doc.Delete('CustomNotation'); s := Doc.ToJSON; check(s='{"ID":2,"Notation":"ABC","Price":10.1}'); s := VariantSaveJSON(V); check(s='{"ID":1,"Notation":"ABC","Price":10.1,"CustomNotation":"XYZ"}'); // some tests to avoid regression about bugs reported by users on forum lTable := TSQLTableJSON.Create(''); try lTable.UpdateFrom(TEST_DATA_1,lRefreshed,nil); ndx := lTable.FieldIndex('RELATION_ID'); Check(ndx=3); lTable.SortFields(ndx); doc.Clear; i := lTable.SearchFieldSorted('10',{RELATION_ID}ndx); lTable.ToDocVariant(i,variant(doc)); doc.Delete('REC_ID'); doc.Clear; i := lTable.SearchFieldSorted('11',{RELATION_ID}ndx); lTable.ToDocVariant(i,variant(doc)); V := doc.Value['PHONE']; check(V='1234'); finally lTable.Free; end; end; {$endif LVCL} procedure TTestLowLevelTypes.RTTI; var i: Integer; tmp: RawUTF8; auto: TPersistentAutoCreateFieldsTest; s: TSynLogInfos; astext: boolean; P: PUTF8Char; eoo: AnsiChar; e: TEmoji; begin check(EMOJI_UTF8[eNone]=''); checkEqual(BinToHex(EMOJI_UTF8[eGrinning]),'F09F9880'); checkEqual(BinToHex(EMOJI_UTF8[ePray]),'F09F998F'); check(EmojiFromText(Pointer(EMOJI_UTF8[eGrinning]),4)=eNone); check(EmojiFromText(nil,0)=eNone); checkEqual(EmojiToDots('toto'),'toto'); for e := low(e) to high(e) do begin check(EmojiFromText(pointer(EMOJI_TEXT[e]),length(EMOJI_TEXT[e]))=e); if e=eNone then continue; check(length(EMOJI_UTF8[e])=4); P := Pointer(EMOJI_UTF8[e]); checkEqual(NextUTF8UCS4(P),$1f5ff+ord(e)); FormatUTF8(':smile % ok',[EMOJI_TAG[e]],tmp); P := pointer(tmp); check(EmojiParseDots(P)=eNone); check(IdemPChar(P,'SMILE :')); inc(P,6); check(P^=':'); check(EmojiParseDots(P)=e); check(IdemPChar(P,' OK')); checkEqual(EmojiToDots(EMOJI_UTF8[e]),EMOJI_TAG[e]); checkEqual(EmojiToDots(' '+EMOJI_UTF8[e]+' '),' '+EMOJI_TAG[e]+' '); checkEqual(EmojiToDots(EmojiFromDots(tmp)),tmp); end; tmp := ':) :( :JoY: :o :|'; P := pointer(tmp); check(EmojiParseDots(P)=eSmiley); check(P^=' '); inc(P); check(EmojiParseDots(P)=eFrowning); check(IdemPChar(P,' :JOY:')); inc(P); check(EmojiParseDots(P)=eJoy); check(P^=' '); inc(P); check(EmojiParseDots(P)=eOpen_mouth); check(P^=' '); inc(P); check(EmojiParseDots(P)=eExpressionless); check(P^=#0); with PTypeInfo(TypeInfo(TSynLogInfo))^.EnumBaseType^ do for i := 0 to integer(high(TSynLogInfo)) do begin {$ifdef VERBOSE}writeln(i,' ',GetEnumName(i)^, ' ',GetEnumNameTrimed(i));{$endif} tmp := GetEnumNameTrimed(i); Check(GetEnumNameValue(GetEnumName(i)^)=i); Check(GetEnumNameTrimedValue(tmp)=i); Check(GetEnumNameTrimedValue(pointer(tmp))=i); Check(GetEnumNameValue(tmp)=i); Check(GetEnumNameValue(pointer(tmp))=i); Check(GetEnumNameValue(SynCommons.GetEnumName(TypeInfo(TSynLogInfo),i)^)=i); Check(SynCommons.GetEnumNameValue(TypeInfo(TSynLogInfo),pointer(tmp),length(tmp),true)=i); tmp := GetEnumName(i)^; Check(SynCommons.GetEnumNameValue(TypeInfo(TSynLogInfo),pointer(tmp),length(tmp))=i); end; for astext := false to true do begin integer(s) := 0; for i := -1 to ord(high(TSynLogInfo)) do begin if i>=0 then SetBit(s,i); tmp := SaveJSON(s,TypeInfo(TSynLogInfos),astext); if astext then case i of -1: Check(tmp='[]'); 0: Check(tmp='["sllNone"]'); else if i=ord(high(TSynLogInfo)) then Check(tmp='["*"]'); end else Check(GetCardinal(pointer(tmp))=cardinal(s)); tmp := tmp+','; // mimics GetJsonField layout P := pointer(tmp); eoo := ' '; Check(GetSetNameValue(TypeInfo(TSynLogInfos),P,eoo)=cardinal(s)); Check(eoo=','); end; end; Check(PTypeInfo(TypeInfo(TSynLogInfos))^.SetEnumType= PTypeInfo(TypeInfo(TSynLogInfo))^.EnumBaseType); with PTypeInfo(TypeInfo(TSQLRecordTest))^ do begin Check(InheritsFrom(TSQLRecordTest)); Check(InheritsFrom(TSQLRecord)); Check(not InheritsFrom(TSQLRecordPeople)); end; Check(GetDisplayNameFromClass(nil)=''); Check(GetDisplayNameFromClass(TSQLRecord)='Record'); Check(GetDisplayNameFromClass(TSQLRecordPeople)='People'); Check(GetDisplayNameFromClass(TObject)='Object'); Check(GetDisplayNameFromClass(TSQLTable)='Table'); Check(GetDisplayNameFromClass(TSynValidateRest)='ValidateRest'); Check(InternalMethodInfo(TSQLRecord,'ABC')=nil); Check(InternalMethodInfo(TSQLRestServer,'ABC')=nil); Check(InternalMethodInfo(TSQLRestServer,'STAT')<>nil); Check(InternalMethodInfo(TSQLRestServer,'stat')^.MethodAddr= TSQLRestServer.MethodAddress('STAT')); Check(InternalMethodInfo(TSQLRestServer,'timestamp')<>nil); Check(InternalMethodInfo(TSQLRestServer,'timestamp')^.MethodAddr= TSQLRestServer.MethodAddress('TIMEstamp')); auto := TPersistentAutoCreateFieldsTest.CreateFake; try Check(auto.Value1<>nil); Check(auto.Value2<>nil); tmp := ObjectToJSON(auto); Check(tmp='{"Text":"text","Value1":{"Real":1.5,"Imaginary":2.5},'+ '"Value2":{"Real":1.7,"Imaginary":2.7}}'); finally auto.Free; end; end; {$endif DELPHI5OROLDER} procedure TTestLowLevelTypes.UrlEncoding; var i: integer; s,t: RawUTF8; {$ifndef DELPHI5OROLDER} d: RawUTF8; {$endif} begin for i := 1 to 100 do begin s := RandomUTF8(i); t := UrlEncode(s); Check(UrlDecode(t)=s); {$ifndef DELPHI5OROLDER} d := 'seleCT='+t+'&where='+ {$ifndef ENHANCEDRTL}Int32ToUtf8{$else}IntToStr{$endif}(i); Check(UrlEncode(['seleCT',s,'where',i])='?'+d); {$endif DELPHI5OROLDER} end; end; {$ifndef DELPHI5OROLDER} procedure TTestLowLevelTypes._TSynTableStatement; var Stmt: TSynTableStatement; Props: TSQLRecordProperties; bits: TSQLFieldBits; withID: boolean; procedure NewStmt(const SQL: RawUTF8); begin Stmt.Free; Stmt := TSynTableStatement.Create(SQL,Props.Fields.IndexByName, Props.SimpleFieldsBits[soSelect]); Check(Stmt.SQLStatement=SQL,'Statement should be valid'); end; procedure CheckIdData(limit,offset: integer); begin Check(Stmt.TableName='tab'); Check(Stmt.Where=nil,'no WHERE clause'); Check((length(Stmt.Select)=2)and (Stmt.Select[0].Field=0) and (Props.Fields.List[Stmt.Select[1].Field-1].Name='Data')); Check(Stmt.Limit=limit); Check(Stmt.Offset=offset); end; procedure CheckWhere(isOR: Boolean); begin Check(Stmt.TableName='tab'); Check(length(Stmt.Where)=2); Check(Stmt.Where[0].Field=0); Check(Stmt.Where[0].Operator=opGreaterThanOrEqualTo); Check(Stmt.Where[0].ValueInteger=10); Check(Stmt.Where[1].JoinedOR=isOR); Check(Props.Fields.List[Stmt.Where[1].Field-1].Name='YearOfBirth'); Check(Stmt.Where[1].Operator=opGreaterThan); Check(Stmt.Where[1].ValueInteger=1600); Check(Stmt.Limit=10); Check(Stmt.Offset=20); Check((length(Stmt.Select)=2)and(Stmt.Select[1].Field=0)and (Props.Fields.List[Stmt.Select[0].Field-1].Name='Data')); Check(Stmt.OrderByField=nil); end; begin Stmt := nil; Props := TSQLRecordPeople.RecordProps; NewStmt('select * from atable'); Check(Stmt.TableName='atable'); Check(Stmt.Where=nil); Stmt.SelectFieldBits(bits,withID); Check(withID); Check(IsEqual(bits,Props.SimpleFieldsBits[soSelect])); Check(Stmt.OrderByField=nil); NewStmt('select iD,Data from tab'); CheckIdData(0,0); Check(Stmt.OrderByField=nil); NewStmt('select iD,Data from tab order by firstname'); CheckIdData(0,0); Check((length(Stmt.OrderByField)=1)and(Props.Fields.List[Stmt.OrderByField[0]-1].Name='FirstName')); Check(not Stmt.OrderByDesc); NewStmt('select iD,Data from tab order by firstname desc'); CheckIdData(0,0); Check((length(Stmt.OrderByField)=1)and(Props.Fields.List[Stmt.OrderByField[0]-1].Name='FirstName')); Check(Stmt.OrderByDesc); NewStmt('select rowid , Data from tab order by firstname , lastname desc'); CheckIdData(0,0); Check((length(Stmt.OrderByField)=2) and (Props.Fields.List[Stmt.OrderByField[0]-1].Name='FirstName') and (Props.Fields.List[Stmt.OrderByField[1]-1].Name='LastName')); Check(Stmt.OrderByDesc); NewStmt('select rowid,Data from tab order by firstname,lastname limit 10'); CheckIdData(10,0); Check((length(Stmt.OrderByField)=2) and (Props.Fields.List[Stmt.OrderByField[0]-1].Name='FirstName') and (Props.Fields.List[Stmt.OrderByField[1]-1].Name='LastName')); Check(not Stmt.OrderByDesc); NewStmt('select rowid,Data from tab group by firstname order by firstname,lastname'); CheckIdData(0,0); Check((length(Stmt.GroupByField)=1) and (Props.Fields.List[Stmt.GroupByField[0]-1].Name='FirstName')); Check((length(Stmt.OrderByField)=2) and (Props.Fields.List[Stmt.OrderByField[0]-1].Name='FirstName') and (Props.Fields.List[Stmt.OrderByField[1]-1].Name='LastName')); NewStmt('select rowid,Data from tab group by firstname,lastname limit 10'); CheckIdData(10,0); Check((length(Stmt.GroupByField)=2) and (Props.Fields.List[Stmt.GroupByField[0]-1].Name='FirstName') and (Props.Fields.List[Stmt.GroupByField[1]-1].Name='LastName')); Check(not Stmt.OrderByDesc); NewStmt('select iD,Data from tab limit 20'); CheckIdData(20,0); Check(Stmt.OrderByField=nil); Check(not Stmt.OrderByDesc); NewStmt('select iD,Data from tab offset 20'); CheckIdData(0,20); Check(Stmt.OrderByField=nil); Check(not Stmt.OrderByDesc); NewStmt('select data,iD from tab where id >= 10 limit 10 offset 20 order by firstname desc'); Check(Stmt.TableName='tab'); Check(length(Stmt.Where)=1); Check(Stmt.Where[0].Field=0); Check(Stmt.Where[0].Operator=opGreaterThanOrEqualTo); Check(Stmt.Where[0].ValueInteger=10); Check(Stmt.Limit=10); Check(Stmt.Offset=20); Check((length(Stmt.Select)=2)and(Stmt.Select[1].Field=0)and (Props.Fields.List[Stmt.Select[0].Field-1].Name='Data')); Check((length(Stmt.OrderByField)=1)and(Props.Fields.List[Stmt.OrderByField[0]-1].Name='FirstName')); Check(Stmt.OrderByDesc); NewStmt('select iD,Data from tab where id in (1, 2, 3)'); Check(Stmt.TableName='tab'); Check(length(Stmt.Where)=1); Check(Stmt.Where[0].Field=0); Check(Stmt.Where[0].Operator=opIn); Check(Stmt.Where[0].Value='[1,2,3]'); Check(Stmt.OrderByField=nil); NewStmt('select iD,Data from tab where firstname in ( ''a'' , ''b'', ''3'' ) order by id desc'); Check(Stmt.TableName='tab'); Check(length(Stmt.Where)=1); Check(Props.Fields.List[Stmt.Where[0].Field-1].Name='FirstName'); Check(Stmt.Where[0].Operator=opIn); Check(Stmt.Where[0].Value='["a","b","3"]'); Check((length(Stmt.OrderByField)=1)and(Stmt.OrderByField[0]=0)); Check(Stmt.OrderByDesc); NewStmt('select data,iD from tab where id >= 10 and YearOfBirth > 1600 limit 10 offset 20'); CheckWhere(false); NewStmt('select data,iD from tab where rowid>=10 or YearOfBirth>1600 offset 20 limit 10'); CheckWhere(true); NewStmt('select data,iD from tab where id <> 100 or data is not null limit 20 offset 10'); Check(Stmt.TableName='tab'); Check(length(Stmt.Where)=2); Check(Stmt.Where[0].Field=0); Check(Stmt.Where[0].Operator=opNotEqualTo); Check(Stmt.Where[0].ValueInteger=100); Check(Stmt.Where[1].JoinedOR); Check(Props.Fields.List[Stmt.Where[1].Field-1].Name='Data'); Check(Stmt.Where[1].Operator=opIsNotNull); Check(Stmt.Limit=20); Check(Stmt.Offset=10); Check((length(Stmt.Select)=2)and(Stmt.Select[1].Field=0)and (Props.Fields.List[Stmt.Select[0].Field-1].Name='Data')); Check(Stmt.OrderByField=nil); NewStmt('select data,iD from tab where firstname like "monet" or data is null limit 20 offset 10'); Check(Stmt.TableName='tab'); Check(length(Stmt.Where)=2); Check(Props.Fields.List[Stmt.Where[0].Field-1].Name='FirstName'); Check(Stmt.Where[0].Operator=opLike); Check(Stmt.Where[0].Value='monet'); Check(Stmt.Where[1].JoinedOR); Check(Props.Fields.List[Stmt.Where[1].Field-1].Name='Data'); Check(Stmt.Where[1].Operator=opIsNull); Check(Stmt.Limit=20); Check(Stmt.Offset=10); Check((length(Stmt.Select)=2)and(Stmt.Select[1].Field=0)and (Props.Fields.List[Stmt.Select[0].Field-1].Name='Data')); Check(Stmt.OrderByField=nil); NewStmt('select count(*) from tab'); Check(Stmt.TableName='tab'); Check(Stmt.Where=nil); Check((length(Stmt.Select)=1)and(Stmt.Select[0].Field=0)); Check((length(Stmt.Select)=1)and(Stmt.Select[0].FunctionName='count')); Check(Stmt.Limit=0); NewStmt('select count(*) from tab limit 10'); Check(Stmt.TableName='tab'); Check(Stmt.Where=nil); Check((length(Stmt.Select)=1)and(Stmt.Select[0].Field=0)); Check((length(Stmt.Select)=1)and(Stmt.Select[0].FunctionName='count')); Check(Stmt.Limit=10); NewStmt('select count(*) from tab where yearofbirth>1000 limit 10'); Check(Stmt.TableName='tab'); Check(length(Stmt.Where)=1); Check(Props.Fields.List[Stmt.Where[0].Field-1].Name='YearOfBirth'); Check(Stmt.Where[0].Operator=opGreaterThan); Check(Stmt.Where[0].ValueInteger=1000); Check((length(Stmt.Select)=1)and(Stmt.Select[0].Field=0)); Check((length(Stmt.Select)=1)and(Stmt.Select[0].FunctionName='count')); Check(Stmt.Limit=10); NewStmt('select distinct ( yearofdeath ) from tab where yearofbirth > :(1000): limit 20'); Check(Stmt.TableName='tab'); Check(length(Stmt.Where)=1); Check(Props.Fields.List[Stmt.Where[0].Field-1].Name='YearOfBirth'); Check(Stmt.Where[0].Operator=opGreaterThan); Check(Stmt.Where[0].ValueInteger=1000); Check((length(Stmt.Select)=1) and (Props.Fields.List[Stmt.Select[0].Field-1].Name='YearOfDeath')); Check((length(Stmt.Select)=1) and (Stmt.Select[0].FunctionName='distinct')); Check(Stmt.Limit=20); NewStmt('select id from tab where id>:(1): and integerdynarraycontains ( yearofbirth , :(10): ) '+ 'order by firstname desc limit 20'); Check(Stmt.TableName='tab'); Check((length(Stmt.Select)=1) and (Stmt.Select[0].Field=0) and (Stmt.Select[0].Alias='')); Check(length(Stmt.Where)=2); Check(Stmt.Where[0].Field=0); Check(Stmt.Where[0].Operator=opGreaterThan); Check(Stmt.Where[0].ValueInteger=1); Check(Props.Fields.List[Stmt.Where[1].Field-1].Name='YearOfBirth'); Check(Stmt.Where[1].FunctionName='INTEGERDYNARRAYCONTAINS'); Check(Stmt.Where[1].ValueInteger=10); Check(Stmt.Where[1].Operator=opContains); Check((length(Stmt.OrderByField)=1)and(Props.Fields.List[Stmt.OrderByField[0]-1].Name='FirstName')); Check(Stmt.OrderByDesc); Check(Stmt.Limit=20); NewStmt('select max(yearofdeath) as maxYOD from tab where yearofbirth > :(1000):'); Check(Stmt.TableName='tab'); Check((length(Stmt.Select)=1) and (Props.Fields.List[Stmt.Select[0].Field-1].Name='YearOfDeath') and (Stmt.Select[0].Alias='maxYOD') and (Stmt.Select[0].ToBeAdded=0)); Check(length(Stmt.Where)=1); Check(Props.Fields.List[Stmt.Where[0].Field-1].Name='YearOfBirth'); Check(Stmt.Where[0].Operator=opGreaterThan); Check(Stmt.Where[0].ValueInteger=1000); Check((length(Stmt.Select)=1) and (Props.Fields.List[Stmt.Select[0].Field-1].Name='YearOfDeath')); Check((length(Stmt.Select)=1) and (Stmt.Select[0].FunctionName='max')); Check(Stmt.Limit=0); NewStmt('select max(yearofdeath)+115 as maxYOD from tab where yearofbirth > :(1000):'); Check(Stmt.TableName='tab'); Check((length(Stmt.Select)=1) and (Props.Fields.List[Stmt.Select[0].Field-1].Name='YearOfDeath') and (Stmt.Select[0].Alias='maxYOD') and (Stmt.Select[0].ToBeAdded=115)); Check(length(Stmt.Where)=1); Check(Props.Fields.List[Stmt.Where[0].Field-1].Name='YearOfBirth'); Check(Stmt.Where[0].Operator=opGreaterThan); Check(Stmt.Where[0].ValueInteger=1000); Check((length(Stmt.Select)=1) and (Props.Fields.List[Stmt.Select[0].Field-1].Name='YearOfDeath')); Check((length(Stmt.Select)=1) and (Stmt.Select[0].FunctionName='max')); Check(Stmt.Limit=0); Stmt.Free; end; procedure TTestLowLevelTypes._TSynMonitorUsage; var id: TSynMonitorUsageID; now,id2: TTimelog; n: TTimeLogBits absolute now; i: integer; s,s2: RawUTF8; begin id.Value := 0; now := TimeLogNowUTC and not pred(1 shl 12); // truncate to hour resolution id.FromTimeLog(now); s := n.Text(true); id2 := id.ToTimeLog; s2 := id.Text(true); Check(id2=now); Check(s2=s); for i := 1 to 200 do begin n.From(n.ToDateTime+Random*50); now := now and not pred(1 shl 12); s := n.Text(true); id.SetTime(mugYear,n.Year); id.SetTime(mugMonth,n.Month); id.SetTime(mugDay,n.Day); id.SetTime(mugHour,n.Hour); id2 := id.ToTimeLog; s2 := id.Text(true); Check(id2=now); Check(s2=s); Check(id.Granularity=mugHour); id.From(n.Year,n.Month,n.Day); Check(id.Granularity=mugDay); id.From(n.Year,n.Month); Check(id.Granularity=mugMonth); id.From(n.Year); Check(id.Granularity=mugYear); end; end; { TTestBasicClasses } procedure TTestBasicClasses._TSQLModel; var M: TSQLModel; U: TSQLRestServerURI; begin M := TSQLModel.Create([TSQLRecordTest]); try Check(M['Test']<>nil); Check(M['Test2']=nil); Check(M['TEST']=TSQLRecordTest); finally M.Free; end; Check(U.URI=''); U.URI := 'addr:port/root'; Check(U.Address='addr'); Check(U.Port='port'); Check(U.Root='root'); U.URI := 'addr:port'; Check(U.Address='addr'); Check(U.Port='port'); Check(U.Root=''); U.URI := 'addr/root'; Check(U.Address='addr'); Check(U.Port=''); Check(U.Root='root'); U.URI := 'addr'; Check(U.Address='addr'); Check(U.Port=''); Check(U.Root=''); end; procedure TTestBasicClasses._TSQLRestServerFullMemory; var Model: TSQLModel; Server: TSQLRestServerFullMemory; {$ifdef MSWINDOWS} Client: TSQLRestClientURIMessage; {$else} // Under Linux, no windows message loop : URIDll will be used ! Client: TSQLRestClientURIDll; {$endif} R: TSQLRecordTest; Batch: TSQLRestBatch; IDs: TIDDynArray; i,j,n: integer; dummy: RawUTF8; {$ifndef NOVARIANTS} procedure CheckVariantWith(const V: Variant; const i: Integer; const offset: integer=0); begin Check(V.ID=i); Check(V.Int=i); Check(V.Test=Int32ToUtf8(i)); Check(V.Ansi=V.Test); Check(V.Unicode=V.Test); Check(V.ValFloat=i*2.5); Check(V.ValWord=i+offset); Check(V.ValDate=i+30000); Check(V.Data=V.Test); Check(DocVariantType.IsOfType(V.ValVariant)); Check(VariantSaveJson(V.ValVariant)='{"id":'+V.Test+'}'); end; var readonly: boolean; docs: variant; T: TSQLTable; {$endif} {$ifdef ISDELPHI2010} var List: TObjectList; {$endif} begin Model := TSQLModel.Create([TSQLRecordTest]); try DeleteFile('fullmem.data'); Check(not FileExists('fullmem.data')); Server := TSQLRestServerFullMemory.Create(Model,'fullmem.data',true,true); try Server.CreateMissingTables; {$ifdef MSWINDOWS} Check(Server.ExportServerMessage('fullmem')); Client := TSQLRestClientURIMessage.Create(Model,'fullmem','fullmemclient',1000); {$else} Server.ExportServer; // initialize URIRequest() with the aStatic database USEFASTMM4ALLOC := true; // getmem() is 2x faster than GlobalAlloc() Client := TSQLRestClientURIDll.Create(Model,URIRequest); {$endif} try Client.ForceBlobTransfert := true; Check(Client.ServerTimestampSynchronize); Check(Client.SetUser('User','synopse')); Client.TransactionBegin(TSQLRecordTest); R := TSQLRecordTest.Create; try for i := 1 to 99 do begin R.FillWith(i); Check(Client.Add(R,true)=i); end; Client.Commit; Check(Client.BatchStart(TSQLRecordTest,1000)); for i := 100 to 9999 do begin R.FillWith(i); Check(Client.BatchAdd(R,true,false,ALL_FIELDS)=i-100); end; Check(Client.BatchSend(IDs)=HTTP_SUCCESS); Check(Length(IDs)=9900); Check(not FileExists('fullmem.data')); Check(Client.CallBackPut('Flush','',dummy)=HTTP_SUCCESS); Check(FileExists('fullmem.data')); Check(Client.Retrieve(200,R)); R.CheckWith(self,200); finally R.Free; end; finally Client.Free; end; finally Server.Free; end; Server := TSQLRestServerFullMemory.Create(Model,'fullmem.data',true,true); try Server.CreateMissingTables; {$ifdef MSWINDOWS} Check(Server.ExportServerMessage('fullmem')); Client := TSQLRestClientURIMessage.Create(Model,'fullmem','fullmemclient',1000); {$else} Server.ExportServer; // initialize URIRequest() with the aStatic database USEFASTMM4ALLOC := true; // getmem() is 2x faster than GlobalAlloc() Client := TSQLRestClientURIDll.Create(Model,URIRequest); {$endif} try Client.ForceBlobTransfert := true; Check(Client.ServerTimestampSynchronize); Check(Client.SetUser('User','synopse')); R := TSQLRecordTest.CreateAndFillPrepare(Client,'','*'); try Check((R.FillTable<>nil) and (R.FillTable.RowCount=9999)); i := 0; while R.FillOne do begin inc(i); R.CheckWith(self,i); end; Check(i=9999); for i := 1 to 9999 do begin Check(R.FillRow(i)); R.CheckWith(self,i); end; for i := 1 to 19999 do begin j := Random32(9999)+1; Check(R.FillRow(j)); R.CheckWith(self,j); end; finally R.Free; end; {$ifdef ISDELPHI2010} List := Client.RetrieveList('*'); if not CheckFailed(List<>nil) then try Check(List.Count=9999); for R in List do R.CheckWith(self,R.IDValue); for i := 0 to List.Count-1 do begin R := List[i]; R.CheckWith(self,i+1); end; finally List.Free; end; {$endif} {$ifndef NOVARIANTS} for readonly := false to true do begin T := Client.MultiFieldValues(TSQLRecordTest,'*'); if CheckFailed(T<>nil) then Continue; Check(T.RowCount=9999); T.ToDocVariant(docs,readonly); with DocVariantData(docs)^ do for j := 0 to Count-1 do CheckVariantWith(Values[j],j+1); T.Free; end; dummy := TSynMustache.Parse( '{{#items}}'#13#10'{{Int}}={{Test}}'#13#10'{{/items}}').Render( Client.RetrieveDocVariantArray(TSQLRecordTest,'items','Int,Test')); check(IdemPChar(pointer(dummy),'1=1'#$D#$A'2=2'#$D#$A'3=3'#$D#$A'4=4')); check(Hash32(dummy)=$BC89CA72); {$endif} Check(Client.UpdateField(TSQLRecordTest,100,'ValWord',[100+10]), 'update one field of a given record'); R := TSQLRecordTest.Create(Client,100); try R.CheckWith(self,100,10); finally R.Free; end; Check(Client.UpdateField(TSQLRecordTest,100,'ValWord',[100])); R := TSQLRecordTest.Create(Client,100); try R.CheckWith(self,100); finally R.Free; end; Check(Client.UpdateField(TSQLRecordTest,'Unicode',['110'],'ValWord',[120]), 'update one field of a given record'); R := TSQLRecordTest.Create(Client,110); try R.CheckWith(self,110,10); Batch := TSQLRestBatch.Create(Server,TSQLRecordTest,30); try for i := 10000 to 10099 do begin R.FillWith(i); Check(Batch.Add(R,true,false,ALL_FIELDS)=i-10000); end; Check(Server.BatchSend(Batch,IDs)=HTTP_SUCCESS); finally Batch.Free; end; finally R.Free; end; Check(Length(IDs)=100); R := TSQLRecordTest.CreateAndFillPrepare(Server,'','*'); try i := 0; while R.FillOne do begin inc(i); if i=110 then R.CheckWith(self,i,10) else R.CheckWith(self,i); {$ifdef NOVARIANTS} // FillPrepare([200,300]) below not available if (i=200) or (i=300) then begin R.FillWith(R.ID+10); Check(Client.Update(R,'ValWord,ValDate'),'update only 2 fields'); end; {$endif} end; Check(i=10099); finally R.Free; end; {$ifndef NOVARIANTS} // SELECT .. IN ... is implemented via a TDocVariant R := TSQLRecordTest.CreateAndFillPrepare(Client,[200,300],'ValWord,ValDate,ID'); try i := 0; while R.FillOne do begin inc(i); Check(R.ID>=200); R.FillWith(R.ID+10); Check(Client.Update(R,'ValWord,ValDate'),'update only 2 fields'); end; Check(i=2); finally R.Free; end; {$endif} n := 20000; R := TSQLRecordTest.create; try for i := 10100 to n do begin R.FillWith(i); Check(Server.AddWithBlobs(R,false)=i); end; finally R.Free; end; CheckEqual(Server.TableRowCount(TSQLRecordTest),n); for i := 1 to n do if i and 511=0 then begin Check(Server.Delete(TSQLRecordTest,i)); dec(n); end; CheckEqual(Server.TableRowCount(TSQLRecordTest),n); for i := 1 to n do Check(Server.MemberExists(TSQLRecordTest,i)=(i and 511<>0)); R := TSQLRecordTest.CreateAndFillPrepare(Server,'','*'); try i := 0; while R.FillOne do begin inc(i); if i and 511=0 then inc(i); if i=110 then R.CheckWith(self,i,10) else if (i=200) or (i=300) then begin Check(R.Int=i); Check(R.Test=Int32ToUtf8(i)); Check(R.ValFloat=i*2.5); Check(R.ValWord=i+10); Check(R.ValDate=i+30010); end else R.CheckWith(self,i); end; Check(i=20000); finally R.Free; end; finally Client.Free; end; finally Server.Free; end; finally Model.Free; end; end; procedure TTestBasicClasses._TSQLRecord; var i: integer; P: PPropInfo; s,s1,s2: RawUTF8; M: TSQLModel; T,T2: TSQLRecordTest; {$ifndef LVCL} s3: RawUTF8; bin: RawByteString; valid: boolean; {$endif} {$ifndef NOVARIANTS} obj: Variant; {$endif} begin Check(isSelect('select * from toto')); Check(isSelect(' select * from toto')); Check(isSelect('vacuum')); Check(isSelect(' vacuum')); Check(isSelect('pragma')); Check(isSelect(' pragma')); Check(isSelect('with recursive cnt(x) as (values(1) union all '+ 'select x+1 from cnt where x<1000000) select x from cnt')); Check(not isSelect('update toto')); Check(not isSelect(' update toto')); Check(not isSelect('insert into toto')); Check(not isSelect(' insert into toto')); Check(not isSelect('delete from toto')); Check(not isSelect(' delete from toto')); Check(not isSelect('with recursive cnt(x) as (values(1) union all '+ 'select x+1 from cnt where x<1000000) insert into toto select x from cnt')); Check(GetTableNameFromSQLSelect('select a,b from titi',false)='titi'); Check(GetTableNameFromSQLSelect('select a,b from titi limit 10',false)='titi'); Check(GetTableNameFromSQLSelect('select a,b from titi,tutu',false)='titi'); Check(GetTableNameFromSQLSelect('select a,b from titi,tutu order by a',false)='titi'); Check(GetTableNameFromSQLSelect('select a,b from titi,tutu',true)=''); Check(RawUTF8ArrayToCSV(GetTableNamesFromSQLSelect( 'select a,b from titi where id=2'))='titi'); Check(RawUTF8ArrayToCSV(GetTableNamesFromSQLSelect( 'select a,b from titi,tutu'))='titi,tutu'); Check(RawUTF8ArrayToCSV(GetTableNamesFromSQLSelect( 'select a,b from titi, tutu , tata where a=2'))='titi,tutu,tata'); T := TSQLRecordTest.Create; M := TSQLModel.Create([TSQLRecordTest]); for i := 0 to InternalClassPropInfo(TSQLRecordTest,P)-1 do begin Check(TSQLRecordTest.RecordProps.Fields.IndexByName(RawUTF8(P^.Name))=i); Check(T.RecordProps.Fields.ByRawUTF8Name(RawUTF8(P^.Name))<>nil); P := P^.Next; end; s := TSQLRecordTest.GetSQLCreate(M); Check(s='CREATE TABLE Test(ID INTEGER PRIMARY KEY AUTOINCREMENT, Int INTEGER, '+ 'Test TEXT COLLATE SYSTEMNOCASE, Unicode TEXT COLLATE SYSTEMNOCASE, '+ 'Ansi TEXT COLLATE NOCASE, ValFloat FLOAT, ValWord INTEGER, '+ 'ValDate TEXT COLLATE ISO8601, Next INTEGER, Data BLOB'+ {$ifndef NOVARIANTS}', ValVariant TEXT COLLATE BINARY'+{$endif}');'); s := TSQLRecordTest.RecordProps.SQLAddField(0); Check(s='ALTER TABLE Test ADD COLUMN Int INTEGER; '); s := TSQLRecordTest.RecordProps.SQLAddField(1000); Check(s=''); T2 := TSQLRecordTest.Create; try Check(T.RecordProps.SQLTableName='Test'); Check(T.SQLTableName='Test'); Check(GetCaptionFromClass(T.RecordClass)='Record test'); s := T.GetSQLSet; Check(s='Int=0, Test='''', Unicode='''', Ansi='''', ValFloat=0, ValWord=0, '+ 'ValDate='''', Next=0'{$ifndef NOVARIANTS}+', ValVariant=null'{$endif}); s := T.GetSQLValues; Check(s='Int,Test,Unicode,Ansi,ValFloat,ValWord,ValDate,Next'+ {$ifndef NOVARIANTS}',ValVariant'+{$endif} ' VALUES (0,'''','''','''',0,0,'''',0'+{$ifndef NOVARIANTS}',null'+{$endif}')'); {$ifndef LVCL} s := ObjectToJSON(T); Check(s='{"ID":0,"Int":0,"Test":"","Unicode":"","Ansi":"","ValFloat":0,'+ '"ValWord":0,"ValDate":"","Next":0,"Data":"","ValVariant":null}'); {$endif} T.ValDate := 39882.888612; // a fixed date and time T.Ansi := 'abcde6ef90'; T.fAnsi[6] := #$E9; T.fAnsi[9] := #$E0; T.fAnsi[10] := #$E9; T.Test := WinAnsiToUTF8(T.Ansi); T.Unicode := Utf8DecodeToRawUnicode(T.fTest); Check(RawUnicodeToWinAnsi(T.fUnicode)=T.fAnsi); // the same string is stored with some Delphi types, but will remain // identical in UTF-8 SQL, as all will be converted into UTF-8 T.Valfloat := 3.141592653; T.ValWord := 1203; {$ifndef NOVARIANTS} T.ValVariant := 3.1416; // will be stored as TEXT, i.e. '3.1416' {$endif} s := T.GetSQLSet; Check(s='Int=0, Test='''+T.Test+''', Unicode='''+T.Test+ ''', Ansi='''+T.Test+''', ValFloat=3.141592653, ValWord=1203, '+ 'ValDate=''2009-03-10T21:19:36'', Next=0'{$ifndef NOVARIANTS}+ ', ValVariant=''3.1416'''{$endif}); s := T.GetSQLValues; {$ifndef NOVARIANTS} Check(Hash32(s)=$2D344A5E); {$else} Check(Hash32(s)=$6DE61E87); {$endif} s := T.GetJSONValues(false,true,soSelect); s1 := '{"fieldCount":'+{$ifndef NOVARIANTS}'10'{$else}'9'{$endif}+ ',"values":["RowID","Int","Test","Unicode","Ansi",'+ '"ValFloat","ValWord","ValDate","Next"'{$ifndef NOVARIANTS}+ ',"ValVariant"'{$endif}+',0,0,"'+T.Test+'","'+ T.Test+'","'+T.Test+'",3.141592653,1203,"2009-03-10T21:19:36",0' {$ifndef NOVARIANTS}+',3.1416'{$endif}+']}'; CheckEqual(s,s1); Check(T.SameValues(T)); Check(not T.SameValues(T2)); T2.FillFrom(s); Check(T.SameValues(T2)); Check(T2.GetJSONValues(false,true,soSelect)=s); T.fID := 10; s := T.GetJSONValues(true,true,soSelect); {$ifdef VERBOSE}writeln(s);{$endif} T2.ClearProperties; Check(not T.SameValues(T2)); T2.FillFrom(s); Check(T.SameValues(T2)); Check(T2.GetJSONValues(true,true,soSelect)=s); {$ifndef NOVARIANTS} obj := T.GetSimpleFieldsAsDocVariant; s3 := VariantSaveJSON(obj); Check(s3=s); {$endif} {$ifndef LVCL} s := ObjectToJSON(T); Check(s='{"ID":10,"Int":0,"Test":"'+T.Test+'","Unicode":"'+T.Test+ '","Ansi":"'+T.Test+'","ValFloat":3.141592653,"ValWord":1203,'+ '"ValDate":"2009-03-10T21:19:36","Next":0,"Data":""'{$ifndef NOVARIANTS} +',"ValVariant":3.1416'{$endif}+'}'); T2.ClearProperties; Check(not T.SameValues(T2)); Check(JSONToObject(T2,pointer(s),valid)=nil); Check(valid); Check(T.SameValues(T2)); {$endif} T.Int := 1234567890123456; s := T.GetJSONValues(true,true,soSelect); Check(s='{"RowID":10,"Int":1234567890123456,"Test":"'+T.Test+'","Unicode":"'+T.Test+ '","Ansi":"'+T.Test+'","ValFloat":3.141592653,"ValWord":1203,'+ '"ValDate":"2009-03-10T21:19:36","Next":0'+ {$ifndef NOVARIANTS}',"ValVariant":3.1416'+{$endif}'}'); T2.ClearProperties; Check(not T.SameValues(T2)); T2.FillFrom(s); Check(T.SameValues(T2)); Check(T2.GetJSONValues(true,true,soSelect)=s); Check(T2.Int=1234567890123456); {$ifndef NOVARIANTS} T.ValVariant := UTF8ToSynUnicode(T.Test); {$endif} s := T.GetJSONValues(true,true,soSelect); s1 := '{"RowID":10,"Int":1234567890123456,"Test":"'+T.Test+'","Unicode":"'+T.Test+ '","Ansi":"'+T.Test+'","ValFloat":3.141592653,"ValWord":1203,'+ '"ValDate":"2009-03-10T21:19:36","Next":0'; Check(s=s1{$ifndef NOVARIANTS}+',"ValVariant":"'+T.Test+'"'{$endif}+'}'); s := T.GetSQLSet; s2 := 'Int=1234567890123456, Test='''+T.Test+''', Unicode='''+T.Test+ ''', Ansi='''+T.Test+''', ValFloat=3.141592653, ValWord=1203, '+ 'ValDate=''2009-03-10T21:19:36'', Next=0'; Check(s=s2{$ifndef NOVARIANTS}+', ValVariant='''+T.Test+''''{$endif}); {$ifndef NOVARIANTS} T.ValVariant := _JSON('{name:"John",int:1234}'); s := T.GetSQLSet; Check(s=s2+', ValVariant=''{"name":"John","int":1234}''','JSON object as text'); s := T.GetJSONValues(true,true,soSelect); Check(s=s1+',"ValVariant":{"name":"John","int":1234}}'); T2.ClearProperties; Check(not T.SameValues(T2)); T2.FillFrom(s); {$ifdef MSWINDOWS} s := VariantSaveMongoJSON(T2.ValVariant,modMongoStrict); Check(s=VariantSaveMongoJSON(T.ValVariant,modMongoStrict)); Check(T.SameValues(T2)); {$endif} s := T.GetJSONValues(true,true,soSelect); Check(T2.GetJSONValues(true,true,soSelect)=s); s := GetJSONObjectAsSQL(s,true,false,0,true); Check(s=StringReplaceAll(s2,', ',',')+',ValVariant=''{"name":"John","int":1234}'''); s := ObjectToJSON(T); delete(s1,3,3); // "RowID":10 -> "ID":10 Check(s=s1+',"Data":"","ValVariant":{"name":"John","int":1234}}'); bin := T.GetBinary; T2.ClearProperties; Check(T2.SetBinary(pointer(bin),PAnsiChar(pointer(bin))+length(bin))); Check(T.SameValues(T2)); T2.ClearProperties; Check(T2.SetBinary(bin)); Check(T.SameValues(T2)); bin := VariantSave(T.ValVariant); Check(bin<>''); Check(VariantLoad(T2.fVariant,pointer(bin),@JSON_OPTIONS[true])<>nil); {$ifdef MSWINDOWS} Check(VariantSaveMongoJSON(T2.fVariant,modMongoStrict)='{"name":"John","int":1234}'); {$endif} {$endif} finally M.Free; T2.Free; T.Free; end; end; procedure TTestBasicClasses._TSQLRecordSigned; var R: TSQLRecordSigned; i: integer; Content: RawByteString; begin R := TSQLRecordSigned.Create; try for i := 1 to 50 do begin Content := RandomString(5*Random(1000)); Check(R.SetAndSignContent('User',Content)); Check(R.SignedBy='User'); Check(R.CheckSignature(Content)); Content := Content+'?'; // invalidate content Check(not R.CheckSignature(Content)); R.UnSign; end; finally R.Free; end; end; {$endif DELPHI5OROLDER} {$ifdef UNICODE} {$WARNINGS ON} // don't care about implicit string cast in tests {$endif} { TTestCompression } procedure TTestCompression.Setup; begin Data := StringFromFile(ExeVersion.ProgramFileName); end; procedure TTestCompression.CleanUp; begin FreeAndNil(M); end; const // uses a const table instead of a dynamic array, for better regression test crc32tab: array[byte] of cardinal = ($00000000, $77073096, $EE0E612C, $990951BA, $076DC419, $706AF48F, $E963A535, $9E6495A3, $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91, $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7, $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5, $3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B, $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59, $26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F, $2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D, $76DC4190, $01DB7106, $98D220BC, $EFD5102A, $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433, $7807C9A2, $0F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01, $6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457, $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65, $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB, $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9, $5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F, $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD, $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $04DB2615, $73DC1683, $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1, $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7, $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5, $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B, $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79, $CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F, $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D, $9B64C2B0, $EC63F226, $756AA39C, $026D930A, $9C0906A9, $EB0E363F, $72076785, $05005713, $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21, $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777, $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45, $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB, $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9, $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF, $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D); function UpdateCrc32(aCRC32: cardinal; inBuf: pointer; inLen: integer) : cardinal; var i: integer; begin // slowest reference version result := not aCRC32; for i := 1 to inLen do begin result := crc32tab[(result xor pByte(inBuf)^) and $ff] xor (result shr 8); inc(PByte(inBuf)); end; result := not result; end; procedure TTestCompression.GZipFormat; var Z: TSynZipCompressor; L,n: integer; P: PAnsiChar; crc2: Cardinal; st: TRawByteStringStream; s,tmp: RawByteString; gzr: TGZRead; begin Check(crc32(0,@crc32tab,5)=$DF4EC16C,'crc32'); Check(UpdateCrc32(0,@crc32tab,5)=$DF4EC16C,'crc32'); Check(crc32(0,@crc32tab,1024)=$6FCF9E13,'crc32'); Check(UpdateCrc32(0,@crc32tab,1024)=$6FCF9E13); Check(crc32(0,@crc32tab,1024-5)=$70965738,'crc32'); Check(UpdateCrc32(0,@crc32tab,1024-5)=$70965738); Check(crc32(0,pointer(PtrInt(@crc32tab)+1),2)=$41D912FF,'crc32'); Check(UpdateCrc32(0,pointer(PtrInt(@crc32tab)+1),2)=$41D912FF); Check(crc32(0,pointer(PtrInt(@crc32tab)+3),1024-5)=$E5FAEC6C,'crc32'); Check(UpdateCrc32(0,pointer(PtrInt(@crc32tab)+3),1024-5)=$E5FAEC6C,'crc32'); M := SynCommons.THeapMemoryStream.Create; Z := TSynZipCompressor.Create(M,6,szcfGZ); L := length(Data); P := Pointer(Data); crc0 := 0; crc2 := 0; while L<>0 do begin if L>1000 then n := 1000 else n := L; Z.Write(P^,n); // compress by little chunks to test streaming crc0 := crc32(crc0,P,n); crc2 := UpdateCrc32(crc2,P,n); inc(P,n); dec(L,n); end; Check(crc0=Z.CRC,'crc32'); Check(crc2=crc0,'crc32'); Z.Free; Check(GZRead(M.Memory,M.Position)=Data,'gzread'); crc1 := crc32(0,M.Memory,M.Position); s := Data; Check(CompressGZip(s,true)='gzip'); Check(CompressGZip(s,false)='gzip'); Check(s=Data,'compressGZip'); Check(gzr.Init(M.Memory,M.Position),'TGZRead'); Check(gzr.uncomplen32=Cardinal(length(data))); Check(gzr.crc32=crc0); Check(gzr.ToMem=data,'ToMem'); st := TRawByteStringStream.Create; try Check(gzr.ToStream(st),'ToStream'); s := st.DataString; Check(s=Data,'ToStream?'); finally st.Free; end; SetLength(tmp,gzr.uncomplen32 div 5); Check(gzr.ZStreamStart(pointer(tmp),length(tmp)),'ZStreamStart'); s := ''; repeat n := gzr.ZStreamNext; if n=0 then break; s := s+copy(tmp,1,n); until false; check(gzr.ZStreamDone,'ZStreamDone'); Check(gzr.uncomplen32=Cardinal(length(s))); check(s=Data); s := Data; Check(CompressDeflate(s,true)='deflate'); Check(CompressDeflate(s,false)='deflate'); Check(s=Data,'CompressDeflate'); end; procedure TTestCompression.InMemoryCompression; var comp: Integer; tmp: RawByteString; begin Check(CRC32string('TestCRC32')=$2CB8CDF3); tmp := RawByteString(Ident); for comp := 0 to 9 do Check(UnCompressString(CompressString(tmp,False,comp))=tmp); Check(UnCompressString(CompressString(Data,False,6))=Data); end; procedure TTestCompression.ZipFormat; var FN,FN2: TFileName; ExeName: string; S: TRawByteStringStream; procedure Test(Z: TZipRead; aCount: integer); var i: integer; tmp: RawByteString; tmpFN: TFileName; info: TFileInfo; begin with Z do try Check(Count=aCount,'count'); i := NameToIndex('REP1\ONE.exe'); Check(i=0,'0'); FillcharFast(info,sizeof(info),0); Check(RetrieveFileInfo(i,info),'info'); Check(integer(info.zfullSize)=length(Data),'siz'); Check(info.zcrc32=crc0,'crc0'); Check(UnZip(i)=Data,'unzip1'); i := NameToIndex('REp2\ident.gz'); Check(i=1,'unzip2'); Check(Entry[i].infoLocal^.zcrc32=crc1,'crc1a'); tmp := UnZip(i); Check(tmp<>'','unzip3'); Check(crc32(0,pointer(tmp),length(tmp))=crc1,'crc1b'); i := NameToIndex(ExeName); Check(i=2,'unzip4'); Check(UnZip(i)=Data,'unzip6'); Check(Entry[i].infoLocal^.zcrc32=info.zcrc32,'crc32'); i := NameToIndex('REp2\ident2.gz'); Check(i=3,'unzip5'); Check(Entry[i].infoLocal^.zcrc32=crc1,'crc1c'); tmp := UnZip(i); Check(tmp<>'','unzip7'); Check(crc32(0,pointer(tmp),length(tmp))=crc1,'crc1d'); if aCount=4 then Exit; i := NameToIndex('REP1\twO.exe'); Check(i=4,'unzip8'); Check(UnZip(i)=Data,'unzip9'); tmpFN := 'TestSQL3zipformat.tmp'; Check(UnZip('REP1\one.exe',tmpFN,true),'unzipa'); Check(StringFromFile(tmpFN)=Data,'unzipb'); Check(DeleteFile(tmpFN),'unzipc'); finally Free; end; end; procedure Prepare(Z: TZipWriteAbstract); begin with Z do try AddDeflated('rep1\one.exe',pointer(Data),length(Data)); Check(Count=1,'cnt1'); AddDeflated('rep2\ident.gz',M.Memory,M.Position); Check(Count=2,'cnt2'); if Z is TZipWrite then TZipWrite(Z).AddDeflated(ExeVersion.ProgramFileName) else Z.AddDeflated(ExeName,pointer(Data),length(Data)); Check(Count=3,'cnt3'); AddStored('rep2\ident2.gz',M.Memory,M.Position); Check(Count=4,'cnt4'); finally Free; end; end; {$ifdef MSWINDOWS} procedure TestPasZipRead(const FN: TFileName; Count: integer); var pasZR: PasZip.TZipRead; begin pasZR := PasZip.TZipRead.Create(FN); try Check(pasZR.Count=Count,'paszip1'); Check(pasZR.NameToIndex('rep1\ONE.exe')=0,'paszip2'); Check(pasZR.UnZip(0)=data,'paszip3'); finally pasZR.Free; end; end; var pasZW: PasZip.TZipWrite; {$endif} var i: integer; begin ExeName := ExtractFileName(ExeVersion.ProgramFileName); FN := ChangeFileExt(ExeVersion.ProgramFileName,'.zip'); Prepare(TZipWrite.Create(FN)); Test(TZipRead.Create(FN),4); S := TRawByteStringStream.Create; try Prepare(TZipWriteToStream.Create(S)); Test(TZipRead.Create(pointer(S.DataString),length(S.DataString)),4); finally S.Free; end; with TZipWrite.CreateFrom(FN) do try Check(Count=4,'two4'); AddDeflated('rep1\two.exe',pointer(Data),length(Data)); Check(Count=5,'two5'); finally Free; end; Test(TZipRead.Create(FN),5); {$ifdef MSWINDOWS} TestPasZipRead(FN,5); FN2 := ChangeFileExt(FN,'2.zip'); pasZW := PasZip.TZipWrite.Create(FN2); try pasZW.AddDeflated('rep1\one.exe',pointer(Data),length(Data)); Check(pasZW.Count=1,'paszipA'); pasZW.AddDeflated('rep2\ident.gz',M.Memory,M.Position); Check(pasZW.Count=2,'paszipB'); pasZW.AddDeflated(ExeVersion.ProgramFileName); Check(pasZW.Count=3,'paszipC'); pasZW.AddStored('rep2\ident2.gz',M.Memory,M.Position); Check(pasZW.Count=4,'paszipD'); finally pasZW.Free; end; TestPasZipRead(FN2,4); DeleteFile(FN2); {$endif} DeleteFile(FN); FN2 := ExeVersion.ProgramFilePath+'ddd.zip'; with TZipWrite.Create(FN2) do try FN := ExeVersion.ProgramFilePath+'ddd'; if not DirectoryExists(FN) then FN := ExeVersion.ProgramFilePath+'..'+PathDelim+'ddd'; if DirectoryExists(FN) then begin AddFolder(FN,'*.pas'); Check(Count>10); for i := 0 to Count-1 do Check(SameText(ExtractFileExt(Ansi7ToString(Entry[i].intName)),'.pas'),'ddd'); end; finally Free; end; DeleteFile(FN2); end; procedure TTestCompression._SynLZO; var s,t: AnsiString; i: integer; begin for i := 0 to 1000 do begin t := RandomString(i*8); s := t; Check(CompressSynLZO(s,true)='synlzo'); Check(CompressSynLZO(s,false)='synlzo'); Check(s=t); end; s := Data; Check(CompressSynLZO(s,true)='synlzo'); Check(CompressSynLZO(s,false)='synlzo'); Check(s=Data); end; function Spaces(n: integer): RawUTF8; begin SetString(result,nil,n); FillCharFast(pointer(result)^,n,32); end; function By4(pattern,n: integer): RawUTF8; var i: integer; begin SetString(result,nil,n*4); for i := 0 to n-1 do PIntegerArray(result)[i] := pattern; end; procedure TTestCompression._SynLZ; var s,t,rle: RawByteString; i,j, complen2: integer; comp2,dec1: array of byte; {$ifdef CPUINTEL} comp1,dec2: array of byte; complen1: integer; {$endif} begin for i := 1 to 200 do begin s := SynLZCompress(StringOfChar(AnsiChar(i),i)); t := SynLZDecompress(s); Check(t=StringOfChar(AnsiChar(i),i)); end; rle := 'hello'+Spaces(10000)+'hello'+Spaces(1000)+'world'; s := SynLZCompress(rle); t := SynLZDecompress(s); Check(t=rle); rle := 'hello'+by4($3031333,10000)+'hello'+by4($3031333,1000)+'world'; s := SynLZCompress(rle); t := SynLZDecompress(s); Check(t=rle); for i := 0 to 1000 do begin s := StringOfChar(AnsiChar(' '),20); t := RandomTextParagraph(i, '.', s); SetString(s,PAnsiChar(pointer(t)),length(t)); // =UniqueString Check(CompressSynLZ(s,true)='synlz'); Check(CompressSynLZ(s,false)='synlz'); Check(s=t); Check(SynLZDecompress(SynLZCompress(s))=t); SetLength(comp2,SynLZcompressdestlen(length(s))); complen2 := SynLZcompress1pas(Pointer(s),length(s),pointer(comp2)); Check(complen2'' then s := log else s := RandomTextParagraph(i*8); timer.Start; t := algo.Compress(s); inc(timecomp, timer.StopInMicroSec); timer.Start; s2 := algo.Decompress(t,aclNoCrcFast); inc(timedecomp, timer.StopInMicroSec); Check(s2=s, algo.ClassName); if (log<>'') and (s2<>s) then FileFromString(s2,'bigTest'+algo.ClassName+'.log'); inc(plain, length(s)); inc(comp, length(t)); if log<>'' then break; end; AddConsole(format('%s %s->%s: comp %d:%dMB/s decomp %d:%dMB/s', [algo.ClassName, KB(plain), KB(comp), ((plain*Int64(1000*1000)) div timecomp)shr 20, ((comp*Int64(1000*1000)) div timecomp)shr 20, ((comp*Int64(1000*1000)) div timedecomp)shr 20, ((plain*Int64(1000*1000)) div timedecomp)shr 20])); s2 := algo.Decompress(algo.Compress(s),aclNoCrcFast); Check(s2=s, algo.ClassName); if (log<>'') and (s2<>s) then FileFromString(s2,'bigTestPartial'+algo.ClassName+'.log'); end; begin TestAlgo(AlgoSynLZ); Check(AlgoSynLZ.AlgoName='synlz'); {$ifdef MSWINDOWS} if (Lizard=nil) and FileExists(ExeVersion.ProgramFilePath+LIZARD_LIB_NAME) then Lizard := TSynLizardDynamic.Create; {$endif} TestAlgo(AlgoLizard); TestAlgo(AlgoLizardFast); TestAlgo(AlgoLizardHuffman); {$ifndef DELPHI5OROLDER} TestAlgo(AlgoDeflate); TestAlgo(AlgoDeflateFast); Check(AlgoDeflateFast.AlgoName ='deflatefast'); {$endif} end; { FPC Linux x86-64 (in VM) with static linked library for a 53MB log file: TAlgoSynLz 53 MB->5 MB: comp 650:62MB/s decomp 90:945MB/s TAlgoLizard 53 MB->3.9 MB: comp 55:4MB/s decomp 139:1881MB/s TAlgoLizardFast 53 MB->6.8 MB: comp 695:89MB/s decomp 196:1522MB/s TAlgoDeflate 53 MB->4.8 MB: comp 71:6MB/s decomp 48:540MB/s TAlgoDeflateFast 53 MB->7 MB: comp 142:18MB/s decomp 56:428MB/s Delphi Win64 with external lizard1-64.dll: TAlgoSynLz 53 MB->5 MB: comp 667:63MB/s decomp 103:1087MB/s TAlgoLizard 53 MB->3.9 MB: comp 61:4MB/s decomp 169:2290MB/s TAlgoLizardFast 53 MB->6.8 MB: comp 690:89MB/s decomp 263:2039MB/s TAlgoLizardHuffman 53 MB->2 MB: comp 658:25MB/s decomp 86:2200MB/s TAlgoDeflate 53 MB->4.8 MB: comp 25:2MB/s decomp 19:214MB/s TAlgoDeflateFast 53 MB->7 MB: comp 52:6MB/s decomp 23:176MB/s speed difference may come from the FPC/Delphi heap manager, and/or the Linux VM } { TTestCryptographicRoutines } procedure TTestCryptographicRoutines._Adler32; begin Check(Adler32SelfTest); end; procedure TTestCryptographicRoutines._Base64; const Value64: RawUTF8 = 'SGVsbG8gL2Mn6XRhaXQg5+Ar'; var tmp: RawByteString; b64: RawUTF8; Value: WinAnsiString; i, L: Integer; begin Value := 'Hello /c''0tait 67+'; Value[10] := #$E9; Value[16] := #$E7; Value[17] := #$E0; Check(not IsBase64(Value)); Check(SockBase64Encode(Value)=Value64); Check(BinToBase64(Value)=Value64); Check(IsBase64(Value64)); tmp := StringFromFile(ExeVersion.ProgramFileName); b64 := SockBase64Encode(tmp); Check(IsBase64(b64)); Check(SynCrtSock.SockBase64Decode(b64)=tmp); Check(BinToBase64(tmp)=b64); Check(Base64ToBin(b64)=tmp); tmp := ''; for i := 1 to 1998 do begin b64 := SockBase64Encode(tmp); Check(SynCrtSock.SockBase64Decode(b64)=tmp); Check((tmp='') or IsBase64(b64)); Check(BinToBase64(tmp)=b64); Check(Base64ToBin(b64)=tmp); if tmp<>'' then begin L := length(b64); Check(not IsBase64(pointer(b64),L-1)); b64[Random(L)+1] := '&'; Check(not IsBase64(pointer(b64),L)); end; b64 := BinToBase64uri(tmp); Check(Base64uriToBin(b64)=tmp); tmp := tmp+AnsiChar(Random(255)); end; end; {$ifdef MSWINDOWS} // same conditions as in SynCrtSock.pas {$ifndef DELPHI5OROLDER} // on Windows: enable Microsoft AES Cryptographic Provider (XP SP3 and up) {$define USE_PROV_RSA_AES} {$endif} {$endif} const TEST_AES_REF: array[0..2,0..4] of RawByteString = ( // 128-bit ('aS24Jm0RHPz26P_RHqX-pGktuCZtERz89uj_0R6l_qRpLbgmbREc_Pbo_9Eepf6kB7pVFdRAcIoVhoTQPytzTQ', 'aS24Jm0RHPz26P_RHqX-pCTLpnA2lH7fAWpovxWR8Voytqn9B_zTt6Zrt1Gjb4J5HUs6E7C9Uf4fV83SxyILCg', '0YRWak2ZiQj-cncKQ3atJtcclNgW9OiQPpY6mLvrfYQc_mORQygR9LFU2z2Prc8I5anMvOABB62Ei5AAWY8M0Q', '0YRWak2ZiQj-cncKQ3atJingGAyjpdvuFAvnZ4vDXweTPTJOFSBVUuqs9SW6vSkAyhtoFM9p-gO3IRZh227twA', '0YRWak2ZiQj-cncKQ3atJjjmhYzJAYmaqNOy9bCBqYa0YYLiSrlUwv9f4JqyVmPQg7w2zQjjdyHSCuYxA-coGQ'), // 192-bit ('3S2QhC78T0eesG3hiqtA2N0tkIQu_E9HnrBt4YqrQNjdLZCELvxPR56wbeGKq0DYJob7gbbvgBaFdm_Bwed4RQ', '3S2QhC78T0eesG3hiqtA2HNVuHHzMsrQOruEy1t6Q-AMQMszIPd_86pnqzIyzdSZut-CCacA9T5O8e8ZJKvZOQ', 'a6wXR1K29yQvbGGkawiHN1RcFhrbtbne2w13ziEURY1Btg1oqiL-BqTGtEsu4LH5wLYcGNQJ21CR58LBtRysQg', 'a6wXR1K29yQvbGGkawiHN4Cloz_9GlJhlEozeNI4MFjKwihToQP6_FDpDVHz21qUonhk6MZ9_-6vNvnGqbOTcg', 'a6wXR1K29yQvbGGkawiHN7koCYngh0WS5R-rsGy5zSaC9txKnyHDavH1tkXlWZuxTjQCNHbiAIIRYK4giZDHzA'), // 256-bit ('Kw50ybT0hl8MXw1IcBFm5isOdMm09IZfDF8NSHARZuYrDnTJtPSGXwxfDUhwEWbmn9aUUA6_ZwXpKRiFMlXRiw', 'Kw50ybT0hl8MXw1IcBFm5iV4ZAxvgHN-4j2F7ch7PWr6yHhbcp0Scqd2WDHZMRygi3thq9H3jKVo34_NPKdK1A', 'vf-UrsBFA2NkziMn6szalnw24-wbPmG9lySgx0WLZZpfkTpw2euPIm6ZkFzjFa-lqr4yngOkvW99hPGzYEAjDw', 'vf-UrsBFA2NkziMn6szalgQnKyYBxXxLhVI9s8D3cZkYsLsdfSUCTUY8moP2SenmHCWQWwaq_ibRCr4JngSkZQ', 'vf-UrsBFA2NkziMn6szalimh8XYdFObdg_TwNyfX8Zy2Dk8YVPSDzzAvZ2Xx6WP_4owC6MIq7kZ2xPZ_d6vZmg')); procedure TTestCryptographicRoutines._AES256; var A: TAES; st, orig, crypted, s2, s3: RawByteString; Key: TSHA256Digest; s,b,p: TAESBlock; i,k,ks,m, len: integer; AES: TAESFull; PC: PAnsiChar; noaesni: boolean; Timer: array[boolean] of TPrecisionTimer; ValuesCrypted,ValuesOrig: array[0..1] of RawByteString; {$ifdef CPUINTEL} backup: TIntelCpuFeatures; {$endif CPUINTEL} const MAX = 4096*1024; // test 4 MB data, i.e. multi-threaded AES MODES: array[0..6{$ifdef USE_PROV_RSA_AES}+2{$endif}] of TAESAbstractClass = (TAESECB, TAESCBC, TAESCFB, TAESOFB, TAESCTR, TAESCFBCRC, TAESOFBCRC {$ifdef USE_PROV_RSA_AES}, TAESECB_API, TAESCBC_API{$endif}); // TAESCFB_API and TAESOFB_API just do not work begin {$ifdef CPUINTEL} backup := CpuFeatures; {$endif CPUINTEL} Check(AESSelfTest(true),'Internal Tables'); SetLength(orig,MAX); SetLength(crypted,MAX+256); st := '1234essai'; PInteger(UniqueRawUTF8(RawUTF8(st)))^ := Random(MaxInt); for noaesni := false to true do begin Timer[noaesni].Init; for k := 0 to 2 do begin ks := 128+k*64; // test keysize of 128, 192 and 256 bits for m := 0 to high(MODES) do begin st := RawUTF8(StringOfChar('x',50)); with MODES[m].Create(pointer(st)^,ks) do try s2 := EncryptPKCS7(st,false); s3 := BinToBase64uri(s2); i := m; if i>=7 then // e.g. TAESECB_API -> TAESECB dec(i,7) else if i>=5 then dec(i,3); // e.g. TAESCFBCRC -> TAESCFB CheckUTF8(TEST_AES_REF[k,i]=s3,'test vector %-%',[MODES[m],ks]); check(DecryptPKCS7(s2,false)=st); finally Free; end; end; SHA256Weak(st,Key); for i := 1 to 100 do begin move(Key,s,16); A.EncryptInit(Key,ks); A.Encrypt(s,b); A.Done; A.DecryptInit(Key,ks); A.Decrypt(b,p); A.Done; Check(CompareMem(@p,@s,sizeof(p))); Check(IsEqual(p,s)); Timer[noaesni].Resume; Check(SynCrypto.AES(Key,ks,SynCrypto.AES(Key,ks,st,true),false)=st); Timer[noaesni].Pause; st := st+RandomString(4); end; PC := Pointer(orig); len := MAX; repeat // populate orig with random data if len>length(st) then i := length(st) else i := len; dec(len,i); move(pointer(st)^,PC^,i); inc(PC,i); until len=0; len := AES.EncodeDecode(Key,ks,MAX,True,nil,nil,pointer(orig),pointer(crypted)); Check(len=MAX); len := AES.EncodeDecode(Key,ks,len,False,nil,nil,pointer(crypted),nil); try Check(len=MAX); Check(CompareMem(AES.outStreamCreated.Memory,pointer(orig),MAX)); if not noaesni then begin for m := low(MODES) to high(MODES) do with MODES[m].Create(Key,ks) do try FillCharFast(pointer(@IV)^,sizeof(TAESBlock),1); //Timer.Start; for i := 0 to 256 do begin if i<64 then len := i else if i<128 then len := i*16 else len := i*32; FillCharFast(pointer(crypted)^,len,0); Encrypt(AES.outStreamCreated.Memory,pointer(crypted),len); FillCharFast(pointer(orig)^,len,0); Decrypt(pointer(crypted),pointer(orig),len); Check((len=0) or (not isZero(pointer(orig),len)) or isZero(AES.outStreamCreated.Memory,len)); Check(CompareMem(AES.outStreamCreated.Memory,pointer(orig),len)); s2 := copy(orig,1,len); Check(DecryptPKCS7(EncryptPKCS7(s2))=s2,IntToStr(len)); end; //fRunConsole := Format('%s %s%d:%s'#10,[fRunConsole,Copy(MODES[m].ClassName,5,10),ks,Timer.Stop]); if m6 then begin Check(ValuesOrig[m-7]=s2); Check(ValuesCrypted[m-7]=Copy(crypted,1,len),MODES[m].ClassName); end; finally Free; end; end; finally AES.outStreamCreated.Free; end; end; {$ifndef CPUINTEL} break; {$else} if noaesni then begin fRunConsole := format('%s cypher 1..%d bytes with AES-NI: %s, without: %s', [fRunConsole,length(st),Timer[false].Stop,Timer[true].Stop]); Include(CpuFeatures,cfAESNI); // revert Exclude() below from previous loop end; if A.UsesAESNI then Exclude(CpuFeatures,cfAESNI) else break; {$endif CPUINTEL} end; {$ifdef CPUINTEL} CpuFeatures := backup; {$endif CPUINTEL} end; procedure TTestCryptographicRoutines._CompressShaAes; var s1,s2: RawByteString; keysize,i: integer; begin for keysize := 0 to 10 do begin CompressShaAesSetKey(RandomString(keysize)); for i := 0 to 50 do begin s1 := RandomString(i*3); s2 := s1; Check(CompressShaAes(s1,true)='synshaaes'); Check(CompressShaAes(s1,false)='synshaaes'); Check(s1=s2); end; end; end; procedure TTestCryptographicRoutines._MD5; var i,n: integer; md: TMD5; dig,dig2: TMD5Digest; tmp: TByteDynArray; begin check(MD5SelfTest); check(htdigest('agent007','download area','secret')= 'agent007:download area:8364d0044ef57b3defcfa141e8f77b65'); check(MD5('')='d41d8cd98f00b204e9800998ecf8427e'); check(MD5('a')='0cc175b9c0f1b6a831c399e269772661'); check(MD5('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789')='d174ab98d277d9f5a5611c2c9f419d9f'); SetLength(tmp,256); for n := 256-80 to 256 do begin md.Init; for i := 1 to n do md.Update(tmp[0],1); md.Final(dig); md.Full(pointer(tmp),n,dig2); check(IsEqual(dig,dig2)); check(CompareMem(@dig,@dig2,sizeof(dig))); end; end; procedure TTestCryptographicRoutines._RC4; var key, s, d: RawByteString; ks, i, len: integer; rc4, ref: TRC4; begin Check(RC4SelfTest); key := RandomString(100); for ks := 1 to 10 do begin ref.InitSHA3(pointer(key)^,ks*10); for i := 0 to 100 do begin len := i*3; s := RandomAnsi7(len); SetString(d,nil,len); rc4 := ref; rc4.EncryptBuffer(pointer(s),pointer(d),len); // encrypt rc4 := ref; rc4.EncryptBuffer(pointer(d),pointer(d),len); // decrypt check(s=d); end; end; end; procedure TTestCryptographicRoutines._SHA1; procedure SingleTest(const s: AnsiString; TDig: TSHA1Digest); var SHA: TSHA1; Digest: TSHA1Digest; i: integer; begin // 1. Hash complete AnsiString SHA.Full(pointer(s),length(s),Digest); Check(CompareMem(@Digest,@TDig,sizeof(Digest))); Check(IsEqual(Digest,TDig)); // 2. one update call for all chars for i := 1 to length(s) do SHA.Update(@s[i],1); SHA.Final(Digest); Check(CompareMem(@Digest,@TDig,sizeof(Digest))); Check(IsEqual(Digest,TDig)); // 3. test consistency with Padlock engine down results {$ifdef USEPADLOCK} if not padlock_available then exit; padlock_available := false; // force PadLock engine down SHA.Full(pointer(s),length(s),Digest); Check(CompareMem(@Digest,@TDig,sizeof(Digest))); Check(IsEqual(Digest,TDig)); {$ifdef PADLOCKDEBUG} write('=padlock '); {$endif} padlock_available := true; // restore previous value {$endif} end; const Test1Out: TSHA1Digest= ($A9,$99,$3E,$36,$47,$06,$81,$6A,$BA,$3E,$25,$71,$78,$50,$C2,$6C,$9C,$D0,$D8,$9D); Test2Out: TSHA1Digest= ($84,$98,$3E,$44,$1C,$3B,$D2,$6E,$BA,$AE,$4A,$A1,$F9,$51,$29,$E5,$E5,$46,$70,$F1); DIG1 = '0c60c80f961f0e71f3a9b524af6012062fe037a6'; DIG2 = 'ea6c014dc72d6f8ccd1ed92ace1d41f0d8de8957'; DIG4096 = '4b007901b765489abead49d926f721d065a429c1'; var s: AnsiString; SHA: TSHA1; Hash: THash512Rec; Digest: TSHA1Digest absolute Hash; sign: TSynSigner; begin SingleTest('abc',Test1Out); SingleTest('abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq',Test2Out); s := 'Wikipedia, l''encyclopedie libre et gratuite'; SHA.Full(pointer(s),length(s),Digest); Check(SHA1DigestToString(Digest)='c18cc65028bbdc147288a2d136313287782b9c73'); HMAC_SHA1('','',Digest); check(SHA1DigestToString(Digest)='fbdb1d1b18aa6c08324b7d64b71fb76370690e1d'); HMAC_SHA1('key','The quick brown fox jumps over the lazy dog',Digest); check(SHA1DigestToString(Digest)='de7c9b85b8b78aa6bc8a7a36f70a90701c9db4d9'); // from https://www.ietf.org/rfc/rfc6070.txt PBKDF2_HMAC_SHA1('password','salt',1,Digest); check(SHA1DigestToString(Digest)=DIG1); PBKDF2_HMAC_SHA1('password','salt',2,Digest); check(SHA1DigestToString(Digest)=DIG2); PBKDF2_HMAC_SHA1('password','salt',4096,Digest); check(SHA1DigestToString(Digest)=DIG4096); sign.PBKDF2(saSHA1,'password','salt',1,Hash); check(SHA1DigestToString(Digest)=DIG1); sign.PBKDF2(saSHA1,'password','salt',2,Hash); check(SHA1DigestToString(Digest)=DIG2); sign.PBKDF2(saSHA1,'password','salt',4096,Hash); check(SHA1DigestToString(Digest)=DIG4096); end; procedure TTestCryptographicRoutines._SHA256; procedure DoTest; procedure SingleTest(const s: AnsiString; const TDig: TSHA256Digest); var SHA: TSHA256; Digest: TSHA256Digest; i: integer; begin // 1. Hash complete AnsiString SHA.Full(pointer(s),length(s),Digest); Check(IsEqual(Digest,TDig)); Check(CompareMem(@Digest,@TDig,sizeof(Digest))); // 2. one update call for each char SHA.Init; for i := 1 to length(s) do SHA.Update(@s[i],1); SHA.Final(Digest); Check(IsEqual(Digest,TDig)); Check(CompareMem(@Digest,@TDig,sizeof(Digest))); end; const D1: TSHA256Digest = ($ba,$78,$16,$bf,$8f,$01,$cf,$ea,$41,$41,$40,$de,$5d,$ae,$22,$23, $b0,$03,$61,$a3,$96,$17,$7a,$9c,$b4,$10,$ff,$61,$f2,$00,$15,$ad); D2: TSHA256Digest = ($24,$8d,$6a,$61,$d2,$06,$38,$b8,$e5,$c0,$26,$93,$0c,$3e,$60,$39, $a3,$3c,$e4,$59,$64,$ff,$21,$67,$f6,$ec,$ed,$d4,$19,$db,$06,$c1); D3: TSHA256Digest = ($94,$E4,$A9,$D9,$05,$31,$23,$1D,$BE,$D8,$7E,$D2,$E4,$F3,$5E,$4A, $0B,$F4,$B3,$BC,$CE,$EB,$17,$16,$D5,$77,$B1,$E0,$8B,$A9,$BA,$A3); DIG4096 = 'c5e478d59288c841aa530db6845c4c8d962893a001ce4e11a4963873aa98134a'; var Digest: THash512Rec; Digests: THash256DynArray; sign: TSynSigner; c: AnsiChar; i: integer; sha: TSHA256; begin SingleTest('abc',D1); SingleTest('abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq',D2); SHA256Weak('lagrangehommage',Digest.Lo); // test with len=256>64 Check(IsEqual(Digest.Lo,D3)); Check(CompareMem(@Digest,@D3,sizeof(Digest.Lo))); PBKDF2_HMAC_SHA256('password','salt',1,Digest.Lo); check(SHA256DigestToString(Digest.Lo)= '120fb6cffcf8b32c43e7225256c4f837a86548c92ccc35480805987cb70be17b'); PBKDF2_HMAC_SHA256('password','salt',2,Digest.Lo); check(SHA256DigestToString(Digest.Lo)= 'ae4d0c95af6b46d32d0adff928f06dd02a303f8ef3c251dfd6e2d85a95474c43'); SetLength(Digests,2); check(IsZero(Digests[0])); check(IsZero(Digests[1])); PBKDF2_HMAC_SHA256('password','salt',2,Digests); check(IsEqual(Digests[0],Digest.Lo)); check(not IsEqual(Digests[1],Digest.Lo)); check(SHA256DigestToString(Digests[1])= '830651afcb5c862f0b249bd031f7a67520d136470f5ec271ece91c07773253d9'); PBKDF2_HMAC_SHA256('password','salt',4096,Digest.Lo); check(SHA256DigestToString(Digest.Lo)= DIG4096); FillZero(Digest.b); sign.PBKDF2(saSha256,'password','salt',4096,Digest); check(SHA256DigestToString(Digest.Lo)= DIG4096); c := 'a'; sha.Init; for i := 1 to 1000000 do sha.Update(@c,1); sha.Final(Digest.Lo); Check(SHA256DigestToString(Digest.Lo)= 'cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0'); end; begin DoTest; {$ifdef USEPADLOCK} if padlock_available then begin fRunConsole := fRunConsole+' using Padlock'; padlock_available := false; // force PadLock engine down DoTest; padlock_available := true; end; {$endif} {$ifdef CPUX64} if cfSSE41 in CpuFeatures then begin fRunConsole := fRunConsole+' using SSE4 instruction set'; Exclude(CpuFeatures,cfSSE41); DoTest; Include(CpuFeatures,cfSSE41); end {$endif} end; procedure TTestCryptographicRoutines._SHA512; procedure Test(const password,secret,expected: RawUTF8; rounds: integer=0); var dig: THash512Rec; sign: TSynSigner; begin if rounds=0 then begin HMAC_SHA512(password,secret,dig.b); Check(SHA512DigestToString(dig.b)=expected); sign.Init(saSha512,password); sign.Update(secret); Check(sign.Final=expected); end else begin PBKDF2_HMAC_SHA512(password,secret,rounds,dig.b); Check(SHA512DigestToString(dig.b)=expected); FillZero(dig.b); sign.PBKDF2(saSha512,password,secret,rounds,dig); Check(SHA512DigestToString(dig.b)=expected); end; end; const FOX: RawByteString = 'The quick brown fox jumps over the lazy dog'; var dig: TSHA512Digest; i: integer; sha: TSHA512; c: AnsiChar; temp: RawByteString; begin // includes SHA-384, which is a truncated SHA-512 Check(SHA384('')='38b060a751ac96384cd9327eb1b1e36a21fdb71114be07434c0cc7bf63'+ 'f6e1da274edebfe76f65fbd51ad2f14898b95b'); Check(SHA384('abc')='cb00753f45a35e8bb5a03d699ac65007272c32ab0eded1631a8b605'+ 'a43ff5bed8086072ba1e7cc2358baeca134c825a7'); Check(SHA384('abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmn'+ 'hijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu')='09330c33f711'+ '47e83d192fc782cd1b4753111b173b3b05d22fa08086e3b0f712fcc7c71a557e2db966c3e9fa91746039'); Check(SHA512('')='cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d'+ '36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e'); Check(SHA512(FOX)='07e547d9586f6a73f73fbac0435ed76951218fb7d0c8d788a309d785'+ '436bbb642e93a252a954f23912547d1e8a3b5ed6e1bfd7097821233fa0538f3db854fee6'); Check(SHA512(FOX+'.')='91ea1245f20d46ae9a037a989f54f1f790f0a47607eeb8a14d128'+ '90cea77a1bbc6c7ed9cf205e67b7f2b8fd4c7dfd3a7a8617e45f3c463d481c7e586c39ac1ed'); sha.Init; for i := 1 to length(FOX) do sha.Update(@FOX[i],1); sha.Final(dig); Check(SHA512DigestToString(dig)='07e547d9586f6a73f73fbac0435ed76951218fb7d0c'+ '8d788a309d785436bbb642e93a252a954f23912547d1e8a3b5ed6e1bfd7097821233fa0538f3db854fee6'); c := 'a'; sha.Init; for i := 1 to 1000 do sha.Update(@c,1); sha.Final(dig); Check(SHA512DigestToString(dig)='67ba5535a46e3f86dbfbed8cbbaf0125c76ed549ff8'+ 'b0b9e03e0c88cf90fa634fa7b12b47d77b694de488ace8d9a65967dc96df599727d3292a8d9d447709c97'); SetLength(temp,1000); FillCharFast(pointer(temp)^,1000,ord('a')); Check(SHA512(temp)=SHA512DigestToString(dig)); for i := 1 to 1000000 do sha.Update(@c,1); sha.Final(dig); Check(SHA512DigestToString(dig)='e718483d0ce769644e2e42c7bc15b4638e1f98b13b2'+ '044285632a803afa973ebde0ff244877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b'); Test('','','b936cee86c9f87aa5d3c6f2e84cb5a4239a5fe50480a'+ '6ec66b70ab5b1f4ac6730c6c515421b327ec1d69402e53dfb49ad7381eb067b338fd7b0cb22247225d47'); Test('key',FOX,'b42af09057bac1e2d41708e48a902e09b5ff7f12ab42'+ '8a4fe86653c73dd248fb82f948a549f7b791a5b41915ee4d1ec3935357e4e2317250d0372afa2ebeeb3a'); Test(FOX+FOX,FOX,'19e504ba787674baa63471436a4ec5a71ba359a0f2d375'+ '12edd4db69dce1ec6a0e48f0ae460fc9342fbb453cf2942a0e3fa512dd361e30f0e8b8fc8c7a4ece96'); Test('Jefe','what do ya want for nothing?','164b7a7bfcf819e2e395fbe73b56e0a387bd64222e8'+ '31fd610270cd7ea2505549758bf75c05a994a6d034f65f8f0e6fdcaeab1a34d4a6b4b636e070a38bce737'); Test('password','salt','867f70cf1ade02cff3752599a3a53dc4af34c7a669815ae5'+ 'd513554e1c8cf252c02d470a285a0501bad999bfe943c08f050235d7d68b1da55e63f73b60a57fce',1); Test('password','salt','d197b1b33db0143e018b12f3d1d1479e6cdebdcc97c5c0f87'+ 'f6902e072f457b5143f30602641b3d55cd335988cb36b84376060ecd532e039b742a239434af2d5',4096); HMAC_SHA256('Jefe','what do ya want for nothing?',PHash256(@dig)^); Check(SHA256DigestToString(PHash256(@dig)^)='5bdcc146bf60754e6a042426089575c'+ '75a003f089d2739839dec58b964ec3843'); HMAC_SHA384('Jefe','what do ya want for nothing?',PHash384(@dig)^); Check(SHA384DigestToString(PHash384(@dig)^)='af45d2e376484031617f78d2b58a6b1'+ 'b9c7ef464f5a01b47e42ec3736322445e8e2240ca5e69e2c78b3239ecfab21649'); PBKDF2_HMAC_SHA384('password','salt',4096,PHash384(@dig)^); Check(SHA384DigestToString(PHash384(@dig)^)='559726be38db125bc85ed7895f6e3cf574c7a01c'+ '080c3447db1e8a76764deb3c307b94853fbe424f6488c5f4f1289626'); PBKDF2_HMAC_SHA512('passDATAb00AB7YxDTT','saltKEYbcTcXHCBxtjD',1,dig); Check(SHA512DigestToString(dig)='cbe6088ad4359af42e603c2a33760ef9d4017a7b2aad10af46'+ 'f992c660a0b461ecb0dc2a79c2570941bea6a08d15d6887e79f32b132e1c134e9525eeddd744fa'); PBKDF2_HMAC_SHA384('passDATAb00AB7YxDTTlRH2dqxDx19GDxDV1zFMz7E6QVqK', 'saltKEYbcTcXHCBxtjD2PnBh44AIQ6XUOCESOhXpEp3HrcG',1,PHash384(@dig)^); Check(SHA384DigestToString(PHash384(@dig)^)='0644a3489b088ad85a0e42be3e7f82500ec189366'+ '99151a2c90497151bac7bb69300386a5e798795be3cef0a3c803227'); { // rounds=100000 is slow, so not test by default PBKDF2_HMAC_SHA512('passDATAb00AB7YxDTT','saltKEYbcTcXHCBxtjD',100000,dig); Check(SHA512DigestToString(dig)='accdcd8798ae5cd85804739015ef2a11e32591b7b7d16f76819b30'+ 'b0d49d80e1abea6c9822b80a1fdfe421e26f5603eca8a47a64c9a004fb5af8229f762ff41f'); PBKDF2_HMAC_SHA384('passDATAb00AB7YxDTTlRH2dqxDx19GDxDV1zFMz7E6QVqK','saltKEYbcTcXHCBxtj'+ 'D2PnBh44AIQ6XUOCESOhXpEp3HrcG',100000,PHash384(@dig)^); Check(SHA384DigestToString(PHash384(@dig)^)='bf625685b48fe6f187a1780c5cb8e1e4a7b0dbd'+ '6f551827f7b2b598735eac158d77afd3602383d9a685d87f8b089af30'); } end; procedure TTestCryptographicRoutines._SHA3; const HASH1 = '79f38adec5c20307a98ef76e8324afbfd46cfd81b22e3973c65fa1bd9de31787'; DK = '7bbdbe37ea70dd2ed640837ff8a926d381806ffa931695addd38ab950d35ad18801a8290e8d97fe14cdfd3cfdbcd0fe766d3e6e4636bd0a17d710a61678db363'; var instance: TSHA3; secret, data, encrypted: RawByteString; dig: THash256; h512: THash512Rec; s, i: integer; sign: TSynSigner; begin // validate against official NIST vectors // taken from http://csrc.nist.gov/groups/ST/toolkit/examples.html#aHashing Check(instance.FullStr(SHA3_224, nil, 0) = '6B4E03423667DBB73B6E15454F0EB1ABD4597F9A1B078E3F5B5A6BC7'); Check(instance.FullStr(SHA3_256, nil, 0) = 'A7FFC6F8BF1ED76651C14756A061D662F580FF4DE43B49FA82D80A4B80F8434A'); Check(instance.FullStr(SHA3_384, nil, 0) = '0C63A75B845E4F7D01107D852E4C2485C51A50AAAA94FC61995E71BBEE983A2AC3713831264ADB47FB6BD1E058D5F004'); Check(instance.FullStr(SHA3_512, nil, 0) = 'A69F73CCA23A9AC5C8B567DC185A756E97C982164FE25859E0D1DCC1475C80A615B2123AF1F5F94C11E3E9402C3AC558F500199D95B6D3E301758586281DCD26'); Check(instance.FullStr(SHAKE_128, nil, 0) = '7F9C2BA4E88F827D616045507605853ED73B8093F6EFBC88EB1A6EACFA66EF26'); Check(instance.FullStr(SHAKE_256, nil, 0) = '46B9DD2B0BA88D13233B3FEB743EEB243FCD52EA62B81B82B50C27646ED5762FD75DC4DDD8C0F200CB05019D67B592F6FC821C49479AB48640292EACB3B7C4BE'); SetLength(data, 200); FillCharFast(pointer(data)^, 200, $A3); Check(instance.FullStr(SHA3_224, pointer(data), length(data)) = '9376816ABA503F72F96CE7EB65AC095DEEE3BE4BF9BBC2A1CB7E11E0'); Check(instance.FullStr(SHA3_256, pointer(data), length(data)) = '79F38ADEC5C20307A98EF76E8324AFBFD46CFD81B22E3973C65FA1BD9DE31787'); Check(instance.FullStr(SHA3_384, pointer(data), length(data)) = '1881DE2CA7E41EF95DC4732B8F5F002B189CC1E42B74168ED1732649CE1DBCDD76197A31FD55EE989F2D7050DD473E8F'); Check(instance.FullStr(SHA3_512, pointer(data), length(data)) = 'E76DFAD22084A8B1467FCF2FFA58361BEC7628EDF5F3FDC0E4805DC48CAEECA81B7C13C30ADF52A3659584739A2DF46BE589C51CA1A4A8416DF6545A1CE8BA00'); instance.Init(SHA3_256); for i := 1 to length(data) do instance.Update(pointer(data), 1); instance.Final(dig); Check(SHA256DigestToString(dig) = HASH1); Check(sign.Full(saSha3256,data,nil,0) = HASH1); instance.Init(SHA3_256); instance.Update(pointer(data), 100); instance.Update(pointer(data), 50); instance.Update(pointer(data), 20); instance.Update(pointer(data), 10); instance.Update(pointer(data), 10); instance.Update(pointer(data), 5); instance.Update(pointer(data), 5); instance.Final(dig, true); // NoInit=true to check Extendable-Output Function Check(SHA256DigestToString(dig) = HASH1); instance.Final(dig, true); Check(SHA256DigestToString(dig) = 'f85500852a5b9bb4a35440e7e4b4dba9184477a4c97b97ab0b24b91a8b04d1c8'); for i := 1 to 200 do begin FillZero(dig); instance.Final(dig, true); Check(not IsZero(dig),'XOF mode'); end; instance.Final(dig); Check(SHA256DigestToString(dig) = '75f8b0591e2baeae027d56c14ef3bc014d9dd29cce08b8b184528589147fc252','XOF vector'); encrypted := instance.Cypher('secret', 'toto'); Check(SynCommons.BinToHex(encrypted) = 'BF013A29'); Check(SynCommons.BinToHexLower(encrypted) = 'bf013a29'); for s := 0 to 3 do begin secret := RandomString(s * 3); Check(instance.Cypher(secret, '') = ''); for i := 1 to 1000 do begin data := RandomString(i); encrypted := instance.Cypher(secret, data); Check((i<16) or (encrypted <> data)); instance.InitCypher(secret); Check(instance.Cypher(encrypted) = data); end; end; PBKDF2_SHA3(SHA3_512,'pass','salt',1000,@h512); check(SHA512DigestToString(h512.b)=DK); FillZero(h512.b); sign.PBKDF2(saSha3512,'pass','salt',1000,h512); check(SHA512DigestToString(h512.b)=DK); // taken from https://en.wikipedia.org/wiki/SHA-3 Check(SHA3(SHAKE_128, 'The quick brown fox jumps over the lazy dog') = 'F4202E3C5852F9182A0430FD8144F0A74B95E7417ECAE17DB0F8CFEED0E3E66E'); Check(SHA3(SHAKE_128, 'The quick brown fox jumps over the lazy dof') = '853F4538BE0DB9621A6CEA659A06C1107B1F83F02B13D18297BD39D7411CF10C'); end; procedure TTestCryptographicRoutines._TAESPNRG; var b1,b2: TAESBlock; a1,a2: TAESPRNG; s1,s2,split: RawByteString; c: cardinal; d: double; e: TSynExtended; i,stripes: integer; clo, chi, dlo, dhi, elo, ehi: integer; begin TAESPRNG.Main.FillRandom(b1); TAESPRNG.Main.FillRandom(b2); Check(not IsEqual(b1,b2)); Check(not CompareMem(@b1,@b2,sizeof(b1))); clo := 0; chi := 0; dlo := 0; dhi := 0; elo := 0; ehi := 0; a1 := TAESPRNG.Create; a2 := TAESPRNG.Create; try a1.FillRandom(b1); a2.FillRandom(b2); Check(not IsEqual(b1,b2)); Check(not CompareMem(@b1,@b2,sizeof(b1))); Check(a1.FillRandom(0)=''); Check(a1.FillRandomHex(0)=''); for i := 1 to 2000 do begin s1 := a1.FillRandom(i); s2 := a2.FillRandom(i); check(length(s1)=i); check(length(s2)=i); if i>4 then check(s1<>s2); // compress the output to validate (somehow) its randomness check(length(SynLZCompress(s1))>i,'random should not compress'); check(length(SynLZCompress(s2))>i,'random should not compress'); s1 := a1.FillRandomHex(i); check(length(s1)=i*2); check(SynCommons.HexToBin(pointer(s1),nil,i)); c := a1.Random32; check(c<>a2.Random32,'Random32 collision'); if ca2.Random64); check(a1.Random32(i)=0)and(d<1)); if d<0.5 then inc(dlo) else inc(dhi); d := a2.RandomDouble; check((d>=0)and(d<1)); if d<0.5 then inc(dlo) else inc(dhi); e := a1.Randomext; check((e>=0)and(e<1)); if e<0.5 then inc(elo) else inc(ehi); e := a2.Randomext; check((e>=0)and(e<1)); if e<0.5 then inc(elo) else inc(ehi); end; finally a1.Free; a2.Free; end; Check(clo+chi=2000); Check(dlo+dhi=4000); Check(elo+ehi=4000); CheckUTF8((clo>=900) and (clo<=1100),'Random32 distribution clo=%',[clo]); CheckUTF8((dlo>=1800) and (dlo<=2100),'RandomDouble distribution dlo=%',[dlo]); CheckUTF8((elo>=1900) and (elo<=2100),'RandomExt distribution elo=%',[elo]); s1 := TAESPRNG.Main.FillRandom(100); for i := 1 to length(s1) do for stripes := 0 to 10 do begin split := TAESPRNG.Main.AFSplit(pointer(s1)^,i,stripes); check(length(split)=i*(stripes+1)); check(TAESPRNG.AFUnsplit(split,pointer(s2)^,i)); check(CompareMem(pointer(s1),pointer(s2),i)); end; check(PosEx(s1,split)=0); end; procedure TTestCryptographicRoutines.CryptData(dpapi: boolean); var i,size: integer; plain,enc,test: RawByteString; appsec: RawUTF8; func: function(const Data,AppSecret: RawByteString; Encrypt: boolean): RawByteString; tim: TPrecisionTimer; const MAX = 1000; begin {$ifdef MSWINDOWS} if dpapi then func := CryptDataForCurrentUserDPAPI else {$endif} func := CryptDataForCurrentUser; func('warmup','appsec',true); size := 0; tim.Start; for i := 0 to MAX-1 do begin plain := TAESPRNG.Main.FillRandom(i); check(length(plain)=i); UInt32ToUtf8(i,appsec); enc := func(plain,appsec,true); check((plain='') or (enc<>'')); check(length(enc)>=length(plain)); test := func(enc,appsec,false); check(length(test)=i); check(test=plain); inc(size,i+length(enc)); end; if dpapi then NotifyTestSpeed('DPAPI',MAX*2,size,@tim) else NotifyTestSpeed('AES-CFB',MAX*2,size,@tim); end; procedure TTestCryptographicRoutines._CryptDataForCurrentUser; begin CryptData(false); end; {$ifdef MSWINDOWS} procedure TTestCryptographicRoutines._CryptDataForCurrentUserAPI; begin CryptData(true); end; {$endif} {$ifndef NOVARIANTS} procedure TTestCryptographicRoutines._JWT; procedure test(one: TJWTAbstract); var t: RawUTF8; jwt: TJWTContent; i: integer; exp: TUnixTime; begin t := one.Compute(['http://example.com/is_root',true],'joe'); check(t<>''); check(TJWTAbstract.VerifyPayload(t,'','joe','',@exp)=jwtValid); check(one.VerifyPayload(t,'','joe','',@exp)=jwtValid); check(one.CacheTimeoutSeconds=0); one.Options := one.Options+[joHeaderParse]; one.Verify(t,jwt); check(jwt.result=jwtValid); check(jwt.reg[jrcIssuer]='joe'); one.Options := one.Options-[joHeaderParse]; one.CacheTimeoutSeconds := 60; check(one.CacheTimeoutSeconds=60); one.Verify(t,jwt); check(exp=GetCardinal(pointer(jwt.reg[jrcExpirationTime]))); check(jwt.result=jwtValid); check(jwt.reg[jrcExpirationTime]<>''); check(jwt.reg[jrcIssuer]='joe'); check(jwt.data.B['http://example.com/is_root']); check((jwt.reg[jrcIssuedAt]<>'')=(jrcIssuedAt in one.Claims)); check((jwt.reg[jrcJWTID]<>'')=(jrcJWTID in one.Claims)); for i := 1 to 1000 do begin Finalize(jwt); FillCharFast(jwt,sizeof(jwt),0); check(jwt.reg[jrcIssuer]=''); one.Verify(t,jwt); check(jwt.result=jwtValid,'from cache'); check(jwt.reg[jrcIssuer]='joe'); check((jwt.reg[jrcJWTID]<>'')=(jrcJWTID in one.Claims)); end; if (one.Algorithm<>'none') and (t[length(t)] in ['1'..'9','B'..'Z','b'..'z']) then begin dec(t[length(t)]); // invalidate signature one.Verify(t,jwt); check(jwt.result<>jwtValid); end; one.Free; end; procedure Benchmark(algo: TSignAlgo); var i: integer; tok: RawUTF8; j: TJWTAbstract; jwt: TJWTContent; tim: TPrecisionTimer; begin j := JWT_CLASS[algo].Create('secret',0,[jrcIssuer,jrcExpirationTime],[]); try tok := j.Compute([],'myself'); tim.Start; for i := 1 to 1000 do begin jwt.result := jwtWrongFormat; j.Verify(tok,jwt); check(jwt.result=jwtValid); check(jwt.reg[jrcIssuer]='myself'); end; NotifyTestSpeed('%',[JWT_TEXT[algo]],1000,0,@tim); finally j.Free; end; end; var i: integer; j: TJWTAbstract; jwt: TJWTContent; secret: TECCCertificateSecret; tok: RawUTF8; tim: TPrecisionTimer; a: TSignAlgo; begin test(TJWTNone.Create([jrcIssuer,jrcExpirationTime],[],60)); test(TJWTNone.Create([jrcIssuer,jrcExpirationTime,jrcIssuedAt],[],60)); test(TJWTNone.Create([jrcIssuer,jrcExpirationTime,jrcIssuedAt,jrcJWTID],[],60)); test(TJWTHS256.Create('sec',100,[jrcIssuer,jrcExpirationTime],[],60)); test(TJWTHS256.Create('sec',200,[jrcIssuer,jrcExpirationTime,jrcIssuedAt],[],60)); test(TJWTHS256.Create('sec',10,[jrcIssuer,jrcExpirationTime,jrcIssuedAt,jrcJWTID],[],60)); j := TJWTHS256.Create('secret',0,[jrcSubject],[]); try jwt.result := jwtWrongFormat; j.Verify('eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiIxMjM0NTY3ODkwIiwibm'+ 'FtZSI6IkpvaG4gRG9lIiwiYWRtaW4iOnRydWV9.TJVA95OrM7E2cBab30RMHrHDcEfxjoYZgeF'+ 'ONFh7HgQ',jwt); // reference from jwt.io check(jwt.result=jwtValid); check(jwt.reg[jrcSubject]='1234567890'); check(jwt.data.U['name']='John Doe'); check(jwt.data.B['admin']); j.Verify('eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiIxMjM0NTY3ODkwIiwibm'+ 'FtZSI6IkpvaG4gRG9lIiwiYWRtaW4iOnRydWV9.TJVA95OrM7E2cBab30RMHrHDcEfxjoYZgeF'+ 'ONFh7hgQ',jwt); // altered one char in signature check(jwt.result=jwtInvalidSignature); tok := j.Compute(['uid','{1CCA336D-A78F-4EB6-B701-1DB8E749BD1F}'],'','subject'); j.Verify(tok,jwt); Check(jwt.result=jwtValid); check(jwt.reg[jrcSubject]='subject'); check(jwt.data.U['uid']='{1CCA336D-A78F-4EB6-B701-1DB8E749BD1F}'); finally j.Free; end; for i := 1 to 10 do begin secret := TECCCertificateSecret.CreateNew(nil); // self-signed certificate test(TJWTES256.Create(secret,[jrcIssuer,jrcExpirationTime],[],60)); test(TJWTES256.Create(secret,[jrcIssuer,jrcExpirationTime,jrcIssuedAt],[],60)); test(TJWTES256.Create(secret,[jrcIssuer,jrcExpirationTime,jrcIssuedAt,jrcJWTID],[],60)); secret.Free; end; for a := saSha256 to high(a) do Benchmark(a); secret := TECCCertificateSecret.CreateNew(nil); j := TJWTES256.Create(secret,[jrcIssuer,jrcExpirationTime],[],60); try tok := j.Compute([],'myself'); tim.Start; for i := 1 to 100 do begin jwt.result := jwtWrongFormat; j.Verify(tok, jwt); check(jwt.result=jwtValid); check(jwt.reg[jrcIssuer]='myself'); end; NotifyTestSpeed('ES256',100,0,@tim); finally j.Free; secret.Free; end; end; {$endif NOVARIANTS} type TBenchmark = ( // non cryptographic hashes bCRC32c, bXXHash32, bHash32, // cryptographic hashes bMD5, bSHA1, bHMACSHA1, bSHA256, bHMACSHA256, bSHA384, bHMACSHA384, bSHA512, bHMACSHA512, bSHA3_256, bSHA3_512, // encryption bRC4, bAES128CFB, bAES128OFB, bAES128CFBCRC, bAES128OFBCRC, bAES256CFB, bAES256OFB, bAES256CFBCRC, bAES256OFBCRC, bSHAKE128, bSHAKE256 ); procedure TTestCryptographicRoutines.Benchmark; const SIZ: array[0..4] of integer = (8, 50, 100, 1000, 10000); COUNT = 500; AESCLASS: array[bAES128CFB .. bAES256OFBCRC] of TAESAbstractClass = ( TAESCFB, TAESOFB, TAESCFBCRC, TAESOFBCRC, TAESCFB, TAESOFB, TAESCFBCRC, TAESOFBCRC); AESBITS: array[bAES128CFB .. bAES256OFBCRC] of integer = ( 128, 128, 128, 128, 256, 256, 256, 256); var b: TBenchmark; s, i, size, n: integer; data, encrypted: RawByteString; dig: THash512Rec; MD5: TMD5; SHA1: TSHA1; SHA256: TSHA256; SHA384: TSHA384; SHA512: TSHA512; SHA3, SHAKE128, SHAKE256: TSHA3; RC4: TRC4; timer: TPrecisionTimer; time: array[TBenchmark] of Int64; AES: array[bAES128CFB .. bAES256OFBCRC] of TAESAbstract; TXT: array[TBenchmark] of RawUTF8; begin GetEnumTrimmedNames(TypeInfo(TBenchmark),@TXT); for b := low(b) to high(b) do TXT[b] := LowerCase(TXT[b]); for b := low(AES) to high(AES) do AES[b] := AESCLASS[b].Create(dig, AESBITS[b]); SHAKE128.InitCypher('secret', SHAKE_128); SHAKE256.InitCypher('secret', SHAKE_256); RC4.InitSHA3(dig,SizeOf(dig)); FillCharFast(time,sizeof(time),0); size := 0; n := 0; for s := 0 to high(SIZ) do begin data := RandomString(SIZ[s]); SetLength(encrypted, SIZ[s]); for b := low(b) to high(b) do begin timer.Start; for i := 1 to COUNT do begin dig.d0 := 0; dig.d1 := 0; case b of bXXHash32: dig.d0 := xxHash32(0,pointer(data),SIZ[s]); bHash32: dig.d0 := Hash32(pointer(data),SIZ[s]); bCRC32c: dig.d0 := crc32c(0,pointer(data),SIZ[s]); bMD5: MD5.Full(pointer(data),SIZ[s],dig.h0); bSHA1: SHA1.Full(pointer(data),SIZ[s],dig.b160); bHMACSHA1: HMAC_SHA1('secret',data,dig.b160); bSHA256: SHA256.Full(pointer(data),SIZ[s],dig.Lo); bHMACSHA256: HMAC_SHA256('secret',data,dig.Lo); bSHA384: SHA384.Full(pointer(data),SIZ[s],dig.b384); bHMACSHA384: HMAC_SHA384('secret',data,dig.b384); bSHA512: SHA512.Full(pointer(data),SIZ[s],dig.b); bHMACSHA512: HMAC_SHA512('secret',data,dig.b); bSHA3_256: SHA3.Full(pointer(data),SIZ[s],dig.Lo); bSHA3_512: SHA3.Full(pointer(data),SIZ[s],dig.b); bRC4: RC4.EncryptBuffer(pointer(data), pointer(Encrypted), SIZ[s]); bAES128CFB, bAES128OFB, bAES256CFB, bAES256OFB: AES[b].EncryptPKCS7(Data, true); bAES128CFBCRC, bAES128OFBCRC, bAES256CFBCRC, bAES256OFBCRC: AES[b].MACAndCrypt(Data,true); bSHAKE128: SHAKE128.Cypher(pointer(Data), pointer(Encrypted), SIZ[s]); bSHAKE256: SHAKE256.Cypher(pointer(Data), pointer(Encrypted), SIZ[s]); end; Check((b >= bRC4) or (dig.d0 <> 0) or (dig.d1 <> 0)); end; inc(time[b],NotifyTestSpeed('% %',[TXT[b],SIZ[s]],COUNT,SIZ[s]*COUNT,@timer,{onlylog=}true)); //if b in [bSHA3_512,high(b)] then AddConsole(''); end; inc(size,SIZ[s]*COUNT); inc(n,COUNT); end; for b := low(b) to high(b) do AddConsole(format('%d %s in %s i.e. %d/s or %s/s', [n, TXT[b], MicroSecToString(time[b]), (Int64(n)*1000000) div time[b], KB((Int64(size)*1000000) div time[b])])); for b := low(AES) to high(AES) do AES[b].Free; end; { some numbers, on a Core i7 (SSE4.2+AESNI) notebook, with SynCrypto 1.18.3800: Delphi 7, Win32 - Benchmark: 1,050,000 assertions passed 8.62s 10000 crc32c 8 B in 161us i.e. 62111801/s, aver. 0us, 473.8 MB/s 10000 xxhash32 8 B in 185us i.e. 54054054/s, aver. 0us, 412.4 MB/s 10000 md5 8 B in 1.68ms i.e. 5948839/s, aver. 0us, 45.3 MB/s 10000 sha1 8 B in 3.01ms i.e. 3312355/s, aver. 0us, 25.2 MB/s 10000 hmacsha1 8 B in 11.97ms i.e. 835421/s, aver. 1us, 6.3 MB/s 10000 sha256 8 B in 4.07ms i.e. 2451581/s, aver. 0us, 18.7 MB/s 10000 hmacsha256 8 B in 16.15ms i.e. 619041/s, aver. 1us, 4.7 MB/s 10000 sha512 8 B in 6.66ms i.e. 1500375/s, aver. 0us, 11.4 MB/s 10000 hmacsha512 8 B in 29.67ms i.e. 336961/s, aver. 2us, 2.5 MB/s 10000 sha3_256 8 B in 8.45ms i.e. 1182312/s, aver. 0us, 9 MB/s 10000 sha3_512 8 B in 8.49ms i.e. 1177856/s, aver. 0us, 8.9 MB/s 10000 aes128cfb 8 B in 996us i.e. 10040160/s, aver. 0us, 76.6 MB/s 10000 aes128ofb 8 B in 903us i.e. 11074197/s, aver. 0us, 84.4 MB/s 10000 aes128cfbcrc 8 B in 1.14ms i.e. 8726003/s, aver. 0us, 66.5 MB/s 10000 aes128ofbcrc 8 B in 1.18ms i.e. 8460236/s, aver. 0us, 64.5 MB/s 10000 aes256cfb 8 B in 1.55ms i.e. 6430868/s, aver. 0us, 49 MB/s 10000 aes256ofb 8 B in 980us i.e. 10204081/s, aver. 0us, 77.8 MB/s 10000 aes256cfbcrc 8 B in 1.22ms i.e. 8149959/s, aver. 0us, 62.1 MB/s 10000 aes256ofbcrc 8 B in 1.25ms i.e. 7974481/s, aver. 0us, 60.8 MB/s 10000 shake128 8 B in 538us i.e. 18587360/s, aver. 0us, 141.8 MB/s 10000 shake256 8 B in 1.33ms i.e. 7485029/s, aver. 0us, 57.1 MB/s 10000 crc32c 50 B in 129us i.e. 77519379/s, aver. 0us, 3.6 GB/s 10000 xxhash32 50 B in 189us i.e. 52910052/s, aver. 0us, 2.4 GB/s 10000 md5 50 B in 1.45ms i.e. 6863417/s, aver. 0us, 327.2 MB/s 10000 sha1 50 B in 3.07ms i.e. 3247807/s, aver. 0us, 154.8 MB/s 10000 hmacsha1 50 B in 11.89ms i.e. 840689/s, aver. 1us, 40 MB/s 10000 sha256 50 B in 4.17ms i.e. 2396931/s, aver. 0us, 114.2 MB/s 10000 hmacsha256 50 B in 16.06ms i.e. 622393/s, aver. 1us, 29.6 MB/s 10000 sha512 50 B in 7.32ms i.e. 1364628/s, aver. 0us, 65 MB/s 10000 hmacsha512 50 B in 26.80ms i.e. 373134/s, aver. 2us, 17.7 MB/s 10000 sha3_256 50 B in 8.56ms i.e. 1167815/s, aver. 0us, 55.6 MB/s 10000 sha3_512 50 B in 8.39ms i.e. 1191185/s, aver. 0us, 56.8 MB/s 10000 aes128cfb 50 B in 1.75ms i.e. 5685048/s, aver. 0us, 271 MB/s 10000 aes128ofb 50 B in 1.65ms i.e. 6056935/s, aver. 0us, 288.8 MB/s 10000 aes128cfbcrc 50 B in 1.83ms i.e. 5443658/s, aver. 0us, 259.5 MB/s 10000 aes128ofbcrc 50 B in 2.35ms i.e. 4239084/s, aver. 0us, 202.1 MB/s 10000 aes256cfb 50 B in 1.96ms i.e. 5083884/s, aver. 0us, 242.4 MB/s 10000 aes256ofb 50 B in 1.96ms i.e. 5094243/s, aver. 0us, 242.9 MB/s 10000 aes256cfbcrc 50 B in 2.14ms i.e. 4662004/s, aver. 0us, 222.3 MB/s 10000 aes256ofbcrc 50 B in 2.25ms i.e. 4428697/s, aver. 0us, 211.1 MB/s 10000 shake128 50 B in 2.56ms i.e. 3898635/s, aver. 0us, 185.9 MB/s 10000 shake256 50 B in 3.86ms i.e. 2590002/s, aver. 0us, 123.5 MB/s 10000 crc32c 100 B in 164us i.e. 60975609/s, aver. 0us, 5.6 GB/s 10000 xxhash32 100 B in 300us i.e. 33333333/s, aver. 0us, 3.1 GB/s 10000 md5 100 B in 2.71ms i.e. 3679175/s, aver. 0us, 350.8 MB/s 10000 sha1 100 B in 5.91ms i.e. 1692047/s, aver. 0us, 161.3 MB/s 10000 hmacsha1 100 B in 14.65ms i.e. 682267/s, aver. 1us, 65 MB/s 10000 sha256 100 B in 11.16ms i.e. 895495/s, aver. 1us, 85.4 MB/s 10000 hmacsha256 100 B in 19.68ms i.e. 507897/s, aver. 1us, 48.4 MB/s 10000 sha512 100 B in 7.14ms i.e. 1399972/s, aver. 0us, 133.5 MB/s 10000 hmacsha512 100 B in 26.34ms i.e. 379535/s, aver. 2us, 36.1 MB/s 10000 sha3_256 100 B in 8.43ms i.e. 1185677/s, aver. 0us, 113 MB/s 10000 sha3_512 100 B in 16.43ms i.e. 608457/s, aver. 1us, 58 MB/s 10000 aes128cfb 100 B in 2.33ms i.e. 4282655/s, aver. 0us, 408.4 MB/s 10000 aes128ofb 100 B in 2.97ms i.e. 3365870/s, aver. 0us, 320.9 MB/s 10000 aes128cfbcrc 100 B in 2.51ms i.e. 3976143/s, aver. 0us, 379.1 MB/s 10000 aes128ofbcrc 100 B in 2.46ms i.e. 4055150/s, aver. 0us, 386.7 MB/s 10000 aes256cfb 100 B in 2.92ms i.e. 3418803/s, aver. 0us, 326 MB/s 10000 aes256ofb 100 B in 2.91ms i.e. 3425830/s, aver. 0us, 326.7 MB/s 10000 aes256cfbcrc 100 B in 3.06ms i.e. 3259452/s, aver. 0us, 310.8 MB/s 10000 aes256ofbcrc 100 B in 3.09ms i.e. 3229974/s, aver. 0us, 308 MB/s 10000 shake128 100 B in 4.98ms i.e. 2006823/s, aver. 0us, 191.3 MB/s 10000 shake256 100 B in 5.80ms i.e. 1721763/s, aver. 0us, 164.2 MB/s 10000 crc32c 1000 B in 2.00ms i.e. 4995004/s, aver. 0us, 4.6 GB/s 10000 xxhash32 1000 B in 2.08ms i.e. 4796163/s, aver. 0us, 4.4 GB/s 10000 md5 1000 B in 20.95ms i.e. 477235/s, aver. 2us, 455.1 MB/s 10000 sha1 1000 B in 45.64ms i.e. 219072/s, aver. 4us, 208.9 MB/s 10000 hmacsha1 1000 B in 56.70ms i.e. 176363/s, aver. 5us, 168.1 MB/s 10000 sha256 1000 B in 61.30ms i.e. 163121/s, aver. 6us, 155.5 MB/s 10000 hmacsha256 1000 B in 72.31ms i.e. 138276/s, aver. 7us, 131.8 MB/s 10000 sha512 1000 B in 54.13ms i.e. 184723/s, aver. 5us, 176.1 MB/s 10000 hmacsha512 1000 B in 70.01ms i.e. 142828/s, aver. 7us, 136.2 MB/s 10000 sha3_256 1000 B in 62.15ms i.e. 160890/s, aver. 6us, 153.4 MB/s 10000 sha3_512 1000 B in 108.78ms i.e. 91927/s, aver. 10us, 87.6 MB/s 10000 aes128cfb 1000 B in 16.28ms i.e. 613948/s, aver. 1us, 585.5 MB/s 10000 aes128ofb 1000 B in 14.86ms i.e. 672540/s, aver. 1us, 641.3 MB/s 10000 aes128cfbcrc 1000 B in 15.20ms i.e. 657505/s, aver. 1us, 627 MB/s 10000 aes128ofbcrc 1000 B in 15.94ms i.e. 627273/s, aver. 1us, 598.2 MB/s 10000 aes256cfb 1000 B in 20.52ms i.e. 487305/s, aver. 2us, 464.7 MB/s 10000 aes256ofb 1000 B in 20.56ms i.e. 486357/s, aver. 2us, 463.8 MB/s 10000 aes256cfbcrc 1000 B in 21.31ms i.e. 469241/s, aver. 2us, 447.5 MB/s 10000 aes256ofbcrc 1000 B in 23.93ms i.e. 417780/s, aver. 2us, 398.4 MB/s 10000 shake128 1000 B in 47.67ms i.e. 209744/s, aver. 4us, 200 MB/s 10000 shake256 1000 B in 56.18ms i.e. 177973/s, aver. 5us, 169.7 MB/s 10000 crc32c 9 KB in 23.40ms i.e. 427186/s, aver. 2us, 3.9 GB/s 10000 xxhash32 9 KB in 15.91ms i.e. 628535/s, aver. 1us, 5.8 GB/s 10000 md5 9 KB in 210.63ms i.e. 47475/s, aver. 21us, 452.7 MB/s 10000 sha1 9 KB in 444.99ms i.e. 22472/s, aver. 44us, 214.3 MB/s 10000 hmacsha1 9 KB in 458.45ms i.e. 21812/s, aver. 45us, 208 MB/s 10000 sha256 9 KB in 607.39ms i.e. 16463/s, aver. 60us, 157 MB/s 10000 hmacsha256 9 KB in 618.00ms i.e. 16181/s, aver. 61us, 154.3 MB/s 10000 sha512 9 KB in 502.78ms i.e. 19889/s, aver. 50us, 189.6 MB/s 10000 hmacsha512 9 KB in 525.57ms i.e. 19026/s, aver. 52us, 181.4 MB/s 10000 sha3_256 9 KB in 564.61ms i.e. 17711/s, aver. 56us, 168.9 MB/s 10000 sha3_512 9 KB in 1.05s i.e. 9506/s, aver. 105us, 90.6 MB/s 10000 aes128cfb 9 KB in 149.54ms i.e. 66871/s, aver. 14us, 637.7 MB/s 10000 aes128ofb 9 KB in 142.10ms i.e. 70368/s, aver. 14us, 671 MB/s 10000 aes128cfbcrc 9 KB in 146.78ms i.e. 68124/s, aver. 14us, 649.6 MB/s 10000 aes128ofbcrc 9 KB in 148.38ms i.e. 67393/s, aver. 14us, 642.7 MB/s 10000 aes256cfb 9 KB in 198.82ms i.e. 50295/s, aver. 19us, 479.6 MB/s 10000 aes256ofb 9 KB in 199.27ms i.e. 50181/s, aver. 19us, 478.5 MB/s 10000 aes256cfbcrc 9 KB in 199.70ms i.e. 50073/s, aver. 19us, 477.5 MB/s 10000 aes256ofbcrc 9 KB in 200.13ms i.e. 49966/s, aver. 20us, 476.5 MB/s 10000 shake128 9 KB in 478.81ms i.e. 20884/s, aver. 47us, 199.1 MB/s 10000 shake256 9 KB in 574.64ms i.e. 17402/s, aver. 57us, 165.9 MB/s 50000 crc32c in 25.87ms i.e. 1932292/s or 4 GB/s 50000 xxhash32 in 18.68ms i.e. 2676659/s or 5.5 GB/s 50000 md5 in 237.45ms i.e. 210562/s or 448.1 MB/s 50000 sha1 in 502.65ms i.e. 99471/s or 211.6 MB/s 50000 hmacsha1 in 553.69ms i.e. 90302/s or 192.1 MB/s 50000 sha256 in 688.12ms i.e. 72660/s or 154.6 MB/s 50000 hmacsha256 in 742.24ms i.e. 67363/s or 143.3 MB/s 50000 sha512 in 578.07ms i.e. 86493/s or 184 MB/s 50000 hmacsha512 in 678.42ms i.e. 73700/s or 156.8 MB/s 50000 sha3_256 in 652.23ms i.e. 76659/s or 163.1 MB/s 50000 sha3_512 in 1.19s i.e. 41876/s or 89.1 MB/s 50000 aes128cfb in 170.93ms i.e. 292517/s or 622.5 MB/s 50000 aes128ofb in 162.51ms i.e. 307662/s or 654.7 MB/s 50000 aes128cfbcrc in 167.51ms i.e. 298489/s or 635.2 MB/s 50000 aes128ofbcrc in 170.34ms i.e. 293521/s or 624.6 MB/s 50000 aes256cfb in 225.80ms i.e. 221427/s or 471.2 MB/s 50000 aes256ofb in 225.71ms i.e. 221520/s or 471.4 MB/s 50000 aes256cfbcrc in 227.46ms i.e. 219810/s or 467.8 MB/s 50000 aes256ofbcrc in 230.69ms i.e. 216739/s or 461.2 MB/s 50000 shake128 in 534.59ms i.e. 93528/s or 199 MB/s 50000 shake256 in 641.85ms i.e. 77899/s or 165.7 MB/s Total failed: 0 / 1,302,057 - Cryptographic routines PASSED 10.49s Delphi 10.2 Tokyo, Win64 - Benchmark: 1,050,000 assertions passed 7.42s 10000 crc32c 8 B in 114us i.e. 87719298/s, aver. 0us, 669.2 MB/s 10000 xxhash32 8 B in 130us i.e. 76923076/s, aver. 0us, 586.8 MB/s 10000 md5 8 B in 1.92ms i.e. 5208333/s, aver. 0us, 39.7 MB/s 10000 sha1 8 B in 3.38ms i.e. 2950722/s, aver. 0us, 22.5 MB/s 10000 hmacsha1 8 B in 13.21ms i.e. 756944/s, aver. 1us, 5.7 MB/s 10000 sha256 8 B in 2.56ms i.e. 3900156/s, aver. 0us, 29.7 MB/s 10000 hmacsha256 8 B in 10.08ms i.e. 991669/s, aver. 1us, 7.5 MB/s 10000 sha512 8 B in 3.51ms i.e. 2845759/s, aver. 0us, 21.7 MB/s 10000 hmacsha512 8 B in 13.41ms i.e. 745212/s, aver. 1us, 5.6 MB/s 10000 sha3_256 8 B in 8.09ms i.e. 1235635/s, aver. 0us, 9.4 MB/s 10000 sha3_512 8 B in 7.98ms i.e. 1252505/s, aver. 0us, 9.5 MB/s 10000 aes128cfb 8 B in 1.18ms i.e. 8453085/s, aver. 0us, 64.4 MB/s 10000 aes128ofb 8 B in 1.16ms i.e. 8620689/s, aver. 0us, 65.7 MB/s 10000 aes128cfbcrc 8 B in 1.26ms i.e. 7936507/s, aver. 0us, 60.5 MB/s 10000 aes128ofbcrc 8 B in 1.24ms i.e. 8058017/s, aver. 0us, 61.4 MB/s 10000 aes256cfb 8 B in 1.65ms i.e. 6045949/s, aver. 0us, 46.1 MB/s 10000 aes256ofb 8 B in 1.24ms i.e. 8058017/s, aver. 0us, 61.4 MB/s 10000 aes256cfbcrc 8 B in 1.33ms i.e. 7468259/s, aver. 0us, 56.9 MB/s 10000 aes256ofbcrc 8 B in 1.33ms i.e. 7490636/s, aver. 0us, 57.1 MB/s 10000 shake128 8 B in 518us i.e. 19305019/s, aver. 0us, 147.2 MB/s 10000 shake256 8 B in 614us i.e. 16286644/s, aver. 0us, 124.2 MB/s 10000 crc32c 50 B in 125us i.e. 80000000/s, aver. 0us, 3.7 GB/s 10000 xxhash32 50 B in 188us i.e. 53191489/s, aver. 0us, 2.4 GB/s 10000 md5 50 B in 1.76ms i.e. 5656108/s, aver. 0us, 269.7 MB/s 10000 sha1 50 B in 3.39ms i.e. 2947244/s, aver. 0us, 140.5 MB/s 10000 hmacsha1 50 B in 13.27ms i.e. 753238/s, aver. 1us, 35.9 MB/s 10000 sha256 50 B in 2.57ms i.e. 3888024/s, aver. 0us, 185.3 MB/s 10000 hmacsha256 50 B in 10.04ms i.e. 995619/s, aver. 1us, 47.4 MB/s 10000 sha512 50 B in 3.52ms i.e. 2839295/s, aver. 0us, 135.3 MB/s 10000 hmacsha512 50 B in 13.44ms i.e. 743715/s, aver. 1us, 35.4 MB/s 10000 sha3_256 50 B in 8.08ms i.e. 1236552/s, aver. 0us, 58.9 MB/s 10000 sha3_512 50 B in 7.96ms i.e. 1256281/s, aver. 0us, 59.9 MB/s 10000 aes128cfb 50 B in 2.11ms i.e. 4719207/s, aver. 0us, 225 MB/s 10000 aes128ofb 50 B in 1.92ms i.e. 5208333/s, aver. 0us, 248.3 MB/s 10000 aes128cfbcrc 50 B in 2.20ms i.e. 4526935/s, aver. 0us, 215.8 MB/s 10000 aes128ofbcrc 50 B in 2.38ms i.e. 4185851/s, aver. 0us, 199.5 MB/s 10000 aes256cfb 50 B in 2.46ms i.e. 4063388/s, aver. 0us, 193.7 MB/s 10000 aes256ofb 50 B in 2.25ms i.e. 4438526/s, aver. 0us, 211.6 MB/s 10000 aes256cfbcrc 50 B in 2.55ms i.e. 3907776/s, aver. 0us, 186.3 MB/s 10000 aes256ofbcrc 50 B in 2.32ms i.e. 4310344/s, aver. 0us, 205.5 MB/s 10000 shake128 50 B in 2.34ms i.e. 4260758/s, aver. 0us, 203.1 MB/s 10000 shake256 50 B in 2.91ms i.e. 3431708/s, aver. 0us, 163.6 MB/s 10000 crc32c 100 B in 144us i.e. 69444444/s, aver. 0us, 6.4 GB/s 10000 xxhash32 100 B in 297us i.e. 33670033/s, aver. 0us, 3.1 GB/s 10000 md5 100 B in 3.39ms i.e. 2945508/s, aver. 0us, 280.9 MB/s 10000 sha1 100 B in 6.37ms i.e. 1569612/s, aver. 0us, 149.6 MB/s 10000 hmacsha1 100 B in 16.37ms i.e. 610575/s, aver. 1us, 58.2 MB/s 10000 sha256 100 B in 4.70ms i.e. 2123593/s, aver. 0us, 202.5 MB/s 10000 hmacsha256 100 B in 12.34ms i.e. 809847/s, aver. 1us, 77.2 MB/s 10000 sha512 100 B in 3.52ms i.e. 2840909/s, aver. 0us, 270.9 MB/s 10000 hmacsha512 100 B in 13.43ms i.e. 744158/s, aver. 1us, 70.9 MB/s 10000 sha3_256 100 B in 8.07ms i.e. 1238390/s, aver. 0us, 118.1 MB/s 10000 sha3_512 100 B in 14.98ms i.e. 667244/s, aver. 1us, 63.6 MB/s 10000 aes128cfb 100 B in 3.05ms i.e. 3272251/s, aver. 0us, 312 MB/s 10000 aes128ofb 100 B in 3.03ms i.e. 3292723/s, aver. 0us, 314 MB/s 10000 aes128cfbcrc 100 B in 3.10ms i.e. 3219575/s, aver. 0us, 307 MB/s 10000 aes128ofbcrc 100 B in 2.70ms i.e. 3698224/s, aver. 0us, 352.6 MB/s 10000 aes256cfb 100 B in 3.64ms i.e. 2743484/s, aver. 0us, 261.6 MB/s 10000 aes256ofb 100 B in 3.23ms i.e. 3087372/s, aver. 0us, 294.4 MB/s 10000 aes256cfbcrc 100 B in 3.76ms i.e. 2658867/s, aver. 0us, 253.5 MB/s 10000 aes256ofbcrc 100 B in 3.30ms i.e. 3030303/s, aver. 0us, 288.9 MB/s 10000 shake128 100 B in 4.46ms i.e. 2238638/s, aver. 0us, 213.4 MB/s 10000 shake256 100 B in 5.55ms i.e. 1798884/s, aver. 0us, 171.5 MB/s 10000 crc32c 1000 B in 469us i.e. 21321961/s, aver. 0us, 19.8 GB/s 10000 xxhash32 1000 B in 1.69ms i.e. 5899705/s, aver. 0us, 5.4 GB/s 10000 md5 1000 B in 27.18ms i.e. 367822/s, aver. 2us, 350.7 MB/s 10000 sha1 1000 B in 49.08ms i.e. 203715/s, aver. 4us, 194.2 MB/s 10000 hmacsha1 1000 B in 58.57ms i.e. 170724/s, aver. 5us, 162.8 MB/s 10000 sha256 1000 B in 34.10ms i.e. 293246/s, aver. 3us, 279.6 MB/s 10000 hmacsha256 1000 B in 41.55ms i.e. 240633/s, aver. 4us, 229.4 MB/s 10000 sha512 1000 B in 24.76ms i.e. 403844/s, aver. 2us, 385.1 MB/s 10000 hmacsha512 1000 B in 34.00ms i.e. 294117/s, aver. 3us, 280.4 MB/s 10000 sha3_256 1000 B in 57.47ms i.e. 173994/s, aver. 5us, 165.9 MB/s 10000 sha3_512 1000 B in 98.39ms i.e. 101628/s, aver. 9us, 96.9 MB/s 10000 aes128cfb 1000 B in 20.87ms i.e. 479064/s, aver. 2us, 456.8 MB/s 10000 aes128ofb 1000 B in 16.51ms i.e. 605656/s, aver. 1us, 577.6 MB/s 10000 aes128cfbcrc 1000 B in 20.73ms i.e. 482346/s, aver. 2us, 460 MB/s 10000 aes128ofbcrc 1000 B in 16.27ms i.e. 614363/s, aver. 1us, 585.9 MB/s 10000 aes256cfb 1000 B in 25.92ms i.e. 385787/s, aver. 2us, 367.9 MB/s 10000 aes256ofb 1000 B in 21.89ms i.e. 456787/s, aver. 2us, 435.6 MB/s 10000 aes256cfbcrc 1000 B in 26.66ms i.e. 375051/s, aver. 2us, 357.6 MB/s 10000 aes256ofbcrc 1000 B in 21.91ms i.e. 456412/s, aver. 2us, 435.2 MB/s 10000 shake128 1000 B in 41.89ms i.e. 238686/s, aver. 4us, 227.6 MB/s 10000 shake256 1000 B in 52.93ms i.e. 188925/s, aver. 5us, 180.1 MB/s 10000 crc32c 9 KB in 4.02ms i.e. 2482621/s, aver. 0us, 23.1 GB/s 10000 xxhash32 9 KB in 15.40ms i.e. 649139/s, aver. 1us, 6 GB/s 10000 md5 9 KB in 267.76ms i.e. 37346/s, aver. 26us, 356.1 MB/s 10000 sha1 9 KB in 472.80ms i.e. 21150/s, aver. 47us, 201.7 MB/s 10000 hmacsha1 9 KB in 482.23ms i.e. 20736/s, aver. 48us, 197.7 MB/s 10000 sha256 9 KB in 331.68ms i.e. 30149/s, aver. 33us, 287.5 MB/s 10000 hmacsha256 9 KB in 338.41ms i.e. 29549/s, aver. 33us, 281.8 MB/s 10000 sha512 9 KB in 241.79ms i.e. 41357/s, aver. 24us, 394.4 MB/s 10000 hmacsha512 9 KB in 243.28ms i.e. 41103/s, aver. 24us, 391.9 MB/s 10000 sha3_256 9 KB in 517.69ms i.e. 19316/s, aver. 51us, 184.2 MB/s 10000 sha3_512 9 KB in 963.30ms i.e. 10380/s, aver. 96us, 99 MB/s 10000 aes128cfb 9 KB in 197.43ms i.e. 50650/s, aver. 19us, 483 MB/s 10000 aes128ofb 9 KB in 158.28ms i.e. 63176/s, aver. 15us, 602.4 MB/s 10000 aes128cfbcrc 9 KB in 196.23ms i.e. 50959/s, aver. 19us, 485.9 MB/s 10000 aes128ofbcrc 9 KB in 155.09ms i.e. 64478/s, aver. 15us, 614.9 MB/s 10000 aes256cfb 9 KB in 250.88ms i.e. 39858/s, aver. 25us, 380.1 MB/s 10000 aes256ofb 9 KB in 211.23ms i.e. 47341/s, aver. 21us, 451.4 MB/s 10000 aes256cfbcrc 9 KB in 254.16ms i.e. 39344/s, aver. 25us, 375.2 MB/s 10000 aes256ofbcrc 9 KB in 209.72ms i.e. 47681/s, aver. 20us, 454.7 MB/s 10000 shake128 9 KB in 414.13ms i.e. 24146/s, aver. 41us, 230.2 MB/s 10000 shake256 9 KB in 525.12ms i.e. 19043/s, aver. 52us, 181.6 MB/s 50000 crc32c in 4.89ms i.e. 10206164/s or 21.2 GB/s 50000 xxhash32 in 17.73ms i.e. 2819601/s or 5.8 GB/s 50000 md5 in 302.06ms i.e. 165529/s or 352.2 MB/s 50000 sha1 in 535.07ms i.e. 93445/s or 198.8 MB/s 50000 hmacsha1 in 583.71ms i.e. 85658/s or 182.3 MB/s 50000 sha256 in 375.66ms i.e. 133098/s or 283.2 MB/s 50000 hmacsha256 in 412.48ms i.e. 121216/s or 257.9 MB/s 50000 sha512 in 277.14ms i.e. 180411/s or 383.9 MB/s 50000 hmacsha512 in 317.62ms i.e. 157418/s or 335 MB/s 50000 sha3_256 in 599.45ms i.e. 83409/s or 177.5 MB/s 50000 sha3_512 in 1.09s i.e. 45759/s or 97.3 MB/s 50000 aes128cfb in 224.69ms i.e. 222528/s or 473.5 MB/s 50000 aes128ofb in 180.94ms i.e. 276331/s or 588 MB/s 50000 aes128cfbcrc in 223.56ms i.e. 223644/s or 475.9 MB/s 50000 aes128ofbcrc in 177.72ms i.e. 281328/s or 598.7 MB/s 50000 aes256cfb in 284.59ms i.e. 175687/s or 373.9 MB/s 50000 aes256ofb in 239.87ms i.e. 208438/s or 443.6 MB/s 50000 aes256cfbcrc in 288.51ms i.e. 173303/s or 368.8 MB/s 50000 aes256ofbcrc in 238.61ms i.e. 209544/s or 445.9 MB/s 50000 shake128 in 463.39ms i.e. 107899/s or 229.6 MB/s 50000 shake256 in 587.17ms i.e. 85153/s or 181.2 MB/s Total failed: 0 / 1,302,089 - Cryptographic routines PASSED 8.86s } { TTestECCCryptography } const ECC_COUNT = {$ifdef CPU64}200{$else}50{$endif}; procedure TTestECCCryptography.ReferenceVectors; var pr1,pr2: TECCPrivateKey; pu1,pu2: TECCPublicKey; h1,h2: TECCHash; si1,si2: TECCSignature; s1,s2,s3: TECCSecretKey; begin SetLength(pub, ECC_COUNT); SetLength(priv, ECC_COUNT); SetLength(sign, ECC_COUNT); TAESPRNG.Main.FillRandom(@hash,sizeof(hash)); Check(SynCommons.HexToBin(PAnsiChar( 'DC5B79BD481E536DD8075D06C18D42B25B557B4671017BA2A26102B69FD9B70A'),@pr1,sizeof(pr1))); Check(SynCommons.HexToBin(PAnsiChar( '024698753E25650A3129320A7DDBA43D56051F4BEE3653897960A61FBC92AB24A5'),@pu1,sizeof(pu1))); Check(SynCommons.HexToBin(PAnsiChar( 'CFA96FAC873F522897000815BE96338DE8D355D5F495DD5C5A4FEF0AEDB66D5B'),@pr2,sizeof(pr2))); Check(SynCommons.HexToBin(PAnsiChar( '0298D0D01FCE73146C10CD05E08BEA573BEE4EFC56D5EBAAC64B32672C8FAC1502'),@pu2,sizeof(pu2))); Check(SynCommons.HexToBin(PAnsiChar( '9509D00BBBA2308445BC73311C3887E935183F65D361D4C39E2FA432B7168599'),@h1,sizeof(h1))); Check(SynCommons.HexToBin( PAnsiChar('F04CD0AA3D40433C51F35D07DBF4E11C91C922791A8BA7B930B5C30716D8B26E4B65EFBF'+ 'BDC0526A94ABDAA31130248F0413AC33D5BFA903E09847AAF42FD043'),@si1,sizeof(si1))); Check(SynCommons.HexToBin(PAnsiChar( '3366C112F95B2F52836171CAD3F3441C4B3C75348859092B200DE5024CB0C91B'),@h2,sizeof(h2))); Check(SynCommons.HexToBin(PAnsiChar( 'EEEF6F1D0A590BFC72B9D7DC0DB4BF36A8928DA2B8078FEE567808BB082525438CF68546'+ '26E17FBB28528450E50E43AB2598ED2CD3ACC7B43865BEB843452713'),@si2,sizeof(si2))); Check(SynCommons.HexToBin(PAnsiChar( '51A0C8018EC725F9B9F821D826FEEC4CAE8843066685522F1961D25935EAA39E'),@s1,sizeof(s1))); Check(ecdsa_verify(pu1,h1,si1)); Check(ecdsa_verify(pu2,h2,si2)); FillZero(s2); Check(ecdh_shared_secret(pu1,pr2,s2)); Check(IsEqual(s1,s2)); Check(CompareMem(@s1,@s2,sizeof(s1))); FillZero(s3); Check(ecdh_shared_secret(pu2,pr1,s3)); Check(IsEqual(s1,s3)); Check(CompareMem(@s1,@s3,sizeof(s1))); {$ifdef HASUINT64} // pascal (fallback) version Check(ecdsa_verify_pas(pu1,h1,si1)); Check(ecdsa_verify_pas(pu2,h2,si2)); FillZero(s2); Check(ecdh_shared_secret_pas(pu1,pr2,s2)); Check(IsEqual(s1,s2)); FillZero(s3); Check(ecdh_shared_secret_pas(pu2,pr1,s3)); Check(IsEqual(s1,s3)); {$endif} end; procedure TTestECCCryptography._ecc_make_key; var i: integer; begin for i := 0 to ECC_COUNT-1 do Check(ecc_make_key(pub[i], priv[i])); end; procedure TTestECCCryptography._ecdsa_sign; var i: integer; begin for i := 0 to ECC_COUNT-1 do Check(ecdsa_sign(priv[i], hash, sign[i])); end; procedure TTestECCCryptography._ecdsa_verify; var i: integer; begin for i := 0 to ECC_COUNT-1 do check(ecdsa_verify(pub[i], hash, sign[i])); end; procedure TTestECCCryptography._ecdh_shared_secret; var sec1,sec2: TECCSecretKey; i: integer; begin for i := 0 to ECC_COUNT-2 do begin check(ecdh_shared_secret(pub[i],priv[i+1],sec1)); check(ecdh_shared_secret(pub[i+1],priv[i],sec2)); check(IsEqual(sec1,sec2)); end; end; procedure TTestECCCryptography.CertificatesAndSignatures; const PUBPRIV64: RawUTF8 = 'AQAKAAoAFAAp49cdwmwTSgk7ocIs+iWCLVmLFDvnzMbgAAAAAAAAACnj1x3CbBN'+ 'KCTuhwiz6JYItWYsUO+fMxuAAAAAAAAAAAgm92LeP/SogOQAmFAKppFHFPPn1vRERJ1dwk5y8'+ 'AloD66iKgas4FCX8yprik12Unvk3K45kS1tIkga7U273SBAoDj5WP1ENURn7znVgPm5UPrMZO'+ 'vaZNdUuDPlCy1uzNJeQTIkgAAAAnddux+slXpcupBr3m2g/2skZyPIT0Y2mk9As06J2mMY='; PUBPRIVJSON: RawUTF8 = '{"Version":1,"Serial":"29E3D71DC26C134A093BA1C22CFA2582",'+ '"Issuer":"synopse.info","IssueDate":"2016-08-11","ValidityStart":'+ '"2016-08-11","ValidityEnd":"2016-08-21","AuthoritySerial":'+ '"29E3D71DC26C134A093BA1C22CFA2582","AuthorityIssuer":"synopse.info",'+ '"IsSelfSigned":true,"Base64":"'; const // Generated by tests MYPRIVKEY: array[0..255] of byte = ( $39,$EC,$C0,$0D,$D0,$ED,$47,$DC,$2A,$14,$72,$80,$D7,$E2,$48,$C1, $87,$6F,$11,$60,$5C,$77,$1C,$C6,$9B,$A8,$AD,$FD,$95,$17,$45,$A3, $2F,$A0,$4A,$B3,$AF,$B4,$27,$13,$85,$16,$E0,$6C,$F7,$75,$F1,$C5, $7C,$75,$6D,$34,$8C,$8F,$AB,$AD,$AA,$EA,$94,$5F,$A7,$B6,$F1,$E3, $D4,$0E,$3D,$FE,$96,$ED,$5C,$53,$90,$98,$60,$1A,$85,$9D,$BF,$70, $0F,$B2,$9D,$9B,$B2,$66,$36,$26,$F7,$FD,$3A,$5F,$DC,$AE,$67,$3B, $8E,$C4,$61,$71,$5D,$F6,$1F,$9A,$2A,$20,$A0,$C9,$F8,$0D,$FB,$EE, $3A,$17,$FA,$50,$FA,$AB,$EF,$72,$F8,$1D,$55,$CA,$1F,$6A,$86,$CB, $AA,$0E,$58,$01,$1F,$8E,$6F,$CC,$EA,$ED,$98,$1B,$4D,$1F,$85,$89, $74,$F6,$03,$FB,$9F,$1A,$50,$95,$F2,$8C,$79,$78,$9A,$94,$5C,$7F, $2E,$CA,$06,$3E,$E7,$93,$7F,$93,$8F,$64,$6D,$27,$A4,$B3,$81,$CE, $DB,$B1,$2A,$28,$79,$B6,$22,$87,$9F,$91,$01,$53,$6B,$B1,$AF,$91, $60,$87,$8F,$61,$87,$55,$D0,$FF,$33,$73,$05,$FD,$39,$DC,$A9,$B7, $EA,$D3,$72,$D6,$A6,$00,$98,$D2,$91,$96,$19,$A9,$1D,$7C,$6C,$9B, $F8,$D0,$50,$31,$52,$C3,$D8,$1D,$9B,$54,$1B,$09,$8C,$CE,$36,$1B, $4F,$2A,$EC,$98,$9B,$A2,$F7,$C4,$A8,$78,$AD,$DA,$B5,$56,$89,$67); MYPRIVKEY_LEN = SizeOf(MYPRIVKEY); MYPRIVKEY_ROUNDS = 100; MYPRIVKEY_PASS = '123456'; MYPRIVKEY_CYPH = '4e/QgInP'; var selfsignedroot, secret: TECCCertificateSecret; cert: TECCCertificate; sav, json, serial: RawUTF8; bin: RawByteString; {$ifndef DELPHI5OROLDER} json1,json2,jsonchain: RawUTF8; {$endif} chain: TECCCertificateChain; sign: TECCSignatureCertified; signcontent: TECCSignatureCertifiedContent; begin chain := TECCCertificateChain.Create; try check(chain.Count=0); selfsignedroot := TECCCertificateSecret.CreateNew(nil,'synopse.info',10); check(selfsignedroot.IsSelfSigned); check(selfsignedroot.HasSecret); check(chain.IsValid(nil)=ecvBadParameter); check(chain.IsValid(selfsignedroot)=ecvValidSelfSigned); check(chain.Add(nil)=-1); check(chain.Add(selfsignedroot)=-1); check(chain.Count=0); check(chain.AddSelfSigned(selfsignedroot)=0); check(chain.Count=1); check(not chain.IsValidCached); chain.IsValidCached := true; selfsignedroot := TECCCertificateSecret.CreateNew(nil,'mORMot.net',0); serial := selfsignedroot.Serial; check(length(serial)=32); check(selfsignedroot.IsSelfSigned); check(selfsignedroot.HasSecret); check(chain.IsValid(nil)=ecvBadParameter); check(chain.IsValid(selfsignedroot)=ecvValidSelfSigned); check(chain.Add(nil)=-1); check(chain.Add(selfsignedroot)=-1); check(chain.Count=1); check(chain.AddSelfSigned(selfsignedroot)=1); check(chain.Count=2); secret := TECCCertificateSecret.CreateNew(selfsignedroot,'google.fr'); check(chain.Count=2); check(secret.HasSecret); check(not secret.IsSelfSigned); check(chain.IsValid(secret)=ecvValidSigned); {$ifndef DELPHI5OROLDER} json1 := ObjectToJson(secret); {$endif} sav := secret.PublicToBase64; cert := TECCCertificate.CreateFromBase64(sav); check(cert.Serial=secret.Serial); check(not cert.IsSelfSigned); check(chain.IsValid(cert)=ecvValidSigned); check(cert.Issuer='google.fr'); check(cert.AuthorityIssuer='mormot.net'); check(chain.Add(cert)=2); check(chain.Count=3); check(chain.GetBySerial(cert.Content.Signed.Serial)=cert); {$ifndef DELPHI5OROLDER} json2 := ObjectToJson(cert); check(json1=json2,'serialization trim private key'); {$endif} secret.Free; inc(sav[10]); // corrupt cert := TECCCertificate.Create; check(not cert.FromBase64(sav)); check(chain.IsValid(cert)=ecvCorrupted); secret := TECCCertificateSecret.CreateFromBase64(PUBPRIV64); check(secret.HasSecret); check(secret.IsSelfSigned); check(chain.IsValid(secret.Content,true)=ecvValidSelfSigned); check(secret.Serial<>cert.Serial); check(secret.Serial='29E3D71DC26C134A093BA1C22CFA2582'); {$ifndef DELPHI5OROLDER} json1 := ObjectToJson(secret); check(json1<>json2); json2 := PUBPRIVJSON+copy(PUBPRIV64,1,posEx('y1uzNJeQTIk',PUBPRIV64)+10)+'AAAAA"}'; check(json1=json2,'no private key'); jsonchain := ObjectToJson(chain); check(length(jsonchain)=1545); {$endif} sav := secret.SaveToSource('MyPrivKey','Generated by tests','123456'); // FileFromString(sav,'privkey.pas'); check(length(sav)=1467); secret.Free; cert.Free; check(selfsignedroot.SaveToSecureFile('pass','.',64,1000)); secret := TECCCertificateSecret.CreateNew(selfsignedroot,'toto.com'); check(chain.Count=3); check(chain.IsValid(secret)=ecvValidSigned); json := chain.SaveToJson; check(length(json)=718,'certificates have fixed len'); chain.Free; // will release selfsignedroot chain := TECCCertificateChain.Create; check(chain.IsValid(secret)=ecvUnknownAuthority); check(chain.LoadFromJson(json)); check(chain.SaveToJson=json); check(chain.Count=3); check(chain.IsValid(secret)=ecvValidSigned); {$ifndef DELPHI5OROLDER} json := ObjectToJson(chain); check(length(json)=1546); chain.SaveToFile('test'); {$endif} bin := secret.SaveToSecureBinary('toto',64,1000); check(length(bin)=2320); secret.Free; secret := TECCCertificateSecret.CreateFromSecureBinary( @MYPRIVKEY,MYPRIVKEY_LEN,MYPRIVKEY_PASS,MYPRIVKEY_ROUNDS); check(secret.Serial='29E3D71DC26C134A093BA1C22CFA2582'); check(chain.IsValid(secret.Content,true)=ecvValidSelfSigned); {$ifndef DELPHI5OROLDER} json2 := ObjectToJson(secret); check(json1=json2); {$endif} secret.Free; secret := TECCCertificateSecret.Create; check(chain.IsValid(secret)=ecvCorrupted); check(not secret.LoadFromSecureBinary(bin,'titi',1000)); check(secret.LoadFromSecureBinary(bin,'toto',1000)); check(chain.IsValid(secret)=ecvValidSigned); chain.Add(secret); check(chain.Count=4); sign := TECCSignatureCertified.CreateNew(secret,pointer(json),length(json)); check(sign.Check); check(sign.AuthoritySerial=secret.Serial); check(sign.AuthorityIssuer=secret.Issuer); sav := sign.ToBase64; bin := sign.SaveToDERBinary; check(length(bin)>=ECC_BYTES*2+6); sign.Free; sign := TECCSignatureCertified.CreateFromBase64(sav); check(sign.Check); check(sign.Version=1); check(sign.Date=ECCText(NowECCDate)); check(sign.AuthoritySerial=secret.Serial); check(sign.AuthorityIssuer='toto.com'); check(sign.SaveToDERBinary=bin); check(chain.IsSigned(sign,pointer(json),length(json))=ecvValidSigned); signcontent := sign.Content; inc(signcontent.Signature[10]); // corrupt sign.Content := signcontent; check(sign.Check,'seems valid'); check(chain.IsSigned(sign,pointer(json),length(json))=ecvInvalidSignature); dec(signcontent.Signature[10]); sign.Content := signcontent; check(chain.IsSigned(sign,pointer(json),length(json))=ecvValidSigned); check(chain.IsSigned(sav,pointer(json),length(json))=ecvValidSigned); dec(json[10]); check(chain.IsSigned(sign,pointer(json),length(json))=ecvInvalidSignature); check(chain.IsSigned(sav,pointer(json),length(json))=ecvInvalidSignature); chain.Clear; check(chain.Count=0); check(chain.IsSigned(sign,pointer(json),length(json))=ecvUnknownAuthority); sign.Free; selfsignedroot := TECCCertificateSecret.CreateFromSecureFile( '.',serial,'pass',1000); {$ifndef DELPHI5OROLDER} check(chain.LoadFromFile('test')); check(chain.Count=3); check(chain.IsValid(selfsignedroot)=ecvValidSelfSigned); check(selfsignedroot.IssueDate=ECCText(NowECCDate)); check(selfsignedroot.Content.Signed.IssueDate=NowECCDate); check(chain.GetBySerial(serial)<>nil); chain.IsValidCached := true; check(ObjectToJson(chain)=jsonchain); {$endif} check(DeleteFile(selfsignedroot.SaveToSecureFileName)); selfsignedroot.Free; finally chain.Free; end; end; {$ifndef DELPHI5OROLDER} procedure TTestECCCryptography.ECCCommandLineTool; var sw: ICommandLine; ctxt: TCommandLine; i: integer; previd,prevpass: RawUTF8; plainfn,rawfn: TFileName; keys: array of record priv,pub,test,crypt: TFileName; id,issuer,pass,text: RawUTF8; rounds: integer; end; exectemp: variant; function Exec(const nv: array of const; cmd: TECCCommand): PDocVariantData; var sw: ICommandLine; ctxt: TCommandLine; begin ctxt := TCommandLine.Create(nv); sw := ctxt; check(ECCCommand(cmd,sw)=eccSuccess); if CheckFailed(ctxt.ConsoleLines<>nil) then result := @DocVariantDataFake else begin exectemp := _JsonFast(ctxt.ConsoleLines[0]); result := _Safe(exectemp); end; end; begin if DirectoryExists('synecc') then DirectoryDelete('synecc',FILES_ALL,true) else CreateDir('synecc'); SetCurrentDir('synecc'); try SetLength(keys,ECC_COUNT shr 4); for i := 0 to high(keys) do with keys[i] do begin formatUTF8('name%',[i],issuer); formatUTF8('pass%',[i],pass); rounds := 1000+i; ctxt := TCommandLine.Create([ 'auth',previd,'authpass',prevpass,'authrounds',rounds-1, 'issuer',issuer,'days',30+i,'newpass',pass,'newrounds',rounds]); sw := ctxt; check(ECCCommand(ecNew,sw)=eccSuccess); if CheckFailed(ctxt.ConsoleLines<>nil) then exit; id := Trim(split(ctxt.ConsoleLines[high(ctxt.ConsoleLines)],'.')); priv := format('%s.private',[id]); pub := format('%s.public',[id]); previd := id; prevpass := pass; text := RandomTextParagraph(1000); test := format('test%d.txt',[i]); crypt := 'crypt-'+test; FileFromString(text,test); Exec(['file',test,'out',crypt,'auth',pub,'saltrounds',i+10],ecCrypt); end; sw := TCommandLine.Create([]); check(ECCCommand(ecChainAll,sw)=eccSuccess); for i := 0 to high(keys) do with keys[i] do begin with Exec(['auth',priv,'pass',pass,'rounds',rounds],ecInfoPriv)^ do begin check(I['Version']=1); check(U['Serial']=id); check(U['Issuer']=issuer); end; with Exec(['file',crypt],ecInfoCrypt)^ do begin check(I['Size']=length(text)); check(U['recipient']=issuer); check(U['Recipientserial']=id); check(length(U['RandomPublicKey'])=sizeof(TECCPublicKey)*2); check(U['Algorithm']=ShortStringToAnsi7String(ToText(ecaPBKDF2_HMAC_SHA256_AES256_CFB_SYNLZ)^)); check(O['Signature']^.VarType=varNull,'not signed'); check(not B['Meta']); end; plainfn := 'plain-'+test; Exec(['file',crypt,'out',plainfn,'auth',priv,'authpass',pass, 'authrounds',rounds,'saltrounds',i+10],ecDecrypt); check(StringFromFile(plainfn)=text); Exec(['file',test,'out',crypt,'auth',id,'pass',pass,'rounds',rounds],ecSign); Exec(['file',test,'out',crypt,'auth',pub,'saltrounds',i+10,'algo', ord(ecaPBKDF2_HMAC_SHA256_AES128_CTR)],ecCrypt); rawfn := 'raw-'+test; with Exec(['file',crypt,'rawfile',rawfn],ecInfoCrypt)^ do begin check(I['Size']=length(text)); check(U['recipient']=issuer); check(U['Recipientserial']=id); check(length(U['RandomPublicKey'])=sizeof(TECCPublicKey)*2); check(U['Algorithm']='ecaPBKDF2_HMAC_SHA256_AES128_CTR'); check(O['Signature']^.I['Version']=1,'signed'); check(O['Signature']^.U['AuthoritySerial']=id); check(B['Meta']); end; check(PosEx(StringFromFile(rawfn),StringFromFile(crypt))=sizeof(TECIESHeader)+1); DeleteFile(plainfn); Exec(['file',crypt,'out',plainfn,'authpass',pass,'authrounds',rounds, 'saltrounds',i+10],ecDecrypt); check(StringFromFile(plainfn)=text,'guess .private from header'); end; finally SetCurrentDir('..'); end; end; {$endif} procedure TTestECCCryptography.ECDHEStreamProtocol; const MAX = 10000; var //timer: TPrecisionTimer; str: TRawByteStringDynArray; function Test(const prot: IProtocol; const name: string): integer; var i: integer; enc,after: RawByteString; ref: IProtocol; // to release memory begin ref := prot; result := 0; //timer.Start; for i := 0 to MAX do begin prot.Encrypt(str[i],enc); inc(result,length(str[i])+length(enc)); check(length(enc)>=length(str[i])); check(prot.Decrypt(enc,after)=sprSuccess); check(after=str[i]); end; //fRunConsole := format('%s %s %s',[fRunConsole,name,KB(timer.PerSec(result))]); end; var key: THash256; a: TECDHEAuth; c: TECDHEProtocolClient; s: TECDHEProtocolServer; cs, ss: TECCCertificateSecret; i: integer; enc,after: RawByteString; procedure handshake; var cf: TECDHEFrameClient; sf: TECDHEFrameServer; begin c := TECDHEProtocolClient.Create(a,nil,cs); s := TECDHEProtocolServer.Create(a,nil,ss); { c.EF := efAesCfb128; c.MAC := macHmacCrc32c; s.EF := c.EF; s.MAC := c.MAC; } c.ComputeHandshake(cf); Check(s.ComputeHandshake(cf,sf)=sprSuccess); Check(c.ValidateHandshake(sf)=sprSuccess); end; begin SetLength(str,MAX+1); for i := 0 to MAX do str[i] := RandomString(i shr 3+1); Test(TProtocolNone.Create,'none'); TAESPRNG.Main.FillRandom(key); Test(TProtocolAES.Create(TAESCFB,key,128),'aes'); cs := TECCCertificateSecret.CreateNew(nil,'client'); ss := TECCCertificateSecret.CreateNew(nil,'server'); for a := low(a) to high(a) do begin handshake; for i := 0 to MAX do begin c.Encrypt(str[i],enc); check(s.CheckError(enc)=sprSuccess); check(s.Decrypt(enc,after)=sprSuccess); check(after=str[i]); if i and 7=0 then continue; // check asymmetric communication s.Encrypt(str[i],enc); check(c.CheckError(enc)=sprSuccess); check(c.Decrypt(enc,after)=sprSuccess); check(after=str[i]); if i and 3=0 then continue; c.Encrypt(str[i],enc); check(s.CheckError(enc)=sprSuccess); check(s.Decrypt(enc,after)=sprSuccess); check(after=str[i]); c.Encrypt(str[i],enc); inc(enc[2]); check(s.CheckError(enc)=sprInvalidMAC); check(s.Decrypt(enc,after)=sprInvalidMAC); end; c.Free; s.Free; handshake; Test(c,format('c%d',[ord(a)])); Test(s,format('s%d',[ord(a)])); end; cs.Free; ss.Free; end; {$ifdef MSWINDOWS} {$ifndef FPC} {$ifndef LVCL} { TTestSynopsePDF } const FIXED_DATE = 40339.803675; // forced date to have the exact same Hash32 value procedure TTestSynopsePDF._TPdfDocument; var MS: THeapMemoryStream; i,y: integer; embed: boolean; expected: cardinal; WS: SynUnicode; const Hash: array[boolean] of Cardinal = (2336277040,1967009088); Hash10: array[boolean] of Cardinal = (2379006506,1967009088); Name: array[boolean] of PDFString = ('Arial','Helvetica'); begin MS := THeapMemoryStream.Create; with TPdfDocument.Create do try for embed := false to true do begin Info.CreationDate := FIXED_DATE; // no FIXED_DATE nor creator variation in hashed value Info.Data.PdfTextByName('Producer').Value := 'Synopse PDF engine'; StandardFontsReplace := embed; AddPage; Canvas.SetFont('arial',10,[]); Check(Canvas.Page.Font.Name=Name[embed]); y := 800; for i := 1 to 30 do begin Canvas.SetFont('Arial',9+i,[]); WS := 'Texte accentue n.'+IntToString(i); PWordArray(WS)^[13] := 233; PWordArray(WS)^[16] := 176; Canvas.TextOutW(100,y,pointer(WS)); dec(y,9+i); end; SaveToStream(MS,FIXED_DATE); //MS.SaveToFile(ChangeFileExt(ExeVersion.ProgramFileName,'.pdf')); if OSVersionANSI_CHARSET then break; // StandardFontsReplace will work only with ANSI code page NewDoc; MS.Clear; end; end; finally Free; MS.Free; end; end; procedure TTestSynopsePDF._TPdfDocumentGDI; const EMF: RawByteString = // some compressed EMF file content 'gDUBAAAAAABwgLjg3Z0LkBXVmcfPGd4KCqNRNCwBBaPDw1EU8RFkZlY2rkJQRkWBACIjRJFHYHaWkDgl'+ 'RLMkQTTo6hbZ4CMlURfQJXHjWuXsrsoaWUUqUckaJSWV4Got+MJVMLPnu6f/PX0/7wwX7vdxv0pTh+7T'+ '/+5zfqdPT79uf/33zrkbXdtwS4VzY3xb/vZJzvUZ6tyAi8aNdc675rO9qz/WuZ6ODV1C6uzcM2HdOT5f'+ 'euutrq7fsi7ui2G6d2b+5SHN91Sqcx+1trZm11kVy8j9P85NdANCmuFuct/MTc1yC90c18AZOhg2djvX'+ 'b/qk0k3eWJfL0zTNm//Red4PHuV7v1QTF1x/oR+zqsav+79K98K+Grc/LLcjjHeFNChMj/lJjR8axlvD'+ 'cl8I7aX1J4T1c+VcELZc0Na9Wee6TZy1cM6sb474xR4q90JPdfVLNFqWUu+7a/yEUA7Np2HtnK/4pk8r'+ '3WM76tyln7bNc67SPTekLtXRBprO6S/XuTF3TG+keQ+Gsmb+dErjf4bxlJD+Msy7rtF1J22wi/1GG7Wv'+ 'a+vDU0LqF1JFks92H9Yh7dhkuldIX07K6JQsh+7D8jT/hGSatMpMOdllLiW+TH18/1sW8jUhP9DtySzV'+ 'fGHh6cJDtj5Mh921GdOhPc3YF0OXfm5ffKqibbPU5Pa8GXl/Mwc3TG2kNnfNzDl19HC3a0+lG/etqFEe'+ 'Q8H23xv7uv2hJUnO7Xqv0v33kqmNh16md5Nmnx7L2kf7cml/A3xfpO2d3Rez/XNC2/xW7D8+s0y23+jw'+ '09ExpPR+c25K6KPrQqK/tfoPKt1Hv+m8eGmXhf5Pod7dizot/v4TUxr7zhjubh85wm1tGOZ29B2WW4/m'+ 'NY0Y5k6cGftgTyjj5Y1h2V4D39jY8+rcsr5AfaPer3TLXpuS9gstQ8vS/LVhPnEsveevcsexDSGf+7sO'+ 'Ze4MG/XGsAxpbUNp/cv7jbZ3oX7L9gnt4+38LeWGw9UnW2fGPqF+WDUntpXmUZ9sm1W4T2jZYvuElj2Y'+ 'PsFyzpXWd7xPaHsfqE+6uY7/TupDf8x289zcMD60oTLH8e7+ytzBvlNWohr8mFhnOHet21eZ46Mxncdo'+ '+t0w/9sLalz3O2r8fXW17mch0fzmk8b4k1+vc8eGZc8L49qQWsL0pa/HcyHKooHKGhry//haTd51ClU/'+ 'KczffeuExvv98XkaTf/XI0++ni1rdhgv39d2Ht4app//3oTGH4Y0cO30Rf/y0vzccls+a20dlJTP+4S2'+ 'd3vHt2KOddnzZvZ8OiQp9woXz8fzwwKVPr/Pi/lbLcRzKMfk41zhfbA+pNWOjv7hOiOk5SGNSK753Jhe'+ 'ta5zr9prE43WudTlD63JcF1Om+eud5PD9cKs3JXgHLfI/a2bmtvGSJ0z00idkvldkzFYi9kW7W27Q90W'+ 'uRT6qm9Y8OowHsy2xVWJ5jvYFhPC9JlJ+YXaUuy+dSDO3T6yfOg/z/m+L47zjNBn2pzfT1hWFeBcWSRn'+ 'tfL2nOQiG7EML8BZlWgVB+AcFrYo9mVN1hYXeZ53n2d91hXLeuZhYZ2S8MwqwDqjaNYRHbKG40gz7pO6'+ 'J1rmUiZdjrTsfRLueek4TcfnkUmeH6+z5fdIysT1R3Nzc7pcj3bKp+PGMZnyKX+8b9Pp7zWrUz6rr2T6'+ 'SqZXMb2K6bRPZHXKZ/UZTJ+R6IWu67Pb4ohkOxfaFkd0sC0on90WlWxbZHXKV7JtkdVXMr2K6VVMf9bl'+ '68+6fH0G02ckeqF75G6Zv5GO+r4P6/s+rL1ZHflse7P6SqZXMb2K6dS+rI58tr1ZfQbTj2T7LuW/kNEH'+ 'MX0Q00czfTTTH2L7LuWzegvTW5i+nenbmV7H9DqmT2H6FKYvZvpipr/h8nXKZ/WPmf4x0/uw8vuw8pew'+ '9Zew9X/E9B8x/VGmP5roha6t2rsebu/6q717mmLOF0e5tmeMR7q2+57lnWLCvSgxlX4vWt570HBVUdI9'+ 'aNgrS7oH5fc9tL35uXqTi8eta0M6MaSnXP65mvan20Pq49o/V88P0xeFXprlZoar/4Xh6vImNyDcrc4L'+ 'pc4J8+M9Qdt1f1fXdt2fvTcg7QiWR8J1QHYfPDXTroO5f+jo/u9A+29FgW24PKT+yfzxIeG+E9vwa4nW'+ 'o4NtON3Rdflad1a46q0O+0117l9sZ3abYbtl8xLXcR21qypp18gC7aoqsl0j8to130S7Lkja9dUC7bqg'+ 'yHadabC/xifpmgLtGl9ku84w2K7pCf+NBdo1vch2Vee1q6as7Wpy8TebhUm7vlOgXaR166BddJ91bl6b'+ 'qsraluVJW1YVaMvyItoyqsB+V6623J205f4Cbbm7iLacY6gt65K2bCrQlnVFtGVkXlsqy9qWJ5O2PFeg'+ 'LU8W0ZazDfXLlqQtrxVoy5Yi2pJ/vdDaWs62vJG05X8KtOWNItoywtBxbE/Slv0F2rKniLYUui4oV1sq'+ 'fGzLUf7zbSHtQG0pdC1wMG3JPi/p6Flc9vkLns0dzDMXanP/TBkTknxWr2Z6NdNrmV7L9Hqm1zO9gekN'+ 'TG9iehPTVzB9BdPXMH0N09czfT3TW5jewvRtTN/G9J1M38n0vUzfy/TuPl/v3sHzxgM9U7yC9Tc9v+3P'+ '9GqmVzO9lum1TK9nej3TG5jewPQmpjcxfQXTVzB9DdPXMH0909czvYXpLUzfxvRtTN/J9J1M38v0vUzP'+ '9jfp2f4+2GeqV7L+Rj6rVzO9mum1TK9lej3T65newPQGpjcxvYnpK5i+gulrmL6G6euZvp7pLUxvYfo2'+ 'pm9j+k6m72T6XqbvZXq2v5HP/v2fmFn/8iSf1Xv6fL0nW/94tv7xbP2j2fpHs/WPYesfw9bvzfTeTB/K'+ '9KFMP43ppzF9MNMHM/0kpp/E9NFMH83085l+PtPPYfo5TD+L6WcxfQLTJzB9HNPHMf1ipl/M9LFMH8v0'+ 'a5l+LdOnMX0a0yczfTLTJzF9EtMXMX0R0xcwfQHT5zJ9LtO/wfRvMP1Wpt/K9GVMX8b0m5l+M9OXMn0p'+ '0+9h+j1Mv4vpdzH9DqbfwfSVTF/J9IeZ/jDTH2L6Q0x/gOkPMH0t09cy/SmmP8X0XzL9l0z/OdN/zvTH'+ 'mf44019k+otMf4HpLzB9M9M3M/0Zpj/D9B1M38H03zH9d0zfzvTtTH+F6a8w/X2mv8/03UzfzfR3mP4O'+ '03cxfRfTO7PzS2d2fvFM90z/jJX/GSv/U6ZT/pKQxrh4LUPXyAOSsXdt51n6XW1+8hszzxe6xsreX7b3'+ 'Hjn9rpIbkjcTs78jpfejrfnXc1XJujj3T3XxHJytN/u7jURddIzv5uO12FHKdc1K6rrxMNTVkNQ19zDU'+ 'RXV09fF81ku5rgVJXU2Hoa5vJXXd8mdW1y1JXX93GOqic3QXH8/1PZXr+rGLx9QHaXnluu5L6lp3GOr6'+ 'wMVzNR3Pf+N066J3TbaG9KeQXlWu64iw3Ta6eJ55Qrmu3sl+Qe+oPaJcV79Qx51hfHIY36tc10Afr3NP'+ '9fF6WbMues91cRif7eO1vWZdtT7GkV0cxjco13WZT+7Xwvhq5bom+nitdo2P94+addF7+Je6GL85Ubmu'+ 'G3x8HrbQx/tyzbpu9vR7T7h/DePzlOtq9vQbhnO3efp9Wbcueu+d3hy709PvjLp13e1jOT9O6tSsa2Oo'+ '4+QwfsLHeZp10bucNN4Rxl9SrusdH3+zovdv/0K5LordoOeVe318bq1Z16c+Ptv0FfEZq2Zdp4bM0WF8'+ 'ekXclpp11VXEe9u/pveJleuaVBHnT6uIy2rWdX1FvJe/qSLuI3TP3zsprouTewbA2bPPBvB+P9qRvufa'+ 'nN+W7LOCbLnt/UaN5xv0PlqvzPMRejaQvZ/o1g5bl8PABhawTTPEBhaw0TPvI42wgQVsswyxgQVs1xti'+ 'AwvY6Dn/EUbYwAK2uYbYwAK2eYbYwAK2hYbYwAI2es7XwwgbWMD2N4bYwAK2JYbYwAK2pYbYwAK2mw2x'+ 'gQVstxhiAwvYlhtiAwvYbjPEBhawrTDEBhaw/cAQG1jARrFeVs5ZYAHbnYbYwAK21YbYwAK2vzfEBhaw'+ '3WuIDSxgW2OIDSxg+4khNrCA7T5DbGABG/1+ZOXYCxawPWSIDSxg+5khNrCA7VFDbGAB2wYX34OxwAYW'+ 'sD1miA0sYNvk4rsvFtjAArYnDLGBBWz0vmFXI2xgARu9K9nFCBtYwPa0i++CWGADC9j+LaRORtjAAjZ6'+ 'P7TCCBtYwJaLDzXCBhawPZ9UYoENLGDb4uK7QxbYwAI2eofqMyNsYAHbyyHtM8IGFrD9OqRPjLCBBWz0'+ 'jvfHRtjAAjZ6P/0jI2xgARt9GPUDI2xgARvFe+8xwgYWsP0+pP81wgYWsFG83TtG2MACtj+E9LYRNrCA'+ '7e1kngU2sICNtuFbRtjAAjba9940wgYWsL3n4nHFAhtYwEbHuu1G2MACtr0u/x3zcrKBBWx03t9mhA0s'+ 'YKPrpReNsIEFbHQN/CsjbGABG93XbDbCBhaw0b3qfxhhAwvY6NnI00bYwAI2eob5r0bYwAI2em8qG2tS'+ 'TjawgI3i9P7ZCBtYwEbvgW4wwgYWsNG3ah8xwgYWsB3n4+8hFtjAAjb6jvoDRtjAArYvhvxaI2xgAVt/'+ 'H39TtcAGFrAN8DHW0gIbWMBG8XCrjbCBBWzkV7LKCBtYwEaxfT8wwgYWsA3xMY7YAhtYwEbxit81wgYW'+ 'sFX7+L6eBTawgI38fL5jhA0sYBvpY6y8BTawgG2Uj+/8WmADC9jO9/FdaQtsYAEbOWIuMMIGFrCNCfmb'+ 'jLCBBWzkS3GDETawgO2ikJ9thA0sYPuqT7yFDLCBBWyX+BgXZYENLGAb5+O30i2wgQVsE3yMw7PABhaw'+ 'Ucz/NUbYwAK2K3ziZWaADSxgo+8xXGGEDSxgm+zzv6lQTjawpLGxIX+ZETawgG16yH/NCBtYwDbTx29O'+ 'WmADSxob62MctwU2sIBtts//5kc52cCSxsZ6ckSywQaWNDbWk/eRDTawgI08tuqMsIEljY315O9lgw0s'+ 'YCOvtzFG2MACtiYfv/lrgQ0saWysj75JFtjAArZv+/gtZAtsYAFbs8//BlI52cCSxsb6/G8mlTU2NmEB'+ '23d9/H61BTawgO17Pv/7T+VkA0saG+vjd70tsIEFbD/08btgFtjAksbG+ujxbYENLGlsrI/fOLPABhaw'+ '3eXjd4sssIEljY0N+dONsIEFbP/g87/rVk42sICNvjk3zAgbWNLYWB99GSywgQVs94f8ECNsYAHbT33+'+ 't/3KyQaWNDbWRy8NC2xgAdvDPnrRWmADC9j+ycfv01lgA0saG2uIbQNjezzkTzHCBpY0NtbH9S2wgSWN'+ 'jTXE9gRje9JHb2YLbGBJY2N9/L6qBTawpLGxhtieZmz/7qNHkgU2sKSxsSE/0AgbWMC22RDbZsb2q5Af'+ 'YIQNLGlsrCG2LYztJZ//veRysoEFbNsMsW1jbL/2+d9jLmtsrM/3OHzVENurjO23hth+y9he9/nf8y5r'+ 'bGzCArY3DbG9ydh+72N9FtjAksbGGmLbydj+aIjtj4ztbR81C2xgAdu7htjeZWz0vf7st/PLyQaWNDbW'+ 'ENt7jO1DQ2wfMraPDbF9zNg+8fk+A2WNjU1YwLbfENt+xtZqiK2VsZH/Rl8jbGABW2dDbJ0ZW1dDbF0Z'+ 'Ww9DbD0YW8/EP8QCG1jS2FhDbEcxtj6G2PowtmMNsR3L2I4zxHYcYzuB+RGVkw0sYOtniK0fY+tviK0/'+ 'YxtoiG0gYxtkiG0QYzuF+WWVNTY2YQHbaYbYTmNsQw2xDWVsww2xDWdsZxhiO4OxjTDENoKxjayIZVlg'+ 'AwvYzjXEdi5jO98Q2/mMbbQhttGMrcYQWw1jqzPEVsfYxhpiG8vYLq6I3p8W2MCSxsYaYruEsY03xDae'+ 'sV1miO0yxjbRENtExnalIbYrGdskQ2yTGNtkQ2yTGdvXDbF9nbFNTzyDLbCBJY2NNcQ2k7E1GGJrYGyz'+ 'k/wlSd7FcsQ8mQ+lra1Opq0ansxSbBqezFJsGp7MUmwansxSbGAB2/WG2MCSxp270n3MpNg0PJml2MAC'+ 'NglPZik2DU9mKTawgG2RK93HTIoNLGCT8GSWYtPwZJZi0/BklmIDC9gkPJml2DQ8maXYNDyZpdjAArbb'+ 'DLGBJY07N8Sm4cksxQaWNO7c2TlnaXgyS7GBBWyrDbGBJY07N8Sm4cksxQYWsK0xxAaWNO7cEJuGJ7MU'+ 'G1jA9qCzc+wFSxp3bogNLGCT8GSWYtPwZJZiA0sad+5K9z2WYtPwZJZi0/BklmIDSxp3bohNw5NZig0s'+ 'adw5rWeEDSxp3Lkr3ZNZik3Dk1mKDSxp3Lkr3ZNZig0sYHuOdCNsYAGbhCezFJuGJ7MUG1jAJuHJLMWm'+ '4cksxabhySzFBhawveJK92SWYgML2La70j2ZpdjAksadu9I9maXYwAI2CU9mKTYNT2YpNrCkceeudE9m'+ 'KTawgO0PrnRPZik2sKRx5650T2YpNg1PZik2sIBNwpNZik3Dk1mKTcOTWYpNw5NZig0sady5K92TWYoN'+ 'LGCj66VSPZml2MACNglPZik2DU9mKTYNT2YpNg1PZik2DU9mKTYNT2YpNg1PZik2DU9mKTYNT2YpNg1P'+ 'Zik2DU9mKTYNT2YpNg1PZik2DU9mKTawgE3Ck1mKTcOTWYpNw5NZik3Dk1mKTcOTWYpNw5NZik3Dk1mK'+ 'TcOTWYpNw5NZik3Dk1mKTcOTWYpNw5NZig0sady5L92TWYpNw5NZik3Dk1mKTcOTWYpNw5NZik3Dk1mK'+ 'TcOTWYpNw5NZik3Dk1mKTcOTWYpNw5NZLDbWy3syS7GBJY0796V7MkuxaXgyi8XGenlPZik2DU9msdhY'+ 'L+/JLBYb6+U9maXYNDyZxWJjvbwnsxSbhiezFJuGJ7NYbKyX92SWYtPwZJZiA0saG+tL92QWi4318p7M'+ 'UmwansxSbBqezGKxsV7ek1mKTcOTWSw21st7MovFxnp5T2YpNg1PZrHYWC/vySzFpuHJLMWm4cksFhvr'+ '5T2Zpdg0PJml2DQ8mcViY728J7MUm4YnsxSbhiezWGysl/dklmLT8GQWi41NWNLYWENsGp7MUmwansxi'+ 'sbFe3pNZLDbWy3syS7FpeDKLxcZ6eU9mKTYNT2YpNg1PZrHYWMYm4cksxabhySzFpuHJLBYb6+U9maXY'+ 'NDyZpdg0PJnFYmO9vCezFJuGJ7NYbGzCksbGGmLT8GSWYtPwZBaLjU1YwCbhySzFpuHJLMWm4cksFhvr'+ '5T2Zpdg0PJml2DQ8mcViY728J7MUm4YnsxSbhiezWGysgiezFJuGJ7NYbKyCJ7NYbKyCJ7MUm4Yns1hs'+ 'rIIns1hsrIInsxSbhiezWGysgiezFJuGJ7MUm4Yns1hsrIInsxSbhiezFJuGJ7NYbKyCJ7MUm4YnsxSb'+ 'hiezWGysgiezFJuGJ7NYbKyCJ7NYbKyCJ7MUm4Yns1hsrIInsxSbhiezFJuGJ7NYbKyCJ7MUm4YnsxSb'+ 'hiezWGysgiezFJuGJ7MUm4Yns1hsrIInsxSbhiezWGysgiezWGysgiezFJuGJ7NYbKyCJ7NYbKyCJ7MU'+ 'W7GezMWwYjowNF/uYhwkLfNBa2urywyrfFtT6t0MN9vNc3PD+NCG6Y1TrprWiAIr0vlD3I6Fw9woP8Q1'+ 'jz/dDXej3ZClzk14r9LVXTW1kca7FgzLrfNaWG5KyG/40tuNtM7LvavpM665+Q+G+dsXdVoc3x5vK5fK'+ 'WP0ebanRbmgol+oYnDQrW+6mTLl3Hln9FZS7n5W7K+Gi8ZIw3vqLIZ2yZd44wufWeWzS1Ebaxn17Dfzy'+ 'CW6jv67RdXcuf1/o69I+T+fTdim0j3Ry8TccmqZuqswsX2i+d/n7Qnv9f1RSHw29k+n/Bw=='; METAFILE_HASH: array[boolean] of Cardinal = ($212C0E5A,$FB81AAAD); var S: RawByteString; MS: THeapMemoryStream; MF: TMetaFile; Doc: TPdfDocument; Page: TPdfPage; orientation: boolean; H: cardinal; i,j: integer; // E: RawByteString; i,L,n: integer; begin { S := SockBase64Encode(CompressString(StringFromFile('d:\temp\tmpCurve.emf'))); E := ' EMF: RawByteString = // some compressed simple EMF file'#13#10; L := length(S); i := 1; while L>0 do begin if L>80 then n := 80 else n := L; E := E+' '''+copy(S,i,n)+'''+'#13#10; dec(L,n); inc(i,n); end; FileFromString(E,'test.pas');} S := UncompressString(Base64ToBin(EMF)); Check(Hash32(S)=$5BB4C8B1); MS := THeapMemoryStream.Create; try with TPdfDocument.Create do try Info.CreationDate := FIXED_DATE; // force fixed date and creator for Hash32() Info.Data.PdfTextByName('Producer').Value := 'Synopse PDF engine'; //CompressionMethod := cmNone; useful for debugg purposes of metafile enum AddPage; MF := TMetaFile.Create; try MS.Write(pointer(S)^,length(S)); MS.Position := 0; MF.LoadFromStream(MS); Canvas.RenderMetaFile(MF); Check(Canvas.Page.Font.Name='Tahoma'); finally MF.Free; end; MS.Clear; SaveToStream(MS,FIXED_DATE); // force constant Arial,Bold and Tahoma FontBBox SetString(s,PAnsiChar(MS.Memory),MS.Position); MS.SaveToFile(ChangeFileExt(ExeVersion.ProgramFileName,'.pdf')); if (GetACP<>1252) {$ifdef CPU64}or true{$endif} then Check(length(s)>6500) else begin i := PosEx('/FontBBox[',s); if CheckFailed(i<>0) then exit; FillCharFast(s[i],32,32); j := PosEx('/FontBBox[',s); if CheckFailed(j<>0) then exit; FillCharFast(s[j],32,32); i := PosEx('/FontBBox[',s); if CheckFailed(i<>0)then exit; FillCharFast(s[i],32,32); H := Hash32(s); Check(H=$FE2D27CA); end; finally Free; end; MF := TMetafile.Create; try // create test metafile MF.Width := 700; MF.Height := 700; with TMetafileCanvas.Create(MF, GetDC(0)) do try MoveTo(0, 0); LineTo(700, 700); MoveTo(0, 700); LineTo(700, 0); finally Free; end; // create page in portrait/landscape orientation, and render metafile to it for orientation := false to true do begin Doc := TPdfDocument.Create; try Doc.GeneratePDF15File := True; Doc.Info.CreationDate := FIXED_DATE; // force fixed date for Hash32() Doc.Info.Data.PdfTextByName('Producer').Value := 'Synopse PDF engine'; Doc.DefaultPaperSize := psA4; Page := Doc.AddPage; Page.PageLandscape := orientation; MS.Clear; Doc.Canvas.RenderMetaFile(MF); Doc.SaveToStream(MS,FIXED_DATE); H := Hash32(MS.Memory,MS.Position); Check(H=METAFILE_HASH[orientation]); finally Doc.Free; end; end; finally MF.Free; end; finally MS.Free; end; end; {$endif} {$endif} {$endif} const UTF8_E0_F4_BYTES: array[0..5] of byte = ($E0,$E7,$E8,$E9,$EA,$F4); var _uE0,_uE7,_uE8,_uE9,_uEA,_uF4: RawUTF8; {$ifndef DELPHI5OROLDER} { TTestSQLite3Engine } function TTestSQLite3Engine.OnBackupProgress(Sender: TSQLDatabaseBackupThread): Boolean; begin BackupProgressStep := Sender.Step; result := true; end; procedure InternalSQLFunctionCharIndex(Context: TSQLite3FunctionContext; argc: integer; var argv: TSQLite3ValueArray); cdecl; var StartPos: integer; begin case argc of 2: StartPos := 1; 3: begin StartPos := sqlite3.value_int64(argv[2]); if StartPos<=0 then StartPos := 1; end; else begin ErrorWrongNumberOfArgs(Context); exit; end; end; if (sqlite3.value_type(argv[0])=SQLITE_NULL) or (sqlite3.value_type(argv[1])=SQLITE_NULL) then sqlite3.result_int64(Context,0) else sqlite3.result_int64(Context,SynCommons.PosEx( sqlite3.value_text(argv[0]),sqlite3.value_text(argv[1]),StartPos)); end; {$ifdef UNICODE} {$WARNINGS OFF} // don't care about implicit string cast in tests {$endif} {.$define WITHUNSAFEBACKUP} { define this if you really need the old blocking TSQLRestServerDB backup methods - those methods are deprecated - you should use DB.BackupBackground() instead - should match mORMotSQLite3.pas unit } const // BLOBs are stored as array of byte to avoid any charset conflict BlobDali: array[0..3] of byte = (97,233,224,231); BlobMonet: array[0..13] of byte = (224,233,231,ord('d'),ord('s'),ord('j'), ord('d'),ord('s'),ord('B'),ord('L'),ord('O'),ord('B'),ord('2'),ord('3')); procedure TTestSQLite3Engine.DatabaseDirectAccess; procedure InsertData(n: integer); var i: integer; s: string; ins: RawUTF8; R: TSQLRequest; begin // this code is a lot faster than sqlite3 itself, even if it use Utf8 encoding: // -> we test the engine speed, not the test routines speed :) ins := 'INSERT INTO People (FirstName,LastName,Data,YearOfBirth,YearOfDeath) VALUES ('''; for i := 1 to n do begin str(i,s); // we put some accents in order to test UTF-8 encoding R.Prepare(Demo.DB,ins+'Salvador'+RawUTF8(s)+''', ''Dali'', ?, 1904, 1989);'); R.Bind(1,@BlobDali,4); // Bind Blob R.Execute; Demo.Execute(ins+'Samuel Finley Breese'+s+''', ''Morse'', ''a'+_uE9+_uE0+_uE7+''', 1791, 1872);'); Demo.Execute(ins+'Sergei'+s+''', ''Rachmaninoff'', '''+_uE9+'z'+_uE7+'b'', 1873, 1943);'); Demo.Execute(ins+'Alexandre'+s+''', ''Dumas'', '''+_uE9+_uE7+'b'', 1802, 1870);'); Demo.Execute(ins+'Franz'+s+''', ''Schubert'', '''+_uE9+_uE0+_uE7+'a'', 1797, 1828);'); Demo.Execute(ins+'Leonardo'+s+''', ''da Vin'+_uE7+'i'', ''@'+_uE7+'b'', 1452, 1519);'); Demo.Execute(ins+'Aldous Leonard'+s+''', ''Huxley'', '''+_uE9+_uE0+''', 1894, 1963);'); R.Prepare(Demo.DB,ins+'Claud'+_uE8+s+#10#7''', ''M'+_uF4+'net'', ?, 1840, 1926);'); R.Bind(1,@BlobMonet,sizeof(BlobMonet)); // Bind Blob R.Execute; R.Prepare(Demo.DB,'INSERT INTO People (FirstName,LastName,Data,YearOfBirth,'+ 'YearOfDeath) VALUES (?,?,?,?,?)'); R.BindS(1,'Albert'+s); R.BindS(2,'Einstein'); R.Bind(3,_uE9+_uE7+'p'); R.Bind(4,1879); R.Bind(5,1955); R.Execute; // Demo.Execute(ins+'Albert'+s+''', ''Einstein'', '''+_uE9+_uE7+'p'', 1879, 1955);'); Demo.Execute(ins+'Johannes'+s+''', ''Gutenberg'', '''+_uEA+'mls'', 1400, 1468);'); Demo.Execute(ins+'Jane'+s+''', ''Aust'+_uE8+'n'', '''+_uE7+_uE0+_uE7+'m'', 1775, 1817);'); end; end; var SoundexValues: array[0..5] of RawUTF8; Names: TRawUTF8DynArray; i,i1,i2: integer; Res: Int64; id: TID; password, s: RawUTF8; R: TSQLRequest; begin Check(JSONGetID('{"id":123}',id) and (id=123)); Check(JSONGetID('{"rowid":1234}',id) and (id=1234)); Check(JSONGetID(' { "id": 123}',id) and (id=123)); Check(JSONGetID(' { "ROWID": 1234}',id) and (id=1234)); Check(JSONGetID('{id:123}',id) and (id=123)); Check(JSONGetID('{rowid:1234}',id) and (id=1234)); Check(not JSONGetID('{"id":0}',id)); Check(not JSONGetID('{"id":-10}',id)); Check(not JSONGetID('{"id":null}',id)); Check(not JSONGetID('{"ROWID":null}',id)); Check(not JSONGetID('{id:0}',id)); Check(not JSONGetID('{id:-10}',id)); Check(not JSONGetID('{"ide":123}',id)); Check(not JSONGetID('{"rowide":1234}',id)); Check(not JSONGetID('{"as":123}',id)); Check(not JSONGetID('{"s":1234}',id)); Check(not JSONGetID('"ide":123}',id)); Check(not JSONGetID('{ "rowide":1234}',id)); if ClassType=TTestMemoryBased then TempFileName := SQLITE_MEMORY_DATABASE_NAME else begin TempFileName := 'test.db3'; DeleteFile(TempFileName); // use a temporary file {$ifndef NOSQLITE3ENCRYPT} if ClassType<>TTestFileBasedMemoryMap then // memory map is not compatible with our encryption password := 'password1'; {$endif} end; EncryptedFile := (password<>''); Demo := TSQLDataBase.Create(TempFileName,password); Demo.Synchronous := smOff; Demo.LockingMode := lmExclusive; if ClassType=TTestFileBasedMemoryMap then Demo.MemoryMappedMB := 256; // will do nothing for SQLite3 < 3.7.17 R.Prepare(Demo.DB,'select mod(?,?)'); for i1 := 0 to 100 do for i2 := 1 to 100 do begin R.Bind(1,i1); R.Bind(2,i2); check(R.Step=SQLITE_ROW); check(R.FieldInt(0)=i1 mod i2); R.Reset; end; R.Close; SoundexValues[0] := 'bonjour'; SoundexValues[1] := 'bonchour'; SoundexValues[2] := 'Bnjr'; SoundexValues[3] := 'mohammad'; SoundexValues[4] := 'mohhhammeeet'; SoundexValues[5] := 'bonjourtr'+_uE8+'slongmotquid'+_uE9+'passe'; for i1 := 0 to high(SoundexValues) do begin s := FormatUTF8('SELECT SoundEx("%");',[SoundexValues[i1]]); Demo.Execute(s,res); Check(res=SoundExUTF8(pointer(SoundexValues[i1])),s); end; for i1 := 0 to high(SoundexValues) do begin s := FormatUTF8('SELECT SoundExFr("%");',[SoundexValues[i1]]); Demo.Execute(s,res); Check(res=SoundExUTF8(pointer(SoundexValues[i1]),nil,sndxFrench),s); end; for i1 := 0 to high(SoundexValues) do begin s := FormatUTF8('SELECT SoundExEs("%");',[SoundexValues[i1]]); Demo.Execute(s,res); Check(res=SoundExUTF8(pointer(SoundexValues[i1]),nil,sndxSpanish),s); end; Demo.RegisterSQLFunction(InternalSQLFunctionCharIndex,2,'CharIndex'); Demo.RegisterSQLFunction(InternalSQLFunctionCharIndex,3,'CharIndex'); for i1 := 0 to high(SoundexValues) do begin s := FormatUTF8('SELECT CharIndex("o","%");',[SoundexValues[i1]]); Demo.Execute(s,res); Check(res=PosEx('o',SoundexValues[i1]),s); s := FormatUTF8('SELECT CharIndex("o","%",5);',[SoundexValues[i1]]); Demo.Execute(s,res); Check(res=PosEx('o',SoundexValues[i1],5),s); end; Demo.UseCache := true; // use the cache for the JSON requests Demo.WALMode := InheritsFrom(TTestFileBasedWAL); // test Write-Ahead Logging Check(Demo.WALMode=InheritsFrom(TTestFileBasedWAL)); Demo.Execute( ' CREATE TABLE IF NOT EXISTS People (' + ' ID INTEGER PRIMARY KEY,'+ ' FirstName TEXT COLLATE SYSTEMNOCASE,' + ' LastName TEXT,' + ' Data BLOB,'+ ' YearOfBirth INTEGER,' + ' YearOfDeath INTEGER); '); // Inserting data 1x without transaction '); InsertData(1); { Insert some sample data - now with transaction. Multiple records are inserted and not yet commited until the transaction is finally ended. This single transaction is very fast compared to multiple individual transactions. It is even faster than other database engines. } Demo.TransactionBegin; InsertData(1000); Demo.Commit; Req := 'SELECT * FROM People WHERE LastName=''M'+_uF4+'net'' ORDER BY FirstName;'; Check(WinAnsiToUtf8(Utf8ToWinAnsi(Req))=Req,'WinAnsiToUtf8/Utf8ToWinAnsi'); JS := Demo.ExecuteJSON(Req); // get result in JSON format FileFromString(JS,'Test1.json'); Check(Hash32(JS)=$40C1649A,'Expected ExecuteJSON result not retrieved'); {$ifndef NOSQLITE3ENCRYPT} if password<>'' then begin // check file encryption password change Check(Demo.MemoryMappedMB=0,'mmap pragma disallowed'); FreeAndNil(Demo); // if any exception occurs in Create(), Demo.Free is OK check(IsSQLite3File(TempFileName)); check(IsSQLite3FileEncrypted(TempFileName)); check(not IsOldSQLEncryptTable(TempFileName)); check(not ChangeSQLEncryptTablePassWord(TempFileName,'password1','password1')); check(IsSQLite3File(TempFileName)); check(IsSQLite3FileEncrypted(TempFileName)); check(not IsOldSQLEncryptTable(TempFileName)); check(ChangeSQLEncryptTablePassWord(TempFileName,'password1','')); check(IsSQLite3File(TempFileName)); check(not IsOldSQLEncryptTable(TempFileName)); check(not IsSQLite3FileEncrypted(TempFileName)); check(ChangeSQLEncryptTablePassWord(TempFileName,'','NewPass')); check(IsSQLite3File(TempFileName)); check(IsSQLite3FileEncrypted(TempFileName)); check(not IsOldSQLEncryptTable(TempFileName)); Demo := TSQLDataBase.Create(TempFileName,'NewPass'); // reuse the temporary file Demo.Synchronous := smOff; Demo.LockingMode := lmExclusive; Demo.UseCache := true; // use the cache for the JSON requests Demo.WALMode := InheritsFrom(TTestFileBasedWAL); // test Write-Ahead Logging Check(Demo.WALMode=InheritsFrom(TTestFileBasedWAL)); Check(Demo.MemoryMappedMB=0,'mmap pragma disallowed'); Check(Hash32(Demo.ExecuteJSON(Req))=$40C1649A,'ExecuteJSON crypted'); Check(Demo.MemoryMappedMB=0,'mmap pragma disallowed'); end else {$endif} if ClassType=TTestFileBasedMemoryMap then begin // force re-open to test reading FreeAndNil(Demo); Demo := TSQLDataBase.Create(TempFileName,password); Demo.Synchronous := smOff; Demo.LockingMode := lmExclusive; Demo.MemoryMappedMB := 256; Demo.UseCache := true; end; Demo.GetTableNames(Names); Check(length(Names)=1); Check(Names[0]='People'); Demo.Execute('SELECT Concat(FirstName," and ") FROM People WHERE LastName="Einstein"',s); Check(Hash32(s)=$68A74D8E,'Albert1 and Albert1 and Albert2 and Albert3 and ...'); i1 := Demo.Execute('SELECT FirstName from People WHERE FirstName like "%eona%"',Names); check(i1=2002,'like/strcspn'); check(Names[i1]=''); for i := 0 to i1-1 do check(PosEx('eona',Names[i])>0); end; procedure TTestSQLite3Engine.VirtualTableDirectAccess; const LOG1: RawUTF8 = 'D:\Dev\lib\SQLite3\exe\TestSQL3.exe 1.2.3.4 (2011-04-07)'#13#10+ 'Host=MyPC User=MySelf CPU=2*0-15-1027 OS=2.3=5.1.2600 Wow64=0 Freq=3579545'#13#10+ 'TSynLog 1.13 LVCL 2011-04-07 12:04:09'#13#10#13#10+ '20110407 12040904 debug {"TObjectList(00AF8D00)":["TObjectList(00AF8D20)",'+ '"TObjectList(00AF8D60)","TFileVersion(00ADC0B0)","TSynMapFile(00ACC990)"]}'; var Res: Int64; s,s2,s3: RawUTF8; n: PtrInt; begin // register the Log virtual table module to this connection RegisterVirtualTableModule(TSQLVirtualTableLog,Demo); // test Log virtual table module FileFromString(LOG1,'temptest.log'); Demo.Execute('CREATE VIRTUAL TABLE test USING log(temptest.log);'); Demo.Execute('select count(*) from test',Res); Check(Res=1); n := 0; s := Demo.ExecuteJSON('select * from test',False,@n); Check(s<>''); Check(n=Res); s2 := Demo.ExecuteJSON('select * from test where rowid=2',False,@n); Check(s2='{"fieldCount":3,"values":["DateTime","Level","Content"],"rowCount":0}'#$A); Check(n=0); s2 := Demo.ExecuteJSON('select * from test where rowid=1',False,@n); Check(s2<>''); Check(s=s2); Check(n=1); n := 0; s3 := Demo.ExecuteJSON('select * from test where level=2',False,@n); Check(n=1); Check(s3='{"fieldCount":3,"values":["DateTime","Level","Content","2011-04-07T12:04:09.064",'+ '2,"20110407 12040904 debug {\"TObjectList(00AF8D00)\":[\"TObjectList(00AF8D20)\",'+ '\"TObjectList(00AF8D60)\",\"TFileVersion(00ADC0B0)\",\"TSynMapFile(00ACC990)\"]}"],'+ '"rowCount":1}'#$A); s3 := Demo.ExecuteJSON('select * from test where level=3',False,@n); Check(s3='{"fieldCount":3,"values":["DateTime","Level","Content"],"rowCount":0}'#$A); Check(n=0); end; {$ifdef TEST_REGEXP} procedure TTestSQLite3Engine.RegexpFunction; const EXPRESSIONS: array[0..2] of RawUTF8 = ('\bFinley\b','^Samuel F','\bFinley\b'); var Model: TSQLModel; Client: TSQLRestClientDB; i,n: integer; begin Model := TSQLModel.Create([TSQLRecordPeople]); Client := TSQLRestClientDB.Create(Model,nil,'test.db3',TSQLRestServerDB,false,''); try if CheckFailed(CreateRegExpFunction(Client.Server.DB.DB)) then exit; for i := 0 to high(EXPRESSIONS) do with TSQLRecordPeople.CreateAndFillPrepare(Client,'FirstName REGEXP ?',[EXPRESSIONS[i]]) do try if not CheckFailed(fFill<>nil) then begin Check(fFill.Table.RowCount=1001); n := 0; while FillOne do begin Check(LastName='Morse'); Check(IdemPChar(pointer(FirstName),'SAMUEL FINLEY ')); inc(n); end; Check(n=1001); end; Client.Server.DB.CacheFlush; // force compile '\bFinley\b' twice finally Free; end; finally Client.Free; Model.Free; end; end; {$endif TEST_REGEXP} type TSQLRecordPeopleVersioned = class(TSQLRecordPeople) protected fVersion: TRecordVersion; published property Version: TRecordVersion read fVersion write fVersion; end; procedure TestMasterSlaveRecordVersion(Test: TSynTestCase; const DBExt: TFileName); procedure TestMasterSlave(Master,Slave: TSQLRestServer; SynchronizeFromMaster: TSQLRest); var res: TRecordVersion; Rec1,Rec2: TSQLRecordPeopleVersioned; begin if SynchronizeFromMaster<>nil then res := Slave.RecordVersionSynchronizeSlave(TSQLRecordPeopleVersioned,SynchronizeFromMaster,500) else res := Slave.RecordVersionCurrent; Test.Check(res=Master.RecordVersionCurrent); Rec1 := TSQLRecordPeopleVersioned.CreateAndFillPrepare(Master,'order by ID','*'); Rec2 := TSQLRecordPeopleVersioned.CreateAndFillPrepare(Slave,'order by ID','*'); try Test.Check(Rec1.FillTable.RowCount=Rec2.FillTable.RowCount); while Rec1.FillOne do begin Test.Check(Rec2.FillOne); Test.Check(Rec1.SameRecord(Rec2),'simple fields'); Test.Check(Rec1.Version=Rec2.Version); end; finally Rec1.Free; Rec2.Free; end; end; var Model: TSQLModel; Master,Slave1,Slave2: TSQLRestServerDB; MasterAccess: TSQLRestClientURI; IDs: TIDDynArray; Rec: TSQLRecordPeopleVersioned; Slave2Callback: IServiceRecordVersionCallback; i,n: integer; timeout: Int64; function CreateServer(const DBFileName: TFileName; DeleteDBFile: boolean): TSQLRestServerDB; begin if DeleteDBFile then DeleteFile(DBFileName); result := TSQLRestServerDB.Create(TSQLModel.Create(Model),DBFileName,false,''); result.Model.Owner := result; result.DB.Synchronous := smOff; result.DB.LockingMode := lmExclusive; result.CreateMissingTables; end; procedure CreateMaster(DeleteDBFile: boolean); var serv: TSQLHttpServer; ws: TSQLHttpClientWebsockets; begin Master := CreateServer('testversion'+DBExt,DeleteDBFile); if Test is TTestBidirectionalRemoteConnection then begin serv := TTestBidirectionalRemoteConnection(Test).fHttpServer; Test.Check(serv.AddServer(Master)); serv.WebSocketsEnable(Master,'key2').Settings.SetFullLog; ws := TSQLHttpClientWebsockets.Create('127.0.0.1',HTTP_DEFAULTPORT,TSQLModel.Create(Model)); ws.Model.Owner := ws; ws.WebSockets.Settings.SetFullLog; Test.Check(ws.WebSocketsUpgrade('key2')=''); MasterAccess := ws; end else MasterAccess := TSQLRestClientDB.Create(Master); end; begin Model := TSQLModel.Create( [TSQLRecordPeople,TSQLRecordPeopleVersioned,TSQLRecordTableDeleted],'root0'); CreateMaster(true); Slave1 := CreateServer('testversionreplicated'+DBExt,true); Slave2 := CreateServer('testversioncallback'+DBExt,true); try Rec := TSQLRecordPeopleVersioned.CreateAndFillPrepare(StringFromFile('Test1.json')); try // Rec contains 1001 input rows of data TestMasterSlave(Master,Slave1,MasterAccess); TestMasterSlave(Master,Slave2,MasterAccess); n := Rec.FillTable.RowCount; Test.Check(n>100); for i := 0 to 9 do begin // first test raw direct add Test.Check(Rec.FillOne); Master.Add(Rec,true,true); end; TestMasterSlave(Master,Slave1,MasterAccess); if Test is TTestBidirectionalRemoteConnection then Test.Check(TTestBidirectionalRemoteConnection(Test).fHttpServer. RemoveServer(Master)); if Test is TTestBidirectionalRemoteConnection then TTestBidirectionalRemoteConnection(Test).fHttpServer.RemoveServer(Master); Master.Free; // test TSQLRestServer.InternalRecordVersionMaxFromExisting MasterAccess.Free; CreateMaster(false); MasterAccess.BatchStart(TSQLRecordPeopleVersioned,10000); while Rec.FillOne do // fast add via Batch Test.Check(MasterAccess.BatchAdd(Rec,true,true)>=0); Test.Check(MasterAccess.BatchSend(IDs)=HTTP_SUCCESS); Test.Check(n=length(IDs)+10); Test.Check(Rec.FillRewind); for i := 0 to 9 do Test.Check(Rec.FillOne); for i := 0 to high(IDs) do if Rec.FillOne then Test.Check(IDs[i]=Rec.IDValue) else Test.Check(false); TestMasterSlave(Master,Slave1,MasterAccess); TestMasterSlave(Master,Slave2,MasterAccess); if Test is TTestBidirectionalRemoteConnection then begin // asynchronous synchronization via websockets Test.Check(Master.RecordVersionSynchronizeMasterStart(true)); Test.Check(Slave2.RecordVersionSynchronizeSlaveStart( TSQLRecordPeopleVersioned,MasterAccess,nil)); end else begin // direct synchronization within the same process Slave2Callback := TServiceRecordVersionCallback.Create( Slave2,MasterAccess,TSQLRecordPeopleVersioned,nil); Master.RecordVersionSynchronizeSubscribeMaster(TSQLRecordPeopleVersioned, Slave2.RecordVersionCurrent,Slave2Callback); end; Test.Check(Rec.FillRewind); for i := 0 to 20 do begin Test.Check(Rec.FillOne); Rec.YearOfBirth := Rec.YearOfBirth+1; if i and 3=1 then Test.Check(Master.Delete(TSQLRecordPeopleVersioned,Rec.IDValue)) else Test.Check(Master.Update(Rec)); if i and 3=2 then begin Rec.YearOfBirth := Rec.YearOfBirth+4; Test.Check(Master.Update(Rec),'update twice to increase Version'); end; end; TestMasterSlave(Master,Slave1,MasterAccess); TestMasterSlave(Master,Slave1,MasterAccess); if Test is TTestBidirectionalRemoteConnection then begin timeout := GetTickCount64+3000; repeat sleep(1) until (GetTickCount64>timeout) or // wait all callbacks to be received (Slave2.RecordVersionCurrent=Master.RecordVersionCurrent); Test.Check(Slave2.RecordVersionSynchronizeSlaveStop(TSQLRecordPeopleVersioned)); end; TestMasterSlave(Master,Slave2,nil); TestMasterSlave(Master,Slave2,MasterAccess); finally Rec.Free; end; if Test is TTestBidirectionalRemoteConnection then TTestBidirectionalRemoteConnection(Test).fHttpServer.RemoveServer(Master); finally Slave2Callback := nil; Slave1.Free; // warning: Free should be in this order for callbacks release Slave2.Free; Master.Free; MasterAccess.Free; Model.Free; end; end; procedure TTestSQLite3Engine._TRecordVersion; begin TestMasterSlaveRecordVersion(self,'.db3'); end; procedure TTestMemoryBased._TSQLTableWritable; procedure Test(intern: TRawUTF8Interning); var s1,s2: TSQLTableJSON; w: TSQLTableWritable; f,r: integer; begin s1 := TSQLTableJSON.CreateFromTables([TSQLRecordPeople],'',JS); s2 := TSQLTableJSON.CreateFromTables([TSQLRecordPeople],'',JS); w := TSQLTableWritable.CreateFromTables([TSQLRecordPeople],'',JS); try // merge the same data twice, and validate duplicated columns w.NewValuesInterning := intern; check(w.RowCount=s1.RowCount); check(w.FieldCount=s1.FieldCount); w.Join(s2,'rowid','ID'); // s2 will be sorted -> keep s1 untouched check(w.RowCount=s1.RowCount); check(w.FieldCount=s1.FieldCount*2-1); for f := 0 to s1.FieldCount-1 do begin check(w.FieldIndex(s1.FieldNames[f])=f); if f>0 then // f=0='ID' is not duplicated check(w.FieldIndex(s1.FieldNames[f]+'2')=f+s1.FieldCount-1); end; for r := 1 to w.RowCount do begin for f := 0 to s1.FieldCount-1 do begin check(StrComp(s1.Get(r,f),w.Get(r,f))=0); if f>0 then check(StrComp(s1.Get(r,f),w.Get(r,f+s1.FieldCount-1))=0); end; end; if intern<>nil then check(intern.Count=0); for r := 0 to w.RowCount do w.Update(r,1,UInt32ToUTF8(r and 127)); for r := 1 to w.RowCount do check(w.GetAsInteger(r,1)=r and 127); if intern<>nil then check(intern.Count=128); finally s1.Free; s2.Free; w.Free; intern.Free; end; end; begin Test(nil); Test(TRawUTF8Interning.Create); end; type TSQLRecordMapBox = class(TSQLRecordRTree) protected fMinX, fMaxX, fMinY, fMaxY: double; published property MinX: double read fMinX write fMinX; property MaxX: double read fMaxX write fMaxX; property MinY: double read fMinY write fMinY; property MaxY: double read fMaxY write fMaxY; end; TSQLRecordMapBoxI = class(TSQLRecordRTreeInteger) protected fMinX, fMaxX, fMinY, fMaxY: integer; published property MinX: integer read fMinX write fMinX; property MaxX: integer read fMaxX write fMaxX; property MinY: integer read fMinY write fMinY; property MaxY: integer read fMaxY write fMaxY; end; TSQLRecordMapBoxPlain = class(TSQLRecord) protected fMinX, fMaxX, fMinY, fMaxY: double; published property MinX: double read fMinX write fMinX; property MaxX: double read fMaxX write fMaxX; property MinY: double read fMinY write fMinY; property MaxY: double read fMaxY write fMaxY; end; procedure TTestMemoryBased._RTree; var Model: TSQLModel; Client: TSQLRestClientDB; Box: TSQLRecordMapBox; BoxI: TSQLRecordMapBoxI; //BoxPlain: TSQLRecordMapBoxPlain; i: integer; timer: TPrecisionTimer; procedure CheckBox(i: integer); begin Check(Box.fID=i*2); CheckSame(Box.MinX,i*1.0); CheckSame(Box.MaxX,i*1.0+0.5); CheckSame(Box.MinY,i*2.0); CheckSame(Box.MaxY,i*2.0+0.5); end; procedure CheckBoxI(i: integer); begin Check(BoxI.fID=i*2); Check(BoxI.MinX=i); Check(BoxI.MaxX=i+2); Check(BoxI.MinY=i*2); Check(BoxI.MaxY=i*2+2); end; {procedure CheckBoxPlain(i: integer); begin Check(BoxPlain.fID=i*2); CheckSame(BoxPlain.MinX,i*1.0); CheckSame(BoxPlain.MaxX,i*1.0+0.5); CheckSame(BoxPlain.MinY,i*2.0); CheckSame(BoxPlain.MaxY,i*2.0+0.5); end;} const COUNT=10000; begin Model := TSQLModel.Create([TSQLRecordMapBox,TSQLRecordMapBoxI,TSQLRecordMapBoxPlain]); Client := TSQLRestClientDB.Create(Model,nil,SQLITE_MEMORY_DATABASE_NAME,TSQLRestServerDB,false,''); try (Client.Server as TSQLRestServer).CreateMissingTables; {timer.Start; BoxPlain := TSQLRecordMapBoxPlain.Create; try Client.TransactionBegin(TSQLRecordMapBoxPlain); for i := 1 to COUNT do begin BoxPlain.fID := i*2; // force ID BoxPlain.MinX := i*1.0; BoxPlain.MaxX := i*1.0+0.5; BoxPlain.MinY := i*2.0; BoxPlain.MaxY := i*2.0+0.5; Check(Client.Add(BoxPlain,true,true)=i*2); end; Client.Commit; writeln('added in ',timer.Stop); timer.Start; with Client.Server as TSQLRestServer do begin CreateSQLIndex(TSQLRecordMapBoxPlain,'MinX',false); CreateSQLIndex(TSQLRecordMapBoxPlain,'MaxX',false); CreateSQLIndex(TSQLRecordMapBoxPlain,'MinY',false); CreateSQLIndex(TSQLRecordMapBoxPlain,'MaxY',false); end; writeln('indexes created in ',timer.Stop); timer.Start; for i := 1 to COUNT do begin Check(Client.Retrieve(i*2,BoxPlain)); CheckBoxPlain(i); end; writeln('retrieved by id in ',timer.Stop); timer.Start; for i := 1 to COUNT do begin BoxPlain.FillPrepare(Client,'MinX<=? and ?<=MaxX and MinY<=? and ?<=MaxY', [i*1.0+0.25,i*1.0+0.25,i*2.0+0.25,i*2.0+0.25]); Check(BoxPlain.FillOne); CheckBoxPlain(i); Check(not BoxPlain.FillOne); end; writeln('retrieved by coords in ',timer.Stop); timer.Start; finally BoxPlain.Free; end; NotifyTestSpeed('Without RTree',COUNT,0,@timer);} timer.Start; Box := TSQLRecordMapBox.Create; try Client.TransactionBegin(TSQLRecordMapBox); for i := 1 to COUNT do begin Box.fID := i*2; // force ID Box.MinX := i*1.0; Box.MaxX := i*1.0+0.5; Box.MinY := i*2.0; Box.MaxY := i*2.0+0.5; Check(Client.Add(Box,true,true)=i*2); end; Client.Commit; for i := 1 to COUNT do begin Check(Client.Retrieve(i*2,Box)); CheckBox(i); end; for i := 1 to COUNT do begin Box.FillPrepare(Client,'MinX<=? and ?<=MaxX and MinY<=? and ?<=MaxY', [i*1.0+0.25,i*1.0+0.25,i*2.0+0.25,i*2.0+0.25]); Check(Box.FillOne); CheckBox(i); Check(not Box.FillOne); end; Box.FillPrepare(Client,'MinX<=? and ?<=MaxX and MinY<=? and ?<=MaxY', [1.0,1.0,2.0,2.0]); Check(Box.FillOne); CheckBox(1); Box.FillPrepare(Client,'MinX<=? and ?<=MaxX and MinY<=? and ?<=MaxY', [1.5,1.5,2.5,2.5]); Check(Box.FillOne); CheckBox(1); finally Box.Free; end; NotifyTestSpeed('With RTree',COUNT,0,@timer); timer.Start; BoxI := TSQLRecordMapBoxI.Create; try Client.TransactionBegin(TSQLRecordMapBoxI); for i := 1 to COUNT do begin BoxI.fID := i*2; // force ID BoxI.MinX := i; BoxI.MaxX := i+2; BoxI.MinY := i*2; BoxI.MaxY := i*2+2; Check(Client.Add(BoxI,true,true)=i*2); end; Client.Commit; for i := 1 to COUNT do begin Check(Client.Retrieve(i*2,BoxI)); CheckBoxI(i); end; for i := 1 to COUNT do begin BoxI.FillPrepare(Client,'MinX<=? and ?<=MaxX and MinY<=? and ?<=MaxY', [i+1,i+1,i*2+1,i*2+1]); Check(BoxI.FillOne); CheckBoxI(i); Check(not BoxI.FillOne); end; BoxI.FillPrepare(Client,'MinX<=? and ?<=MaxX and MinY<=? and ?<=MaxY', [1,1,2,2]); Check(BoxI.FillOne); CheckBoxI(1); BoxI.FillPrepare(Client,'MinX<=? and ?<=MaxX and MinY<=? and ?<=MaxY', [3,3,4,4]); Check(BoxI.FillOne); CheckBoxI(1); finally BoxI.Free; end; NotifyTestSpeed('With RTreeInteger',COUNT,0,@timer); finally Client.Free; Model.Free; end; end; { Delphi Win32: 10000 With RTree in 806.64ms i.e. 12396/s, aver. 80us 10000 With RTreeInteger in 750.94ms i.e. 13316/s, aver. 75us 10000 Without RTree in 16.82s i.e. 594/s, aver. 1.68ms (no index) 10000 Without RTree in 22.96s i.e. 435/s, aver. 2.29ms (with indexes created last) added in 136.90ms indexes created in 25.02ms retrieved by id in 119.87ms retrieved by coords in 22.71s 10000 Without RTree in 23.13s i.e. 432/s, aver. 2.31ms (with indexes created first) Delphi Win64: 10000 With RTree in 737ms i.e. 13568/s, aver. 73us 10000 With RTreeInteger in 621.83ms i.e. 16081/s, aver. 62us FPC Win32: 10000 With RTree in 852.12ms i.e. 11735/s, aver. 85us 10000 With RTreeInteger in 764.59ms i.e. 13078/s, aver. 76us FPC Win64: 10000 With RTree in 718.39ms i.e. 13919/s, aver. 71us 10000 With RTreeInteger in 667.80ms i.e. 14974/s, aver. 66us FPC Linux64 (within Windows Linux Layer): 10000 With RTree in 1.08s i.e. 9218/s, aver. 108us 10000 With RTreeInteger in 1s i.e. 9966/s, aver. 100us } const SHARD_MAX = 10000; SHARD_RANGE = 1000; function TTestMemoryBased.CreateShardDB(maxshard: Integer): TSQLRestServer; begin result := TSQLRestServer.CreateWithOwnModel([TSQLRecordTest],false,'shardtest'); Check(result.StaticDataAdd(TSQLRestStorageShardDB.Create( TSQLRecordTest,result,SHARD_RANGE,[],'',maxshard))); end; procedure TTestMemoryBased.ShardWrite; var R: TSQLRecordTest; i: integer; db: TSQLRestServer; b: TSQLRestBatch; begin DirectoryDelete(ExeVersion.ProgramFilePath,'Test0*.dbs',True); db := CreateShardDB(100); try R := TSQLRecordTest.Create; try for i := 1 to 50 do begin R.FillWith(i); Check(db.AddWithBlobs(R)=i); R.CheckWith(self,i); end; b := TSQLRestBatch.Create(db,TSQLRecordTest,SHARD_RANGE div 3,[boExtendedJSON]); try for i := 51 to SHARD_MAX do begin R.FillWith(i); Check(b.Add(R,true,false,ALL_FIELDS)=i-51); end; Check(db.BatchSend(b)=HTTP_SUCCESS); finally b.Free; end; finally R.Free; end; finally db.Free; end; end; procedure TTestMemoryBased.ShardRead; var R: TSQLRecordTest; i: integer; db: TSQLRestServer; begin db := CreateShardDB(100); try R := TSQLRecordTest.Create; try for i := 1 to SHARD_MAX do begin Check(db.Retrieve(i,R)); Check(db.RetrieveBlobFields(R)); R.CheckWith(self,i,0); end; finally R.Free; end; finally db.Free; end; end; procedure TTestMemoryBased.ShardReadAfterPurge; var R: TSQLRecordTest; i: integer; db: TSQLRestServer; begin Check(DeleteFile(ExeVersion.ProgramFilePath+'Test0000.dbs')); Check(DeleteFile(ExeVersion.ProgramFilePath+'Test0001.dbs')); db := CreateShardDB(100); try R := TSQLRecordTest.Create; try for i := 1 to SHARD_RANGE*2 do Check(not db.Retrieve(i,R)); for i := SHARD_RANGE*2+1 to SHARD_MAX do begin Check(db.Retrieve(i,R)); Check(db.RetrieveBlobFields(R)); R.CheckWith(self,i,0); end; finally R.Free; end; finally db.Free; end; end; procedure TTestMemoryBased._MaxShardCount; var R: TSQLRecordTest; i,last: integer; db: TSQLRestServer; b: TSQLRestBatch; begin db := CreateShardDB(5); try R := TSQLRecordTest.Create; try last := SHARD_MAX-SHARD_RANGE*5; for i := 1 to last do Check(not db.Retrieve(i,R)); for i := last+1 to SHARD_MAX do begin Check(db.Retrieve(i,R)); Check(db.RetrieveBlobFields(R)); R.CheckWith(self,i,0); end; b := TSQLRestBatch.Create(db,TSQLRecordTest,SHARD_RANGE div 3,[boExtendedJSON]); try for i := SHARD_MAX+1 to SHARD_MAX+2000 do begin R.FillWith(i); Check(b.Add(R,true)=i-(SHARD_MAX+1)); end; Check(db.BatchSend(b)=HTTP_SUCCESS); finally b.Free; end; last := SHARD_MAX+2000-SHARD_RANGE*5; for i := 1 to last do Check(not db.Retrieve(i,R)); for i := last+1 to SHARD_MAX+2000 do begin Check(db.Retrieve(i,R)); R.CheckWith(self,i,0,false); end; finally R.Free; end; finally db.Free; end; end; { TTestClientServerAccess } {$WARN SYMBOL_PLATFORM OFF} procedure TTestClientServerAccess._TSQLHttpClient; var Resp: TSQLTable; len: integer; begin Client := TSQLHttpClient.Create('127.0.0.1',HTTP_DEFAULTPORT,Model); fRunConsole := fRunConsole+'using '+string(Client.ClassName); (Client as TSQLHttpClientGeneric).Compression := []; Resp := Client.List([TSQLRecordPeople],'*'); if CheckFailed(Resp<>nil) then exit; try Check(Resp.InheritsFrom(TSQLTableJSON)); len := Length(TSQLTableJSON(Resp).PrivateInternalCopy)-16; if not CheckFailed(len>0) then Check(Hash32(pointer(TSQLTableJSON(Resp).PrivateInternalCopy),len)=$F11CEAC0); //FileFromString(Resp.GetODSDocument,'people.ods'); finally Resp.Free; end; end; {$WARN SYMBOL_PLATFORM ON} {$ifdef MSWINDOWS} class function TTestClientServerAccess.RegisterAddUrl(OnlyDelete: boolean): string; begin result := THttpApiServer.AddUrlAuthorize('root',HTTP_DEFAULTPORT,false,'+',OnlyDelete); end; {$endif} procedure TTestClientServerAccess._TSQLHttpServer; begin Model := TSQLModel.Create([TSQLRecordPeople],'root'); Check(Model<>nil); Check(Model.GetTableIndex('people')>=0); try DataBase := TSQLRestServerDB.Create(Model,'test.db3'); DataBase.DB.Synchronous := smOff; DataBase.DB.LockingMode := lmExclusive; Server := TSQLHttpServer.Create( HTTP_DEFAULTPORT,[DataBase],'+',HTTP_DEFAULT_MODE,16,secSynShaAes); fRunConsole := fRunConsole+'using '+Server.HttpServer.APIVersion; Database.NoAJAXJSON := true; // expect not expanded JSON from now on except on E: Exception do Check(false,E.Message); end; end; procedure TTestClientServerAccess.CleanUp; begin FreeAndNil(Client); // should already be nil Server.Shutdown; FreeAndNil(Server); FreeAndNil(DataBase); FreeAndNil(Model); end; {$define WTIME} const CLIENTTEST_WHERECLAUSE = 'FirstName Like "Sergei1%"'; procedure TTestClientServerAccess.ClientTest; const IDTOUPDATE = 3; {$ifdef WTIME} LOOP=1000; var Timer: ILocalPrecisionTimer; {$else} LOOP=100; {$endif} var i,siz: integer; Resp: TSQLTable; Rec, Rec2: TSQLRecordPeople; Refreshed: boolean; procedure TestOne; var i: integer; begin i := Rec.YearOfBirth; Rec.YearOfBirth := 1982; Check(Client.Update(Rec)); Rec2.ClearProperties; Check(Client.Retrieve(IDTOUPDATE,Rec2)); Check(Rec2.YearOfBirth=1982); Rec.YearOfBirth := i; Check(Client.Update(Rec)); if Client.InheritsFrom(TSQLRestClientURI) then begin Check(TSQLRestClientURI(Client).UpdateFromServer([Rec2],Refreshed)); Check(Refreshed,'should have been refreshed'); end else Check(Client.Retrieve(IDTOUPDATE,Rec2)); Check(Rec.SameRecord(Rec2)); end; begin {$ifdef WTIME} Timer := TLocalPrecisionTimer.CreateAndStart; {$endif} // first calc result: all transfert protocols have to work from cache Resp := Client.List([TSQLRecordPeople],'*',CLIENTTEST_WHERECLAUSE); if CheckFailed(Resp<>nil) then exit; siz := length(TSQLTableJSON(Resp).PrivateInternalCopy)-16; if not CheckFailed(siz=4818) then Check(Hash32(pointer(TSQLTableJSON(Resp).PrivateInternalCopy),siz)=$8D727024); Resp.Free; {$ifdef WTIME} fRunConsole := format('%s%s, first %s, ',[fRunConsole,KB(siz),Timer.Stop]); {$endif} // test global connection speed and caching (both client and server sides) Rec2 := TSQLRecordPeople.Create; Rec := TSQLRecordPeople.Create(Client,IDTOUPDATE); try Check(Rec.ID=IDTOUPDATE,'retrieve record'); Check(Database.Cache.CachedEntries=0); Check(Client.Cache.CachedEntries=0); Check(Client.Cache.CachedMemory=0); TestOne; Check(Client.Cache.CachedEntries=0); Client.Cache.SetCache(TSQLRecordPeople); // cache whole table Check(Client.Cache.CachedEntries=0); Check(Client.Cache.CachedMemory=0); TestOne; Check(Client.Cache.CachedEntries=1); Check(Client.Cache.CachedMemory>0); Client.Cache.Clear; // reset cache settings Check(Client.Cache.CachedEntries=0); Client.Cache.SetCache(Rec); // cache one = SetCache(TSQLRecordPeople,Rec.ID) Check(Client.Cache.CachedEntries=0); Check(Client.Cache.CachedMemory=0); TestOne; Check(Client.Cache.CachedEntries=1); Check(Client.Cache.CachedMemory>0); Client.Cache.SetCache(TSQLRecordPeople); TestOne; Check(Client.Cache.CachedEntries=1); Client.Cache.Clear; Check(Client.Cache.CachedEntries=0); TestOne; Check(Client.Cache.CachedEntries=0); if not (Client.InheritsFrom(TSQLRestClientDB)) then begin // server-side Database.Cache.SetCache(TSQLRecordPeople); TestOne; Check(Client.Cache.CachedEntries=0); Check(Database.Cache.CachedEntries=1); Database.Cache.Clear; Check(Client.Cache.CachedEntries=0); Check(Database.Cache.CachedEntries=0); Database.Cache.SetCache(TSQLRecordPeople,Rec.ID); TestOne; Check(Client.Cache.CachedEntries=0); Check(Database.Cache.CachedEntries=1); Database.Cache.SetCache(TSQLRecordPeople); Check(Database.Cache.CachedEntries=0); TestOne; Check(Database.Cache.CachedEntries=1); if Client.InheritsFrom(TSQLRestClientURI) then TSQLRestClientURI(Client).ServerCacheFlush else Database.Cache.Flush; Check(Database.Cache.CachedEntries=0); Check(Database.Cache.CachedMemory=0); Database.Cache.Clear; end; finally Rec2.Free; Rec.Free; end; // test average speed for a 5 KB request Resp := Client.List([TSQLRecordPeople],'*',CLIENTTEST_WHERECLAUSE); Check(Resp<>nil); Resp.Free; {$ifdef WTIME} Timer.Start; {$endif} for i := 1 to LOOP do begin Resp := Client.List([TSQLRecordPeople],'*',CLIENTTEST_WHERECLAUSE); if CheckFailed(Resp<>nil) then exit; try Check(Resp.InheritsFrom(TSQLTableJSON)); // every answer contains 113 rows, for a total JSON size of 4803 bytes siz := length(TSQLTableJSON(Resp).PrivateInternalCopy)-16; if not CheckFailed(siz>0) then Check(Hash32(pointer(TSQLTableJSON(Resp).PrivateInternalCopy),siz)=$8D727024); finally Resp.Free; end; end; {$ifdef WTIME} fRunConsole := format('%sdone %s i.e. %d/s, aver. %s, %s/s', [fRunConsole,Timer.Stop,Timer.PerSec(LOOP),Timer.ByCount(LOOP), KB(Timer.PerSec(4898*(LOOP+1)))]); {$endif} end; procedure TTestClientServerAccess.HttpClientKeepAlive; begin (Client as TSQLHttpClientGeneric).KeepAliveMS := 20000; (Client as TSQLHttpClientGeneric).Compression := []; ClientTest; end; procedure TTestClientServerAccess.HttpClientMultiConnect; begin (Client as TSQLHttpClientGeneric).KeepAliveMS := 0; (Client as TSQLHttpClientGeneric).Compression := []; ClientTest; end; procedure TTestClientServerAccess.HttpClientEncrypted; begin (Client as TSQLHttpClientGeneric).KeepAliveMS := 20000; (Client as TSQLHttpClientGeneric).Compression := [hcSynShaAes]; ClientTest; end; procedure TTestClientServerAccess.HTTPClientCustomEncryptionAesSha; var rnd: THash256; sign: TSynSigner; begin TAESPRNG.Main.FillRandom(rnd); sign.Init(saSha256,'secret1'); Client.SetCustomEncryption(TAESOFB.Create(rnd),@sign,AlgoSynLZ); DataBase.SetCustomEncryption(TAESOFB.Create(rnd),@sign,AlgoSynLZ); ClientTest; end; procedure TTestClientServerAccess.HTTPClientCustomEncryptionAes; var rnd: THash256; begin TAESPRNG.Main.FillRandom(rnd); Client.SetCustomEncryption(TAESOFB.Create(rnd),nil,AlgoSynLZ); DataBase.SetCustomEncryption(TAESOFB.Create(rnd),nil,AlgoSynLZ); ClientTest; end; procedure TTestClientServerAccess.HTTPClientCustomEncryptionSha; var sign: TSynSigner; begin sign.Init(saSha256,'secret2'); Client.SetCustomEncryption(nil,@sign,AlgoSynLZ); DataBase.SetCustomEncryption(nil,@sign,AlgoSynLZ); ClientTest; Client.SetCustomEncryption(nil,nil,nil); // disable custom encryption DataBase.SetCustomEncryption(nil,nil,nil); end; procedure TTestClientServerAccess.HttpSeveralDBServers; var Instance: array[0..2] of record Model: TSQLModel; Database: TSQLRestServerDB; Client: TSQLHttpClient; end; i: integer; Rec: TSQLRecordPeople; begin Rec := TSQLRecordPeople.CreateAndFillPrepare(Database,CLIENTTEST_WHERECLAUSE); try Check(Rec.FillTable.RowCount=113); // release main http client/server and main database instances CleanUp; assert(Client=nil); assert(Server=nil); assert(DataBase=nil); // create 3 TSQLRestServerDB + TSQLHttpClient instances (and TSQLModel) for i := 0 to high(Instance) do with Instance[i] do begin Model := TSQLModel.Create([TSQLRecordPeople],'root'+Int32ToUtf8(i)); DataBase := TSQLRestServerDB.Create(Model,SQLITE_MEMORY_DATABASE_NAME); Database.NoAJAXJSON := true; // expect not expanded JSON from now on DataBase.CreateMissingTables; end; // launch one HTTP server for all TSQLRestServerDB instances Server := TSQLHttpServer.Create(HTTP_DEFAULTPORT, [Instance[0].Database,Instance[1].Database,Instance[2].Database], '+',HTTP_DEFAULT_MODE,4,secNone); // initialize the clients for i := 0 to high(Instance) do with Instance[i] do Client := TSQLHttpClient.Create('127.0.0.1',HTTP_DEFAULTPORT,Model); // fill remotely all TSQLRestServerDB instances for i := 0 to high(Instance) do with Instance[i] do begin Client.TransactionBegin(TSQLRecordPeople); Check(Rec.FillRewind); while Rec.FillOne do Check(Client.Add(Rec,true,true)=Rec.fID); Client.Commit; end; // test remote access to all TSQLRestServerDB instances try for i := 0 to high(Instance) do begin Client := Instance[i].Client; DataBase := Instance[i].DataBase; try ClientTest; {$ifdef WTIME} if inil) then exit; Test.Check(MS.FillTable.RowCount>=length(sId)); while MS.FillOne do begin Test.Check(MS.DestList.Source.fID=MS.fID); Test.Check(MS.DestList.Dest.SignatureTime<>0); MS.ClearProperties; MS.DestList.Source.ClearProperties; MS.DestList.Dest.ClearProperties; end; MS.FillClose; end; begin MS := TSQLASource.Create; MD := TSQLADest.Create; with Test do try MD.fSignatureTime := TimeLogNow; MS.fSignatureTime := MD.fSignatureTime; Check(MS.DestList<>nil); Check(MS.DestList.InheritsFrom(TSQLRecordMany)); Check(aClient.TransactionBegin(TSQLASource)); // faster process for i := 1 to high(dID) do begin MD.fSignature := FormatUTF8('% %',[aClient.ClassName,i]); dID[i] := aClient.Add(MD,true); Check(dID[i]>0); end; for i := 1 to high(sID) do begin MS.fSignature := FormatUTF8('% %',[aClient.ClassName,i]); sID[i] := aClient.Add(MS,True); Check(sID[i]>0); MS.DestList.AssociationTime := i; Check(MS.DestList.ManyAdd(aClient,sID[i],dID[i])); // associate both lists Check(not MS.DestList.ManyAdd(aClient,sID[i],dID[i],true)); // no dup end; aClient.Commit; for i := 1 to high(dID) do begin Check(MS.DestList.SourceGet(aClient,dID[i],res)); if not CheckFailed(length(res)=1) then Check(res[0]=sID[i]); Check(MS.DestList.ManySelect(aClient,sID[i],dID[i])); Check(MS.DestList.AssociationTime=i); end; for i := 1 to high(sID) do begin Check(MS.DestList.DestGet(aClient,sID[i],res)); if CheckFailed(length(res)=1) then continue; // avoid GPF Check(res[0]=dID[i]); Check(MS.DestList.FillMany(aClient,sID[i])=1); Check(MS.DestList.FillOne); Check(Integer(MS.DestList.Source)=sID[i]); Check(Integer(MS.DestList.Dest)=dID[i]); Check(MS.DestList.AssociationTime=i); Check(not MS.DestList.FillOne); Check(MS.DestList.DestGetJoined(aClient,'',sID[i],res)); if not CheckFailed(length(res)=1) then Check(res[0]=dID[i]); Check(MS.DestList.DestGetJoined(aClient,'ADest.SignatureTime=:(0):',sID[i],res)); Check(length(res)=0); Check(MS.DestList.DestGetJoined(aClient, FormatUTF8('ADest.SignatureTime=?',[],[MD.SignatureTime]),sID[i],res)); // 'ADest.SignatureTime=:('+Int64ToUTF8(MD.SignatureTime)+'):',sID[i],res)); if CheckFailed(length(res)=1) then continue; // avoid GPF Check(res[0]=dID[i]); MD2 := MS.DestList.DestGetJoined(aClient, FormatUTF8('ADest.SignatureTime=?',[],[MD.SignatureTime]),sID[i]) as TSQLADest; // 'ADest.SignatureTime=:('+Int64ToUTF8(MD.SignatureTime)+'):',sID[i]) as TSQLADest; if CheckFailed(MD2<>nil) then continue; try Check(MD2.FillOne); Check(MD2.ID=dID[i]); Check(MD2.Signature=FormatUTF8('% %',[aClient.ClassName,i])); finally MD2.Free; end; end; Check(MS.FillPrepareMany(aClient,'', [],[])); CheckOK; Check(MS.FillPrepareMany(aClient,'DestList.Dest.SignatureTime<>?',[],[0])); CheckOK; Check(MS.FillPrepareMany(aClient, 'DestList.Dest.SignatureTime<>% and RowID>=? and DestList.AssociationTime<>0 '+ 'and SignatureTime=DestList.Dest.SignatureTime '+ 'and DestList.Dest.Signature<>"DestList.AssociationTime"',[0],[sID[1]])); if CheckFailed(MS.FillTable<>nil) then exit; Check(MS.FillTable.RowCount=length(sID)); for i := 1 to high(sID) do begin MS.SignatureTime := 0; MS.DestList.Dest.SignatureTime := 0; if CheckFailed(MS.FillOne) then break; Check(MS.fID=sID[i]); Check(MS.SignatureTime=MD.fSignatureTime); Check(MS.DestList.AssociationTime=i); Check(MS.DestList.Dest.fID=dID[i]); Check(MS.DestList.Dest.SignatureTime=MD.fSignatureTime); Check(MS.DestList.Dest.Signature=FormatUTF8('% %',[aClient.ClassName,i])); end; MS.FillClose; Check(aClient.TransactionBegin(TSQLADests)); // faster process for i := 1 to high(sID) shr 2 do Check(MS.DestList.ManyDelete(aClient,sID[i*4],dID[i*4])); aClient.Commit; for i := 1 to high(sID) do if i and 3<>0 then begin Check(MS.DestList.ManySelect(aClient,sID[i],dID[i])); Check(MS.DestList.AssociationTime=i); end else Check(not MS.DestList.ManySelect(aClient,sID[i],dID[i])); finally MD.Free; MS.Free; end; end; type TSQLRecordMyHistory = class(TSQLRecordHistory); procedure TTestExternalDatabase.ExternalRecords; var SQL: RawUTF8; begin if CheckFailed(fExternalModel=nil) then exit; // should be called once fExternalModel := TSQLModel.Create( [TSQLRecordPeopleExt,TSQLRecordOnlyBlob,TSQLRecordTestJoin, TSQLASource,TSQLADest,TSQLADests,TSQLRecordPeople,TSQLRecordMyHistory]); ReplaceParamsByNames(StringOfChar('?',200),SQL); Check(Hash32(SQL)=$AD27D1E0,'excludes :IF :OF'); end; procedure TTestExternalDatabase.AutoAdaptSQL; var SQLOrigin, s: RawUTF8; Props: TSQLDBConnectionProperties; Server: TSQLRestServer; Ext: TSQLRestStorageExternalHook; procedure Test(aDBMS: TSQLDBDefinition; AdaptShouldWork: boolean; const SQLExpected: RawUTF8=''); var SQL: RawUTF8; begin SQL := SQLOrigin; TSQLDBConnectionPropertiesHook(Props).fDBMS := aDBMS; Check((Props.DBMS=aDBMS)or(aDBMS=dUnknown)); Check(Ext.AdaptSQLForEngineList(SQL)=AdaptShouldWork); Check(SameTextU(SQL,SQLExpected) or not AdaptShouldWork,SQLExpected+#13#10+SQL); end; procedure Test2(const Orig,Expected: RawUTF8); var DBMS: TSQLDBDefinition; begin SQLOrigin := Orig; for DBMS := low(DBMS) to high(DBMS) do Test(DBMS,true,Expected); end; begin check(ReplaceParamsByNumbers('',s)=0); check(s=''); check(ReplaceParamsByNumbers('toto titi',s)=0); check(s='toto titi'); check(ReplaceParamsByNumbers('toto=? titi',s)=1); check(s='toto=$1 titi'); check(ReplaceParamsByNumbers('toto=? titi=?',s)=2); check(s='toto=$1 titi=$2'); check(ReplaceParamsByNumbers('toto=? titi=? and a=''''',s)=2); check(s='toto=$1 titi=$2 and a='''''); check(ReplaceParamsByNumbers('toto=? titi=? and a=''dd''',s)=2); check(s='toto=$1 titi=$2 and a=''dd'''); check(ReplaceParamsByNumbers('toto=? titi=? and a=''d''''d''',s)=2); check(s='toto=$1 titi=$2 and a=''d''''d'''); check(ReplaceParamsByNumbers('toto=? titi=? and a=''d?d''',s)=2); check(s='toto=$1 titi=$2 and a=''d?d'''); check(ReplaceParamsByNumbers('1?2?3?4?5?6?7?8?9?10?11?12? x',s)=12); check(s='1$12$23$34$45$56$67$78$89$910$1011$1112$12 x'); checkequal(BoundArrayToJSONArray(TRawUTF8DynArrayFrom([])),''); checkequal(BoundArrayToJSONArray(TRawUTF8DynArrayFrom(['1'])),'{1}'); checkequal(BoundArrayToJSONArray(TRawUTF8DynArrayFrom(['''1'''])),'{"1"}'); checkequal(BoundArrayToJSONArray(TRawUTF8DynArrayFrom(['1','2','3'])),'{1,2,3}'); checkequal(BoundArrayToJSONArray(TRawUTF8DynArrayFrom(['''1''','2','''3'''])),'{"1",2,"3"}'); checkequal(BoundArrayToJSONArray(TRawUTF8DynArrayFrom(['''1"1''','2','''"3\'''])),'{"1\"1",2,"\"3\\"}'); check(TSQLDBConnectionProperties.IsSQLKeyword(dUnknown,'SELEct')); check(not TSQLDBConnectionProperties.IsSQLKeyword(dUnknown,'toto')); check(TSQLDBConnectionProperties.IsSQLKeyword(dOracle,'SELEct')); check(not TSQLDBConnectionProperties.IsSQLKeyword(dOracle,'toto')); check(TSQLDBConnectionProperties.IsSQLKeyword(dOracle,' auDIT ')); check(not TSQLDBConnectionProperties.IsSQLKeyword(dMySQL,' auDIT ')); check(TSQLDBConnectionProperties.IsSQLKeyword(dSQLite,'SELEct')); check(TSQLDBConnectionProperties.IsSQLKeyword(dSQLite,'clustER')); check(not TSQLDBConnectionProperties.IsSQLKeyword(dSQLite,'value')); Server := TSQLRestServer.Create(fExternalModel); try Props := TSQLDBSQLite3ConnectionProperties.Create(SQLITE_MEMORY_DATABASE_NAME,'','',''); try VirtualTableExternalMap(fExternalModel,TSQLRecordPeopleExt,Props,'SampleRecord'). MapField('LastChange','Changed'); Ext := TSQLRestStorageExternalHook.Create(TSQLRecordPeopleExt,Server); try Test2('select rowid,firstname from PeopleExt where rowid=2', 'select id,firstname from SampleRecord where id=2'); Test2('select rowid,firstname from PeopleExt where rowid=?', 'select id,firstname from SampleRecord where id=?'); Test2('select rowid,firstname from PeopleExt where rowid>=?', 'select id,firstname from SampleRecord where id>=?'); Test2('select rowid,firstname from PeopleExt where rowid= :(2):', 'select Distinct(FirstName),max(Changed)+100 as LastChange from SampleRecord where ID>=:(2):'); Test2('select Distinct(lastchange) , max(rowid)-100 as newid from PeopleExt where rowid >= :(2):', 'select Distinct(Changed) as lastchange,max(id)-100 as newid from SampleRecord where ID>=:(2):'); SQLOrigin := 'select rowid,firstname from PeopleExt where rowid=2 limit 2'; Test(dUnknown,false); Test(dDefault,false); Test(dOracle,true,'select id,firstname from SampleRecord where rownum<=2 and id=2'); Test(dMSSQL,true,'select top(2) id,firstname from SampleRecord where id=2'); Test(dJet,true,'select top 2 id,firstname from SampleRecord where id=2'); Test(dMySQL,true,'select id,firstname from SampleRecord where id=2 limit 2'); Test(dSQLite,true,'select id,firstname from SampleRecord where id=2 limit 2'); SQLOrigin := 'select rowid,firstname from PeopleExt where rowid=2 order by LastName limit 2'; Test(dUnknown,false); Test(dDefault,false); Test(dOracle,true,'select id,firstname from SampleRecord where rownum<=2 and id=2 order by LastName'); Test(dMSSQL,true,'select top(2) id,firstname from SampleRecord where id=2 order by LastName'); Test(dJet,true,'select top 2 id,firstname from SampleRecord where id=2 order by LastName'); Test(dMySQL,true,'select id,firstname from SampleRecord where id=2 order by LastName limit 2'); Test(dSQLite,true,'select id,firstname from SampleRecord where id=2 order by LastName limit 2'); SQLOrigin := 'select rowid,firstname from PeopleExt where firstname=:(''test''): limit 2'; Test(dUnknown,false); Test(dDefault,false); Test(dOracle,true,'select id,firstname from SampleRecord where rownum<=2 and firstname=:(''test''):'); Test(dMSSQL,true,'select top(2) id,firstname from SampleRecord where firstname=:(''test''):'); Test(dJet,true,'select top 2 id,firstname from SampleRecord where firstname=:(''test''):'); Test(dMySQL,true,'select id,firstname from SampleRecord where firstname=:(''test''): limit 2'); Test(dSQLite,true,'select id,firstname from SampleRecord where firstname=:(''test''): limit 2'); SQLOrigin := 'select id,firstname from PeopleExt limit 2'; Test(dUnknown,false); Test(dDefault,false); Test(dOracle,true,'select id,firstname from SampleRecord where rownum<=2'); Test(dMSSQL,true,'select top(2) id,firstname from SampleRecord'); Test(dJet,true,'select top 2 id,firstname from SampleRecord'); Test(dMySQL,true,'select id,firstname from SampleRecord limit 2'); Test(dSQLite,true,'select id,firstname from SampleRecord limit 2'); SQLOrigin := 'select id,firstname from PeopleExt order by firstname limit 2'; Test(dUnknown,false); Test(dDefault,false); Test(dOracle,true,'select id,firstname from SampleRecord where rownum<=2 order by firstname'); Test(dMSSQL,true,'select top(2) id,firstname from SampleRecord order by firstname'); Test(dJet,true,'select top 2 id,firstname from SampleRecord order by firstname'); Test(dMySQL,true,'select id,firstname from SampleRecord order by firstname limit 2'); Test(dSQLite,true,'select id,firstname from SampleRecord order by firstname limit 2'); finally Ext.Free; end; finally Props.Free; end; finally Server.Free; end; end; procedure TTestExternalDatabase.CleanUp; begin FreeAndNil(fExternalModel); FreeAndNil(fPeopleData); inherited; end; procedure TTestExternalDatabase.ExternalViaREST; begin Test(true,false); end; procedure TTestExternalDatabase.ExternalViaVirtualTable; begin Test(false,false); end; procedure TTestExternalDatabase.ExternalViaRESTWithChangeTracking; begin Test(true,true); end; {$ifdef MSWINDOWS} {$ifdef USEZEOS} procedure TTestExternalDatabase.FirebirdEmbeddedViaZDBCOverHTTP; var R: TSQLRecordPeople; Model: TSQLModel; Props: TSQLDBConnectionProperties; Server: TSQLRestServerDB; Http: TSQLHttpServer; Client: TSQLRestClientURI; i,n: integer; ids: array[0..3] of TID; res: TIDDynArray; begin if not FileExists(FIREBIRDEMBEDDEDDLL) then exit; Model := TSQLModel.Create([TSQLRecordPeople]); try R := TSQLRecordPeople.Create; try DeleteFile('test.fdb'); // will be re-created at first connection Props := TSQLDBZEOSConnectionProperties.Create( TSQLDBZEOSConnectionProperties.URI(dFirebird,'',FIREBIRDEMBEDDEDDLL,False), 'test.fdb','',''); try VirtualTableExternalMap(Model,TSQLRecordPeople,Props,'peopleext'). MapFields(['ID','key','YearOfBirth','yob']); Server := TSQLRestServerDB.Create(Model,SQLITE_MEMORY_DATABASE_NAME); try Server.CreateMissingTables; Http := TSQLHttpServer.Create(HTTP_DEFAULTPORT,Server); Client := TSQLHttpClient.Create('localhost',HTTP_DEFAULTPORT,TSQLModel.Create(Model)); Client.Model.Owner := Client; try R.FillPrepare(fPeopleData); if not CheckFailed(R.fFill<>nil) then begin Client.BatchStart(TSQLRecordPeople,5000); n := 0; while R.FillOne do begin R.YearOfBirth := n; Client.BatchAdd(R,true); inc(n); end; Check(Client.BatchSend(res)=HTTP_SUCCESS); Check(length(res)=n); for i := 1 to 100 do begin R.ClearProperties; Check(Client.Retrieve(res[Random(n)],R)); Check(R.ID<>0); Check(res[R.YearOfBirth]=R.ID); end; end; for i := 0 to high(ids) do begin R.YearOfBirth := i; ids[i] := Client.Add(R,true); end; for i := 0 to high(ids) do begin Check(Client.Retrieve(ids[i],R)); Check(R.YearOfBirth=i); end; for i := 0 to high(ids) do begin Client.BatchStart(TSQLRecordPeople); Client.BatchDelete(ids[i]); Check(Client.BatchSend(res)=HTTP_SUCCESS); Check(length(res)=1); Check(res[0]=HTTP_SUCCESS); end; for i := 0 to high(ids) do Check(not Client.Retrieve(ids[i],R)); R.ClearProperties; for i := 0 to high(ids) do begin R.fID := ids[i]; Check(Client.Update(R),'test locking'); end; for i := 0 to high(ids) do begin R.YearOfBirth := i; ids[i] := Client.Add(R,true); end; for i := 0 to high(ids) do begin Check(Client.Retrieve(ids[i],R)); Check(R.YearOfBirth=i); end; finally Client.Free; Http.Free; end; finally Server.Free; end; finally Props.Free; end; finally R.Free; end; finally Model.Free; end; end; {$endif} {$endif} {$ifndef CPU64} {$ifndef LVCL} {$ifdef MSWINDOWS} procedure TTestExternalDatabase.JETDatabase; var R: TSQLRecordPeople; Model: TSQLModel; Props: TSQLDBConnectionProperties; Client: TSQLRestClientDB; i,n, ID,LastID: integer; begin Model := TSQLModel.Create([TSQLRecordPeople]); try R := TSQLRecordPeople.Create; R.FillPrepare(fPeopleData); if not CheckFailed(R.fFill<>nil) then try DeleteFile('test.mdb'); Props := TOleDBJetConnectionProperties.Create('test.mdb','','',''); try VirtualTableExternalRegister(Model,TSQLRecordPeople,Props,''); Client := TSQLRestClientDB.Create(Model,nil,SQLITE_MEMORY_DATABASE_NAME,TSQLRestServerDB); try Client.Server.CreateMissingTables; Client.TransactionBegin(TSQLRecordPeople); n := 0; while R.FillOne do begin inc(n); Check(Client.Add(R,true,true)=R.fFill.Table.IDColumnHiddenValue(n)); if n>999 then break; // Jet is very slow e.g. within the Delphi IDE end; Client.Commit; R.FirstName := ''; R.LastName := ''; R.YearOfBirth := 100; R.fYearOfDeath := 0; R.Data := ''; LastID := Client.Add(R,true); for i := 1 to n do begin R.ClearProperties; ID := R.fFill.Table.IDColumnHiddenValue(n); Check(Client.Retrieve(ID,R)); Check(R.fID=ID); Check(R.ID=ID); Check(R.FirstName<>''); Check(R.YearOfBirth>=1400); Check(R.YearOfDeath>=1468); end; Check(Client.Retrieve(LastID,R)); Check(R.FirstName=''); Check(R.LastName=''); Check(R.YearOfBirth=100); Check(R.fYearOfDeath=0); Check(R.Data=''); finally Client.Free; end; finally Props.Free; end; finally R.Free; end; finally Model.Free; end; end; {$endif} {$endif} {$endif} {$ifndef LVCL} procedure TTestExternalDatabase._TQuery; var Props: TSQLDBConnectionProperties; Query: TQuery; n: integer; begin Props := TSQLDBSQLite3ConnectionProperties.Create('test.db3','','',''); try Query := TQuery.Create(Props.MainConnection); try Query.SQL.Add('select * from People'); Query.SQL.Add('where YearOfDeath=:YOD;'); Query.ParamByName('YOD').AsInteger := 1872; Query.Open; n := 0; while not Query.Eof do begin Check(Query.FieldByName('ID').AsInteger>0); Check(Query.FieldByName('YearOfDeath').AsInteger=1872); Query.Next; inc(n); end; Check(n>500); finally Query.Free; end; finally Props.Free; end; end; {$endif} procedure TTestExternalDatabase._SynDBRemote; var Props: TSQLDBConnectionProperties; procedure DoTest(proxy: TSQLDBConnectionProperties; msg: PUTF8Char); procedure DoTests; var res: ISQLDBRows; id,lastid,n,n1: integer; IDs: TIntegerDynArray; {$ifndef LVCL} Row,RowDoc: variant; {$endif} procedure DoInsert; var i: integer; begin for i := 0 to high(IDs) do Check(proxy.ExecuteNoResult( 'INSERT INTO People (ID,FirstName,LastName,YearOfBirth,YearOfDeath) '+ 'VALUES (?,?,?,?,?)', [IDs[i],'FirstName New '+Int32ToUtf8(i),'New Last',i+1400,1519])=1); end; function DoCount: integer; var res: ISQLDBRows; begin res := proxy.Execute('select count(*) from People where YearOfDeath=?',[1519]); Check(res.Step); result := res.ColumnInt(0); end; var log: ISynLog; begin log := TSynLogTestLog.Enter(proxy,msg); if proxy<>Props then Check(proxy.UserID='user'); proxy.ExecuteNoResult('delete from people where ID>=?',[50000]); res := proxy.Execute('select * from People where YearOfDeath=?',[1519]); Check(res<>nil); n := 0; lastid := 0; while res.Step do begin id := res.ColumnInt('ID'); Check(id<>lastid); Check(id>0); lastid := id; Check(res.ColumnInt('YearOfDeath')=1519); inc(n); end; Check(n=DoCount); n1 := n; n := 0; {$ifndef LVCL} Row := res.RowData; {$endif} if res.Step({rewind=}true) then repeat {$ifdef LVCL} Check(res.ColumnInt('ID')>0); Check(res.ColumnInt('YearOfDeath')=1519); {$else} Check(Row.ID>0); Check(Row.YearOfDeath=1519); res.RowDocVariant(RowDoc); Check(RowDoc.ID=Row.ID); Check(_Safe(RowDoc)^.I['YearOfDeath']=1519); {$endif} inc(n); until not res.Step; res.ReleaseRows; Check(n=n1); SetLength(IDs,50); FillIncreasing(pointer(IDs),50000,length(IDs)); proxy.ThreadSafeConnection.StartTransaction; DoInsert; proxy.ThreadSafeConnection.Rollback; Check(DoCount=n); proxy.ThreadSafeConnection.StartTransaction; DoInsert; proxy.ThreadSafeConnection.Commit; n1 := DoCount; Check(n1=n+length(IDs)); proxy.ExecuteNoResult('delete from people where ID>=?',[50000]); Check(DoCount=n); end; begin try DoTests; finally if proxy<>Props then proxy.Free; end; end; var Server: TSQLDBServerAbstract; const ADDR='127.0.0.1:'+HTTP_DEFAULTPORT; begin Props := TSQLDBSQLite3ConnectionProperties.Create('test.db3','','',''); try DoTest(Props,'raw Props'); DoTest(TSQLDBRemoteConnectionPropertiesTest.Create( Props,'user','pass',TSQLDBProxyConnectionProtocol),'proxy test'); DoTest(TSQLDBRemoteConnectionPropertiesTest.Create( Props,'user','pass',TSQLDBRemoteConnectionProtocol),'remote test'); Server := {$ifndef ONLYUSEHTTPSOCKET}TSQLDBServerHttpApi{$else}TSQLDBServerSockets{$endif}. Create(Props,'root',HTTP_DEFAULTPORT,'user','pass'); try DoTest(TSQLDBSocketConnectionProperties.Create(ADDR,'root','user','pass'),'socket'); {$ifdef USEWININET} DoTest(TSQLDBWinHTTPConnectionProperties.Create(ADDR,'root','user','pass'),'winhttp'); DoTest(TSQLDBWinINetConnectionProperties.Create(ADDR,'root','user','pass'),'wininet'); {$endif} {$ifdef USELIBCURL} DoTest(TSQLDBCurlConnectionProperties.Create(ADDR,'root','user','pass'),'libcurl'); {$endif} finally Server.Free; end; finally Props.Free; end; end; procedure TTestExternalDatabase.DBPropertiesPersistence; var Props: TSQLDBConnectionProperties; json: RawUTF8; begin Props := TSQLDBSQLite3ConnectionProperties.Create('server','','',''); json := Props.DefinitionToJSON(14); Check(json='{"Kind":"TSQLDBSQLite3ConnectionProperties","ServerName":"server","DatabaseName":"","User":"","Password":""}'); Props.Free; Props := TSQLDBSQLite3ConnectionProperties.Create('server','','','1234'); json := Props.DefinitionToJSON(14); Check(json='{"Kind":"TSQLDBSQLite3ConnectionProperties","ServerName":"server","DatabaseName":"","User":"","Password":"MnVfJg=="}'); Props.DefinitionToFile('connectionprops.json'); Props.Free; Props := TSQLDBConnectionProperties.CreateFromFile('connectionprops.json'); Check(Props.ClassType=TSQLDBSQLite3ConnectionProperties); Check(Props.ServerName='server'); Check(Props.DatabaseName=''); Check(Props.UserID=''); Check(Props.PassWord='1234'); Props.Free; DeleteFile('connectionprops.json'); end; procedure TTestExternalDatabase.CryptedDatabase; var R,R2: TSQLRecordPeople; Model: TSQLModel; aID: integer; Client, Client2: TSQLRestClientDB; Res: TIDDynArray; procedure CheckFilledRow; begin Check(R.FillRewind); while R.FillOne do if not CheckFailed(R2.FillOne) then begin Check(R.ID<>0); Check(R2.ID<>0); Check(R.FirstName=R2.FirstName); Check(R.LastName=R2.LastName); Check(R.YearOfBirth=R2.YearOfBirth); Check(R.YearOfDeath=R2.YearOfDeath); end; end; {$ifndef NOSQLITE3ENCRYPT} const password = 'pass'; {$else} const password = ''; {$endif} begin DeleteFile('testpass.db3'); Model := TSQLModel.Create([TSQLRecordPeople]); try Client := TSQLRestClientDB.Create(Model,nil,'test.db3',TSQLRestServerDB,false,''); try R := TSQLRecordPeople.Create; Assert(fPeopleData=nil); fPeopleData := Client.List([TSQLRecordPeople],'*'); R.FillPrepare(fPeopleData); try Client2 := TSQLRestClientDB.Create(Model,nil,'testpass.db3',TSQLRestServerDB,false,password); try Client2.Server.DB.Synchronous := smOff; Client2.Server.DB.LockingMode := lmExclusive; Client2.Server.DB.WALMode := true; Client2.Server.CreateMissingTables; Check(Client2.TransactionBegin(TSQLRecordPeople)); Check(Client2.BatchStart(TSQLRecordPeople)); Check(Client2.BatchSend(Res)=200,'Void batch'); Check(Res=nil); Client2.Commit; Check(Client2.TransactionBegin(TSQLRecordPeople)); Check(Client2.BatchStart(TSQLRecordPeople)); while R.FillOne do begin Check(R.ID<>0); Check(Client2.BatchAdd(R,true)>=0); end; Check(Client2.BatchSend(Res)=200,'INSERT batch'); Client2.Commit; finally Client2.Free; end; Check(IsSQLite3File('testpass.db3')); Check(IsSQLite3FileEncrypted('testpass.db3')=(password<>''),'encrypt1'); // try to read then update the crypted file Client2 := TSQLRestClientDB.Create(Model,nil,'testpass.db3',TSQLRestServerDB,false,password); try Client2.Server.DB.Synchronous := smOff; Client2.Server.DB.LockingMode := lmExclusive; R2 := TSQLRecordPeople.CreateAndFillPrepare(Client2,''); try CheckFilledRow; R2.FirstName := 'One'; aID := Client2.Add(R2,true); Check(aID<>0); R2.FillPrepare(Client2,''); CheckFilledRow; R2.ClearProperties; Check(R2.FirstName=''); Check(Client2.Retrieve(aID,R2)); Check(R2.FirstName='One'); finally R2.Free; end; finally Client2.Free; end; Check(IsSQLite3File('testpass.db3')); Check(IsSQLite3FileEncrypted('testpass.db3')=(password<>''),'encrypt2'); {$ifndef NOSQLITE3ENCRYPT} // now read it after uncypher check(ChangeSQLEncryptTablePassWord('testpass.db3',password,'')); Check(IsSQLite3File('testpass.db3')); Check(not IsSQLite3FileEncrypted('testpass.db3'),'encrypt3'); Client2 := TSQLRestClientDB.Create(Model,nil,'testpass.db3',TSQLRestServerDB,false,''); try R2 := TSQLRecordPeople.CreateAndFillPrepare(Client2,''); try CheckFilledRow; R2.ClearProperties; Check(R2.FirstName=''); Check(Client2.Retrieve(aID,R2)); Check(R2.FirstName='One'); finally R2.Free; end; finally Client2.Free; end; {$endif} finally R.Free; end; finally Client.Free; end; finally Model.Free; end; end; procedure TTestExternalDatabase.Test(StaticVirtualTableDirect, TrackChanges: boolean); const BLOB_MAX = 1000; var RInt,RInt1: TSQLRecordPeople; RExt: TSQLRecordPeopleExt; RBlob: TSQLRecordOnlyBlob; RJoin: TSQLRecordTestJoin; RHist: TSQLRecordMyHistory; Tables: TRawUTF8DynArray; i,n, aID: integer; ok: Boolean; BatchID,BatchIDUpdate,BatchIDJoined: TIDDynArray; ids: array[0..3] of TID; aExternalClient: TSQLRestClientDB; fProperties: TSQLDBConnectionProperties; {$ifndef NOVARIANTS} json: RawUTF8; {$endif} Start, Updated: TTimeLog; // will work with both TModTime and TCreateTime properties procedure HistoryCheck(aIndex,aYOB: Integer; aEvent: TSQLHistoryEvent); var Event: TSQLHistoryEvent; Timestamp: TModTime; R: TSQLRecordPeopleExt; begin RExt.ClearProperties; Check(RHist.HistoryGet(aIndex,Event,Timestamp,RExt)); Check(Event=aEvent); Check(Timestamp>=Start); if Event=heDelete then exit; Check(RExt.ID=400); Check(RExt.FirstName='Franz36'); Check(RExt.YearOfBirth=aYOB); R := RHist.HistoryGet(aIndex) as TSQLRecordPeopleExt; if CheckFailed(R<>nil) then exit; Check(R.ID=400); Check(R.FirstName='Franz36'); Check(R.YearOfBirth=aYOB); R.Free; end; procedure HistoryChecks; var i: integer; begin RHist := TSQLRecordMyHistory.CreateHistory(aExternalClient,TSQLRecordPeopleExt,400); try Check(RHist.HistoryCount=504); HistoryCheck(0,1797,heAdd); HistoryCheck(1,1828,heUpdate); HistoryCheck(2,1515,heUpdate); for i := 1 to 500 do HistoryCheck(i+2,i,heUpdate); HistoryCheck(503,0,heDelete); finally RHist.Free; end; end; var historyDB: TSQLRestServerDB; begin // run tests over an in-memory SQLite3 external database (much faster than file) DeleteFile('extdata.db3'); fProperties := TSQLDBSQLite3ConnectionProperties.Create('extdata.db3','','',''); (fProperties.MainConnection as TSQLDBSQLite3Connection).Synchronous := smOff; (fProperties.MainConnection as TSQLDBSQLite3Connection).LockingMode := lmExclusive; Check(VirtualTableExternalMap(fExternalModel,TSQLRecordPeopleExt,fProperties,'PeopleExternal'). MapField('ID','Key'). MapField('YearOfDeath','YOD'). MapAutoKeywordFields<>nil); Check(VirtualTableExternalRegister(fExternalModel,TSQLRecordOnlyBlob,fProperties,'OnlyBlobExternal')); Check(VirtualTableExternalRegister(fExternalModel,TSQLRecordTestJoin,fProperties,'TestJoinExternal')); Check(VirtualTableExternalRegister(fExternalModel,TSQLASource,fProperties,'SourceExternal')); Check(VirtualTableExternalRegister(fExternalModel,TSQLADest,fProperties,'DestExternal')); Check(VirtualTableExternalRegister(fExternalModel,TSQLADests,fProperties,'DestsExternal')); DeleteFile('testExternal.db3'); // need a file for backup testing if TrackChanges and StaticVirtualTableDirect then begin DeleteFile('history.db3'); historyDB := TSQLRestServerDB.Create( TSQLModel.Create([TSQLRecordMyHistory],'history'), 'history.db3',false); end else historyDB := nil; aExternalClient := TSQLRestClientDB.Create(fExternalModel,nil,'testExternal.db3',TSQLRestServerDB); try if historyDB<>nil then begin historyDB.Model.Owner := historyDB; historyDB.DB.Synchronous := smOff; historyDB.DB.LockingMode := lmExclusive; historyDB.CreateMissingTables; Check(aExternalClient.Server.RemoteDataCreate(TSQLRecordMyHistory,historyDB)<>nil, 'TSQLRecordMyHistory should not be accessed from an external process'); end; aExternalClient.Server.DB.Synchronous := smOff; aExternalClient.Server.DB.LockingMode := lmExclusive; aExternalClient.Server.DB.GetTableNames(Tables); Check(Tables=nil); // we reset the testExternal.db3 file Start := aExternalClient.ServerTimestamp; aExternalClient.Server.StaticVirtualTableDirect := StaticVirtualTableDirect; aExternalClient.Server.CreateMissingTables; if TrackChanges then aExternalClient.Server.TrackChanges([TSQLRecordPeopleExt],TSQLRecordMyHistory,100,10,65536); Check(aExternalClient.Server.CreateSQLMultiIndex( TSQLRecordPeopleExt,['FirstName','LastName'],false)); InternalTestMany(self,aExternalClient); assert(fPeopleData<>nil); RInt := TSQLRecordPeople.Create; RInt1 := TSQLRecordPeople.Create; try RInt.FillPrepare(fPeopleData); Check(RInt.FillTable<>nil); Check(RInt.FillTable.RowCount>0); Check(not aExternalClient.TableHasRows(TSQLRecordPeopleExt)); Check(aExternalClient.TableRowCount(TSQLRecordPeopleExt)=0); Check(not aExternalClient.Server.TableHasRows(TSQLRecordPeopleExt)); Check(aExternalClient.Server.TableRowCount(TSQLRecordPeopleExt)=0); RExt := TSQLRecordPeopleExt.Create; try n := 0; while RInt.FillOne do begin if RInt.fID<100 then // some real entries for backup testing aExternalClient.Add(RInt,true,true); RExt.Data := RInt.Data; RExt.FirstName := RInt.FirstName; RExt.LastName := RInt.LastName; RExt.YearOfBirth := RInt.YearOfBirth; RExt.YearOfDeath := RInt.YearOfDeath; {$ifndef NOVARIANTS} RExt.Value := ValuesToVariantDynArray(['text',RInt.YearOfDeath]); {$endif} RExt.fLastChange := 0; RExt.CreatedAt := 0; if RInt.fID>100 then begin if aExternalClient.BatchCount=0 then aExternalClient.BatchStart(TSQLRecordPeopleExt,5000); aExternalClient.BatchAdd(RExt,true); end else begin aID := aExternalClient.Add(RExt,true); Check(aID<>0); Check(RExt.LastChange>=Start); Check(RExt.CreatedAt>=Start); RExt.ClearProperties; Check(RExt.YearOfBirth=0); Check(RExt.FirstName=''); {$ifndef NOVARIANTS} Check(RExt.Value=nil); {$endif} Check(aExternalClient.Retrieve(aID,RExt)); Check(RExt.FirstName=RInt.FirstName); Check(RExt.LastName=RInt.LastName); Check(RExt.YearOfBirth=RInt.YearOfBirth); Check(RExt.YearOfDeath=RInt.YearOfDeath); Check(RExt.YearOfBirth<>RExt.YearOfDeath); {$ifndef NOVARIANTS} json := FormatUTF8('["text",%]',[RInt.YearOfDeath]); Check(VariantDynArrayToJSON(RExt.Value)=json); {$endif} end; inc(n); end; Check(aExternalClient.Retrieve(1,RInt1)); Check(RInt1.fID=1); Check(n=fPeopleData.RowCount); Check(aExternalClient.BatchSend(BatchID)=HTTP_SUCCESS); Check(length(BatchID)=n-99); Check(aExternalClient.TableHasRows(TSQLRecordPeopleExt)); Check(aExternalClient.TableMaxID(TSQLRecordPeopleExt)=n); Check(aExternalClient.TableRowCount(TSQLRecordPeopleExt)=n); Check(aExternalClient.Server.TableHasRows(TSQLRecordPeopleExt)); Check(aExternalClient.Server.TableRowCount(TSQLRecordPeopleExt)=n); Check(RInt.FillRewind); while RInt.FillOne do begin RExt.FillPrepare(aExternalClient,'FirstName=? and LastName=?', [RInt.FirstName,RInt.LastName]); // query will use index -> fast :) while RExt.FillOne do begin Check(RExt.FirstName=RInt.FirstName); Check(RExt.LastName=RInt.LastName); Check(RExt.YearOfBirth=RInt.YearOfBirth); Check(RExt.YearOfDeath=RInt.YearOfDeath); Check(RExt.YearOfBirth<>RExt.YearOfDeath); {$ifndef NOVARIANTS} Check(VariantDynArrayToJSON(RExt.Value)=FormatUTF8('["text",%]',[RInt.YearOfDeath])); {$endif} end; end; Updated := aExternalClient.ServerTimestamp; Check(Updated>=Start); for i := 1 to BatchID[high(BatchID)] do if i mod 100=0 then begin RExt.fLastChange := 0; RExt.CreatedAt := 0; {$ifndef NOVARIANTS} RExt.Value := nil; {$endif} Check(aExternalClient.Retrieve(i,RExt,true),'for update'); Check(RExt.YearOfBirth<>RExt.YearOfDeath); Check(RExt.CreatedAt<=Updated); {$ifndef NOVARIANTS} Check(VariantDynArrayToJSON(RExt.Value)=FormatUTF8('["text",%]',[RExt.YearOfDeath])); {$endif} RExt.YearOfBirth := RExt.YearOfDeath; // YOB=YOD for 1/100 rows if i>4000 then begin if aExternalClient.BatchCount=0 then aExternalClient.BatchStart(TSQLRecordPeopleExt,10000); Check(aExternalClient.BatchUpdate(RExt)>=0,'BatchUpdate 1/100 rows'); end else begin Check(aExternalClient.Update(RExt),'Update 1/100 rows'); Check(aExternalClient.UnLock(RExt)); Check(RExt.LastChange>=Updated); RExt.ClearProperties; {$ifndef NOVARIANTS} Check(RExt.Value=nil); {$endif} Check(RExt.YearOfDeath=0); Check(RExt.YearOfBirth=0); Check(RExt.CreatedAt=0); Check(aExternalClient.Retrieve(i,RExt),'after update'); Check(RExt.YearOfBirth=RExt.YearOfDeath); Check(RExt.CreatedAt>=Start); Check(RExt.CreatedAt<=Updated); Check(RExt.LastChange>=Updated); {$ifndef NOVARIANTS} Check(VariantDynArrayToJSON(RExt.Value)=FormatUTF8('["text",%]',[RExt.YearOfDeath])); {$endif} end; end; Check(aExternalClient.BatchSend(BatchIDUpdate)=HTTP_SUCCESS); Check(length(BatchIDUpdate)=70); for i := 1 to BatchID[high(BatchID)] do if i and 127=0 then if i>4000 then begin if aExternalClient.BatchCount=0 then aExternalClient.BatchStart(TSQLRecordPeopleExt); Check(aExternalClient.BatchDelete(i)>=0,'BatchDelete 1/128 rows'); end else Check(aExternalClient.Delete(TSQLRecordPeopleExt,i),'Delete 1/128 rows'); Check(aExternalClient.BatchSend(BatchIDUpdate)=HTTP_SUCCESS); Check(length(BatchIDUpdate)=55); n := aExternalClient.TableRowCount(TSQLRecordPeople); Check(aExternalClient.Server.TableRowCount(TSQLRecordPeopleExt)=10925); Check(aExternalClient.Server.StaticVirtualTable[TSQLRecordPeople]=nil); Check(aExternalClient.Server.StaticVirtualTable[TSQLRecordPeopleExt]<>nil); Check(aExternalClient.Server.StaticVirtualTable[TSQLRecordOnlyBlob]<>nil); {$ifdef WITHUNSAFEBACKUP} aExternalClient.Server.BackupGZ(aExternalClient.Server.DB.FileName+'.gz'); Check(aExternalClient.Server.StaticVirtualTable[TSQLRecordPeople]=nil); Check(aExternalClient.Server.StaticVirtualTable[TSQLRecordPeopleExt]<>nil); Check(aExternalClient.Server.StaticVirtualTable[TSQLRecordOnlyBlob]<>nil); {$endif} for i := 1 to BatchID[high(BatchID)] do begin RExt.fLastChange := 0; RExt.CreatedAt := 0; RExt.YearOfBirth := 0; ok := aExternalClient.Retrieve(i,RExt,false); Check(ok=(i and 127<>0),'deletion'); if ok then begin {$ifndef NOVARIANTS} Check(VariantDynArrayToJSON(RExt.Value)=FormatUTF8('["text",%]',[RExt.YearOfDeath])); {$endif} Check(RExt.CreatedAt>=Start); Check(RExt.CreatedAt<=Updated); if i mod 100=0 then begin Check(RExt.YearOfBirth=RExt.YearOfDeath,'Update'); Check(RExt.LastChange>=Updated); end else begin Check(RExt.YearOfBirth<>RExt.YearOfDeath,'Update'); Check(RExt.LastChange>=Start); Check(RExt.LastChange<=Updated); end; end; end; aExternalClient.Retrieve(400,RExt); Check(RExt.fID=400); Check(RExt.FirstName='Franz36'); Check(RExt.YearOfBirth=1828); aExternalClient.UpdateField(TSQLRecordPeopleExt,400,'YearOfBirth',[1515]); RInt1.ClearProperties; Check(aExternalClient.Retrieve(1,RInt1)); Check(RInt1.fID=1); {$ifdef WITHUNSAFEBACKUP} RInt1.YearOfBirth := 1972; Check(aExternalClient.Update(RInt1)); // for RestoreGZ() below Check(aExternalClient.TableRowCount(TSQLRecordPeople)=n); {$endif} // life backup/restore does not work with current sqlite3-64.dll for i := 0 to high(ids) do begin RExt.YearOfBirth := i; ids[i] := aExternalClient.Add(RExt,true); end; for i := 0 to high(ids) do begin Check(aExternalClient.Retrieve(ids[i],RExt)); Check(RExt.YearOfBirth=i); end; for i := 0 to high(ids) do begin aExternalClient.BatchStart(TSQLRecordPeopleExt); aExternalClient.BatchDelete(ids[i]); Check(aExternalClient.BatchSend(BatchID)=HTTP_SUCCESS); Check(length(BatchID)=1); Check(BatchID[0]=HTTP_SUCCESS); end; for i := 0 to high(ids) do Check(not aExternalClient.Retrieve(ids[i],RExt)); RExt.ClearProperties; for i := 0 to high(ids) do begin RExt.fID := ids[i]; Check(aExternalClient.Update(RExt),'test locking'); end; finally RExt.Free; end; RJoin := TSQLRecordTestJoin.Create; try aExternalClient.BatchStart(TSQLRecordTestJoin,1000); for i := 1 to BLOB_MAX do if i and 127<>0 then begin RJoin.Name := Int32ToUTF8(i); RJoin.People := TSQLRecordPeopleExt(i); aExternalClient.BatchAdd(RJoin,true); end; Check(aExternalClient.BatchSend(BatchIDJoined)=HTTP_SUCCESS); Check(length(BatchIDJoined)=993); RJoin.FillPrepare(aExternalClient); Check(RJoin.FillTable.RowCount=993); i := 1; while RJoin.FillOne do begin if i and 127=0 then inc(i); // deleted item Check(GetInteger(pointer(RJoin.Name))=i); Check(RJoin.People.ID=i,'retrieve ID from pointer'); inc(i); end; finally RJoin.Free; end; for i := 0 to high(BatchIDJoined) do begin RJoin := TSQLRecordTestJoin.CreateJoined(aExternalClient,BatchIDJoined[i]); try Check(RJoin.FillTable.FieldType(0)=sftInteger); Check(RJoin.FillTable.FieldType(3)=sftUTF8Text); Check(RJoin.ID=BatchIDJoined[i]); Check(PtrUInt(RJoin.People)>1000); Check(GetInteger(pointer(RJoin.Name))=RJoin.People.ID); {$ifndef NOVARIANTS} Check(length(RJoin.People.Value)=2); Check(RJoin.People.Value[0]='text'); Check(RJoin.People.Value[1]=RJoin.People.YearOfDeath); {$endif} RJoin.ClearProperties; Check(RJoin.ID=0); Check(RJoin.People.ID=0); finally RJoin.Free; end; end; Check(not aExternalClient.Server.TableHasRows(TSQLRecordOnlyBlob)); Check(aExternalClient.Server.TableRowCount(TSQLRecordOnlyBlob)=0); RBlob := TSQLRecordOnlyBlob.Create; try aExternalClient.ForceBlobTransfertTable[TSQLRecordOnlyBlob] := true; aExternalClient.TransactionBegin(TSQLRecordOnlyBlob); for i := 1 to BLOB_MAX do begin Rblob.Data := Int32ToUtf8(i); Check(aExternalClient.Add(RBlob,true)=i); Check(RBlob.ID=i); end; aExternalClient.Commit; for i := 1 to BLOB_MAX do begin Check(aExternalClient.Retrieve(i,RBlob)); Check(GetInteger(pointer(RBlob.Data))=i); end; aExternalClient.TransactionBegin(TSQLRecordOnlyBlob); for i := BLOB_MAX downto 1 do begin RBlob.fID := i; RBlob.Data := Int32ToUtf8(i*2); Check(aExternalClient.Update(RBlob)); end; aExternalClient.Commit; for i := 1 to BLOB_MAX do begin Check(aExternalClient.Retrieve(i,RBlob)); Check(GetInteger(pointer(RBlob.Data))=i*2); end; aExternalClient.ForceBlobTransfertTable[TSQLRecordOnlyBlob] := false; RBlob.ClearProperties; for i := 1 to BLOB_MAX do begin Check(aExternalClient.Retrieve(i,RBlob)); Check(RBlob.Data=''); end; finally RBlob.Free; end; Check(aExternalClient.TableHasRows(TSQLRecordOnlyBlob)); Check(aExternalClient.TableRowCount(TSQLRecordOnlyBlob)=1000); Check(aExternalClient.TableRowCount(TSQLRecordPeople)=n); RInt1.ClearProperties; {$ifdef WITHUNSAFEBACKUP} aExternalClient.Retrieve(1,RInt1); Check(RInt1.fID=1); Check(RInt1.FirstName='Salvador1'); Check(RInt1.YearOfBirth=1972); Check(aExternalClient.Server.RestoreGZ(aExternalClient.Server.DB.FileName+'.gz')); {$endif} // life backup/restore does not work with current sqlite3-64.dll Check(aExternalClient.Server.StaticVirtualTable[TSQLRecordPeople]=nil); Check(aExternalClient.Server.StaticVirtualTable[TSQLRecordPeopleExt]<>nil); Check(aExternalClient.Server.StaticVirtualTable[TSQLRecordOnlyBlob]<>nil); Check(aExternalClient.TableHasRows(TSQLRecordPeople)); Check(aExternalClient.TableRowCount(TSQLRecordPeople)=n); RInt1.ClearProperties; aExternalClient.Retrieve(1,RInt1); Check(RInt1.fID=1); Check(RInt1.FirstName='Salvador1'); Check(RInt1.YearOfBirth=1904); finally RInt.Free; RInt1.Free; end; if TrackChanges then begin RExt := TSQLRecordPeopleExt.Create; try RHist := TSQLRecordMyHistory.CreateHistory(aExternalClient,TSQLRecordPeopleExt,400); try Check(RHist.HistoryCount=3); HistoryCheck(0,1797,heAdd); HistoryCheck(1,1828,heUpdate); HistoryCheck(2,1515,heUpdate); finally RHist.Free; end; for i := 1 to 500 do begin RExt.YearOfBirth := i; aExternalClient.Update(RExt,'YearOfBirth'); end; aExternalClient.Delete(TSQLRecordPeopleExt,400); HistoryChecks; aExternalClient.Server.TrackChangesFlush(TSQLRecordMyHistory); HistoryChecks; finally RExt.Free; end; end; finally aExternalClient.Free; fProperties.Free; historyDB.Free; end; end; procedure TTestSQLite3Engine._TSQLRestClientDB; var V,V2: TSQLRecordPeople; VA: TSQLRecordPeopleArray; {$ifndef LVCL} VO: TSQLRecordPeopleObject; {$endif} VP: TSQLRecordCustomProps; FV: TFV; ModelC: TSQLModel; Client: TSQLRestClientDB; Server: TSQLRestServer; aStatic: TSQLRestStorageInMemory; Curr: Currency; DaVinci, s: RawUTF8; Refreshed: boolean; J: TSQLTableJSON; i, n, nupd, ndx: integer; IntArray: TInt64DynArray; Results: TIDDynArray; List: TObjectList; Data: TSQLRawBlob; DataS: THeapMemoryStream; a,b: double; BackupFN: TFileName; procedure checks(Leonard: boolean; Client: TSQLRestClient; const msg: string); var ID: integer; begin ID := V.ID; // ClearProperties do ID := 0; V.ClearProperties; // reset values Check(Client.Retrieve(ID,V),msg); // internaly call URL() if Leonard then Check(V.FirstName='Leonard') else Check(V.FirstName='Leonardo1',msg); Check(V.LastName=DaVinci,msg); Check(V.YearOfBirth=1452,msg); Check(V.YearOfDeath=1519,msg); end; procedure TestDynArray(aClient: TSQLRestClient); var i, j, k, l: integer; IDs: TInt64DynArray; begin VA.ClearProperties; for i := 1 to n do begin aClient.Retrieve(i,VA); Check(VA.ID=i); Check(VA.LastName='Dali'); Check(length(VA.Ints)=i shr 5); Check(length(VA.Currency)=i shr 5); Check(length(VA.FileVersion)=i shr 5); if i and 31=0 then begin Check(VA.UTF8=''); for j := 0 to high(VA.Ints) do Check(VA.Ints[j]=(j+1) shl 5); for j := 0 to high(VA.Currency) do Check(PInt64(@VA.Currency[j])^=(j+1)*3200); for j := 0 to high(VA.FileVersion) do with VA.FileVersion[j] do begin k := (j+1) shl 5; Check(Major=k); Check(Minor=k+2000); Check(Release=k+3000); Check(Build=k+4000); Check(Main=IntToStr(k)); Check(Detailed=IntToStr(k+1000)); end; end else begin Check(GetInteger(pointer(VA.UTF8))=i); for j := 0 to high(VA.FileVersion) do with VA.FileVersion[j] do begin k := (j+1) shl 5; Check(Major=k); Check(Minor=k+2000); Check(Release=k+3000); Check(Build=k+4000); end; end; {$ifdef PUBLISHRECORD} Check(VA.fRec.nPhrase=i); Check(VA.fRec.nCol=i*2); Check(VA.fRec.hits[2].docs_with_hits=i*3); {$endif PUBLISHRECORD} end; for i := 1 to n shr 5 do begin k := i shl 5; aClient.OneFieldValues(TSQLRecordPeopleArray,'ID', FormatUTF8('IntegerDynArrayContains(Ints,?)',[],[k]),IDs); l := n+1-32*i; Check(length(IDs)=l); for j := 0 to high(IDs) do Check(IDs[j]=k+j); aClient.OneFieldValues(TSQLRecordPeopleArray,'ID', FormatUTF8('CardinalDynArrayContains(Ints,?)',[],[k]),IDs); Check(length(IDs)=l); for j := 0 to high(IDs) do Check(IDs[j]=k+j); aClient.OneFieldValues(TSQLRecordPeopleArray,'ID', FormatUTF8('MyIntegerDynArrayContains(Ints,:("%"):)', [BinToBase64WithMagic(@k,sizeof(k))]),IDs); Check(length(IDs)=l); for j := 0 to high(IDs) do Check(IDs[j]=k+j); end; end; {$ifndef LVCL} procedure TestObject(aClient: TSQLRestClient); var i, j, k: integer; begin for i := 1 to n do begin VO.ClearProperties; aClient.Retrieve(i,VO); Check(VO.ID=i); Check(VO.LastName='Morse'); Check(VO.UTF8.Count=i shr 5); for j := 0 to VO.UTF8.Count-1 do Check(GetInteger(pointer(VO.UTF8[j]))=(j+1) shl 5); Check(VO.Persistent.One.Length=i); Check(VO.Persistent.One.Color=i+100); Check(GetInteger(pointer(VO.Persistent.One.Name))=i); Check(VO.Persistent.Coll.Count=i shr 5); for j := 0 to VO.Persistent.Coll.Count-1 do with VO.Persistent.Coll[j] do begin k := (j+1) shl 5; Check(Color=k+1000); Check(Length=k*2); Check(GetInteger(pointer(Name))=k*3); end; end; end; {$endif LVCL} procedure TestFTS3(aClient: TSQLRestClient); var FTS: TSQLFTSTest; StartID, i: integer; IntResult: TIDDynArray; c: Char; const COUNT=400; begin if CheckFailed(Length(IntArray)>COUNT*2) then exit; FTS := TSQLFTSTest.Create; try if aClient=Client then StartID := 0 else StartID := COUNT; Check(aClient.TransactionBegin(TSQLFTSTest)); // MUCH faster with this for i := StartID to StartID+COUNT-1 do begin FTS.DocID := IntArray[i]; FTS.Subject := aClient.OneFieldValue(TSQLRecordPeople,'FirstName',FTS.DocID); Check(IdemPChar(pointer(FTS.Subject),'SALVADOR')); FTS.Body := FTS.Subject+' bodY'+IntToStr(FTS.DocID); aClient.Add(FTS,true); end; aClient.Commit; // Commit must be BEFORE OptimizeFTS3, memory leak otherwise Check(FTS.OptimizeFTS3Index(Client.Server)); for i := StartID to StartID+COUNT-1 do begin Check(IdemPChar(pointer(aClient.OneFieldValue(TSQLFTSTest,'Subject',IntArray[i])),'SALVADOR')); FTS.DocID := 0; FTS.Subject := ''; FTS.Body := ''; Check(aClient.Retrieve(IntArray[i],FTS)); Check(FTS.DocID=IntArray[i]); Check(IdemPChar(pointer(FTS.Subject),'SALVADOR')); Check(PosEx(Int32ToUtf8(FTS.DocID),FTS.Body,1)>0); end; Check(aClient.FTSMatch(TSQLFTSTest,'Subject MATCH "salVador1"',IntResult)); for i := 0 to high(IntResult) do Check(SameTextU(aClient.OneFieldValue( TSQLRecordPeople,'FirstName',IntResult[i]),'SALVADOR1')); Check(aClient.FTSMatch(TSQLFTSTest,'Subject MATCH "salVador1*"',IntResult)); for i := 0 to high(IntResult) do Check(IdemPChar(pointer(aClient.OneFieldValue( TSQLRecordPeople,'FirstName',IntResult[i])),'SALVADOR1')); Check(not aClient.FTSMatch(TSQLFTSTest,'body*',IntResult,[1]),'invalid count'); for c := '1' to '9' do begin Check(aClient.FTSMatch(TSQLFTSTest,'Body MATCH "body'+c+'*"',IntResult)); Check(length(IntResult)>0); for i := 0 to high(IntResult) do Check(IntToStr(IntResult[i])[1]=c); Check(aClient.FTSMatch(TSQLFTSTest,'body'+c+'*',IntResult,[1,0.5]),'rank'); Check(length(IntResult)>0); for i := 0 to high(IntResult) do Check(IntToStr(IntResult[i])[1]=c); end; finally FTS.Free; end; end; procedure TestVirtual(aClient: TSQLRestClient; DirectSQL: boolean; const Msg: string; aClass: TSQLRecordClass); var n, i, ndx, added: integer; VD, VD2: TSQLRecordDali1; Rest: TSQLRest; stor: TSQLRestStorageInMemoryExternal; fn: TFileName; begin Client.Server.StaticVirtualTableDirect := DirectSQL; Check(Client.Server.ExecuteFmt('DROP TABLE %',[aClass.SQLTableName])); Client.Server.CreateMissingTables; VD := aClass.Create as TSQLRecordDali1; try if aClient.TransactionBegin(aClass) then try // add some items to the file V2.FillPrepare(aClient,'LastName=:("Dali"):'); n := 0; while V2.FillOne do begin VD.FirstName := V2.FirstName; VD.YearOfBirth := V2.YearOfBirth; VD.YearOfDeath := V2.YearOfDeath; inc(n); added := aClient.Add(VD,true); CheckUTF8(added=n,'% Add %<>%',[Msg,added,n]); end; // update some items in the file Check(aClient.TableRowCount(aClass)=1001,'Check SQL Count(*)'); for i := 1 to n do begin VD.ClearProperties; Check(VD.ID=0); Check(VD.FirstName=''); Check(VD.YearOfBirth=0); Check(VD.YearOfDeath=0); Check(aClient.Retrieve(i,VD),Msg); Check(VD.ID=i); Check(IdemPChar(pointer(VD.FirstName),'SALVADOR')); Check(VD.YearOfBirth=1904); Check(VD.YearOfDeath=1989); VD.YearOfBirth := VD.YearOfBirth+i; VD.YearOfDeath := VD.YearOfDeath+i; Check(aClient.Update(VD),Msg); end; // check SQL requests for i := 1 to n do begin VD.ClearProperties; Check(VD.ID=0); Check(VD.FirstName=''); Check(VD.YearOfBirth=0); Check(VD.YearOfDeath=0); CheckUTF8(aClient.Retrieve(i,VD),'% Retrieve',[Msg]); Check(IdemPChar(pointer(VD.FirstName),'SALVADOR')); Check(VD.YearOfBirth=1904+i); Check(VD.YearOfDeath=1989+i); end; CheckUTF8(aClient.TableRowCount(aClass)=1001,'% RowCount',[Msg]); Rest := Client.Server.StaticVirtualTable[aClass]; Check((Rest as TSQLRestStorageInMemoryExternal).Modified); aClient.Commit; // write to file // try to read directly from file content Rest := Client.Server.StaticVirtualTable[aClass]; if CheckFailed(Rest<>nil) then exit; fn := TSQLRestStorageInMemoryExternal(Rest).FileName; if fn<>'' then begin // no file content if ':memory' DB TSQLRestStorageInMemoryExternal(Rest).UpdateFile; // force update (COMMIT not always calls xCommit) stor := TSQLRestStorageInMemoryExternal.Create( aClass,nil,fn,{bin=}aClass=TSQLRecordDali2); try Check(stor.Count=n); for i := 1 to n do begin ndx := stor.IDToIndex(i); if CheckFailed(ndx>=0) then continue; VD2 := stor.Items[ndx] as TSQLRecordDali1; if CheckFailed(VD2<>nil) then continue; Check(VD2.ID=i); Check(IdemPChar(pointer(VD2.FirstName),'SALVADOR')); Check(VD2.YearOfBirth=1904+i); Check(VD2.YearOfDeath=1989+i); end; finally stor.Free; end; end; except aClient.RollBack; // will run an error - but this code is correct end; finally VD.Free; end; end; function TestTable(T: TSQLTable): boolean; var aR,aF: integer; db: TSQLTable; begin result := false; if T=nil then exit; db := TSQLTableDB.Create(Demo,[],Req,true); try if (db.RowCount<>T.RowCount) or (db.FieldCount<>T.FieldCount) then begin Check(False); exit; end; for aR := 0 to db.RowCount do // compare all result values for aF := 0 to db.FieldCount-1 do if StrComp(pointer(db.Get(aR,aF)),pointer(T.Get(aR,aF)))<>0 then begin Check(False); exit; end; result := true; finally db.Free; T.Free; end; end; {$ifdef MSWINDOWS} procedure TestClientDist(ClientDist: TSQLRestClientURI); var i: integer; ids: array[0..3] of TID; res: TIDDynArray; begin try Check(ClientDist.SetUser('User','synopse')); TestFTS3(ClientDist); TestDynArray(ClientDist); {$ifndef LVCL} TestObject(ClientDist); {$endif} InternalTestMany(self,ClientDist); TestVirtual(ClientDist,false,'Remote Virtual Table access via SQLite',TSQLRecordDali1); TestVirtual(ClientDist,false,'Remote Virtual Table access via SQLite',TSQLRecordDali2); TestVirtual(ClientDist,true,'Remote Direct Virtual Table',TSQLRecordDali1); TestVirtual(ClientDist,true,'Remote Direct Virtual Table',TSQLRecordDali2); Check(TestTable(ClientDist.List([TSQLRecordPeople],'*',s)),'through URI and JSON'); for i := 0 to high(IntArray) do begin Check(ClientDist.RetrieveBlob(TSQLRecordPeople,IntArray[i],'Data',Data)); Check((length(Data)=4) and (PInteger(pointer(Data))^=IntArray[i])); V2.fID := IntArray[i]; // debug use - do NOT set ID in your programs! Check(V2.DataAsHex(ClientDist)=SynCommons.BinToHex(Data)); a := Random; b := Random; CheckSame(TSQLRecordPeople.Sum(Client,a,b,false),a+b); CheckSame(TSQLRecordPeople.Sum(Client,a,b,true),a+b); end; V.FirstName := 'Leonardo1'; Check(ClientDist.Update(V)); checks(false,ClientDist,'check remote UPDATE/POST'); V.FirstName := 'Leonard'; Check(ClientDist.Update(V)); checks(true,ClientDist,'check remote UPDATE/POST'); for i := 0 to high(ids) do begin V2.YearOfBirth := i; ids[i] := ClientDist.Add(V2,true); end; for i := 0 to high(ids) do begin Check(ClientDist.Retrieve(ids[i],V2)); Check(V2.YearOfBirth=i); end; for i := 0 to high(ids) do begin ClientDist.BatchStart(TSQLRecordPeople); ClientDist.BatchDelete(ids[i]); Check(ClientDist.BatchSend(res)=HTTP_SUCCESS); Check(length(res)=1); Check(res[0]=HTTP_SUCCESS); end; for i := 0 to high(ids) do Check(not ClientDist.Retrieve(ids[i],V2)); V2.ClearProperties; for i := 0 to high(ids) do begin V2.fID := ids[i]; Check(ClientDist.Update(V2),'test locking'); end; // time := GetTickCount; while time=GetTickCount do; time := GetTickCount; for i := 1 to 400 do // speed test: named pipes are OK checks(true,ClientDist,'caching speed test'); // writeln('NamedPipe connection time is ',GetTickCount-time,'ms'); finally ClientDist.Free; end; end; {$endif} procedure Direct(const URI: RawUTF8; Hash: cardinal; const head: RawUTF8=''); var call: TSQLRestURIParams; begin FillCharFast(call,sizeof(call),0); call.Method :='GET'; call.url := URI; call.InHead := head; TSQLRestServerAuthenticationDefault.ClientSessionSign(Client,call); call.RestAccessRights := @SUPERVISOR_ACCESS_RIGHTS; Server.URI(call); Check(Hash32(call.OutBody)=Hash); end; var ClientDist: TSQLRestClientURI; json: RawUTF8; begin V := TSQLRecordPeople.Create; VA := TSQLRecordPeopleArray.Create; {$ifndef LVCL} VO := TSQLRecordPeopleObject.Create; {$endif} VP := TSQLRecordCustomProps.Create; V2 := nil; try if ClassType<>TTestMemoryBased then begin DeleteFile('dali1.json'); DeleteFile('dali2.data'); end; Demo.RegisterSQLFunction(TypeInfo(TIntegerDynArray),@SortDynArrayInteger, 'MyIntegerDynArrayContains'); ModelC := TSQLModel.Create( [TSQLRecordPeople, TSQLFTSTest, TSQLASource, TSQLADest, TSQLADests, TSQLRecordPeopleArray {$ifndef LVCL}, TSQLRecordPeopleObject{$endif}, TSQLRecordDali1,TSQLRecordDali2, TSQLRecordCustomProps],'root'); ModelC.VirtualTableRegister(TSQLRecordDali1,TSQLVirtualTableJSON); ModelC.VirtualTableRegister(TSQLRecordDali2,TSQLVirtualTableBinary); try Client := TSQLRestClientDB.Create(ModelC,nil,Demo,TSQLRestServerTest,true); try Client.Server.DB.Synchronous := smOff; Client.Server.DB.LockingMode := lmExclusive; with Client.Server.Model do for i := 0 to high(Tables) do if not CheckFailed(GetTableIndex(Tables[i])=i) then Check(GetTableIndex(Tables[i].SQLTableName)=i); // direct client access test Client.Server.CreateMissingTables; // NEED Dest,Source,Dests,... Check(Client.SetUser('User','synopse')); // use default user DaVinci := 'da Vin'+_uE7+'i'; Check(Client.Retrieve('LastName='''+DaVinci+'''',V)); Check(V.FirstName='Leonardo1'); Check(V.LastName=DaVinci); Check(V.YearOfBirth=1452); Check(V.YearOfDeath=1519); checks(false,Client,'Retrieve'); Check(V.ID=6,'check RETRIEVE/GET'); Check(Client.Delete(TSQLRecordPeople,V.ID),'check DELETE'); Check(not Client.Retrieve(V.ID,V),'now this record must not be available'); Check(Client.Add(V,true)>0,'check ADD/PUT'); checks(false,Client,'check created value is well retrieved'); checks(false,Client,'check caching'); V2 := V.CreateCopy as TSQLRecordPeople; Check(V2.SameValues(V)); V2.Free; V2 := TSQLRecordPeople.Create(Client,V.ID); Check(V2.SameValues(V)); Check(Client.Retrieve(V.ID,V2,true),'with LOCK'); Check(V2.SameValues(V)); V.FirstName := 'Leonard'; Check(Client.Update(V)); Check(Client.UnLock(V),'unlock'); checks(true,Client,'check UPDATE/POST'); if Client.SessionUser=nil then // only if has the right for EngineExecute Check(Client.Execute('VACUUM;'),'check direct Execute()') else Check(Client.Server.Execute('VACUUM;')); Check(V2.FirstName='Leonardo1'); Check(not V2.SameValues(V),'V and V2 must differ'); Check(Client.UpdateFromServer([V2],Refreshed)); Check(Refreshed,'V2 value will be synchronized with V'); Check(V2.SameValues(V)); Check(Client.UpdateFromServer([V2],Refreshed)); Check(not Refreshed); Req := StringReplace(Req,'*', Client.Model.Props[TSQLRecordPeople].SQL.TableSimpleFields[true,false],[]); s := 'LastName=''M'+_uF4+'net'' ORDER BY FirstName'; J := Client.List([TSQLRecordPeople],'*',s); Check(Client.UpdateFromServer([J],Refreshed)); Check(not Refreshed); Check(TestTable(J),'incorrect TSQLTableJSON'); Check(Client.OneFieldValues(TSQLRecordPeople,'ID','LastName=:("Dali"):',IntArray)); Check(length(IntArray)=1001); for i := 0 to high(IntArray) do Check(Client.OneFieldValue(TSQLRecordPeople,'LastName',IntArray[i])='Dali'); List := Client.RetrieveList(TSQLRecordPeople,'Lastname=?',['Dali'],'ID,LastName'); if not CheckFailed(List<>nil) then begin Check(List.Count=Length(IntArray)); for i := 0 to List.Count-1 do with TSQLRecordPeople(List.List[i]) do begin Check(ID=IntArray[i]); Check(LastName='Dali'); Check(FirstName=''); end; List.Free; end; Client.Server.SessionsSaveToFile('sessions.data'); Client.Server.SessionsLoadFromFile('sessions.data',false); Check(Client.TransactionBegin(TSQLRecordPeople)); // for UpdateBlob() below for i := 0 to high(IntArray) do begin Check(Client.RetrieveBlob(TSQLRecordPeople,IntArray[i],'Data',Data)); Check(Length(Data)=sizeof(BlobDali)); Check(CompareMem(pointer(Data),@BlobDali,sizeof(BlobDali))); Check(Client.RetrieveBlob(TSQLRecordPeople,IntArray[i],'Data',DataS)); Check((DataS.Size=4) and (PCardinal(DataS.Memory)^=$E7E0E961)); DataS.Free; Check(Client.UpdateBlob(TSQLRecordPeople,IntArray[i],'Data',@IntArray[i],4)); Check(Client.RetrieveBlob(TSQLRecordPeople,IntArray[i],'Data',Data)); Check((length(Data)=4) and (PInteger(pointer(Data))^=IntArray[i])); V2.fID := IntArray[i]; // debug use - do NOT set ID in your programs! Check(V2.DataAsHex(Client)=SynCommons.BinToHex(Data)); a := Random; b := Random; Check(SameValue(TSQLRecordPeople.Sum(Client,a,b,false),a+b,1E-10)); Check(SameValue(TSQLRecordPeople.Sum(Client,a,b,true),a+b,1E-10)); end; Client.Commit; Check(Client.TransactionBegin(TSQLRecordPeopleArray)); V2.FillPrepare(Client,'LastName=:("Dali"):'); n := 0; while V2.FillOne do begin VA.FillFrom(V2); // fast copy some content from TSQLRecordPeople inc(n); if n and 31=0 then begin VA.UTF8 := ''; VA.DynArray('Ints').Add(n); Curr := n*0.01; VA.DynArray(2).Add(Curr); FV.Major := n; FV.Minor := n+2000; FV.Release := n+3000; FV.Build := n+4000; str(n,FV.Main); str(n+1000,FV.Detailed); VA.DynArray('FileVersion').Add(FV); end else str(n,VA.fUTF8); {$ifdef PUBLISHRECORD} VA.fRec.nPhrase := n; VA.fRec.nCol := n*2; VA.fRec.hits[2].docs_with_hits := n*3; {$endif PUBLISHRECORD} Check(Client.Add(VA,true)=n); end; Client.Commit; {$ifndef LVCL} if Client.TransactionBegin(TSQLRecordPeopleObject) then try V2.FillPrepare(Client,'LastName=:("Morse"):'); n := 0; while V2.FillOne do begin VO.FillFrom(V2); // fast copy some content from TSQLRecordPeople inc(n); VO.Persistent.One.Color := n+100; VO.Persistent.One.Length := n; VO.Persistent.One.Name := Int32ToUtf8(n); if n and 31=0 then begin VO.UTF8.Add(VO.Persistent.One.Name); with VO.Persistent.Coll.Add do begin Color := n+1000; Length := n*2; Name := Int32ToUtf8(n*3); end; end; Check(Client.Add(VO,true)=n); end; Client.Commit; except Client.RollBack; end; {$endif LVCL} TestFTS3(Client); TestDynArray(Client); {$ifndef LVCL} TestObject(Client); {$endif} InternalTestMany(self,Client); // RegisterVirtualTableModule(TSQLVirtualTableJSON) done above TestVirtual(Client,false,'Virtual Table access via SQLite 1',TSQLRecordDali1); TestVirtual(Client,false,'Virtual Table access via SQLite 1',TSQLRecordDali2); TestVirtual(Client,true,'Direct Virtual Table access 1',TSQLRecordDali1); TestVirtual(Client,true,'Direct Virtual Table access 2',TSQLRecordDali2); // remote client access test (via named pipes) {$ifdef MSWINDOWS} Check(Client.Server.ExportServerNamedPipe('Test'),'declare Test server'); TestClientDist(TSQLRestClientURINamedPipe.Create(ModelC,'Test')); {$endif} // check custom properties content {$ifndef LVCL} if Client.TransactionBegin(TSQLRecordPeopleObject) then try V2.FillPrepare(Client,'LastName=:("Morse"):'); n := 0; while V2.FillOne do begin VP.FillFrom(V2); // fast copy some content from TSQLRecordPeople inc(n); VP.fGUID.D1 := n; {$ifdef PUBLISHRECORD} VP.fGUIDXE6.D1 := n shl 1; {$endif} Check(Client.Add(VP,true)=n); end; Client.Commit; VP.FillPrepare(Client); while VP.FillOne do begin check(VP.LastName='Morse'); check(Integer(VP.GUID.D1)=VP.ID); {$ifdef PUBLISHRECORD} check(Integer(VP.GUIDXE6.D1)=VP.ID shl 1); {$endif} end; except Client.RollBack; end; {$endif} // test backup API BackupFN := Format('backupbackground%s.dbsynlz',[ClassName]); deleteFile(BackupFN); BackupTimer.Start; Check(Client.DB.BackupBackground(BackupFN,1024,0,OnBackupProgress,true)); // test per-one and batch requests if ClassType=TTestMemoryBased then begin // time consuming, so do it once Server := TSQLRestServerTest.Create(TSQLModel.Create([TSQLRecordPeople]),false); try Server.Model.Owner := Server; // we just use TSQLRecordPeople here Server.NoAJAXJSON := true; DeleteFile('People.json'); DeleteFile('People.data'); Server.StaticDataCreate(TSQLRecordPeople,'People.data',true); json := Demo.ExecuteJSON('SELECT * From People'); aStatic := Server.StaticDataServer[TSQLRecordPeople] as TSQLRestStorageInMemory; Check(aStatic<>nil); aStatic.LoadFromJSON(json); // test Add() and JSON fast loading for i := 0 to aStatic.Count-1 do begin Check(Client.Retrieve(aStatic.ID[i],V),'test statement+bind speed'); Check(V.SameRecord(aStatic.Items[i]),'static retrieve'); end; // test our 'REST-minimal' SELECT statement SQL engine Direct('/root/People?select=%2A&where=id%3D012',$96F68454); Direct('/root/People?select=%2A&where=id%3D:(012):',$96F68454); Direct('/root/People?select=%2A&where=LastName%3D%22M%C3%B4net%22',$BBDCF3A6); Direct('/root/People?select=%2A&where=YearOfBirth%3D1873',$AF4BCA94); Direct('/root/People?select=%2A',$17AE45E3); Direct('/root/People?select=%2A&where=YearOfBirth%3D1873&startindex=10&results=20',$453C7201); Server.URIPagingParameters.SendTotalRowsCountFmt := ',"Total":%'; Direct('/root/People?select=%2A&where=YearOfBirth%3D1873&startindex=10&results=2',$79AFDD53); Server.NoAJAXJSON := false; Direct('/root/People?select=%2A&where=YearOfBirth%3D1873&startindex=10&results=2', $69FDAF5D,'User-Agent: Ajax'); Server.NoAJAXJSON := true; Server.URIPagingParameters.SendTotalRowsCountFmt := ''; // test Retrieve() and Delete() Server.ExportServer; // initialize URIRequest() with the aStatic database USEFASTMM4ALLOC := true; // getmem() is 2x faster than GlobalAlloc() ClientDist := TSQLRestClientURIDll.Create(ModelC,URIRequest); try SetLength(IntArray,(aStatic.Count-1)shr 2); for i := 0 to high(IntArray) do begin IntArray[i] := aStatic.ID[i*4]; Check(ClientDist.Retrieve(IntArray[i],V)); Check(V.SameRecord(aStatic.Items[i*4])); end; Check(V.FillPrepare(Client,IntArray)); for i := 0 to High(IntArray) do begin Check(V.FillOne); Check(V.ID=IntArray[i]); Check(V.SameRecord(aStatic.Items[i*4])); end; V.FillClose; // so that BatchUpdate(V) below will set all fields if ClientDist.TransactionBegin(TSQLRecordPeople) then try for i := 0 to high(IntArray) do Check(ClientDist.Delete(TSQLRecordPeople,IntArray[i])); for i := 0 to high(IntArray) do Check(not ClientDist.Retrieve(IntArray[i],V)); for i := 0 to aStatic.Count-1 do begin Check(ClientDist.Retrieve(aStatic.ID[i],V)); V.YearOfBirth := Random(MaxInt)-Random(MaxInt); Check(ClientDist.Update(V)); Check(ClientDist.Retrieve(aStatic.ID[i],V)); Check(V.SameRecord(aStatic.Items[i])); end; ClientDist.Commit; except ClientDist.RollBack; end else Check(False,'TransactionBegin'); // test BATCH sequence usage if ClientDist.TransactionBegin(TSQLRecordPeople) then try Check(ClientDist.BatchStart(TSQLRecordPeople,5000)); n := 0; for i := 0 to aStatic.Count-1 do if i and 7=0 then begin IntArray[n] := aStatic.ID[i]; inc(n); end; for i := 0 to n-1 do // note that here a warning does make sense, since Server.DB=nil Check(ClientDist.BatchDelete(IntArray[i])=i); nupd := 0; for i := 0 to aStatic.Count-1 do if i and 7<>0 then begin // not yet deleted in BATCH mode Check(ClientDist.Retrieve(aStatic.ID[i],V)); V.YearOfBirth := 1800+nupd; Check(ClientDist.BatchUpdate(V)=nupd+n); inc(nupd); end; V.LastName := 'New'; for i := 0 to 1000 do begin V.FirstName := RandomUTF8(10); V.YearOfBirth := i+1000; Check(ClientDist.BatchAdd(V,true)=n+nupd+i); end; Check(ClientDist.BatchSend(Results)=200); Check(Length(Results)=9260); ClientDist.Commit; for i := 0 to n-1 do Check(not ClientDist.Retrieve(IntArray[i],V),'BatchDelete'); for i := 0 to high(Results) do if i0); ndx := aStatic.IDToIndex(Results[i]); Check(ndx>=0); with TSQLRecordPeople(aStatic.Items[ndx]) do begin Check(LastName='New','BatchAdd'); Check(YearOfBirth=1000+i-nupd-n); end; end; for i := 0 to aStatic.Count-1 do with TSQLRecordPeople(aStatic.Items[i]) do if LastName='New' then break else Check(YearOfBirth=1800+i,'BatchUpdate'); except ClientDist.RollBack; end else Check(False,'TransactionBegin'); // test BATCH update from partial FillPrepare V.FillPrepare(ClientDist,'LastName=?',['New'],'ID,YearOfBirth'); if ClientDist.TransactionBegin(TSQLRecordPeople) then try Check(ClientDist.BatchStart(TSQLRecordPeople)); n := 0; V.LastName := 'NotTransmitted'; while V.FillOne do begin Check(V.LastName='NotTransmitted'); Check(V.YearOfBirth=n+1000); V.YearOfBirth := n; if n and 3=0 then // will update only V.YearOfBirth specifically ClientDist.BatchUpdate(V, TSQLRecordPeople.RecordProps.FieldBitsFromCSV('YearOfBirth')) else // will update only V.YearOfBirth as in previous FillPrepare ClientDist.BatchUpdate(V); inc(n); end; Check(n=1001); SetLength(Results,0); Check(ClientDist.BatchSend(Results)=200); Check(length(Results)=1001); for i := 0 to high(Results) do Check(Results[i]=200); ClientDist.Commit; except ClientDist.RollBack; end else Check(False,'TransactionBegin'); V.FillPrepare(ClientDist,'LastName=?',['New'],'YearOfBirth'); n := 0; while V.FillOne do begin Check(V.LastName='NotTransmitted'); Check(V.YearOfBirth=n); V.YearOfBirth := 1000; inc(n); end; Check(n=length(Results)); V.FillClose; V.LastName := 'last'; V.FirstName := 'first'; V.fID := 4294967297; Check(ClientDist.Add(V,true,True)=V.ID); V.ClearProperties; ClientDist.Retrieve(4294967297,V); Check(V.FirstName='first'); Check(V.ID=4294967297); finally ClientDist.Free; end; aStatic.UpdateFile; // force People.data file content write aStatic.ReloadFromFile; Check(aStatic.Retrieve(11,V),'reload from people.data'); Check(V.FirstName='Jane1'); Check(aStatic.Retrieve(4294967297,V)); Check(V.FirstName='first'); aStatic.FileName := 'People.json'; aStatic.BinaryFile := false; aStatic.Modified := true; aStatic.UpdateFile; // force People.json file content write aStatic.ReloadFromFile; Check(aStatic.Retrieve(11,V),'reload from people.json'); Check(V.FirstName='Jane1'); Check(aStatic.Retrieve(4294967297,V)); Check(V.FirstName='first'); aStatic.Delete(TSQLRecordPeople,4294967297); aStatic.UpdateFile; finally {$ifdef MSWINDOWS} USEFASTMM4ALLOC := false; {$endif} Server.Free; end; end; Client.DB.BackupBackgroundWaitUntilFinished; finally Client.Free; end; finally ModelC.Free; end; finally V.Free; V2.Free; VA.Free; VP.Free; {$ifndef LVCL} VO.Free; {$endif} FreeAndNil(Demo); end; {$ifndef NOSQLITE3ENCRYPT} if EncryptedFile then begin check(ChangeSQLEncryptTablePassWord(TempFileName,'NewPass','')); // uncrypt file Check(IsSQLite3File(TempFileName)); end; {$endif} end; procedure TTestSQLite3Engine._TSQLTableJSON; var J: TSQLTableJSON; i1, i2, aR, aF, F1,F2, n: integer; Comp, Comp1,Comp2: TUTF8Compare; {$ifdef UNICODE} Peoples: TObjectList; {$endif} {$ifndef LVCL} row: variant; {$endif} {$ifndef NOVARIANTS} lContactDataQueueDynArray: TDynArray; lContactDataQueueArray: TRawUTF8DynArray; lContactDataQueueJSON: TDocVariantData; lData, s: RawUTF8; lDocData: TDocVariantData; const TEST_DATA = '['+ '{"REC_ID":29915,"CHANNEL":117,"PHONE":"5004392222,12345678","RINGS":0,' + '"QUEUE_CALL":2,"PRIORITY":25,"TIMESTAMP_CALL":"2017-10-26T04:48:14",' + '"RETRIES_CALL":2,"CONNECTION_TYPE":0,"DISCONNECTION_TYPE":0,"STATUS_CALL":9,'+ '"GC_STATUS_CALL":5404,"START_COMMUNICATION":"","HELLO":0,"EXTENSION":null,' + '"NODE":1,"RESULT_CALL":0,"CONNECT_TIME":0,"SKILL":null,"AGENT_POSITION":0,' + '"COMM_RESULT_CODE":null,"V01_TM":"Marcie","V02_TM":"Sayton",'+ '"V03_TM":"msaytonpe@umn.edu"},'+ '{"REC_ID":29916,"CHANNEL":132,"PHONE":"1763252375","RINGS":0,"QUEUE_CALL":2,' + '"PRIORITY":25,"TIMESTAMP_CALL":"2017-10-26T04:48:14","RETRIES_CALL":2,' + '"CONNECTION_TYPE":0,"DISCONNECTION_TYPE":0,"STATUS_CALL":9,'+ '"GC_STATUS_CALL":5404,"START_COMMUNICATION":"","HELLO":0,"EXTENSION":null,' + '"NODE":1,"RESULT_CALL":0,"CONNECT_TIME":0,"SKILL":null,"AGENT_POSITION":0,' + '"COMM_RESULT_CODE":null,"V01_TM":"Orsola","V02_TM":"Hainge",'+ '"V03_TM":"ohaingepf@reverbnation.com"},'+ '{"REC_ID":29917,"CHANNEL":174,"PHONE":"9149556917","RINGS":0,"QUEUE_CALL":2,' + '"PRIORITY":25,"TIMESTAMP_CALL":"2017-10-26T04:48:14","RETRIES_CALL":2,' + '"CONNECTION_TYPE":0,"DISCONNECTION_TYPE":0,"STATUS_CALL":9,'+ '"GC_STATUS_CALL":5404,"START_COMMUNICATION":"","HELLO":0,"EXTENSION":null,' + '"NODE":1,"RESULT_CALL":0,"CONNECT_TIME":0,"SKILL":null,"AGENT_POSITION":0,' + '"COMM_RESULT_CODE":null,"V01_TM":"Storm","V02_TM":"Jenton",'+ '"V03_TM":"sjentonpg@senate.gov"}]'; {$endif} begin J := TSQLTableJSON.Create('',JS); try J.SetFieldType('YearOfBirth',sftModTime); if JS<>'' then // avoid memory leak with TSQLTableDB.Create(Demo,[],Req,true) do try Check(RowCount=J.RowCount); Check(FieldCount=J.FieldCount); SetFieldType('YearOfBirth',sftModTime); for aR := 0 to RowCount do for aF := 0 to FieldCount-1 do if (aR>0) and (aF=3) then // aF=3=Blob Check(GetBlob(aR,aF)=J.GetBlob(aR,aF)) else begin Check((GetW(aR,aF)=J.GetW(aR,aF)) and (GetA(aR,aF)=J.GetA(aR,aF)) and (length(GetW(aR,aF))shr 1=LengthW(aR,aF)), Format('Get() in Row=%d Field=%d',[aR,aF])); if (aR>0) and (aF>3) then begin Check(GetDateTime(aR,af)=J.GetDateTime(aR,aF)); Check(GetAsDateTime(aR,af)=J.GetAsDateTime(aR,aF)); end; end; finally Free; end; Demo.Execute('VACUUM;'); with TSQLTableDB.Create(Demo,[],Req,true) do // re-test after VACCUM try Check(RowCount=J.RowCount); Check(FieldCount=J.FieldCount); Check(FieldIndex('ID')=0); Check(FieldIndex('RowID')=0); for aF := 0 to FieldCount-1 do Check(FieldIndex(J.Get(0,aF))=aF); for aR := 0 to RowCount do for aF := 0 to FieldCount-1 do // aF=3=Blob Check((aF=3) or (StrIComp(Get(aR,aF),J.Get(aR,aF))=0)); n := 0; while Step do begin for aF := 0 to FieldCount-1 do // aF=3=Blob Check((aF=3) or (StrIComp(FieldBuffer(aF),J.Get(StepRow,aF))=0)); inc(n); end; check(n=J.RowCount); {$ifndef LVCL} n := 0; if not CheckFailed(Step(true,@row)) then repeat Check(row.ID=J.GetAsInteger(StepRow,FieldIndex('ID'))); Check(row.FirstName=J.GetU(StepRow,FieldIndex('FirstName'))); Check(row.LastName=J.GetU(StepRow,FieldIndex('LastName'))); Check(row.YearOfBirth=J.GetAsInteger(StepRow,FieldIndex('YearOfBirth'))); Check(row.YearOfDeath=J.GetAsInteger(StepRow,FieldIndex('YearOfDeath'))); inc(n); until not Step(false,@row); check(n=J.RowCount); {$endif} with ToObjectList(TSQLRecordPeople) do try check(Count=J.RowCount); for aR := 1 to Count do with TSQLRecordPeople(Items[aR-1]) do begin Check(fID=J.GetAsInteger(aR,FieldIndex('ID'))); Check(FirstName=J.GetU(aR,FieldIndex('FirstName'))); Check(LastName=J.GetU(aR,FieldIndex('LastName'))); Check(YearOfBirth=J.GetAsInteger(aR,FieldIndex('YearOfBirth'))); Check(YearOfDeath=J.GetAsInteger(aR,FieldIndex('YearOfDeath'))); end; finally Free; end; {$ifdef UNICODE} Peoples := ToObjectList; try Check(Peoples.Count=J.RowCount); for aR := 1 to Peoples.Count do with Peoples[aR-1] do begin Check(ID=J.GetAsInteger(aR,FieldIndex('ID'))); Check(FirstName=J.GetU(aR,FieldIndex('FirstName'))); Check(LastName=J.GetU(aR,FieldIndex('LastName'))); Check(YearOfBirth=J.GetAsInteger(aR,FieldIndex('YearOfBirth'))); Check(YearOfDeath=J.GetAsInteger(aR,FieldIndex('YearOfDeath'))); end; finally Peoples.Free; end; {$endif} finally Free; end; for aF := 0 to J.FieldCount-1 do begin J.SortFields(aF); Comp := J.SortCompare(aF); if @Comp<>nil then // BLOB field will be ignored for aR := 1 to J.RowCount-1 do // ensure data sorted in increasing order Check(Comp(pointer(J.Get(aR,aF)),pointer(J.Get(aR+1,aF)))<=0,'SortCompare'); end; for aF := 0 to J.FieldCount-1 do begin J.SortFields(aF,false); Comp := J.SortCompare(aF); if @Comp<>nil then // BLOB field will be ignored for aR := 1 to J.RowCount-1 do // ensure data sorted in decreasing order Check(Comp(pointer(J.Get(aR,aF)),pointer(J.Get(aR+1,aF)))>=0,'SortCompare'); end; for F1 := 0 to J.FieldCount-1 do for F2 := 0 to J.FieldCount-1 do if F1<>F2 then begin Comp1 := J.SortCompare(F1); Comp2 := J.SortCompare(F2); if (@Comp1=nil) or (@Comp2=nil) then continue; // BLOB fields will be ignored J.SortFields([F1,F2],[],[]); for aR := 1 to J.RowCount-1 do begin // ensure data sorted in increasing order for both fields aF := Comp1(pointer(J.Get(aR,F1)),pointer(J.Get(aR+1,F1))); Check(aF<=0,'SortCompare'); if aF=0 then // 1st field idem -> check sorted by 2nd field Check(Comp2(pointer(J.Get(aR,F2)),pointer(J.Get(aR+1,F2)))<=0); end; end; for F1 := 0 to J.FieldCount-1 do for F2 := 0 to J.FieldCount-1 do if F1<>F2 then begin Comp1 := J.SortCompare(F1); Comp2 := J.SortCompare(F2); if (@Comp1=nil) or (@Comp2=nil) then continue; // BLOB fields will be ignored J.SortFields([F1,F2],[false,true],[]); // 1st=DESC, 2nd=ASC order for aR := 1 to J.RowCount-1 do begin // ensure data sorted in expected order for both fields aF := Comp1(pointer(J.Get(aR,F1)),pointer(J.Get(aR+1,F1))); Check(aF>=0,'SortCompare'); if aF=0 then // 1st field idem -> check ASC sorted by 2nd field Check(Comp2(pointer(J.Get(aR,F2)),pointer(J.Get(aR+1,F2)))<=0); end; end; finally J.Free; end; if false then with TSQLTableDB.Create(Demo,[TSQLRecordPeople], 'select id,FirstName,LastName,YearOfBirth,YearOfDeath from people',true) do try FileFromString(GetODSDocument(false),'false.ods'); FileFromString(GetODSDocument(true),'true.ods'); finally Free; end; // some tests to avoid regression about bugs reported by users on forum {$ifndef NOVARIANTS} J := TSQLTableJSON.Create('',TEST_DATA); try check(J.fieldCount=24); check(J.rowCount=3); lData := j.GetJSONValues(true); check(lData[1]='['); check(JSONArrayCount(@lData[2])=J.rowCount); check(Hash32(lData)=$B1C13092); lData := j.GetJSONValues(false); check(Hash32(lData)=$6AB30A2); finally J.Free; end; lContactDataQueueJSON.InitJSON(TEST_DATA); lContactDataQueueDynArray.Init(TypeInfo(TRawUTF8DynArray), lContactDataQueueArray); lContactDataQueueJSON.ToRawUTF8DynArray(lContactDataQueueArray); lData := lContactDataQueueDynArray.SaveToJSON; lDocData.InitJSON(lData, [dvoJSONObjectParseWithinString]); check(lDocData.Count=3); check(Hash32(lDocData.ToJSON)=$FCF948A5); check(lDocData.Value[0].QUEUE_CALL=2); s := TEST_DATA; i1 := PosEx(',"CHANNEL":132',s); i2 := PosEx('}',s,i1); delete(s,i1,i2-i1); // truncate the 2nd object J := TSQLTableJSON.Create('',s); try check(J.fieldCount=24); if not checkfailed(J.rowCount=3) then check(J.Get(2,J.FieldCount-1)=nil); check(J.Get(J.rowCount,J.FieldCount-1)='sjentonpg@senate.gov'); finally J.Free; end; {$endif NOVARIANTS} end; {$ifdef UNICODE} {$WARNINGS ON} // don't care about implicit string cast in tests {$endif} { TSQLRestServerTest } procedure TSQLRestServerTest.DataAsHex(Ctxt: TSQLRestServerURIContext); var aData: TSQLRawBlob; begin if (self=nil) or (Ctxt.Table<>TSQLRecordPeople) or (Ctxt.TableID<0) then Ctxt.Error('Need a valid record and its ID') else if RetrieveBlob(TSQLRecordPeople,Ctxt.TableID,'Data',aData) then Ctxt.Results([SynCommons.BinToHex(aData)]) else Ctxt.Error('Impossible to retrieve the Data BLOB field'); end; procedure TSQLRestServerTest.Sum(Ctxt: TSQLRestServerURIContext); var a,b: double; begin if UrlDecodeNeedParameters(Ctxt.Parameters,'A,B') then begin while Ctxt.Parameters<>nil do begin UrlDecodeDouble(Ctxt.Parameters,'A=',a); UrlDecodeDouble(Ctxt.Parameters,'B=',b,@Ctxt.Parameters); end; Ctxt.Results([a+b]); end else Ctxt.Error('Missing Parameter'); end; procedure TSQLRestServerTest.Sum2(Ctxt: TSQLRestServerURIContext); begin with Ctxt do Results([InputDouble['a']+InputDouble['b']]); end; var GlobalInterfaceTestMode: ( itmDirect, itmClient, itmLocked, itmMainThread, itmPerInterfaceThread, itmHttp) = itmDirect; {$ifndef LVCL} { TSQLRecordPeopleObject } constructor TSQLRecordPeopleObject.Create; begin inherited; fPersistent := TCollTst.Create; fUTF8 := TRawUTF8List.Create; end; destructor TSQLRecordPeopleObject.Destroy; begin Persistent.Free; UTF8.Free; inherited; end; { TCollTestsI } class function TCollTestsI.GetClass: TCollectionItemClass; begin result := TCollTest; end; {$endif LVCL} { TComplexNumber } constructor TComplexNumber.Create(aReal, aImaginary: double); begin Real := aReal; Imaginary := aImaginary; end; { TServiceCalculator } type TServiceCalculator = class(TInjectableObject, ICalculator) public function Add(n1,n2: integer): integer; function Subtract(n1,n2: double): double; procedure Swap(var n1,n2: double); function Multiply(n1,n2: Int64): Int64; procedure ToText(Value: Currency; var Result: RawUTF8); function ToTextFunc(Value: double): string; function StackIntMultiply(n1,n2,n3,n4,n5,n6,n7,n8,n9,n10: integer): Int64; function StackFloatMultiply(n1,n2,n3,n4,n5,n6,n7,n8,n9,n10: double): Int64; function SpecialCall(Txt: RawUTF8; var Int: integer; var Card: cardinal; field: TSynTableFieldTypes; fields: TSynTableFieldTypes; var options: TSynTableFieldOptions): TSynTableFieldTypes; function ComplexCall(const Ints: TIntegerDynArray; const Strs1: TRawUTF8DynArray; var Str2: TWideStringDynArray; const Rec1: TVirtualTableModuleProperties; var Rec2: TSQLRestCacheEntryValue; Float1: double; var Float2: double): TSQLRestCacheEntryValue; function DirectCall(const Data: TSQLRawBlob): integer; function RepeatJsonArray(const item: RawUTF8; count: integer): RawJSON; function RepeatTextArray(const item: RawUTF8; count: integer): RawUTF8; function Test(A,B: Integer): RawUTF8; end; TServiceComplexCalculator = class(TServiceCalculator,IComplexCalculator) protected procedure EnsureInExpectedThread; public procedure Substract(n1,n2: TComplexNumber; out Result: TComplexNumber); function IsNull(n: TComplexNumber): boolean; function TestBlob(n: TComplexNumber): TServiceCustomAnswer; {$ifndef NOVARIANTS} function TestVariants(const Text: RawUTF8; V1: Variant; var V2: variant): variant; {$endif} {$ifndef LVCL} procedure Collections(Item: TCollTest; var List: TCollTestsI; out Copy: TCollTestsI); destructor Destroy; override; {$endif LVCL} function GetCurrentThreadID: PtrUInt; function EchoRecord(const Nav: TConsultaNav): TConsultaNav; function GetCustomer(CustomerId: Integer; out CustomerData: TCustomerData): Boolean; procedure FillPeople(var People: TSQLRecordPeople); end; TServiceComplexNumber = class(TInterfacedObject,IComplexNumber) private fReal: double; fImaginary: double; function GetImaginary: double; function GetReal: double; procedure SetImaginary(const Value: double); procedure SetReal(const Value: double); public procedure Assign(aReal, aImaginary: double); procedure Add(aReal, aImaginary: double); property Real: double read GetReal write SetReal; property Imaginary: double read GetImaginary write SetImaginary; end; TServiceUserGroupSession = class(TInterfacedObject,ITestUser,ITestGroup,ITestSession) public function GetContextSessionID: integer; function GetContextSessionUser: integer; function GetContextSessionGroup: integer; end; TServicePerThread = class(TInterfacedObjectWithCustomCreate,ITestPerThread) protected fThreadIDAtCreation: PtrUInt; // TThreadID = ^TThreadRec under BSD public constructor Create; override; function GetContextServiceInstanceID: PtrUInt; function GetThreadIDAtCreation: PtrUInt; function GetCurrentThreadID: PtrUInt; function GetCurrentRunningThreadID: PtrUInt; end; function TServiceCalculator.Add(n1, n2: integer): integer; begin result := n1+n2; end; function TServiceCalculator.Multiply(n1, n2: Int64): Int64; begin result := n1*n2; end; function TServiceCalculator.StackIntMultiply(n1,n2,n3,n4,n5,n6,n7,n8,n9,n10: integer): Int64; begin result := n1*n2*n3*n4*n5*n6*n7*n8*n9*n10; end; function TServiceCalculator.StackFloatMultiply(n1,n2,n3,n4,n5,n6,n7,n8,n9,n10: double): Int64; begin result := round(n1*n2*n3*n4*n5*n6*n7*n8*n9*n10); end; function TServiceCalculator.SpecialCall(Txt: RawUTF8; var Int: integer; var Card: cardinal; field, fields: TSynTableFieldTypes; var options: TSynTableFieldOptions): TSynTableFieldTypes; var dummy: IComplexNumber; begin TryResolve(TypeInfo(IComplexNumber),dummy); inc(Int,length(Txt)); inc(Card); result := fields+field; Include(options,tfoUnique); Exclude(options,tfoIndex); end; function TServiceCalculator.Subtract(n1, n2: double): double; begin result := n1-n2; end; procedure TServiceCalculator.Swap(var n1,n2: double); var tmp: double; begin tmp := n2; n2 := n1; n1 := tmp; end; function TServiceCalculator.Test(A, B: Integer): RawUTF8; begin result := Int32ToUtf8(A+B); end; procedure TServiceCalculator.ToText(Value: Currency; var Result: RawUTF8); begin result := Curr64ToStr(PInt64(@Value)^); end; function TServiceCalculator.ToTextFunc(Value: double): string; begin result := DoubleToString(Value); end; function TServiceCalculator.ComplexCall(const Ints: TIntegerDynArray; const Strs1: TRawUTF8DynArray; var Str2: TWideStringDynArray; const Rec1: TVirtualTableModuleProperties; var Rec2: TSQLRestCacheEntryValue; Float1: double; var Float2: double): TSQLRestCacheEntryValue; var i: integer; begin result := Rec2; result.JSON := StringToUTF8(Rec1.FileExtension); i := length(Str2); SetLength(Str2,i+1); Str2[i] := UTF8ToWideString(RawUTF8ArrayToCSV(Strs1)); inc(Rec2.ID); dec(Rec2.Timestamp512); Rec2.JSON := IntegerDynArrayToCSV(pointer(Ints),length(Ints)); Float2 := Float1; end; function TServiceCalculator.DirectCall(const Data: TSQLRawBlob): integer; var i: integer; begin result := length(Data); for i := 1 to result do if Data[i]<>#1 then result := 0; end; function TServiceCalculator.RepeatJsonArray(const item: RawUTF8; count: integer): RawJSON; var buf: array[word] of byte; begin with TTextWriter.CreateOwnedStream(@buf, SizeOf(buf)) do try Add('['); while count > 0 do begin Add('"'); AddJSONEscape(pointer(item)); Add('"',','); dec(count); end; CancelLastComma; Add(']'); SetText(RawUTF8(result)); finally Free; end; end; function TServiceCalculator.RepeatTextArray(const item: RawUTF8; count: integer): RawUTF8; var buf: array[word] of byte; begin with TTextWriter.CreateOwnedStream(@buf, SizeOf(buf)) do try while count > 0 do begin AddJSONEscape(pointer(item)); dec(count); end; SetText(result); finally Free; end; end; { TServiceComplexCalculator } function TServiceComplexCalculator.IsNull(n: TComplexNumber): boolean; begin result := (n.Real=0) and (n.Imaginary=0); end; procedure TServiceComplexCalculator.Substract(n1, n2: TComplexNumber; out Result: TComplexNumber); begin result.Real := n1.Real-n2.Real; result.Imaginary := n1.Imaginary-n2.Imaginary; end; function TServiceComplexCalculator.EchoRecord(const Nav: TConsultaNav): TConsultaNav; begin result := Nav; end; function GetThreadID: PtrUInt; begin // avoid name conflict with TServiceComplexCalculator.GetCurrentThreadID result := PtrUInt(GetCurrentThreadId); end; procedure TServiceComplexCalculator.EnsureInExpectedThread; begin case GlobalInterfaceTestMode of itmDirect, itmClient, itmMainThread: if GetThreadID<>PtrUInt(MainThreadID) then raise Exception.Create('Shall be in main thread'); itmPerInterfaceThread, itmHttp, itmLocked: if GetThreadID=PtrUInt(MainThreadID) then raise Exception.Create('Shall NOT be in main thread') else if ServiceContext.RunningThread=nil then raise Exception.Create('Shall have a known RunningThread'); end; end; function TServiceComplexCalculator.TestBlob(n: TComplexNumber): TServiceCustomAnswer; begin EnsureInExpectedThread; Result.Header := TEXT_CONTENT_TYPE_HEADER; if n.Real = maxInt then Result.Content := StringOfChar(AnsiChar('-'), 600) else Result.Content := FormatUTF8('%,%',[n.Real,n.Imaginary]); end; {$ifndef NOVARIANTS} function TServiceComplexCalculator.TestVariants(const Text: RawUTF8; V1: Variant; var V2: variant): variant; begin V2 := V2+V1; VariantLoadJSON(Result,Text); end; {$endif} function TServiceComplexCalculator.GetCurrentThreadID: PtrUInt; begin result := GetThreadID; end; function TServiceComplexCalculator.GetCustomer(CustomerId: Integer; out CustomerData: TCustomerData): Boolean; begin CustomerData.Id := CustomerId; CustomerData.AccountNum := Int32ToUtf8(CustomerID); result := True; end; procedure TServiceComplexCalculator.FillPeople(var People: TSQLRecordPeople); begin People.LastName := FormatUTF8('Last %',[People.ID]); People.FirstName := FormatUTF8('First %',[People.ID]); end; {$ifndef LVCL} procedure TServiceComplexCalculator.Collections(Item: TCollTest; var List: TCollTestsI; out Copy: TCollTestsI); begin CopyObject(Item,List.Add); CopyObject(List,Copy); end; destructor TServiceComplexCalculator.Destroy; begin EnsureInExpectedThread; inherited; end; {$endif LVCL} { TServiceComplexNumber } procedure TServiceComplexNumber.Add(aReal, aImaginary: double); begin fReal := fReal+aReal; fImaginary := fImaginary+aImaginary; end; procedure TServiceComplexNumber.Assign(aReal, aImaginary: double); begin fReal := aReal; fImaginary := aImaginary; end; function TServiceComplexNumber.GetImaginary: double; begin result := fImaginary; end; function TServiceComplexNumber.GetReal: double; begin result := fReal; end; procedure TServiceComplexNumber.SetImaginary(const Value: double); begin fImaginary := Value; end; procedure TServiceComplexNumber.SetReal(const Value: double); begin fReal := Value; end; { TServiceUserGroupSession } function TServiceUserGroupSession.GetContextSessionGroup: integer; begin with PServiceRunningContext(@ServiceContext)^ do if Request=nil then result := 0 else result := Request.SessionGroup; end; function TServiceUserGroupSession.GetContextSessionID: integer; begin with PServiceRunningContext(@ServiceContext)^ do if Request=nil then result := 0 else result := Request.Session; end; function TServiceUserGroupSession.GetContextSessionUser: integer; begin with PServiceRunningContext(@ServiceContext)^ do if Request=nil then result := 0 else result := Request.SessionUser; end; { TServicePerThread } constructor TServicePerThread.Create; begin inherited; fThreadIDAtCreation := PtrUInt(GetThreadID); end; function TServicePerThread.GetCurrentThreadID: PtrUInt; begin result := PtrUInt(GetThreadID); with PServiceRunningContext(@ServiceContext)^ do if Request<>nil then if PtrUInt(Result)<>Request.ServiceInstanceID then raise Exception.Create('Unexpected ServiceInstanceID'); end; function TServicePerThread.GetThreadIDAtCreation: PtrUInt; begin result := fThreadIDAtCreation; end; function TServicePerThread.GetContextServiceInstanceID: PtrUInt; begin with PServiceRunningContext(@ServiceContext)^ do if Request=nil then result := 0 else begin result := Request.ServiceInstanceID; if result<>PtrUInt(GetThreadID) then raise Exception.Create('Unexpected ThreadID'); end; end; function TServicePerThread.GetCurrentRunningThreadID: PtrUInt; var Thread: TThread; begin Thread := ServiceContext.RunningThread; if (Thread=nil) and (GlobalInterfaceTestMode=itmHttp) then raise Exception.Create('Unexpected Thread=nil'); if Thread=nil then result := 0 else begin result := PtrUInt(Thread.ThreadID); if result<>PtrUInt(GetThreadID) then raise Exception.Create('Unexpected ThreadID'); end; end; { TTestServiceOrientedArchitecture } procedure TTestServiceOrientedArchitecture.Test(const Inst: TTestServiceInstances; Iterations: Cardinal=700); procedure TestCalculator(const I: ICalculator); var {$ifdef CPU64} i1,i2: int64; {$else} i1,i2: integer; {$endif} t,i3: integer; c: cardinal; cu: currency; n1,n2,s1,s2: double; o: TSynTableFieldOptions; Ints: TIntegerDynArray; Strs1: TRawUTF8DynArray; Str2: TWideStringDynArray; Rec1: TVirtualTableModuleProperties; Rec2, RecRes: TSQLRestCacheEntryValue; s: RawUTF8; r: string; begin Setlength(Ints,2); CSVToRawUTF8DynArray('one,two,three',Strs1); for t := 1 to Iterations do begin i1 := Random(MaxInt)-Random(MaxInt); i2 := Random(MaxInt)-i1; Check(I.Add(i1,i2)=i1+i2); Check(I.Multiply(i1,i2)=Int64(i1)*Int64(i2)); n1 := Random*1E-9-Random*1E-8; n2 := n1*Random; CheckSame(I.Subtract(n1,n2),n1-n2); s1 := n1; s2 := n2; CheckSame(s1,n1); CheckSame(s2,n2); I.Swap(s1,s2); CheckSame(s1,n2); CheckSame(s2,n1); cu := i1*0.01; I.ToText(cu,s); Check(s=Curr64ToStr(PInt64(@cu)^)); r := I.ToTextFunc(n1); CheckSame(StrToFloat(r),n1); o := [tfoIndex,tfoCaseInsensitive]; i3 := i1; c := cardinal(i2); Check(I.SpecialCall(s,i3,c, [tftDouble],[tftWinAnsi,tftVarInt64],o)= [tftWinAnsi,tftVarInt64,tftDouble]); Check(i3=i1+length(s)); Check(c=cardinal(i2)+1); Check(o=[tfoUnique,tfoCaseInsensitive]); Ints[0] := i1; Ints[1] := i2; SetLength(Str2,3); Str2[0] := 'ABC'; Str2[1] := 'DEF'; Str2[2] := 'GHIJK'; FillCharFast(Rec1,sizeof(Rec1),0); Rec1.Features := [vtTransaction,vtSavePoint]; Rec1.FileExtension := ExeVersion.ProgramFileName; Rec2.ID := i1; Rec2.Timestamp512 := c; Rec2.JSON := 'abc'; RecRes := I.ComplexCall(Ints,Strs1,Str2,Rec1,Rec2,n1,n2); Check(length(Str2)=4); Check(Str2[0]='ABC'); Check(Str2[1]='DEF'); Check(Str2[2]='GHIJK'); Check(Str2[3]='one,two,three'); Check(Rec1.Features=[vtTransaction,vtSavePoint]); Check(Rec1.FileExtension=ExeVersion.ProgramFileName); Check(Rec2.ID=i1+1); Check(Rec2.Timestamp512=c-1); Check(Rec2.JSON=IntegerDynArrayToCSV(pointer(Ints),length(Ints))); Check(RecRes.ID=i1); Check(RecRes.Timestamp512=c); Check(RecRes.JSON=StringToUTF8(Rec1.FileExtension)); CheckSame(n1,n2); Rec1.FileExtension := ''; // to avoid memory leak end; n1 := 0; RecRes := I.ComplexCall(Ints,nil,Str2,Rec1,Rec2,n1,n2); Check(length(Str2)=5); Check(Str2[0]='ABC'); Check(Str2[1]='DEF'); Check(Str2[2]='GHIJK'); Check(Str2[3]='one,two,three'); Check(Str2[4]=''); s := StringToUTF8(StringOfChar(#1,100)); check(I.DirectCall(s)=100); s := StringToUTF8(StringOfChar('-',600)); t := length(I.RepeatJsonArray(s, 100)); checkutf8(t = 1 + 100 * 603, 'RawJSON %', [KB(t)]); t := length(I.RepeatTextArray(s, 100)); checkutf8(t = 100 * 600, 'RawUTF8 %', [KB(t)]); end; var s: RawUTF8; {$ifndef LVCL} data: TCustomerData; people: TSQLRecordPeople; cust: TServiceCustomAnswer; c: cardinal; n1,n2: double; C1,C2,C3: TComplexNumber; Item: TCollTest; List,Copy: TCollTestsI; j: integer; x,y: PtrUInt; // TThreadID = ^TThreadRec under BSD {$endif} {$ifndef NOVARIANTS} V1,V2,V3: variant; {$endif} {$ifdef UNICODE} Nav: TConsultaNav; {$endif} begin Check(Inst.I.Add(1,2)=3); Check(Inst.I.Multiply($1111333,$222266667)=$24693E8DB170B85); Check(Inst.I.StackIntMultiply(1,2,3,4,5,6,7,8,9,10)=3628800); Check(Inst.I.StackFloatMultiply(1,2,3,4,5,6,7,8,9,10)=3628800); CheckSame(Inst.I.Subtract(23,20),3); Inst.I.ToText(3.14,s); Check(s='3.14'); Check(Inst.I.ToTextFunc(777)='777'); x := Inst.CT.GetCurrentThreadID; if GlobalInterfaceTestMode<>itmHttp then begin y := Inst.CT.GetThreadIDAtCreation; Check(x=y); end; case GlobalInterfaceTestMode of itmMainThread: Check(Inst.CC.GetCurrentThreadID=PtrUInt(MainThreadID)); itmPerInterfaceThread,itmLocked: Check(Inst.CC.GetCurrentThreadID<>PtrUInt(MainThreadID)); end; TestCalculator(Inst.I); TestCalculator(Inst.CC); // test the fact that CC inherits from ICalculator {$ifndef LVCL} /// in LVCL, TPersistent doesn't have any RTTI information C3 := TComplexNumber.Create(0,0); C1 := TComplexNumber.Create(2,3); C2 := TComplexNumber.Create(20,30); List := TCollTestsI.Create; Copy := TCollTestsI.Create; Item := TCollTest.Create(nil); try Check(Inst.CC.IsNull(C3)); for c := 0 to Iterations do begin Check(not Inst.CC.IsNull(C1)); C3.Imaginary := 0; Inst.CC.Substract(C1,C2,C3); CheckSame(C3.Real,c-18.0); CheckSame(C3.Imaginary,-27); cust := Inst.CC.TestBlob(C3); Check(PosEx(TEXT_CONTENT_TYPE_HEADER,cust.Header)>0); Check(cust.Content=FormatUTF8('%,%',[C3.Real,C3.Imaginary])); {$ifndef NOVARIANTS} V1 := C3.Real; V2 := c; case c mod 3 of 0: s := DoubleToStr(C3.Real); 1: s := Int32ToUtf8(c); 2: s := QuotedStr(Int32ToUtf8(c),'"'); end; V3 := Inst.CC.TestVariants(s,V1,V2); CheckSame(V1,C3.Real); CheckSame(V2,C3.Real+c); Check(VariantSaveJSON(V3)=s); {$endif} Check(Inst.CC.GetCustomer(c,data)); Check(data.Id=integer(c)); Check(GetCardinal(pointer(data.AccountNum))=c); people := TSQLRecordPeople.Create; try people.fID := c; Inst.CC.FillPeople(people); Check(people.ID=c); Check(people.LastName=FormatUTF8('Last %',[c])); Check(people.FirstName=FormatUTF8('First %',[c])); finally people.Free; end; {$ifdef UNICODE} Nav.MaxRows := c; Nav.Row0 := c*2; Nav.RowCount := c*3; Nav.IsSQLUpdateBack := c and 1=0; Nav.EOF := c and 1=1; with Inst.CC.EchoRecord(Nav) do begin Check(MaxRows=c); Check(Row0=c*2); Check(RowCount=c*3); Check(IsSQLUpdateBack=(c and 1=0)); Check(EOF=(c and 1=1)); end; {$endif} if c mod 10=1 then begin Item.Color := Item.Color+1; Item.Length := Item.Color*2; Item.Name := Int32ToUtf8(Item.Color); Inst.CC.Collections(Item,List,Copy); end; if not CheckFailed(List.Count=Item.Color) or not CheckFailed(Copy.Count=List.Count) then for j := 0 to List.Count-1 do begin with TCollTest(List.Items[j]) do begin Check(Color=j+1); Check(Length=Color*2); Check(GetInteger(pointer(Name))=Color); end; with TCollTest(Copy.Items[j]) do begin Check(Color=j+1); Check(Length=Color*2); Check(GetInteger(pointer(Name))=Color); end; end; C1.Real := C1.Real+1; end; C3.Real := maxInt; // magic value for huge content cust := Inst.CC.TestBlob(C3); j := length(cust.Content); checkutf8(j = 600, 'TestBlob len=%', [j]); finally C3.Free; C1.Free; C2.Free; Item.Free; List.Free; Copy.Free; end; n2 := Inst.CN.Imaginary; for c := 0 to Iterations shr 2 do begin CheckSame(Inst.CN.Imaginary,n2,1E-9); n1 := Random*1000; Inst.CN.Real := n1; CheckSame(Inst.CN.Real,n1); CheckSame(Inst.CN.Imaginary,n2,1E-9); n2 := Random*1000; Inst.CN.Imaginary := n2; CheckSame(Inst.CN.Real,n1); CheckSame(Inst.CN.Imaginary,n2,1E-9); Inst.CN.Add(1,2); CheckSame(Inst.CN.Real,n1+1,1E-9); n2 := n2+2; CheckSame(Inst.CN.Imaginary,n2,1E-9); end; {$endif} Inst.CN.Assign(3.14,1.05946); CheckSame(Inst.CN.Real,3.14); CheckSame(Inst.CN.Imaginary,1.05946); Check(Inst.CU.GetContextSessionID=Inst.ExpectedSessionID); Check(Inst.CG.GetContextSessionGroup=Inst.ExpectedGroupID); Check(Inst.CS.GetContextSessionUser=Inst.ExpectedUserID); x := Inst.CT.GetCurrentThreadID; y := Inst.CT.GetThreadIDAtCreation; case GlobalInterfaceTestMode of itmDirect: begin Check(x=y); Check(Inst.CT.GetCurrentRunningThreadID=0); Check(Inst.CT.GetContextServiceInstanceID=0); end; itmClient, itmPerInterfaceThread: begin Check(x=y); Check(Inst.CT.GetCurrentRunningThreadID=0); Check(Inst.CT.GetContextServiceInstanceID<>0); end; itmLocked, itmMainThread: begin Check(x=y); Check(Inst.CT.GetCurrentRunningThreadID<>0); Check(Inst.CT.GetContextServiceInstanceID<>0); end; itmHttp: begin Check(Inst.CT.GetCurrentRunningThreadID<>0); Check(Inst.CT.GetCurrentThreadID<>PtrUInt(MainThreadID)); Check(Inst.CT.GetContextServiceInstanceID<>0); end; end; end; procedure TTestServiceOrientedArchitecture.SetOptions(aAsJSONObject: boolean; aOptions: TServiceMethodOptions); var s: integer; begin with fClient.Server.Services do for s := 0 to Count-1 do with Index(s) as TServiceFactoryServer do begin ResultAsJSONObject := aAsJSONObject; if InterfaceTypeInfo<>TypeInfo(ITestPerThread) then SetOptions([],aOptions); end; end; procedure TTestServiceOrientedArchitecture.ClientTest(aRouting: TSQLRestServerURIContextClass; aAsJSONObject: boolean; {$ifndef LVCL}aRunInOtherThread: boolean;{$endif} aOptions: TServiceMethodOptions); var Inst: TTestServiceInstances; O: TObject; sign: RawUTF8; stat: TSynMonitorInputOutput; begin FillCharFast(Inst,sizeof(Inst),0); GlobalInterfaceTestMode := itmClient; {$ifndef LVCL} if aRunInOtherThread then if optExecLockedPerInterface in aOptions then GlobalInterfaceTestMode := itmLocked else if optExecInMainThread in aOptions then GlobalInterfaceTestMode := itmMainThread else if optExecInPerInterfaceThread in aOptions then GlobalInterfaceTestMode := itmPerInterfaceThread; {$endif} (fClient.Services['Calculator'] as TServiceFactoryClient). ParamsAsJSONObject := aAsJSONObject; SetOptions(aAsJSONObject,aOptions); fClient.Server.ServicesRouting := aRouting; fClient.ServicesRouting := aRouting; (fClient.Server.Services as TServiceContainerServer).PublishSignature := true; sign := fClient.Services['Calculator'].RetrieveSignature; Check(sign=fClient.Server.Services['Calculator'].RetrieveSignature); (fClient.Server.Services as TServiceContainerServer).PublishSignature := false; Check(fClient.Services['Calculator'].RetrieveSignature=''); // once registered, can be accessed by its GUID or URI if CheckFailed(fClient.Services.Info(TypeInfo(ICalculator)).Get(Inst.I)) or CheckFailed(fClient.Services.Info(TypeInfo(IComplexCalculator)).Get(Inst.CC)) or CheckFailed(fClient.Services.Info(TypeInfo(IComplexNumber)).Get(Inst.CN)) or CheckFailed(fClient.Services.Info(TypeInfo(ITestUser)).Get(Inst.CU)) or CheckFailed(fClient.Services.Info(TypeInfo(ITestSession)).Get(Inst.CS)) or CheckFailed(fClient.Services.Info(TypeInfo(ITestGroup)).Get(Inst.CG)) or CheckFailed(fClient.Services.Info(TypeInfo(ITestPerThread)).Get(Inst.CT)) then exit; O := ObjectFromInterface(Inst.I); Check((O<>nil) and (copy(O.ClassName,1,21)='TInterfacedObjectFake')); Inst.ExpectedSessionID := fClient.SessionID; if CheckFailed(fClient.SessionUser<>nil) then exit; fClient.Retrieve('LogonName=?',[],[fClient.SessionUser.LogonName],fClient.SessionUser); Inst.ExpectedUserID := fClient.SessionUser.ID; Inst.ExpectedGroupID := fClient.SessionUser.GroupRights.ID; Test(Inst); Inst.I := nil; if CheckFailed(fClient.Services.Info(ICalculator).Get(Inst.I)) then exit; Test(Inst); Inst.I := nil; if CheckFailed(fClient.Services.Resolve(ICalculator,Inst.I)) then exit; Test(Inst); Finalize(Inst); if CheckFailed(fClient.Services['Calculator'].Get(Inst.I)) or CheckFailed(fClient.Services['ComplexCalculator'].Get(Inst.CC)) or CheckFailed(fClient.Services['ComplexNumber'].Get(Inst.CN)) {$ifdef ISDELPHI2010} then exit; Inst.CU := fClient.Service; if CheckFailed(Inst.CU<>nil) then exit; Inst.CS := fClient.Service; if CheckFailed(Inst.CS<>nil) then exit; Inst.CG := fClient.Service; if CheckFailed(Inst.CG<>nil) then exit; Inst.CT := fClient.Service; if CheckFailed(Inst.CT<>nil) then exit; {$else} or CheckFailed(fClient.Services['TestUser'].Get(Inst.CU)) or CheckFailed(fClient.Services['TestSession'].Get(Inst.CS)) or CheckFailed(fClient.Services['TestGroup'].Get(Inst.CG)) or CheckFailed(fClient.Services['testperthread'].Get(Inst.CT)) then exit; {$endif} {$ifndef CPUARM} // The FPC arm optimizer ruins a return address at level -O2 // So, disable this test until a suitable fix is found. Inst.CN.Imaginary; {$endif} Test(Inst); SetOptions(false,[]); stat := (fClient.Server.Services['Calculator'] as TServiceFactoryServer).Stat['ToText']; Check(stat.TaskCount>0); end; procedure TTestServiceOrientedArchitecture.DirectCall; var Inst: TTestServiceInstances; begin FillCharFast(Inst,sizeof(Inst),0); // all Expected..ID=0 Inst.I := TServiceCalculator.Create; Inst.CC := TServiceComplexCalculator.Create; Inst.CN := TServiceComplexNumber.Create; Inst.CS := TServiceUserGroupSession.Create; Inst.CG := TServiceUserGroupSession.Create; Inst.CU := TServiceUserGroupSession.Create; Inst.CT := TServicePerThread.Create; Test(Inst); Test(Inst); Test(Inst); end; procedure TTestServiceOrientedArchitecture.ServerSide; var Inst: TTestServiceInstances; begin FillCharFast(Inst,sizeof(Inst),0); // all Expected..ID=0 if CheckFailed(fModel<>nil) or CheckFailed(fClient<>nil) or CheckFailed(fClient.Server.Services.Count=7) or CheckFailed(fClient.Server.Services.Index(0).Get(Inst.I)) or CheckFailed(Assigned(Inst.I)) or CheckFailed(fClient.Server.Services.Info(TypeInfo(ICalculator)).Get(Inst.I)) or CheckFailed(fClient.Server.Services.Info(TypeInfo(IComplexCalculator)).Get(Inst.CC)) or CheckFailed(fClient.Server.Services.Info(TypeInfo(IComplexNumber)).Get(Inst.CN)) or CheckFailed(fClient.Server.Services.Info(TypeInfo(ITestUser)).Get(Inst.CU)) or CheckFailed(fClient.Server.Services.Info(TypeInfo(ITestSession)).Get(Inst.CS)) or CheckFailed(fClient.Server.Services.Info(TypeInfo(ITestGroup)).Get(Inst.CG)) or CheckFailed(fClient.Server.Services.Info(TypeInfo(ITestPerThread)).Get(Inst.CT)) then exit; Test(Inst); Finalize(Inst); Check(Inst.I=nil); if CheckFailed(fClient.Server.Services['Calculator'].Get(Inst.I)) or CheckFailed(fClient.Server.Services['ComplexCalculator'].Get(Inst.CC)) or CheckFailed(fClient.Server.Services['ComplexNumber'].Get(Inst.CN)) {$ifdef ISDELPHI2010} then exit; Inst.CU := fClient.Server.Service; if CheckFailed(Inst.CU<>nil) then exit; Inst.CS := fClient.Server.Service; if CheckFailed(Inst.CS<>nil) then exit; Inst.CG := fClient.Server.Service; if CheckFailed(Inst.CG<>nil) then exit; Inst.CT := fClient.Server.Service; if CheckFailed(Inst.CT<>nil) then exit; {$else} or CheckFailed(fClient.Server.Services['TestUser'].Get(Inst.CU)) or CheckFailed(fClient.Server.Services['TestSession'].Get(Inst.CS)) or CheckFailed(fClient.Server.Services['TestGroup'].Get(Inst.CG)) or CheckFailed(fClient.Server.Services['TestPerThread'].Get(Inst.CT)) then exit; {$endif} Test(Inst); Test(Inst); end; procedure TTestServiceOrientedArchitecture.ServiceInitialization; function Ask(Method, Params,ParamsURI,ParamsObj: RawUTF8; ExpectedResult: cardinal): RawUTF8; var resp,data,uriencoded,head: RawUTF8; begin Params := ' [ '+Params+' ]'; // add some ' ' to test real-world values uriencoded := '?'+UrlEncode(Params); if fClient.Server.ServicesRouting=TSQLRestRoutingREST then begin SetString(data,PAnsiChar(pointer(Params)),length(Params)); // =UniqueString Check(fClient.URI('root/calculator.'+Method,'POST',@resp,nil,@data).Lo=ExpectedResult); if ExpectedResult=200 then begin Check(fClient.URI('root/CALCulator.'+Method+uriencoded,'POST',@data).Lo=ExpectedResult); Check(data=resp,'alternative URI-encoded-inlined parameters use'); Check(fClient.URI('root/Calculator.'+Method+'?'+ParamsURI,'GET',@data).Lo=ExpectedResult); Check(data=resp,'alternative "param1=value1¶m2=value2" URI-encoded scheme'); Check(fClient.URI('root/Calculator.'+Method+'/1234?'+ParamsURI,'GET',@data).Lo=ExpectedResult); Check(data=resp,'alternative URI-encoded scheme with ClientDrivenID'); SetString(data,PAnsiChar(pointer(Params)),length(Params)); // =UniqueString Check(fClient.URI('root/calculator/'+Method,'POST',@data,nil,@data).Lo=ExpectedResult); Check(data=resp,'interface/method routing'); SetString(data,PAnsiChar(pointer(Params)),length(Params)); // =UniqueString Check(fClient.URI('root/calculator/'+Method+'/123','POST',@data,nil,@Params).Lo=ExpectedResult); Check(data=resp,'interface/method/clientdrivenID routing'); Check(fClient.URI('root/CALCulator/'+Method+uriencoded,'POST',@data).Lo=ExpectedResult); Check(data=resp,'alternative URI-encoded-inlined parameters use'); Check(fClient.URI('root/Calculator/'+Method+'?'+ParamsURI,'GET',@data).Lo=ExpectedResult); Check(data=resp,'alternative "param1=value1¶m2=value2" URI-encoded scheme'); SetString(data,PAnsiChar(pointer(ParamsObj)),length(ParamsObj)); // =UniqueString Check(fClient.URI('root/calculator/'+Method,'POST',@data,nil,@data).Lo=ExpectedResult); Check(data=resp,'alternative object-encoded-as-body parameters use'); head := 'accept: application/xml'; Check(fClient.URI('root/Calculator/'+Method+'?'+ParamsURI,'GET',@data,@head).Lo=ExpectedResult); Check(data<>resp,'returned as XML'); check(head=XML_CONTENT_TYPE_HEADER); Check(IdemPChar(pointer(data),''') and (result[1]='"') then result := UnQuoteSQLString(result); // '"777"' -> '777' if (ExpectedResult=200) and (fClient.Server.ServicesRouting=TSQLRestRoutingREST) then begin resp := XMLUTF8_HEADER+''+result+''; check(data=resp); end; end; var S: TServiceFactory; i: integer; rout: integer; resp: RawUTF8; const ROUTING: array[0..1] of TSQLRestServerURIContextClass = (TSQLRestRoutingREST,TSQLRestRoutingJSON_RPC); const ExpectedURI: array[0..5] of RawUTF8 = ('Add','Multiply','Subtract','ToText','ToTextFunc','Swap'); ExpectedParCount: array[0..5] of Integer = (4,4,4,3,3,3); ExpectedArgs: array[0..5] of TServiceMethodValueTypes = ([smvSelf,smvInteger],[smvSelf,smvInt64],[smvSelf,smvDouble], [smvSelf,smvCurrency,smvRawUTF8],[smvSelf,smvDouble,smvString], [smvSelf,smvDouble]); ExpectedTypes: array[0..4] of String[10] = ('Integer','Int64','Double','Currency','Double'); ExpectedType: array[0..5] of TServiceMethodValueType = (smvInteger,smvInt64,smvDouble,smvCurrency,smvDouble,smvDouble); ExpectedResult: array[0..2] of String[10] = ('Integer','Int64','Double'); begin if CheckFailed(fModel=nil) then exit; // should be called once // create model, client and server fModel := TSQLModel.Create([TSQLRecordPeople,TSQLAuthUser,TSQLAuthGroup]); fClient := TSQLRestClientDB.Create(fModel,nil,'test.db3',TSQLRestServerDB,true); Check(fClient.SetUser('User','synopse'),'default user for Security tests'); Check(fClient.Server. ServiceRegister(TServiceCalculator,[TypeInfo(ICalculator)],sicShared)<>nil, 'register TServiceCalculator as the ICalculator implementation on the server'); // verify ICalculator RTTI-generated details Check(fClient.Server.Services<>nil); if CheckFailed(fClient.Server.Services.Count=1) then exit; S := fClient.Server.Services.Index(0); if CheckFailed(S<>nil) then exit; Check(S.InterfaceURI='Calculator'); Check(S.InstanceCreation=sicShared); Check(S.InterfaceTypeInfo^.Kind=tkInterface); Check(S.InterfaceTypeInfo^.Name='ICalculator'); Check(GUIDToString(S.InterfaceIID)='{9A60C8ED-CEB2-4E09-87D4-4A16F496E5FE}'); Check(GUIDToRawUTF8(S.InterfaceIID)='{9A60C8ED-CEB2-4E09-87D4-4A16F496E5FE}'); Check(S.InterfaceMangledURI='7chgmrLOCU6H1EoW9Jbl_g'); fClient.Server.Services.ExpectMangledURI := true; Check(fClient.Server.Services[S.InterfaceMangledURI]=S); fClient.Server.Services.ExpectMangledURI := false; Check(fClient.Server.Services['Calculator']=S); Check(fClient.Server.Services['CALCULAtor']=S); Check(fClient.Server.Services['CALCULAtors']=nil); if CheckFailed(length(S.InterfaceFactory.Methods)=13) then exit; Check(S.ContractHash='"4C65C91D6536270A"'); Check(TServiceCalculator(nil).Test(1,2)='3'); Check(TServiceCalculator(nil).ToTextFunc(777)='777'); for i := 0 to high(ExpectedURI) do // SpecialCall interface not checked with S.InterfaceFactory.Methods[i] do begin Check(URI=ExpectedURI[i]); Check(length(Args)=ExpectedParCount[i]); Check(ArgsUsed=ExpectedArgs[i]); Check(Args[0].ParamName^='Self'); Check(Args[0].ValueDirection=smdConst); Check(Args[0].ValueType=smvSelf); Check(Args[0].ArgTypeName^='ICalculator'); Check(Args[1].ValueType=ExpectedType[i]); if i<3 then begin // 0 function Add(n1,n2: integer): integer; // 1 function Multiply(n1,n2: Int64): Int64; // 2 function Subtract(n1,n2: double): double; Check(Args[1].ParamName^='n1'); Check(Args[1].ValueDirection=smdConst); Check(Args[2].ParamName^='n2'); Check(Args[2].ValueDirection=smdConst); Check(Args[2].ValueType=ExpectedType[i]); Check(IdemPropName(Args[3].ArgTypeName^,ExpectedTypes[i]),string(Args[3].ArgTypeName^)); Check(Args[3].ValueDirection=smdResult); Check(Args[3].ValueType=ExpectedType[i]); end else if i<5 then begin // 3 procedure ToText(Value: Currency; var Result: RawUTF8); // 4 function ToTextFunc(Value: double): string; Check(Args[1].ParamName^='Value'); Check(Args[1].ValueDirection=smdConst); Check(Args[2].ParamName^='Result'); if i<4 then Check(Args[2].ValueDirection=smdVar) else Check(Args[2].ValueDirection=smdResult); if i<4 then Check(Args[2].ValueType=smvRawUTF8) else Check(Args[2].ValueType=smvString); end else begin // 5 procedure Swap(var n1,n2: double); Check(Args[1].ParamName^='n1'); Check(Args[1].ValueDirection=smdVar); Check(Args[2].ParamName^='n2'); Check(Args[2].ValueDirection=smdVar); end; end; // IComplexCalculator + IComplexNumber services Check(fClient.Server.ServiceRegister(TServiceComplexCalculator,[TypeInfo(IComplexCalculator)],sicSingle)<>nil); Check(fClient.Server.ServiceRegister(TServiceComplexNumber,[TypeInfo(IComplexNumber)],sicClientDriven)<>nil); Check(fClient.Server.ServiceRegister(TServiceUserGroupSession,[TypeInfo(ITestSession)],sicPerSession)<>nil); Check(fClient.Server.ServiceRegister(TServiceUserGroupSession,[TypeInfo(ITestUser)],sicPerUser)<>nil); Check(fClient.Server.ServiceRegister(TServiceUserGroupSession,[TypeInfo(ITestGroup)],sicPerGroup)<>nil); Check(fClient.Server.ServiceRegister(TServicePerThread,[TypeInfo(ITestPerThread)],sicPerThread)<>nil); // JSON-level access for rout := low(ROUTING) to high(ROUTING) do begin fClient.ServicesRouting := ROUTING[rout]; fClient.Server.ServicesRouting := ROUTING[rout]; if rout=0 then (fClient.Server.Services['Calculator'] as TServiceFactoryServer). ResultAsXMLObjectIfAcceptOnlyXML := true; Check(Ask('None','1,2','one=1&two=2','{one:1,two=2}',400)=''); Check(Ask('Add','1,2','n1=1&n2=2','{n1:1,n2:2}',200)='3'); Check(Ask('Add','1,0','n2=1','{n2:1}',200)='1'); Check(Ask('Multiply','2,3','n1=2&n2=3','{n0:"abc",n2:3,m:null,n1:2}',200)='6'); Check(Ask('Subtract','23,20','n2=20&n1=23','{n0:"abc",n2:20,n1:23}',200)='3'); Check(Ask('ToText','777,"abc"','result=abc&value=777','{result:"abc",value=777}',200)='777'); Check(Ask('ToTextFunc','777','value=777','{result:"abc",value=777}',200)='777'); if rout=0 then Check(fClient.URI('root/ComplexCalculator.GetCustomer?CustomerId=John%20Doe', 'POST',@resp,nil,nil).Lo=406,'incorrect input'); end; fClient.ServicesRouting := TSQLRestRoutingREST; // back to default fClient.Server.ServicesRouting := TSQLRestRoutingREST; end; procedure TTestServiceOrientedArchitecture.Security; procedure Test(Expected: TSQLFieldTables; const msg: string); function Ask(const Method, Params: RawUTF8): RawUTF8; var resp,data: RawUTF8; begin data := '{"method":"'+Method+'", "params": [ '+Params+' ]}'; fClient.URI('root/calculator','POST',@resp,nil,@data); result := JSONDecode(resp,'result',nil,true); end; begin Check((Ask('None','1,2')=''),msg); CheckMatchAny(Ask('Add','1,2'),['[3]','{"Result":3}'],true,(1 in Expected),msg); CheckMatchAny(Ask('Multiply','2,3'),['[6]','{"Result":6}'],true,(2 in Expected),msg); CheckMatchAny(Ask('Subtract','23,20'),['[3]','{"Result":3}'],true,(3 in Expected),msg); CheckMatchAny(Ask('ToText','777,"abc"'),['["777"]','{"Result":"777"}'],true,(4 in Expected),msg); CheckMatchAny(Ask('ToTextFunc','777'),['["777"]','{"Result":"777"}'],true,(5 in Expected),msg); end; var S: TServiceFactoryServer; GroupID: TID; g: TIDDynArray; begin fClient.ServicesRouting := TSQLRestRoutingJSON_RPC; fClient.Server.ServicesRouting := TSQLRestRoutingJSON_RPC; GroupID := fClient.MainFieldID(TSQLAuthGroup,'User'); Check(GroupID<>0); Check(fClient.MainFieldIDs(TSQLAuthGroup,['User','Admin'],g)); Check(length(g)=2); Check((g[0]=GroupID) or (g[1]=GroupID)); S := fClient.Server.Services['Calculator'] as TServiceFactoryServer; Test([1,2,3,4,5],'by default, all methods are allowed'); S.AllowAll; Test([1,2,3,4,5],'AllowAll should change nothing'); S.DenyAll; Test([],'DenyAll will reset all settings'); S.AllowAll; Test([1,2,3,4,5],'back to full acccess for everybody'); S.DenyAllByID([GroupID]); Test([],'our current user shall be denied'); S.AllowAll; Test([1,2,3,4,5],'restore allowed for everybody'); S.DenyAllByID([GroupID+1]); Test([1,2,3,4,5],'this group ID won''t affect the current user'); S.DenyByID(['Add'],[GroupID]); Test([2,3,4,5],'exclude a specific method for the current user'); S.DenyByID(['totext'],[GroupID]); Test([2,3,5],'exclude another method for the current user'); S.AllowByID(['Add'],[GroupID+1]); Test([2,3,5],'this group ID won''t affect the current user'); S.AllowByID(['Add'],[GroupID]); Test([1,2,3,5],'allow a specific method for the current user'); S.AllowAllByID([0]); Test([1,2,3,5],'invalid group ID won''t affect the current user'); S.AllowAllByID([GroupID]); Test([1,2,3,4,5],'restore allowed for the current user'); Check(not fClient.SetUser('unknown','wrongpass')); Test([],'no authentication -> access denied'); Check(fClient.SetUser('Admin','synopse')); Test([1,2,3,4,5],'authenticated user'); S.DenyAll; Test([],'DenyAll works even for admins'); S.AllowAll; Test([1,2,3,4,5],'restore allowed for everybody'); S.AllowAllByName(['Supervisor']); Test([1,2,3,4,5],'this group name won''t affect the current Admin user'); S.DenyAllByName(['Supervisor']); Test([1,2,3,4,5],'this group name won''t affect the current Admin user'); S.DenyAllByName(['Supervisor','Admin']); Test([],'Admin group user was explicitely denied access'); S.AllowAllByName(['Admin']); Test([1,2,3,4,5],'restore allowed for current Admin user'); S.AllowAll; Check(fClient.SetUser('User','synopse')); Test([1,2,3,4,5],'restore allowed for everybody'); end; procedure TTestServiceOrientedArchitecture.ClientSideREST; begin Check(fClient.ServiceRegister([TypeInfo(ICalculator)],sicShared)); Check(fClient.ServiceRegister([TypeInfo(IComplexCalculator)],sicSingle)); Check(fClient.ServiceRegister([TypeInfo(ITestSession)],sicPerSession)); Check(fClient.ServiceRegister([TypeInfo(ITestUser)],sicPerUser)); Check(fClient.ServiceRegister([TypeInfo(ITestGroup)],sicPerGroup)); Check(fClient.ServiceRegister([TypeInfo(ITestPerThread)],sicPerThread)); ClientTest(TSQLRestRoutingREST,false); end; procedure TTestServiceOrientedArchitecture.ClientSideRESTServiceLogToDB; var Log: TSQLRestServerDB; begin {$ifdef Darwin} {$ifdef NOSQLITE3STATIC} // due to a very strange error during prepare_v2, this does not (yet) work on Darwin. // at least on Darwin with system sqlite 3.7.13 // however, mORMots own static works perfect Check(1=0,'Not (yet) supported on Darwin !!'); exit; {$endif} {$endif} DeleteFile('servicelog.db'); Log := TSQLRestServerDB.CreateWithOwnModel([TSQLRecordServiceLog],'servicelog.db'); try Log.DB.Synchronous := smOff; Log.DB.LockingMode := lmExclusive; Log.CreateMissingTables; (fClient.Server.ServiceContainer as TServiceContainerServer).SetServiceLog(Log); ClientTest(TSQLRestRoutingREST,false); finally (fClient.Server.ServiceContainer as TServiceContainerServer).SetServiceLog(nil); Log.Free; end; end; procedure TTestServiceOrientedArchitecture.ClientSideRESTSessionsStats; var stats: RawUTF8; store: TSQLRestServerDB; begin fClient.Server.StatLevels := SERVERDEFAULTMONITORLEVELS+[mlSessions]; store := TSQLRestServerDB.CreateWithOwnModel([TSQLMonitorUsage],'servicestats.db3'); try store.DB.Synchronous := smOff; store.DB.LockingMode := lmExclusive; store.CreateMissingTables; fClient.Server.StatUsage := TSynMonitorUsageRest.Create(store,1); ClientTest(TSQLRestRoutingREST,false); fClient.CallBackGet('stat',['withall',true],stats); JSONReformatToFile(stats,'statsSessions.json'); fClient.Server.StatLevels := SERVERDEFAULTMONITORLEVELS; fClient.Server.StatUsage := nil; finally store.Free; end; end; procedure TTestServiceOrientedArchitecture.ClientSideJSONRPC; begin ClientTest(TSQLRestRoutingJSON_RPC,false); end; procedure TTestServiceOrientedArchitecture.ClientSideRESTAsJSONObject; begin ClientTest(TSQLRestRoutingREST,true); end; procedure TTestServiceOrientedArchitecture.TestOverHTTP; var HTTPServer: TSQLHttpServer; HTTPClient: TSQLHttpClient; Inst: TTestServiceInstances; json: RawUTF8; i: integer; URI: TSQLRestServerURIDynArray; const SERVICES: array[0..4] of RawUTF8 = ( 'Calculator','ComplexCalculator','TestUser','TestGroup','TestPerThread'); begin fClient.Server.ServicesRouting := TSQLRestRoutingREST; // back to default GlobalInterfaceTestMode := itmHttp; HTTPServer := TSQLHttpServer.Create(HTTP_DEFAULTPORT,[fClient.Server],'+', {$ifdef ONLYUSEHTTPSOCKET}useHttpSocket{$else}useHttpApiRegisteringURI{$endif}, 8,secNone); try FillCharFast(Inst,sizeof(Inst),0); // all Expected..ID=0 HTTPClient := TSQLHttpClient.Create('127.0.0.1',HTTP_DEFAULTPORT,fModel); try HTTPClient.ServicePublishOwnInterfaces(fClient.Server); //HTTPClient.OnIdle := TLoginForm.OnIdleProcess; // from mORMotUILogin // HTTPClient.Compression := [hcSynShaAes]; // 350ms (300ms for []) Check(HTTPClient.SetUser('User','synopse')); // register services on the client side Check(HTTPClient.ServiceRegister([TypeInfo(ICalculator)],sicShared)); Check(HTTPClient.ServiceRegister([TypeInfo(IComplexCalculator)],sicSingle)); Check(HTTPClient.ServiceRegister([TypeInfo(ITestSession)],sicPerSession)); Check(HTTPClient.ServiceRegister([TypeInfo(ITestUser)],sicPerUser)); Check(HTTPClient.ServiceRegister([TypeInfo(ITestGroup)],sicPerGroup)); Check(HTTPClient.ServiceRegister([TypeInfo(ITestPerThread)],sicPerThread)); // retrieve service instances if CheckFailed(HTTPClient.Services.Info(TypeInfo(ICalculator)).Get(Inst.I)) or CheckFailed(HTTPClient.Services.Info(TypeInfo(IComplexCalculator)).Get(Inst.CC)) or CheckFailed(HTTPClient.Services.Info(TypeInfo(IComplexNumber)).Get(Inst.CN)) or CheckFailed(HTTPClient.Services.Info(TypeInfo(ITestUser)).Get(Inst.CU)) or CheckFailed(HTTPClient.Services.Info(TypeInfo(ITestSession)).Get(Inst.CS)) or CheckFailed(HTTPClient.Services.Info(TypeInfo(ITestGroup)).Get(Inst.CG)) or CheckFailed(HTTPClient.Services.Info(TypeInfo(ITestPerThread)).Get(Inst.CT)) then exit; Inst.ExpectedSessionID := HTTPClient.SessionID; HTTPClient.Retrieve('LogonName=?',[],[HTTPClient.SessionUser.LogonName],HTTPClient.SessionUser); Inst.ExpectedUserID := HTTPClient.SessionUser.ID; Inst.ExpectedGroupID := HTTPClient.SessionUser.GroupRights.ID; //SetOptions(false{$ifndef LVCL},true,[optExecInMainThread]{$endif}); Check(HTTPClient.CallBackGet('stat',['findservice','toto'],json)=HTTP_SUCCESS); Check(json='[]'); for i := 0 to High(SERVICES) do begin Check(HTTPClient.CallBackGet('stat',['findservice',SERVICES[i]],json)=HTTP_SUCCESS); Check(json<>'[]'); Check(HTTPClient.ServiceRetrieveAssociated(SERVICES[i],URI)); Check(length(URI)=1); Check(URI[0].Port=HTTP_DEFAULTPORT); Check(URI[0].Root=fClient.Model.Root); end; Check(HTTPClient.ServiceRetrieveAssociated(IComplexNumber,URI)); Check(length(URI)=1); Check(HTTPClient.ServiceRetrieveAssociated(ITestSession,URI)); Check(length(URI)=1); Test(Inst,100); //SetOptions(false{$ifndef LVCL},true,[]{$endif}); finally Finalize(Inst); HTTPClient.Free; end; finally HTTPServer.Free; GlobalInterfaceTestMode := itmClient; end; end; procedure TTestServiceOrientedArchitecture.ClientAlgo( algo: TSQLRestServerAuthenticationSignedURIAlgo); begin (fClient.Server.AuthenticationRegister(TSQLRestServerAuthenticationDefault) as TSQLRestServerAuthenticationDefault).Algorithm := algo; fClient.SetUser('User','synopse'); ClientTest(TSQLRestRoutingREST,false); end; procedure TTestServiceOrientedArchitecture.ClientSideRESTSignWithCRC32C; begin ClientAlgo(suaCRC32C) end; procedure TTestServiceOrientedArchitecture.ClientSideRESTSignWithXXHASH; begin ClientAlgo(suaXXHASH); end; procedure TTestServiceOrientedArchitecture.ClientSideRESTSignWithMD5; begin ClientAlgo(suaMD5); end; procedure TTestServiceOrientedArchitecture.ClientSideRESTSignWithSHA256; begin ClientAlgo(suaSHA256); end; procedure TTestServiceOrientedArchitecture.ClientSideRESTSignWithSHA512; begin ClientAlgo(suaSHA512); (fClient.Server.AuthenticationRegister(TSQLRestServerAuthenticationDefault) as TSQLRestServerAuthenticationDefault).Algorithm := suaCRC32; end; procedure TTestServiceOrientedArchitecture.ClientSideRESTWeakAuthentication; begin fClient.Server.ServicesRouting := TSQLRestRoutingJSON_RPC; // back to previous fClient.Server.AuthenticationUnregister( [{$ifdef MSWINDOWS}TSQLRestServerAuthenticationSSPI,{$endif} TSQLRestServerAuthenticationDefault]); fClient.Server.AuthenticationRegister(TSQLRestServerAuthenticationNone); TSQLRestServerAuthenticationNone.ClientSetUser(fClient,'User',''); ClientTest(TSQLRestRoutingREST,false); fClient.Server.AuthenticationUnregister(TSQLRestServerAuthenticationNone); end; procedure TTestServiceOrientedArchitecture.ClientSideRESTBasicAuthentication; begin fClient.SessionClose; fClient.Server.AuthenticationRegister(TSQLRestServerAuthenticationHttpBasic); TSQLRestServerAuthenticationHttpBasic.ClientSetUser(fClient,'User','synopse'); ClientTest(TSQLRestRoutingREST,false); fClient.Server.AuthenticationUnregister(TSQLRestServerAuthenticationHttpBasic); // restore default authentications fClient.Server.AuthenticationRegister( [{$ifdef MSWINDOWS}TSQLRestServerAuthenticationSSPI,{$endif} TSQLRestServerAuthenticationDefault]); fClient.SetUser('User','synopse'); end; procedure TTestServiceOrientedArchitecture.ClientSideRESTCustomRecordLayout; begin TTextWriter.RegisterCustomJSONSerializer(TypeInfo(TSQLRestCacheEntryValue), TTestServiceOrientedArchitecture.CustomReader, TTestServiceOrientedArchitecture.CustomWriter); try ClientTest(TSQLRestRoutingREST,false); finally TTextWriter.RegisterCustomJSONSerializer(TypeInfo(TSQLRestCacheEntryValue),nil,nil); end; end; class function TTestServiceOrientedArchitecture.CustomReader(P: PUTF8Char; var aValue; out aValid: Boolean{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; var V: TSQLRestCacheEntryValue absolute aValue; Values: array[0..2] of TValuePUTF8Char; begin // {"ID":1786554763,"Timestamp":323618765,"JSON":"D:\\TestSQL3.exe"} result := JSONDecode(P,['ID','Timestamp','JSON'],@Values); if result=nil then aValid := false else begin V.ID := GetInt64(Values[0].Value); V.Timestamp512 := Values[1].ToCardinal; Values[2].ToUTF8(V.JSON); aValid := true; end; end; class procedure TTestServiceOrientedArchitecture.CustomWriter( const aWriter: TTextWriter; const aValue); var V: TSQLRestCacheEntryValue absolute aValue; begin aWriter.AddJSONEscape(['ID',V.ID,'Timestamp',Int64(V.Timestamp512),'JSON',V.JSON]); end; procedure TTestServiceOrientedArchitecture.Cleanup; var stats: RawUTF8; begin if fClient<>nil then begin fClient.CallBackGet('stat',['withtables',true,'withsqlite3',true, 'withmethods',true,'withinterfaces',true,'withsessions',true],stats); FileFromString(JSONReformat(stats),'stats.json'); end; FreeAndNil(fClient); FreeAndNil(fModel); end; {$ifndef LVCL} { TTestThread } type TTestThread = class(TThread) protected Options: TServiceMethodOptions; procedure Execute; override; public Test: TTestServiceOrientedArchitecture; end; procedure TTestThread.Execute; begin try Test.fClient.Server.BeginCurrentThread(self); Test.ClientTest(TSQLRestRoutingREST,false,true,Options); Test.fClient.Server.EndCurrentThread(self); finally Test := nil; // mark tests finished end; end; procedure TTestServiceOrientedArchitecture.ClientSideRESTMainThread; begin with TTestThread.Create(true) do try Test := self; Options := [optExecInMainThread,optFreeInMainThread]; {$ifdef ISDELPHI2010} Start; {$else} Resume; {$endif} while Test<>nil do CheckSynchronize{$ifndef DELPHI6OROLDER}(1){$endif}; finally Free; end; fClient.Server.ServicesRouting := TSQLRestRoutingJSON_RPC; // back to previous end; procedure TTestServiceOrientedArchitecture.ClientSideRESTBackgroundThread; begin ClientTest(TSQLRestRoutingREST,false,true, [optExecInPerInterfaceThread,optFreeInPerInterfaceThread]); fClient.Server.ServicesRouting := TSQLRestRoutingJSON_RPC; // back to previous end; {$endif LVCL} procedure TTestServiceOrientedArchitecture.ClientSideRESTLocked; begin {$ifdef LVCL} ClientTest(TSQLRestRoutingREST,false,[optExecLockedPerInterface]); {$else} with TTestThread.Create(true) do try Test := self; Options := [optExecLockedPerInterface]; {$ifdef ISDELPHI2010} Start; {$else} Resume; {$endif} while Test<>nil do CheckSynchronize{$ifndef DELPHI6OROLDER}(1){$endif}; finally Free; end; {$endif} fClient.Server.ServicesRouting := TSQLRestRoutingJSON_RPC; // back to previous end; type IChild = interface; IParent = interface procedure SetChild(const Value: IChild); function GetChild: IChild; function HasChild: boolean; property Child: IChild read GetChild write SetChild; end; IChild = interface procedure SetParent(const Value: IParent); function GetParent: IParent; property Parent: IParent read GetParent write SetParent; end; TParent = class(TInterfacedObject, IParent) private FChild: IChild; procedure SetChild(const Value: IChild); function GetChild: IChild; public destructor Destroy; override; function HasChild: boolean; property Child: IChild read GetChild write SetChild; end; TChild = class(TInterfacedObject, IChild) private FParent: IParent; procedure SetParent(const Value: IParent); function GetParent: IParent; public constructor Create(const AParent: IParent; SetChild: boolean); destructor Destroy; override; property Parent: IParent read GetParent write SetParent; end; TUseWeakRef = (direct,weakref,zeroing); var ParentDestroyed, ChildDestroyed: boolean; UseWeakRef: TUseWeakRef; procedure TTestServiceOrientedArchitecture.WeakInterfaces; var Parent: IParent; Child, Child2: IChild; P: TParent; C: TChild; procedure Init(aWeakRef: TUseWeakRef); begin ParentDestroyed := false; ChildDestroyed := false; UseWeakRef := aWeakRef; Check(Parent=nil); Check(Child=nil); P := TParent.Create; Parent := P; Check(ObjectFromInterface(Parent)=P); C := TChild.Create(Parent,true); Child := C; Check(ObjectFromInterface(Child)=C); Parent.Child := Child; end; procedure WeakTest(aWeakRef: TUseWeakRef); var Child2: IChild; begin Init(aWeakRef); Check(ParentDestroyed=false); Check(ChildDestroyed=false); Child2 := Parent.Child; Child2 := nil; // otherwise memory leak, but it is OK Check(ChildDestroyed=false); Child := nil; Check(ChildDestroyed=true); Check(ParentDestroyed=false); Check(Parent.HasChild=(aWeakRef=weakref),'ZEROed Weak'); Parent := nil; end; begin Init(direct); Parent := nil; Check(ParentDestroyed=false); Check(ChildDestroyed=false); Child := nil; Check(ParentDestroyed=false,'Without weak reference: memory leak'); Check(ChildDestroyed=false); P._Release; Check(ParentDestroyed=true,'Manual release'); Check(ChildDestroyed=true); WeakTest(weakref); Init(zeroing); Check(ParentDestroyed=false); Check(ChildDestroyed=false); Child2 := Parent.Child; Child2 := nil; Check(ChildDestroyed=false); Parent := nil; Check(ParentDestroyed=false); Check(ChildDestroyed=false); Child := nil; Check(ParentDestroyed=true); Check(ChildDestroyed=true); WeakTest(zeroing); Init(zeroing); Check(Parent.HasChild); Child2 := TChild.Create(Parent,false); Check(Parent.HasChild); Parent.Child := Child2; Check(Parent.HasChild); Child2 := nil; Check(not Parent.HasChild); Check(ChildDestroyed=true); ChildDestroyed := false; Check(not Parent.HasChild); Child := nil; Check(ParentDestroyed=false); Check(ChildDestroyed=true); Check(not Parent.HasChild); ChildDestroyed := false; Parent := nil; Check(ParentDestroyed=true); Check(ChildDestroyed=false); end; { TParent } destructor TParent.Destroy; begin ParentDestroyed := true; if UseWeakRef=weakref then SetWeak(@FChild,nil); inherited; end; function TParent.GetChild: IChild; begin result := FChild; end; function TParent.HasChild: boolean; begin result := FChild<>nil; end; procedure TParent.SetChild(const Value: IChild); begin case UseWeakRef of direct: FChild := Value; weakref: SetWeak(@FChild,Value); zeroing: SetWeakZero(self,@FChild,Value); end; end; { TChild } constructor TChild.Create(const AParent: IParent; SetChild: boolean); begin FParent := AParent; if SetChild then FParent.Child := self; end; destructor TChild.Destroy; begin ChildDestroyed := true; inherited; end; function TChild.GetParent: IParent; begin result := FParent; end; procedure TChild.SetParent(const Value: IParent); begin case UseWeakRef of direct: FParent := Value; weakref: SetWeak(@FParent,Value); zeroing: SetWeakZero(self,@FParent,Value); end; end; type TLoginController = class protected fUserRepository: IUserRepository; fSmsSender: ISmsSender; public constructor Create(const aUserRepository: IUserRepository; const aSmsSender: ISmsSender); procedure ForgotMyPassword(const UserName: RawUTF8); end; constructor TLoginController.Create(const aUserRepository: IUserRepository; const aSmsSender: ISmsSender); begin fUserRepository := aUserRepository; fSmsSender := aSmsSender; end; procedure TLoginController.ForgotMyPassword(const UserName: RawUTF8); var U: TUser; begin U := fUserRepository.GetUserByName(UserName); Assert(U.Name=UserName,'internal verification'); U.Password := Int32ToUtf8(Random(MaxInt)); U.MobilePhoneNumber := Int32ToUtf8(Random(MaxInt)); if fSmsSender.Send('Your new password is '+U.Password,U.MobilePhoneNumber) then fUserRepository.Save(U); end; procedure TTestServiceOrientedArchitecture.IntSubtractJSON( Ctxt: TOnInterfaceStubExecuteParamsJSON); var P: PUTF8Char; begin if Ctxt.Sender is TInterfaceMock then Ctxt.TestCase.Check(Ctxt.EventParams='toto'); P := pointer(Ctxt.Params); Ctxt.Returns([GetNextItemDouble(P)-GetNextItemDouble(P)]); // Ctxt.Result := '['+DoubleToStr(GetNextItemDouble(P)-GetNextItemDouble(P))+']'; end; {$ifndef NOVARIANTS} procedure TTestServiceOrientedArchitecture.IntSubtractVariant( Ctxt: TOnInterfaceStubExecuteParamsVariant); begin if Ctxt.Sender is TInterfaceMock then Ctxt.TestCase.Check(Ctxt.EventParams='toto'); Ctxt['result'] := Ctxt['n1']-Ctxt['n2']; // with Ctxt do Output[0] := Input[0]-Input[1]; end; procedure TTestServiceOrientedArchitecture.IntSubtractVariantVoid( Ctxt: TOnInterfaceStubExecuteParamsVariant); begin end; {$endif} procedure TTestServiceOrientedArchitecture.MocksAndStubs; var I: ICalculator; n: integer; UserRepository: IUserRepository; SmsSender: ISmsSender; U: TUser; log, UJSON: RawUTF8; HashGetUserByNameToto: cardinal; Stub: TInterfaceStub; Mock: TInterfaceMockSpy; begin Stub := TInterfaceStub.Create(TypeInfo(ICalculator),I). SetOptions([imoLogMethodCallsAndResults]); Check(I.Add(10,20)=0,'Default result'); log := Stub.LogAsText; Check(log='Add(10,20)=[0]'); I := nil; Stub := TInterfaceStub.Create(TypeInfo(ICalculator),I). Returns('Add','30'). Returns('Multiply',[60]). Returns('Multiply',[2,35],[70]). ExpectsCount('Multiply',qoEqualTo,2). ExpectsCount('Subtract',qoGreaterThan,0). ExpectsCount('ToTextFunc',qoLessThan,2). ExpectsTrace('Add',Hash32('Add(10,30)=[30]')). ExpectsTrace('Multiply','Multiply(10,30)=[60],Multiply(2,35)=[70]'). ExpectsTrace('Multiply',[10,30],'Multiply(10,30)=[60]'). ExpectsTrace('Add(10,30)=[30],Multiply(10,30)=[60],'+ 'Multiply(2,35)=[70],Subtract(2.3,1.2)=[0],ToTextFunc(2.3)=["default"]'). Returns('ToTextFunc',['default']); Check(I.Add(10,30)=30); Check(I.Multiply(10,30)=60); Check(I.Multiply(2,35)=70); Check(I.Subtract(2.3,1.2)=0,'Default result'); Check(I.ToTextFunc(2.3)='default'); Check(Stub.LogHash=$34FA7AAF); I := nil; // release Stub -> will check all expectations TInterfaceMock.Create(TypeInfo(ICalculator),I,self). Returns('Add','30'). Fails('Add',[1,2],'expected failure'). SetOptions([imoMockFailsWillPassTestCase]). // -> Check(true) ExpectsCount('Add',qoEqualTo,3). ExpectsCount('Add',[10,30],qoNotEqualTo,1). Executes('Subtract',IntSubtractJSON,'toto'). Returns('Multiply',[60]). Returns('Multiply',[2,35],[70]). Returns('ToTextFunc',[2.3],['two point three']). Returns('ToTextFunc',['default']); Check(I.ToTextFunc(2.3)='two point three'); Check(I.ToTextFunc(2.4)='default'); Check(I.Add(10,30)=30); n := Assertions; I.Add(1,2); // will launch TInterfaceMock.InternalCheck -> Check(true) n := Assertions-n; // tricky code due to Check() inlined Assertions modif. Check(n=1,'test should have passed'); Check(I.Multiply(10,30)=60); Check(I.Multiply(2,35)=70); for n := 1 to 10000 do CheckSame(I.Subtract(n*10.5,n*0.5),n*10,1E-9); n := Assertions; I := nil; // release TInterfaceMock -> will check all expectations n := Assertions-n; Check(n=2,'Add count<>3'); TInterfaceStub.Create(TypeInfo(ISmsSender),SmsSender). Returns('Send',[true]); U.Name := 'toto'; UJSON := RecordSaveJSON(U,TypeInfo(TUser)); HashGetUserByNameToto := Hash32('GetUserByName("toto")=['+UJSON+']'); Mock := TInterfaceMockSpy.Create(TypeInfo(IUserRepository),UserRepository,self); Mock.Returns('GetUserByName','"toto"',UJSON). ExpectsCount('GetUserByName',qoEqualTo,1). ExpectsCount('GetUserByName',['toto'],qoEqualTo,1). ExpectsCount('GetUserByName','"tata"',qoEqualTo,0). ExpectsTrace('GetUserByName',['toto'],HashGetUserByNameToto). ExpectsTrace('GetUserByName',HashGetUserByNameToto). ExpectsCount('Save',qoEqualTo,1); with TLoginController.Create(UserRepository,SmsSender) do try ForgotMyPassword('toto'); finally Free; end; Mock.Verify('Save'); Mock.Verify('GetUserByName',['toto'],qoEqualTo,1); Mock.Verify('GetUserByName','"toto"',qoNotEqualTo,2); Mock.Verify('GetUserByName',['toto'],'['+UJSON+']'); UserRepository := nil; // will release TInterfaceMock and check Excepts*() SmsSender := nil; {$ifndef NOVARIANTS} TInterfaceStub.Create(IID_ICalculator,I). Executes('Subtract',IntSubtractVariantVoid,'titi'); check(I.Subtract(10,20)=0); {$endif} TInterfaceStub.Create(IID_ICalculator,I).Returns('Subtract',[10,20],[3]). {$ifndef NOVARIANTS} Executes('Subtract',IntSubtractVariant,'toto'). {$endif} Fails('Add','expected exception'). Raises('Add',[1,2],ESynException,'expected exception'); {$ifndef NOVARIANTS} for n := 1 to 10000 do CheckSame(I.Subtract(n*10.5,n*0.5),n*10,1E-9); {$endif} Check(I.Subtract(10,20)=3,'Explicit result'); {$WARN SYMBOL_PLATFORM OFF} {$ifndef KYLIX3} {$ifndef FPC} if DebugHook<>0 then {$endif} {$endif} exit; // avoid exceptions in IDE {$WARN SYMBOL_PLATFORM ON} with TSynLog.Family.ExceptionIgnore do begin Add(EInterfaceFactoryException); Add(ESynException); end; try I.Add(0,0); Check(false); except on E: EInterfaceFactoryException do Check(Pos('TInterfaceStub returned error: expected exception',E.Message)>0,E.Message); end; try I.Add(1,2); Check(false); except on E: ESynException do Check(E.Message='expected exception',E.Message); end; with TSynLog.Family.ExceptionIgnore do begin Delete(IndexOf(EInterfaceFactoryException)); Delete(IndexOf(ESynException)); end; end; {$endif DELPHI5OROLDER} {$ifndef DELPHI5OROLDER} { TTestMultiThreadProcess } type TTestMultiThreadProcessThread = class(TSynThread) protected fTest: TTestMultiThreadProcess; fID: integer; fEvent: TEvent; fIterationCount: integer; fProcessFinished: boolean; fIDs: TIntegerDynArray; procedure Execute; override; procedure LaunchProcess; public constructor Create(aTest: TTestMultiThreadProcess; aID: integer); reintroduce; destructor Destroy; override; end; procedure TTestMultiThreadProcess.CleanUp; begin DatabaseClose; FreeAndNil(fModel); FreeAndNil(fThreads); end; constructor TTestMultiThreadProcess.Create(Owner: TSynTests; const Ident: string); begin inherited; fMinThreads := 1; fMaxThreads := 50; fOperationCount := 200; fClientPerThread := 1; end; function TTestMultiThreadProcess.CreateClient: TSQLRest; var ClientIP: RawByteString; begin if fClientOnlyServerIP='' then ClientIP := '127.0.0.1' else ClientIP := fClientOnlyServerIP; if fTestClass=TSQLRestServerDB then result := fDatabase else {$ifdef MSWINDOWS} if fTestClass=TSQLRestClientURINamedPipe then result := TSQLRestClientURINamedPipe.Create(fModel,'test') else {$endif} if fTestClass=TSQLRestClientDB then result := TSQLRestClientDB.Create(fDatabase) else {$ifdef MSWINDOWS} if fTestClass=TSQLRestClientURIMessage then begin result := TSQLRestClientURIMessage.Create(fModel,'test', 'Client'+IntToStr(GetCurrentThreadId),1000); TSQLRestClientURIMessage(result).DoNotProcessMessages := true; end else {$endif} if fTestClass.InheritsFrom(TSQLHttpClientGeneric) then begin result := TSQLHttpClientGenericClass(fTestClass).Create(ClientIP,HTTP_DEFAULTPORT,fModel); if fTestClass=TSQLHttpClientWebsockets then with (result as TSQLHttpClientWebsockets) do begin WebSockets.Settings.SetFullLog; WebSocketsUpgrade('wskey'); end; end else raise ESynException.CreateUTF8('Invalid fTestClass=%',[fTestClass]); end; procedure TTestMultiThreadProcess.CreateThreadPool; var i: integer; begin fModel := TSQLModel.Create([TSQLRecordPeople]); fThreads := TSynObjectList.Create; for i := 1 to fMaxThreads do fThreads.Add(TTestMultiThreadProcessThread.Create(self,i)); Check(fThreads.Count=fMaxThreads); end; procedure TTestMultiThreadProcess.DatabaseClose; begin if fDatabase=nil then exit; fHttpServer.Shutdown; FreeAndNil(fHttpServer); FreeAndNil(fDatabase); fTestClass := nil; end; const TTESTMULTITHREADPROCESS_DBFILENAME = 'testMT.db3'; procedure TTestMultiThreadProcess.Test(aClass: TSQLRestClass; aHttp: TSQLHttpServerOptions; aWriteMode: TSQLRestServerAcquireMode); var n: integer; i,j: integer; allFinished: boolean; Thread: TTestMultiThreadProcessThread; {$ifdef MSWINDOWS} aMsg: TMsg; {$endif} begin if CheckFailed(fTestClass=nil) then exit; fTestClass := aClass; // 1. Prepare a new blank SQLite3 database in high speed mode if fClientOnlyServerIP='' then begin DeleteFile(TTESTMULTITHREADPROCESS_DBFILENAME); if CheckFailed(not FileExists(TTESTMULTITHREADPROCESS_DBFILENAME)) or CheckFailed(aClass<>nil) then exit; fDatabase := TSQLRestServerDB.Create(fModel,TTESTMULTITHREADPROCESS_DBFILENAME); fDatabase.AcquireWriteMode := aWriteMode; fDatabase.DB.Synchronous := smOff; fDatabase.DB.LockingMode := lmExclusive; fDatabase.NoAJAXJSON := true; fDatabase.CreateMissingTables; {$ifdef MSWINDOWS} if fTestClass=TSQLRestClientURINamedPipe then fDatabase.ExportServerNamedPipe('test') else if fTestClass=TSQLRestClientURIMessage then fDatabase.ExportServerMessage('test') else {$endif} if fTestClass.InheritsFrom(TSQLHttpClientGeneric) then begin fHttpServer := TSQLHttpServer.Create(HTTP_DEFAULTPORT,[fDataBase],'+',aHttp); if aHttp=useBidirSocket then fHttpServer.WebSocketsEnable(fDatabase,'wskey').Settings.SetFullLog; end; end; // 2. Perform the tests fRunningThreadCount := fMinThreads; repeat // 2.1. Reset the DB content between loops if (fRunningThreadCount>1) and (fDatabase<>nil) then fDatabase.DB.Execute('delete from people'); // 2.2. Launch the background client threads fTimer.Start; for n := 0 to fRunningThreadCount-1 do begin TTestMultiThreadProcessThread(fThreads[n]).LaunchProcess; sleep(10); // ensure thread process is actually started end; // 2.3. Wait for the background client threads process to be finished repeat {$ifdef MSWINDOWS} if (fTestClass=TSQLRestClientURIMessage) or (fClientOnlyServerIP<>'') then while PeekMessage(aMsg,0,0,0,PM_REMOVE) do begin TranslateMessage(aMsg); DispatchMessage(aMsg); end; {$endif} {$ifndef LVCL} if (fDatabase<>nil) and (fDatabase.AcquireWriteMode=amMainThread) then CheckSynchronize{$ifndef DELPHI6OROLDER}(1){$endif}; {$endif} SleepHiRes(0); allFinished := true; for n := 0 to fRunningThreadCount-1 do if not TTestMultiThreadProcessThread(fThreads.List[n]).fProcessFinished then begin allFinished := false; break; end; until allFinished; fTimer.Stop; fRunConsole := Format('%s%d=%d/s ',[fRunConsole, fRunningThreadCount,fTimer.PerSec(fOperationCount*2)]); // 2.4. Check INSERTed IDs consistency for n := 0 to fRunningThreadCount-1 do with TTestMultiThreadProcessThread(fThreads.List[n]) do for i := 0 to fRunningThreadCount-1 do if i<>n then begin Thread := fThreads.List[i]; for j := 0 to high(fIDs) do if fIDs[j]>0 then if IntegerScanExists(pointer(Thread.fIDs),Thread.fIterationCount,fIDs[j]) then Check(false,format('Duplicate ID %d for thread %d and %d',[fIDs[j],i,n])); end; // 2.5. Execution sequence is with 1,2,5,10,30,50 concurent threads if fRunningThreadCount=1 then fRunningThreadCount := 2 else if fRunningThreadCount=2 then fRunningThreadCount := 5 else if fRunningThreadCount=5 then {$ifdef MSWINDOWS} if fTestClass=TSQLRestClientURINamedPipe then break else {$endif} {$ifdef CPUARM3264} if fTestClass=TSQLHttpClientWebsockets then break else {$endif CPUARM3264} fRunningThreadCount := 10 else {$ifdef MSWINDOWS} if fTestClass=TSQLRestClientURIMessage then break else {$endif} fRunningThreadCount := fRunningThreadCount+20; until fRunningThreadCount>fMaxThreads; // 3. Cleanup for this protocol (but reuse the same threadpool) DatabaseClose; Check(fDatabase=nil); end; procedure TTestMultiThreadProcess.Locked; begin // 1=7310/s 2=8689/s 5=7693/s 10=3893/s 30=1295/s 50=777/s // (numbers are taken from a Xeon Phi 2 @ 1.5GHz with 288 cores) Test(TSQLRestClientDB,HTTP_DEFAULT_MODE,amLocked); end; procedure TTestMultiThreadProcess.Unlocked; begin // 1=7342/s 2=9400/s 5=7693/s 10=3894/s 30=1295/s 50=777/s Test(TSQLRestClientDB,HTTP_DEFAULT_MODE,amUnlocked); end; procedure TTestMultiThreadProcess.BackgroundThread; begin // 1=6173/s 2=7299/s 5=7244/s 10=3912/s 30=1301/s 50=777/s Test(TSQLRestClientDB,HTTP_DEFAULT_MODE,amBackgroundThread); end; {$ifndef LVCL} procedure TTestMultiThreadProcess.MainThread; begin // 1=5000/s 2=5911/s 5=4260/s 10=2663/s 30=1126/s 50=707/s Test(TSQLRestClientDB,HTTP_DEFAULT_MODE,amMainThread); end; {$endif} {$ifndef ONLYUSEHTTPSOCKET} procedure TTestMultiThreadProcess.WindowsAPI; begin {$ifdef USEWININET} Test(TSQLHttpClientWinHTTP,useHttpApi); {$endif} end; {$endif} procedure TTestMultiThreadProcess.SocketAPI; begin // 1=2470/s 2=3866/s 5=3608/s 10=3556/s 30=1303/s 50=780/s Test(TSQLHttpClientWinSock,useHttpSocket); end; procedure TTestMultiThreadProcess.Websockets; begin // 1=2433/s 2=3389/s 5=3208/s 10=3354/s 30=1303/s 50=778/s Test(TSQLHttpClientWebsockets,useBidirSocket); end; {$ifdef USELIBCURL} procedure TTestMultiThreadProcess._libcurl; begin // 1=48/s 2=95/s 5=234/s 10=433/s 30=729/s 50=594/s Test(TSQLHttpClientCurl,useHttpSocket); end; {$endif} procedure TTestMultiThreadProcess._TSQLRestClientDB; begin // 1=7347/s 2=8100/s 5=7654/s 10=3898/s 30=1295/s 50=777/s Test(TSQLRestClientDB); end; {$ifdef MSWINDOWS} procedure TTestMultiThreadProcess._TSQLRestClientURIMessage; begin Test(TSQLRestClientURIMessage); end; procedure TTestMultiThreadProcess._TSQLRestClientURINamedPipe; begin Test(TSQLRestClientURINamedPipe); end; {$endif} procedure TTestMultiThreadProcess._TSQLRestServerDB; begin // 1=9332/s 2=9300/s 5=7826/s 10=3891/s 30=1295/s 50=777/s Test(TSQLRestServerDB); end; { TTestMultiThreadProcessThread } constructor TTestMultiThreadProcessThread.Create(aTest: TTestMultiThreadProcess; aID: integer); begin FreeOnTerminate := false; fEvent := TEvent.Create(nil,false,false,''); fTest := aTest; fID := aID; SetLength(fIDs,fTest.fOperationCount); inherited Create(False); end; destructor TTestMultiThreadProcessThread.Destroy; begin fProcessFinished := true; fEvent.SetEvent; // notify terminate Sleep(0); // is expected for proper process inherited Destroy; FreeAndNil(fEvent); end; procedure TTestMultiThreadProcessThread.Execute; var Rest: array of TSQLRest; Rec: TSQLRecordPeople; i,n,r: integer; begin SetCurrentThreadName('% #%',[self,fID]); Rec := TSQLRecordPeople.Create; try Rec.LastName := 'Thread '+CardinalToHex(PtrUInt(GetCurrentThreadId)); while not Terminated do case FixedWaitFor(fEvent,INFINITE) of wrSignaled: if Terminated or fProcessFinished then // from Destroy break else try try SetLength(Rest,fTest.ClientPerThread); for i := 0 to high(Rest) do Rest[i] := fTest.CreateClient; if not fTest.CheckFailed(Rest<>nil) then begin n := 0; r := 0; for i := 0 to fIterationCount-1 do begin Rec.FirstName := FormatUTF8('%/%',[i,fIterationCount-1]); Rec.YearOfBirth := 1000+i; Rec.YearOfDeath := 1040+i; fIDs[i] := Rest[r].Add(Rec,true); if r=high(Rest) then r := 0 else inc(r); if fTest.CheckFailed(fIDs[i]<>0,'Rest.Add') then break; inc(n); end; for i := 0 to n-1 do if fTest.CheckFailed(Rest[r].Retrieve(fIDs[i],Rec)) then break else begin fTest.Check(Rec.YearOfBirth=1000+i); fTest.Check(Rec.YearOfDeath=1040+i); //if (Rec.YearOfBirth<>1000+i) or (Rec.YearOfDeath<>1040+i) then writeln(i,' ',ObjectToJSON(Rec)); if r=high(Rest) then r := 0 else inc(r); end; end; finally for i := 0 to high(Rest) do if Rest[i]<>fTest.fDatabase then FreeAndNil(Rest[i]); fProcessFinished := true; end; except on E: Exception do fTest.Check(False,E.Message); end; end; finally Rec.Free; end; fProcessFinished := true; end; procedure TTestMultiThreadProcessThread.LaunchProcess; begin fProcessFinished := false; fIterationCount := fTest.fOperationCount div fTest.fRunningThreadCount; fEvent.SetEvent; Sleep(0); // is expected for proper process end; { TTestBidirectionalRemoteConnection } procedure TTestBidirectionalRemoteConnection.WebsocketsJSONProtocol; begin WebsocketsLowLevel(TWebSocketProtocolJSON.Create(''),focText); end; procedure TTestBidirectionalRemoteConnection.WebsocketsBinaryProtocol; begin WebsocketsLowLevel(TWebSocketProtocolBinary.Create('',false,'',false),focBinary); end; procedure TTestBidirectionalRemoteConnection.WebsocketsBinaryProtocolEncrypted; begin WebsocketsLowLevel(TWebSocketProtocolBinary.Create('',false,'pass',false),focBinary); end; procedure TTestBidirectionalRemoteConnection.WebsocketsBinaryProtocolCompressed; begin WebsocketsLowLevel(TWebSocketProtocolBinary.Create('',false,'',true),focBinary); end; procedure TTestBidirectionalRemoteConnection.WebsocketsBinaryProtocolCompressEncrypted; begin WebsocketsLowLevel(TWebSocketProtocolBinary.Create('',false,'pass',true),focBinary); end; type // to access protected low-level frame methods TWebSocketProtocolRestHook = class(TWebSocketProtocolRest); procedure TTestBidirectionalRemoteConnection.WebsocketsLowLevel( protocol: TWebSocketProtocol; opcode: TWebSocketFrameOpCode); procedure TestOne(const content,contentType: RawByteString); var C1,C2: THttpServerRequest; P2: TWebSocketProtocol; frame: TWebSocketFrame; head: RawUTF8; noAnswer1,noAnswer2: boolean; begin C1 := THttpServerRequest.Create(nil,0,nil); C2 := THttpServerRequest.Create(nil,0,nil); P2 := protocol.Clone(''); try C1.Prepare('url','POST','headers',content,contentType,'',false); noAnswer1 := opcode=focBinary; noAnswer2 := not noAnswer1; TWebSocketProtocolRestHook(protocol).InputToFrame(C1,noAnswer1,frame,head); Check(frame.opcode=opcode); TWebSocketProtocolRestHook(P2).FrameToInput(frame,noAnswer2,C2); Check(noAnswer1=noAnswer2); Check(C2.URL='url'); Check(C2.Method='POST'); Check(C2.InHeaders='headers'); Check(C2.InContentType=contentType); Check(C2.InContent=content); C1.OutContent := content; C1.OutContentType := contentType; C1.OutCustomHeaders := 'outheaders'; frame.opcode := focContinuation; head := 'answer'; TWebSocketProtocolRestHook(protocol).OutputToFrame(C1,200,head,frame); Check(frame.opcode=opcode); Check(TWebSocketProtocolRestHook(P2).FrameToOutput(frame,C2)=200); Check(C2.OutContent=content); Check(C2.OutContentType=contentType); Check(C2.OutCustomHeaders='outheaders'); finally P2.Free; C2.Free; C1.Free; end; end; begin try TestOne('content',TEXT_CONTENT_TYPE); TestOne('{"content":1234}',JSON_CONTENT_TYPE); TestOne('"content"',JSON_CONTENT_TYPE); TestOne('["json",2]',JSON_CONTENT_TYPE); TestOne('binary'#0'data',BINARY_CONTENT_TYPE); finally protocol.Free; end; end; type TBidirCallbackInterfacedObject = class(TInterfacedObject,IBidirCallback) protected fValue: Integer; public function Value: Integer; procedure AsynchEvent(a: integer); end; TBidirCallback = class(TInterfacedCallback,IBidirCallback) protected fValue: Integer; public function Value: Integer; procedure AsynchEvent(a: integer); end; function TBidirServer.TestRest(a,b: integer; out c: RawUTF8): variant; begin c := Int32ToUtf8(a+b); result := _ObjFast(['a',a,'b',b,'c',c]); end; function TBidirServer.TestRestCustom(a: integer): TServiceCustomAnswer; begin result.Header := BINARY_CONTENT_TYPE_HEADER; result.Content := Int32ToUtf8(a)+#0#1; result.Status := HTTP_SUCCESS; end; function TBidirServer.TestCallback(d: Integer; const callback: IBidirCallback): boolean; begin fCallback := callback; result := d<>0; end; procedure TBidirServer.LaunchAsynchCallback(a: integer); begin if Assigned(fCallback) then fCallback.AsynchEvent(a); end; function TBidirServer.LaunchSynchCallback: integer; begin if Assigned(fCallback) then result := fCallback.Value else result := 0; end; procedure TBidirServer.RemoveCallback; begin fCallback := nil; end; procedure TBidirCallbackInterfacedObject.AsynchEvent(a: integer); begin inc(fValue,a); end; function TBidirCallbackInterfacedObject.Value: integer; begin result := fValue; end; procedure TBidirCallback.AsynchEvent(a: integer); begin inc(fValue,a); end; function TBidirCallback.Value: integer; begin result := fValue; end; const WEBSOCKETS_KEY = 'key'; procedure TTestBidirectionalRemoteConnection.RunHttpServer; var port: integer; begin TInterfaceFactory.RegisterInterfaces([TypeInfo(IBidirService),TypeInfo(IBidirCallback)]); // sicClientDriven services expect authentication for sessions fServer := TSQLRestServerFullMemory.CreateWithOwnModel([],true); fServer.CreateMissingTables; fBidirServer := TBidirServer.Create; Check(fServer.ServiceDefine(fBidirServer,[IBidirService])<>nil); fHttpServer := TSQLHttpServer.Create(HTTP_DEFAULTPORT,[],'+',useBidirSocket); Check(fHttpServer.AddServer(fServer)); fHttpServer.WebSocketsEnable(fServer,WEBSOCKETS_KEY,true).Settings.SetFullLog; //(fHttpServer.HttpServer as TWebSocketServer).HeartbeatDelay := 5000; port := UTF8ToInteger(HTTP_DEFAULTPORT); fPublicRelayClientsPort := ToUTF8(port+1); fPublicRelayPort := ToUTF8(port+2); end; procedure TTestBidirectionalRemoteConnection.TestRest(Rest: TSQLRest); var I: IBidirService; a,b: integer; c: RawUTF8; v: variant; res: TServiceCustomAnswer; begin Rest.Services.Resolve(IBidirService,I); if CheckFailed(Assigned(I), 'Rest IBidirService') then exit; for a := -10 to 10 do for b := -10 to 10 do begin v := I.TestRest(a,b,c); check(GetInteger(pointer(c))=a+b); if CheckFailed(DocVariantType.IsOfType(v)) then continue; check(v.a=a); check(v.b=b); check(v.c=c); end; for a := -10 to 10 do begin res := I.TestRestCustom(a); check(res.Status=HTTP_SUCCESS); check(GetInteger(pointer(res.Content))=a); check(res.Content[Length(res.Content)]=#1); end; end; procedure TTestBidirectionalRemoteConnection.TestCallback(Rest: TSQLRest); var I: IBidirService; d: integer; subscribed: IBidirCallback; procedure WaitUntilNotified; var timeout: Int64; begin timeout := GetTickCount64+5000; while (subscribed.value<>6) and (GetTickCount640)); I.LaunchAsynchCallback(d); end; WaitUntilNotified; check(fBidirServer.LaunchSynchCallback=6); Rest.Services.CallBackUnRegister(subscribed); // manual callback release notify subscribed := TBidirCallback.Create(Rest,IBidirCallback); // auto notification for d := -5 to 6 do begin check(I.TestCallback(d,subscribed)=(d<>0)); I.LaunchAsynchCallback(d); end; WaitUntilNotified; subscribed := TBidirCallback.Create(Rest,IBidirCallback); for d := -5 to 6 do begin check(I.TestCallback(d,subscribed)=(d<>0)); I.LaunchAsynchCallback(d); I.RemoveCallback; end; WaitUntilNotified; check(fBidirServer.LaunchSynchCallback=0); end; // here TBidirCallback.Free will notify Rest.Services.CallBackUnRegister() procedure TTestBidirectionalRemoteConnection.SOACallbackOnServerSide; begin TestRest(fServer); TestCallback(fServer); TestRest(fServer); end; function TTestBidirectionalRemoteConnection.NewClient(const port: SockString): TSQLHttpClientWebsockets; begin result := TSQLHttpClientWebsockets.Create('127.0.0.1',port,TSQLModel.Create(fServer.Model)); result.Model.Owner := result; result.WebSockets.Settings.SetFullLog; end; procedure TTestBidirectionalRemoteConnection.SOACallbackViaWebsockets( Ajax, Relay: boolean); procedure ServiceDefine(c: TSQLHttpClientWebsockets; const msg: string); begin Check(c.SetUser('User','synopse'),'setuser'+msg); Check(c.ServiceDefine(IBidirService,sicShared)<>nil,'IBidirService'+msg); end; var c1, c2: TSQLHttpClientWebsockets; port: SockString; stats: RawUTF8; begin if Relay then port := fPublicRelayClientsPort else port := HTTP_DEFAULTPORT; c1 := NewClient(port); try // check plain HTTP REST calls Check(c1.ServerTimestampSynchronize); ServiceDefine(c1,'1'); TestRest(c1); // check WebSockets communication CheckEqual(c1.WebSocketsUpgrade(WEBSOCKETS_KEY,Ajax,true), '', 'WebSocketsUpgrade1'); TestCallback(c1); c2 := NewClient(port); try CheckEqual(c2.WebSocketsUpgrade(WEBSOCKETS_KEY,Ajax,true), '', 'WebSocketsUpgrade2'); ServiceDefine(c2,'2'); TestCallback(c2); if Relay then begin stats := HttpGet('127.0.0.1',fPublicRelayPort,'/stats',''); check(PosEx('"version"', stats)>0,'stats'); end; TestRest(c1); TestRest(c2); finally c2.Free; end; finally c1.Free; end; end; procedure TTestBidirectionalRemoteConnection.SOACallbackViaJSONWebsockets; begin SOACallbackViaWebsockets({ajax=}true,{relay=}false); end; procedure TTestBidirectionalRemoteConnection.SOACallbackViaBinaryWebsockets; begin SOACallbackViaWebsockets({ajax=}false,{relay=}false); end; procedure TTestBidirectionalRemoteConnection.RelayStart; const RELAYKEY = 'aes256secret'; var stats: RawUTF8; begin fPublicRelay := TPublicRelay.Create(nil, fPublicRelayClientsPort, fPublicRelayPort, RELAYKEY, TJWTHS256.Create('jwtsecret', 100, [], [])); fPrivateRelay := TPrivateRelay.Create(nil, '127.0.0.1',fPublicRelayPort, RELAYKEY, fPublicRelay.ServerJWT.Compute([]), '127.0.0.1', HTTP_DEFAULTPORT, 'X-Real-IP'); check(not fPrivateRelay.Connected); check(fPrivateRelay.TryConnect); checkEqual(HttpGet('127.0.0.1',fPublicRelayPort,'/invalid',''), '', 'wrong URI'); stats := HttpGet('127.0.0.1',fPublicRelayPort,'/stats',''); check(PosEx('version', stats)>0,'stats'); end; procedure TTestBidirectionalRemoteConnection.RelaySOACallbackViaJSONWebsockets; begin SOACallbackViaWebsockets({ajax=}true,{relay=}true); end; procedure TTestBidirectionalRemoteConnection.RelayConnectionRecreate; begin check(fPrivateRelay.TryConnect); end; procedure TTestBidirectionalRemoteConnection.RelaySOACallbackViaBinaryWebsockets; begin SOACallbackViaWebsockets({ajax=}false,{relay=}true); end; procedure TTestBidirectionalRemoteConnection.RelayShutdown; var stats: RaWUTF8; begin stats := HttpGet('127.0.0.1',fPublicRelayPort,'/stats',''); check(PosEx('"version"', stats)>0,'stats'); fPrivateRelay.Free; sleep(100); stats := HttpGet('127.0.0.1',fPublicRelayPort,'/stats',''); check(PosEx('"version"', stats)>0,'stats'); fPublicRelay.Free; end; procedure TTestBidirectionalRemoteConnection._TRecordVersion; begin TestMasterSlaveRecordVersion(Self,'ws.db3'); end; procedure TTestBidirectionalRemoteConnection.CleanUp; begin FreeAndNil(fHttpServer); FreeAndNil(fServer); end; { TTestDDDSharedUnits } procedure TTestDDDSharedUnits.AuthenticationModel; begin TDDDAuthenticationSHA256.RegressionTests(self); TDDDAuthenticationMD5.RegressionTests(self); end; procedure TTestDDDSharedUnits.EmailValidationProcess; begin TestDddInfraEmailer(TSQLRestServerDB,self); end; procedure TTestDDDSharedUnits.UserModel; begin TCountry.RegressionTests(self); TPersonContactable.RegressionTests(self); end; procedure TTestDDDSharedUnits.UserCQRSRepository; begin TInfraRepoUserFactory.RegressionTests(self); end; type // The infratructure REST class implementing the Query and Command Interfaces for TTest TDDDThreadsTestRest = class(TDDDRepositoryRestCommand, IDDDThreadsCommand) public function SelectByDescription(const aDescription: RawUTF8): TCQRSResult; function SelectAll: TCQRSResult; function Get(out aAggregate: TDDDTest): TCQRSResult; function GetAll(out aAggregates: TDDDTestObjArray): TCQRSResult; function GetNext(out aAggregate: TDDDTest): TCQRSResult; function Add(const aAggregate: TDDDTest): TCQRSResult; function Update(const aUpdatedAggregate: TDDDTest): TCQRSResult; end; // REST Factory for TDDDThreadsTestRest instances TDDDThreadsTestRestFactory = class(TDDDRepositoryRestFactory) public constructor Create(aRest: TSQLRest; aOwner: TDDDRepositoryRestManager = nil); reintroduce; end; // Custom TSQLHttpClient encapsulating the remote IDDDThreadsCommand interface. TDDDThreadsHttpClient = class(TSQLHttpClient) private // Internal Model fModel: TSQLModel; // IDDDThreadsCommand interface. Will be assigned inside SetUser fMyCommand: IDDDThreadsCommand; public constructor Create(const aServer, aPort: AnsiString); reintroduce; destructor Destroy; override; function SetUser(const aUserName, aPassword: RawUTF8; aHashedPassword: Boolean = false): boolean; reintroduce; property MyCommand: IDDDThreadsCommand read fMyCommand; end; // The thread used by TTestDDDMultiThread.ClientTest TDDDThreadsThread = class(TSynThread) private fHttpClient: TDDDThreadsHttpClient; fRequestCount: integer; fId: integer; fIsError: boolean; protected procedure Execute; override; public constructor Create(const aId, aRequestCount: integer); reintroduce; destructor Destroy; override; property IsError: boolean read fIsError; end; { TDDDThreadsTestRest } function TDDDThreadsTestRest.SelectByDescription(const aDescription: RawUTF8): TCQRSResult; begin result := ORMSelectOne('Description=?', [aDescription], (aDescription = '')); end; function TDDDThreadsTestRest.SelectAll: TCQRSResult; begin result := ORMSelectAll('', []); end; function TDDDThreadsTestRest.Get(out aAggregate: TDDDTest): TCQRSResult; begin result := ORMGetAggregate(aAggregate); end; function TDDDThreadsTestRest.GetAll(out aAggregates: TDDDTestObjArray): TCQRSResult; begin result := ORMGetAllAggregates(aAggregates); end; function TDDDThreadsTestRest.GetNext(out aAggregate: TDDDTest): TCQRSResult; begin result := ORMGetNextAggregate(aAggregate); end; function TDDDThreadsTestRest.Add(const aAggregate: TDDDTest): TCQRSResult; begin result := ORMAdd(aAggregate); end; function TDDDThreadsTestRest.Update(const aUpdatedAggregate: TDDDTest): TCQRSResult; begin result := ORMUpdate(aUpdatedAggregate); end; { TInfraRepoUserFactory } constructor TDDDThreadsTestRestFactory.Create(aRest: TSQLRest; aOwner: TDDDRepositoryRestManager); begin inherited Create(IDDDThreadsCommand, TDDDThreadsTestRest, TDDDTest, aRest, TSQLRecordDDDTest, aOwner); end; { TTestDDDMultiThread } procedure TTestDDDMultiThread.CleanUp; begin if Assigned(fHttpServer) then FreeAndNil(fHttpServer); if Assigned(fRestServer) then FreeAndNil(fRestServer); end; procedure TTestDDDMultiThread.DeleteOldDatabase; begin if FileExists(ChangeFileExt(ParamStr(0), '.db3')) then SysUtils.DeleteFile(ChangeFileExt(ParamStr(0), '.db3')); CheckNot(FileExists(ChangeFileExt(ParamStr(0), '.db3'))); end; procedure TTestDDDMultiThread.StartServer; begin fRestServer := TSQLRestServerDB.CreateWithOwnModel([TSQLRecordDDDTest], ChangeFileExt(ParamStr(0), '.db3'), true); with fRestServer do begin DB.Synchronous := smNormal; DB.LockingMode := lmExclusive; CreateMissingTables(); TInterfaceFactory.RegisterInterfaces([TypeInfo(IDDDThreadsQuery), TypeInfo(IDDDThreadsCommand)]); ServiceContainer.InjectResolver([TDDDThreadsTestRestFactory.Create(fRestServer)], true); ServiceDefine(TDDDThreadsTestRest, [IDDDThreadsCommand], sicClientDriven); end; fHttpServer := TSQLHttpServer.Create(HTTP_DEFAULTPORT, fRestServer, '+', {$ifdef ONLYUSEHTTPSOCKET}useHttpSocket{$else}useHttpApiRegisteringURI{$endif}); Check(fHttpServer.DBServerCount>0); end; procedure TTestDDDMultiThread.MultiThreadedClientsTest; begin ClientTest(20, 50); end; procedure TTestDDDMultiThread.SingleClientTest; var HttpClient: TDDDThreadsHttpClient; test: TDDDTest; i: integer; const MAX = 1000; begin HttpClient := TDDDThreadsHttpClient.Create('127.0.0.1', HTTP_DEFAULTPORT); try Check(HttpClient.SetUser('Admin', 'synopse')); test := TDDDTest.Create; try for i := 0 to MAX - 1 do begin test.Description := FormatUTF8('test-%', [i]); Check(HttpClient.MyCommand.Add(test) = cqrsSuccess); end; Check(HttpClient.MyCommand.Commit = cqrsSuccess); finally test.Free; end; finally HttpClient.Free; end; end; function TTestDDDMultiThread.ClientTest(const aClients, aRequests: integer): boolean; var i,count: integer; arrThreads: array of TDDDThreadsThread; {$ifdef MSWINDOWS} arrHandles: array of THandle; {$endif} rWait: Cardinal; begin result := false; count := fRestServer.TableRowCount(TSQLRecordDDDTest); SetLength(arrThreads, aClients); {$ifdef MSWINDOWS} SetLength(arrHandles, aClients); {$endif} for i := Low(arrThreads) to High(arrThreads) do begin arrThreads[i] := TDDDThreadsThread.Create(i, aRequests); {$ifdef MSWINDOWS} arrHandles[i] := arrThreads[i].Handle; {$endif} arrThreads[i].Start; end; try {$ifdef MSWINDOWS} repeat rWait := WaitForMultipleObjects(aClients, @arrHandles[0], True, INFINITE); until rWait <> WAIT_TIMEOUT; {$else} repeat Sleep(10); rWait := 0; for i := Low(arrThreads) to High(arrThreads) do if not arrThreads[i].Terminated then inc(rWait); until rWait=0; {$endif} finally for i := Low(arrThreads) to High(arrThreads) do begin CheckNot(arrThreads[i].IsError); arrThreads[i].Free; end; Check(fRestServer.TableRowCount(TSQLRecordDDDTest)=count+aClients*aRequests); end; end; { TDDDThreadsHttpClient } constructor TDDDThreadsHttpClient.Create(const aServer, aPort: AnsiString); begin fModel := TSQLModel.Create([TSQLRecordDDDTest]); fModel.Owner := self; inherited Create(aServer, aPort, fModel); end; destructor TDDDThreadsHttpClient.Destroy; begin fMyCommand := nil; inherited; end; function TDDDThreadsHttpClient.SetUser(const aUserName, aPassword: RawUTF8; aHashedPassword: Boolean = false): boolean; begin result := inherited SetUser(aUserName, aPassword, aHashedPassword); if result then begin ServiceDefine([IDDDThreadsCommand], sicClientDriven); Services.Resolve(IDDDThreadsCommand, fMyCommand); end; end; { TDDDThreadsThread } constructor TDDDThreadsThread.Create(const aID, aRequestCount: integer); begin inherited Create(true); fRequestCount := aRequestCount; fId := aId; fIsError := false; fHttpClient := TDDDThreadsHttpClient.Create('127.0.0.1', HTTP_DEFAULTPORT); end; destructor TDDDThreadsThread.Destroy; begin fHttpClient.Free; inherited; end; procedure TDDDThreadsThread.Execute; var i: integer; test: TDDDTest; success: boolean; begin fHttpClient.SetUser('Admin', 'synopse'); for i := 1 to 150 {15000} do fHttpClient.ServerTimestampSynchronize; // calls root/timestamp test := TDDDTest.Create; try success := true; i := fRequestCount; // circumvent weird FPC bug on ARM while i>0 do begin test.Description := FormatUTF8('test-%-%', [fID, i]); success := success and (fHttpClient.MyCommand.Add(test) = cqrsSuccess); if not success then break; dec(i); end; if success then success := fHttpClient.MyCommand.Commit = cqrsSuccess; if not success then begin fIsError := true; raise Exception.Create('Something went wrong!'); end; finally test.Free; Terminate; end; end; {$endif DELPHI5OROLDER} { TTestProtocols } procedure TTestProtocols.RTSPOverHTTP; var proxy: TRTSPOverHTTPServer; begin proxy := TRTSPOverHTTPServer.Create('127.0.0.1','3999','3998',TSynLog,nil,nil); try proxy.RegressionTests(self,{$ifdef Darwin}10{$else}100{$endif},10); finally proxy.Free; end; end; initialization {$ifndef LVCL} {$ifdef ISDELPHIXE}FormatSettings.{$endif}{$ifdef FPC}FormatSettings.{$endif} DecimalSeparator := '.'; {$endif LVCL} _uE0 := WinAnsiToUtf8(@UTF8_E0_F4_BYTES[0],1); _uE7 := WinAnsiToUtf8(@UTF8_E0_F4_BYTES[1],1); _uE8 := WinAnsiToUtf8(@UTF8_E0_F4_BYTES[2],1); _uE9 := WinAnsiToUtf8(@UTF8_E0_F4_BYTES[3],1); _uEA := WinAnsiToUtf8(@UTF8_E0_F4_BYTES[4],1); _uF4 := WinAnsiToUtf8(@UTF8_E0_F4_BYTES[5],1); end.