Permalink
Cannot retrieve contributors at this time
/// 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')); | |