Skip to content

/ mORMot

Permalink
master
Switch branches/tags

mORMot/SynSelfTests.pas

Go to file
 
 
Cannot retrieve contributors at this time
20735 lines (20063 sloc) 757 KB
Raw Blame
/// 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) 2021 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) 2021
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;
/// AES-GCM encryption/decryption with authentication
procedure _AES_GCM;
/// 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 MSWINDOWS}
{$endif LVCL}
{$endif CPU64}
{$ifdef MSWINDOWS}
{$ifdef USEZEOS}
/// test external Firebird embedded engine via Zeos/ZDBC (if available)
procedure FirebirdEmbeddedViaZDBCOverHTTP;
{$endif USEZEOS}
{$endif MSWINDOWS}
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 FPC}
{$endif MSWINDOWS}
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<POINTERBITS-1 then begin
CheckEqual(GetBitsCountPtrInt(PtrInt(3) shl i),2);
CheckEqual(GetBitsCountPtrInt((PtrInt(1) shl (i+1))-1),i+1);
end;
if i<POINTERBITS-2 then
CheckEqual(GetBitsCountPtrInt(PtrInt(7) shl i),3);
if i<POINTERBITS-3 then
CheckEqual(GetBitsCountPtrInt(PtrInt(15) shl i),4);
CheckEqual(GetBitsCount64(v,i+1),i+1);
CheckEqual(GetBitsCount(v,i+1),i+1);
end;
for i := 1 to 32 do begin
v := ALLBITS_CARDINAL[i];
CheckEqual(GetBitsCountPtrInt(v),i);
CheckEqual(GetBitsCount(v,POINTERBITS),i);
CheckEqual(GetBitsCount(v,i),i);
end;
for i := 1 to 1000 do begin
v := i;
c := GetBitsCount64(v,POINTERBITS);
CheckEqual(GetBitsCountPtrInt(v),c);
CheckEqual(GetBitsCount(v,POINTERBITS),c);
{$ifdef FPC}CheckEqual(popcnt(v),c);{$endif}
v := v*v*19;
c := GetBitsCount64(v,POINTERBITS);
CheckEqual(GetBitsCountPtrInt(v),c);
{$ifdef FPC}CheckEqual(popcnt(v),c);{$endif}
v := random32gsl{$ifdef CPU64}or (PtrUInt(random32gsl) shl 32){$endif};
c := GetBitsCount64(v,POINTERBITS);
CheckEqual(GetBitsCountPtrInt(v),c);
CheckEqual(GetBitsCount(v,POINTERBITS),c);
{$ifdef FPC}CheckEqual(popcnt(v),c);{$endif}
end;
timer.Start;
for i := 1 to N do
GetBitsCountPtrInt(i);
NotifyTestSpeed(ctxt,N,N shl POINTERSHR,@timer,{onlylog=}true);
end;
var Bits: array[byte] of byte;
Bits64: Int64 absolute Bits;
Si,i: integer;
c: cardinal;
{$ifdef FPC}
u: {$ifdef CPU64}QWord{$else}DWord{$endif};
timer: TPrecisionTimer;
{$endif FPC}
begin
{$ifdef CPUINTEL}
GetBitsCountPtrInt := @GetBitsCountPurePascal;
TestPopCnt('pas');
GetBitsCountPtrInt := @GetBitsCountPas; // x86/x86_64 assembly
TestPopCnt('asm');
{$ifndef ABSOLUTEPASCAL}
if cfPOPCNT in CpuFeatures then begin
GetBitsCountPtrInt := @GetBitsCountSSE42;
TestPopCnt('sse4.2');
end;
{$endif ABSOLUTEPASCAL}
{$else}
TestPopCnt('pas');
{$endif CPUINTEL}
{$ifdef FPC}
timer.Start;
for u := 1 to N do
i := popcnt(u);
NotifyTestSpeed('FPC',N,N shl POINTERSHR,@timer,{onlylog=}true);
{$endif FPC}
FillcharFast(Bits,sizeof(Bits),0);
for i := 0 to high(Bits)*8+7 do begin
Check(not GetBit(Bits,i));
Check(not GetBitPtr(@Bits,i));
end;
RandSeed := 10; // will reproduce the same Random() values
for i := 1 to 100 do begin
Si := Random(high(Bits));
SetBit(Bits,Si);
Check(GetBit(Bits,Si));
Check(GetBitPtr(@Bits,Si));
end;
RandSeed := 10;
for i := 1 to 100 do
Check(GetBit(Bits,Random(high(Bits))));
RandSeed := 10;
for i := 1 to 100 do begin
Si := Random(high(Bits));
UnSetBit(Bits,Si);
Check(not GetBit(Bits,Si));
Check(not GetBitPtr(@Bits,Si));
end;
for i := 0 to high(Bits)*8+7 do
Check(not GetBit(Bits,i));
for i := 0 to 63 do
Check(not GetBit64(Bits64,i));
RandSeed := 10;
for i := 1 to 30 do begin
Si := Random(63);
SetBit64(Bits64,Si);
Check(GetBit64(Bits64,Si));
end;
RandSeed := 10;
for i := 1 to 30 do
Check(GetBit64(Bits64,Random(63)));
RandSeed := 10;
for i := 1 to 30 do begin
Si := Random(63);
UnSetBit64(Bits64,Si);
Check(not GetBit64(Bits64,Si));
end;
for i := 0 to 63 do
Check(not GetBit64(Bits64,i));
c := 1;
for i := 1 to 32 do begin
Check(GetAllBits($ffffffff,i));
Check(not GetAllBits(0,i));
Check(GetAllBits(c,i));
Check(not GetAllBits(c and -2,i));
Check(GetAllBits(ALLBITS_CARDINAL[i],i));
c := c or (1 shl i);
end;
Randomize; // we fixed the RandSeed value above -> 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 n<P;
inc(n,SizeOf(P));
if P<n then
repeat
if PByte(P)^<>byte(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_-.%7E+');
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'));