├── UnitTests ├── JsonTestData.rc ├── Tests │ ├── person.dat │ ├── Grijjy.ProtocolBuffers.Tests.Resources.rc │ ├── alltypes.dat │ ├── Grijjy.ProtocolBuffers.Tests.Resources.res │ ├── Tests.Grijjy.Collections.RingBuffer.pas │ ├── Tests.Grijjy.Collections.Lists.pas │ ├── Tests.Grijjy.Collections.Sets.pas │ ├── Tests.Grijjy.Collections.Base.pas │ ├── Tests.Grijjy.Bson.Path.pas │ └── Tests.Grijjy.Collections.Dictionaries.pas ├── JsonTestData.RES ├── JsonTestData.zip ├── GrijjyFoundationTests.res └── GrijjyFoundationTests.dpr ├── Grijjy logo.png ├── Grijjy.inc ├── Grijjy.RemotePush.Receiver.pas ├── .gitattributes ├── Delphinus.Info.json ├── Delphinus.Install.json ├── .gitignore ├── Linuxapi.Timerfd.pas ├── Grijjy.JWT.pas ├── Grijjy.System.pas ├── Grijjy.Console.pas ├── License.txt ├── Grijjy.Uri.pas ├── README.md ├── Grijjy.System.Console.pas ├── Grijjy.Social.pas ├── Macapi.Gcd.pas ├── Grijjy.Hash.pas ├── Linuxapi.Epoll.pas ├── Grijjy.MemoryPool.pas ├── Grijjy.DateUtils.pas ├── Grijjy.TimerQueue.Win.pas ├── Grijjy.RemotePush.Sender.pas ├── Grijjy.BinaryCoding.pas ├── Grijjy.Hooking.pas ├── Grijjy.TimerQueue.Linux.pas ├── Grijjy.CodeBlocks.pas ├── Grijjy.Winsock2.pas ├── Grijjy.CloudLogging.Protocol.pas ├── Grijjy.Scram.pas ├── Grijjy.OpenSSL.pas └── Grijjy.CloudLogging.InstanceTracker.pas /UnitTests/JsonTestData.rc: -------------------------------------------------------------------------------- 1 | JSON_TEST_DATA RCDATA JsonTestData.zip -------------------------------------------------------------------------------- /Grijjy logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grijjy/GrijjyFoundation/HEAD/Grijjy logo.png -------------------------------------------------------------------------------- /UnitTests/Tests/person.dat: -------------------------------------------------------------------------------- 1 | 2 | Erik van Bilsen*erik@mymail.com" 3 | Number1" 4 | Number2 -------------------------------------------------------------------------------- /UnitTests/JsonTestData.RES: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grijjy/GrijjyFoundation/HEAD/UnitTests/JsonTestData.RES -------------------------------------------------------------------------------- /UnitTests/JsonTestData.zip: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grijjy/GrijjyFoundation/HEAD/UnitTests/JsonTestData.zip -------------------------------------------------------------------------------- /Grijjy.inc: -------------------------------------------------------------------------------- 1 | {$SCOPEDENUMS ON} 2 | 3 | {$IF Defined(ANDROID) or Defined(IOS)} 4 | {$DEFINE MOBILE} 5 | {$ENDIF} 6 | -------------------------------------------------------------------------------- /UnitTests/Tests/Grijjy.ProtocolBuffers.Tests.Resources.rc: -------------------------------------------------------------------------------- 1 | ALLTYPES RCDATA alltypes.dat 2 | PERSON RCDATA person.dat -------------------------------------------------------------------------------- /UnitTests/Tests/alltypes.dat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grijjy/GrijjyFoundation/HEAD/UnitTests/Tests/alltypes.dat -------------------------------------------------------------------------------- /Grijjy.RemotePush.Receiver.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grijjy/GrijjyFoundation/HEAD/Grijjy.RemotePush.Receiver.pas -------------------------------------------------------------------------------- /UnitTests/GrijjyFoundationTests.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grijjy/GrijjyFoundation/HEAD/UnitTests/GrijjyFoundationTests.res -------------------------------------------------------------------------------- /UnitTests/Tests/Grijjy.ProtocolBuffers.Tests.Resources.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grijjy/GrijjyFoundation/HEAD/UnitTests/Tests/Grijjy.ProtocolBuffers.Tests.Resources.res -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | * text=auto 2 | 3 | # Pascal source files should use CRLF line endings to keep the Delphi IDE happy 4 | #*.pas eol=crlf 5 | *.dpr eol=crlf 6 | *.dpk eol=crlf 7 | 8 | # iOS Entitlement Files MUST use LF endings or app won't run on device 9 | Entitlement.TemplateiOS.xml eol=lf 10 | 11 | # macOS shell scripts MUST use LF too 12 | *.sh eol=lf 13 | 14 | # customize language stats 15 | *.inc linguist-language=Pascal -------------------------------------------------------------------------------- /Delphinus.Info.json: -------------------------------------------------------------------------------- 1 | { 2 | "id": "{D8BC19AB-3A1A-4D3C-A407-A20C396128E7}", 3 | "name": "Grijjy Foundation", 4 | "picture": "Grijjy logo.png", 5 | "license_type": "Simplified BSD", 6 | "license_file": "License.txt", 7 | "platforms": "Win32;Win64;OSX32;Android;iOSDevice32;iOSDevice64;Linux64", 8 | "package_compiler_min": 31, 9 | "package_compiler_max": 32, 10 | "compiler_min": 31, 11 | "compiler_max": 32 12 | } -------------------------------------------------------------------------------- /Delphinus.Install.json: -------------------------------------------------------------------------------- 1 | { 2 | "search_pathes": [{ 3 | "pathes": ".", 4 | "platforms": "Win32;Win64;OSX32;Android;iOSDevice32;iOSDevice64;Linux64" 5 | }], 6 | "browsing_pathes": [{ 7 | "pathes": ".", 8 | "platforms": "Win32;Win64;OSX32;Android;iOSDevice32;iOSDevice64;Linux64" 9 | }], 10 | "source_folders": [{ 11 | "folder": "." 12 | }, 13 | { 14 | "folder": "UnitTests", 15 | "recursive": true 16 | }] 17 | } -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | #OS X meta data 2 | ._* 3 | #ignore thumbnails created by windows 4 | Thumbs.db 5 | #ignore Delphi build directories 6 | Android/ 7 | iOSDevice/ 8 | iOSDevice32/ 9 | iOSDevice64/ 10 | iOSSimulator/ 11 | OSX32/ 12 | Win32/ 13 | Win64/ 14 | #ignore Delphi build files 15 | *.obj 16 | *.exe 17 | *.dcu 18 | *.map 19 | *.deployproj 20 | #ignore Delphi temp and backup files 21 | *.~* 22 | #ignore Delphi local files 23 | *.dsk 24 | *.dproj.local 25 | *.identcache 26 | *.groupproj.local 27 | #ignore temporary help files 28 | HtmlHelp/ 29 | Html/ 30 | #ignore DUnitX output 31 | dunitx-results.xml 32 | *.o 33 | -------------------------------------------------------------------------------- /Linuxapi.Timerfd.pas: -------------------------------------------------------------------------------- 1 | unit Linuxapi.Timerfd; 2 | { Linux API for Timerfd } 3 | 4 | {$I Grijjy.inc} 5 | 6 | interface 7 | 8 | uses 9 | Posix.Base, 10 | Posix.Time, 11 | Posix.Fcntl; 12 | 13 | const 14 | TFD_NONBLOCK = O_NONBLOCK; 15 | 16 | // creates a new timer object 17 | function timerfd_create(clockid: Integer; flags: Integer): Integer; cdecl; external libc name _PU + 'timerfd_create'; 18 | 19 | // starts or stops the timer 20 | function timerfd_settime(fd: Integer; flags: Integer; const new_value: Pitimerspec; old_value: Pitimerspec): Integer; cdecl; external libc name _PU + 'timerfd_settime'; 21 | 22 | // returns the current setting of the timer 23 | function timerfd_gettime(fd: Integer; curr_value: Pitimerspec): Integer; cdecl; external libc name _PU + 'timerfd_gettime'; 24 | 25 | implementation 26 | 27 | end. 28 | -------------------------------------------------------------------------------- /Grijjy.JWT.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.JWT; 2 | 3 | { Java Web Tokens } 4 | 5 | interface 6 | 7 | uses 8 | System.SysUtils; 9 | 10 | const 11 | { RSA with SHA256 } 12 | JWT_RS256 = '{"alg":"RS256","typ":"JWT"}'; 13 | 14 | { TODO: Added HMAC with SHA256 token support } 15 | 16 | { Creates a Java Web Token using the provided private key in PEM format } 17 | function JavaWebToken(const APrivateKey: TBytes; const AHeader, APayload: String; out AJWT: String): Boolean; 18 | 19 | implementation 20 | 21 | uses 22 | Grijjy.OpenSSL, 23 | Grijjy.BinaryCoding; 24 | 25 | function JavaWebToken(const APrivateKey: TBytes; const AHeader, APayload: String; out AJWT: String): Boolean; 26 | var 27 | Data: TBytes; 28 | JWS: TBytes; 29 | begin 30 | Data := goBase64Encode(BytesOf(AHeader)) + [Ord('.')] + goBase64Encode(BytesOf(APayload)); 31 | if TgoSSLHelper.Sign_RSASHA256(Data, APrivateKey, JWS) then 32 | begin 33 | AJWT := StringOf(Data) + '.' + StringOf(goBase64Encode(JWS)); 34 | Result := True; 35 | end 36 | else 37 | Result := False; 38 | end; 39 | 40 | end. 41 | -------------------------------------------------------------------------------- /Grijjy.System.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.System; 2 | 3 | {$INCLUDE 'Grijjy.inc'} 4 | 5 | interface 6 | 7 | type 8 | { Abstract base class for classes that can implement interfaces, but are not 9 | reference counted (unless on ARC systems of course). If you want your class 10 | to be reference counted, derive from TInterfacedObject instead. } 11 | TgoNonRefCountedObject = class abstract(TObject) 12 | {$REGION 'Internal Declarations'} 13 | protected 14 | { IInterface } 15 | function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; 16 | function _AddRef: Integer; stdcall; 17 | function _Release: Integer; stdcall; 18 | {$ENDREGION 'Internal Declarations'} 19 | end; 20 | 21 | implementation 22 | 23 | { TgoNonRefCountedObject } 24 | 25 | function TgoNonRefCountedObject.QueryInterface(const IID: TGUID; 26 | out Obj): HResult; 27 | begin 28 | if GetInterface(IID, Obj) then 29 | Result := S_OK 30 | else 31 | Result := E_NOINTERFACE; 32 | end; 33 | 34 | function TgoNonRefCountedObject._AddRef: Integer; 35 | begin 36 | Result := -1; 37 | end; 38 | 39 | function TgoNonRefCountedObject._Release: Integer; 40 | begin 41 | Result := -1; 42 | end; 43 | 44 | end. 45 | -------------------------------------------------------------------------------- /Grijjy.Console.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.Console; 2 | 3 | {$INCLUDE 'Grijjy.inc'} 4 | 5 | interface 6 | 7 | uses 8 | {$IFDEF LINUX} 9 | Posix.Signal, 10 | {$ENDIF} 11 | {$IFDEF MSWINDOWS} 12 | Windows, 13 | {$ENDIF} 14 | SysUtils; 15 | 16 | procedure WaitForCtrlC; 17 | 18 | implementation 19 | 20 | var 21 | Control_C: Boolean = False; 22 | 23 | {$IFDEF MSWINDOWS} 24 | function ConsoleCtrlHandler(dwCtrlType: DWORD): BOOL; stdcall; 25 | begin 26 | if (dwCtrlType = CTRL_C_EVENT) then 27 | Control_C := True; 28 | Result := True; 29 | end; 30 | {$ENDIF} 31 | 32 | {$IFDEF LINUX} 33 | var 34 | sigIntHandler: sigaction_t; 35 | 36 | procedure SigHandler(SigNum: Integer); cdecl; 37 | begin 38 | Control_C := True; 39 | end; 40 | {$ENDIF} 41 | 42 | procedure WaitForCtrlC; 43 | begin 44 | while not Control_C do 45 | Sleep(25); 46 | end; 47 | 48 | initialization 49 | {$IFDEF MSWINDOWS} 50 | Windows.SetConsoleCtrlHandler(@ConsoleCtrlHandler, True); 51 | {$ENDIF} 52 | {$IFDEF LINUX} 53 | sigIntHandler._u.sa_handler := @SigHandler; 54 | sigemptyset(sigIntHandler.sa_mask); 55 | sigIntHandler.sa_flags := 0; 56 | sigaction(SIGINT, @sigIntHandler, nil); 57 | {$ENDIF} 58 | 59 | end. 60 | -------------------------------------------------------------------------------- /License.txt: -------------------------------------------------------------------------------- 1 | GrijjyFoundation is licensed under the Simplified BSD License. 2 | 3 | ------------------------------------------------------------------------------- 4 | 5 | Copyright (c) 2017 by Grijjy, Inc. 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions are met: 10 | 11 | 1. Redistributions of source code must retain the above copyright notice, this 12 | list of conditions and the following disclaimer. 13 | 2. Redistributions in binary form must reproduce the above copyright notice, 14 | this list of conditions and the following disclaimer in the documentation 15 | and/or other materials provided with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 21 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 22 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 23 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 24 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Grijjy.Uri.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.Uri; 2 | 3 | { URI helper } 4 | 5 | {$I Grijjy.inc} 6 | 7 | interface 8 | 9 | uses 10 | System.SysUtils, 11 | System.Classes, 12 | System.Net.URLClient; 13 | 14 | type 15 | TgoURI = record 16 | private 17 | FURI: TURI; 18 | public 19 | Scheme: String; 20 | Username: String; 21 | Password: String; 22 | Host: String; 23 | Port: Integer; 24 | Path: String; 25 | Query: String; 26 | Params: String; 27 | Fragment: String; 28 | public 29 | constructor Create(const AUri: String); 30 | function ToString: String; 31 | end; 32 | 33 | implementation 34 | 35 | { TgoURI } 36 | 37 | constructor TgoURI.Create(const AUri: String); 38 | var 39 | I: Integer; 40 | begin 41 | FURI := TURI.Create(AUri); 42 | Scheme := FURI.Scheme; 43 | Username := FURI.Username; 44 | Password := FURI.Password; 45 | Host := FURI.Host; 46 | Port := FURI.Port; 47 | Path := FURI.Path; 48 | Query := FURI.Query; 49 | for I := 0 to Length(FURI.Params) - 1 do 50 | Params := Params + FURI.Params[I].Name + '=' + FURI.Params[I].Value + '&'; 51 | Params := Params.Substring(0, Params.Length - 1); 52 | Fragment := FURI.Fragment; 53 | end; 54 | 55 | function TgoURI.ToString: String; 56 | var 57 | Auth: String; 58 | begin 59 | if Username <> '' then 60 | Auth := Username + ':' + Password + '@' 61 | else 62 | Auth := ''; 63 | Result := Scheme + '://' + Auth + Host; 64 | if ((Port <> -1) and (Port <> 0)) and 65 | ((SameText(Scheme, 'http') and (Port <> 80)) or (SameText(Scheme, 'https') and (Port <> 443))) then 66 | Result := Result + ':' + IntToStr(Port); 67 | Result := Result + Path; 68 | if Length(Params) > 0 then 69 | Result := Result + '?' + Params; 70 | end; 71 | 72 | end. 73 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Grijjy Foundation 2 | 3 | This repository contains foundation classes and utilities that are used throughout the other [Grijjy Repositories](https://github.com/grijjy). 4 | 5 | ## Grijjy Blog 6 | 7 | Take a look at our [Grijjy Blog](https://blog.grijjy.com/) for discussions of our source code. In particular, these posts apply the the code in this repository: 8 | 9 | * [Expand your Collections collection – Part 1: a generic set](https://blog.grijjy.com/2017/01/05/expand-your-collections-collection-part-1-a-generic-set/) 10 | * [Expand your Collections collection – Part 2: a generic ring buffer](https://blog.grijjy.com/2017/01/12/expand-your-collections-collection-part-2-a-generic-ring-buffer/) 11 | * [Unit Testing Generic Types](https://blog.grijjy.com/2017/01/10/unit-testing-generic-types/) 12 | * [Scalable HTTP/S and TCP client sockets for the cloud](https://blog.grijjy.com/2017/01/09/scalable-https-and-tcp-client-sockets-for-the-cloud/) 13 | * [Working with big data databases in Delphi – Cassandra, Couchbase and MongoDB](https://blog.grijjy.com/2017/01/11/working-with-big-data-databases-in-delphi-cassandra-couchbase-and-mongodb-part-2-of-3/) 14 | * [Efficient and easy-to-use JSON and BSON library](https://blog.grijjy.com/2017/01/30/efficient-and-easy-to-use-json-and-bson-library/) 15 | * [Binary Serialization with Google Protocol Buffers](https://blog.grijjy.com/2017/04/25/binary-serialization-with-google-protocol-buffers/) 16 | * [Query JSON documents with JSONPath](https://blog.grijjy.com/2018/10/29/query-json-documents-with-jsonpath/) 17 | 18 | ## API Documentation 19 | 20 | The API documentation for this repository can be found at [https://grijjy.github.io/GrijjyFoundation/](https://grijjy.github.io/GrijjyFoundation/) 21 | 22 | It is automatically generated from the source code using a custom version of [PasDoc](https://github.com/pasdoc/pasdoc/wiki). 23 | 24 | ## Miscellaneous 25 | You can install [Delphinus package manager](https://github.com/Memnarch/Delphinus/wiki/Installing-Delphinus) and then install our foundation package there. (Delphinus-Support) -------------------------------------------------------------------------------- /Grijjy.System.Console.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.System.Console; 2 | 3 | {$INCLUDE 'Grijjy.inc'} 4 | 5 | interface 6 | 7 | uses 8 | {$IFDEF LINUX} 9 | Posix.Signal, 10 | {$ENDIF} 11 | {$IFDEF MSWINDOWS} 12 | Windows, 13 | {$ENDIF} 14 | System.SysUtils, 15 | System.SyncObjs; 16 | 17 | function WaitForCtrlC(const ATimeout: Cardinal = INFINITE): Boolean; 18 | 19 | var 20 | CtrlC: Boolean = False; 21 | 22 | implementation 23 | 24 | var 25 | CtrlC_Event: TEvent; 26 | 27 | {$IFDEF MSWINDOWS} 28 | function ConsoleCtrlHandler(dwCtrlType: DWORD): BOOL; stdcall; 29 | begin 30 | if (dwCtrlType = CTRL_C_EVENT) then 31 | begin 32 | CtrlC_Event.SetEvent; 33 | CtrlC := True; 34 | end; 35 | Result := True; 36 | end; 37 | {$ENDIF} 38 | 39 | {$IFDEF LINUX} 40 | var 41 | sigIntHandler: sigaction_t; 42 | 43 | procedure SigHandler(SigNum: Integer); cdecl; 44 | begin 45 | CtrlC_Event.SetEvent; 46 | end; 47 | {$ENDIF} 48 | 49 | function WaitForCtrlC(const ATimeout: Cardinal): Boolean; 50 | begin 51 | Result := (CtrlC_Event.WaitFor(ATimeout) = TWaitResult.wrTimeout); 52 | end; 53 | 54 | {$IFDEF MSWINDOWS} 55 | procedure DisableQuickEdit; 56 | const 57 | ENABLE_QUICK_EDIT = $40; 58 | ENABLE_EXTENDED_FLAGS = $80; 59 | var 60 | StdHandle: THandle; 61 | Mode: UInt32; 62 | begin 63 | StdHandle := GetStdHandle(STD_INPUT_HANDLE); 64 | GetConsoleMode(StdHandle, Mode); 65 | Mode := Mode and not ENABLE_QUICK_EDIT; 66 | Mode := Mode and not ENABLE_LINE_INPUT; 67 | Mode := Mode and not ENABLE_MOUSE_INPUT; 68 | Mode := Mode and not ENABLE_EXTENDED_FLAGS; 69 | SetConsoleMode(StdHandle, Mode); 70 | end; 71 | {$ENDIF} 72 | 73 | initialization 74 | CtrlC_Event := TEvent.Create(nil, True, False, ''); 75 | 76 | {$IFDEF MSWINDOWS} 77 | Windows.SetConsoleCtrlHandler(@ConsoleCtrlHandler, True); 78 | DisableQuickEdit; 79 | {$ENDIF} 80 | {$IFDEF LINUX} 81 | sigIntHandler._u.sa_handler := @SigHandler; 82 | sigemptyset(sigIntHandler.sa_mask); 83 | sigIntHandler.sa_flags := 0; 84 | sigaction(SIGINT, @sigIntHandler, nil); 85 | {$ENDIF} 86 | 87 | finalization 88 | CtrlC_Event.Free; 89 | 90 | end. 91 | -------------------------------------------------------------------------------- /UnitTests/GrijjyFoundationTests.dpr: -------------------------------------------------------------------------------- 1 | program GrijjyFoundationTests; 2 | 3 | {$IFNDEF TESTINSIGHT} 4 | {$APPTYPE CONSOLE} 5 | {$WARN SYMBOL_PLATFORM OFF} 6 | {$ENDIF} 7 | 8 | {$STRONGLINKTYPES ON} 9 | 10 | uses 11 | System.SysUtils, 12 | DUnitX.TestFramework, 13 | DUnitX.Loggers.Console, 14 | DUnitX.Loggers.Xml.NUnit, 15 | Tests.Grijjy.Collections.Base in 'Tests\Tests.Grijjy.Collections.Base.pas', 16 | Tests.Grijjy.Collections.Sets in 'Tests\Tests.Grijjy.Collections.Sets.pas', 17 | Tests.Grijjy.Collections.RingBuffer in 'Tests\Tests.Grijjy.Collections.RingBuffer.pas', 18 | Tests.Grijjy.Collections.Lists in 'Tests\Tests.Grijjy.Collections.Lists.pas', 19 | Tests.Grijjy.Collections.Dictionaries in 'Tests\Tests.Grijjy.Collections.Dictionaries.pas', 20 | Tests.Grijjy.Bson in 'Tests\Tests.Grijjy.Bson.pas', 21 | Tests.Grijjy.Bson.IO in 'Tests\Tests.Grijjy.Bson.IO.pas', 22 | Tests.Grijjy.Bson.Serialization in 'Tests\Tests.Grijjy.Bson.Serialization.pas', 23 | Tests.Grijjy.ProtocolBuffers in 'Tests\Tests.Grijjy.ProtocolBuffers.pas', 24 | Tests.Grijjy.PropertyBag in 'Tests\Tests.Grijjy.PropertyBag.pas'; 25 | 26 | var 27 | runner : ITestRunner; 28 | results : IRunResults; 29 | logger : ITestLogger; 30 | nunitLogger : ITestLogger; 31 | begin 32 | {$IFDEF TESTINSIGHT} 33 | TestInsight.DUnitX.RunRegisteredTests; 34 | exit; 35 | {$ENDIF} 36 | try 37 | //Check command line options, will exit if invalid 38 | TDUnitX.CheckCommandLine; 39 | //Create the test runner 40 | runner := TDUnitX.CreateRunner; 41 | //Tell the runner to use RTTI to find Fixtures 42 | runner.UseRTTI := True; 43 | //tell the runner how we will log things 44 | //Log to the console window 45 | logger := TDUnitXConsoleLogger.Create(true); 46 | runner.AddLogger(logger); 47 | 48 | //Generate an NUnit compatible XML File 49 | nunitLogger := TDUnitXXMLNUnitFileLogger.Create(TDUnitX.Options.XMLOutputFile); 50 | runner.AddLogger(nunitLogger); 51 | runner.FailsOnNoAsserts := False; //When true, Assertions must be made during tests; 52 | 53 | //Run tests 54 | results := runner.Execute; 55 | if not results.AllPassed then 56 | System.ExitCode := EXIT_ERRORS; 57 | 58 | {$IFNDEF CI} 59 | //We don't want this happening when running under CI. 60 | if (DebugHook <> 0) then 61 | begin 62 | System.Write('Done.. press key to quit.'); 63 | System.Readln; 64 | end; 65 | {$ENDIF} 66 | except 67 | on E: Exception do 68 | System.Writeln(E.ClassName, ': ', E.Message); 69 | end; 70 | end. 71 | -------------------------------------------------------------------------------- /UnitTests/Tests/Tests.Grijjy.Collections.RingBuffer.pas: -------------------------------------------------------------------------------- 1 | unit Tests.Grijjy.Collections.RingBuffer; 2 | 3 | interface 4 | 5 | uses 6 | DUnitX.TestFramework; 7 | 8 | type 9 | TTestTgoRingBuffer = class 10 | public 11 | [Test] 12 | procedure TestReadWrite; 13 | 14 | [Test] 15 | procedure TestTryReadWrite; 16 | end; 17 | 18 | implementation 19 | 20 | uses 21 | Grijjy.Collections; 22 | 23 | { TTestTgoRingBuffer } 24 | 25 | procedure TTestTgoRingBuffer.TestReadWrite; 26 | var 27 | CUT: TgoRingBuffer; 28 | WriteBuffer, ReadBuffer: array [0..99] of Byte; 29 | I: Integer; 30 | begin 31 | CUT := TgoRingBuffer.Create(100); 32 | try 33 | Assert.AreEqual(0, CUT.Read(ReadBuffer)); 34 | 35 | for I := 0 to 99 do 36 | WriteBuffer[I] := i; 37 | Assert.AreEqual(100, CUT.Write(WriteBuffer)); 38 | 39 | Assert.AreEqual(50, CUT.Read(ReadBuffer, 0, 50)); 40 | for I := 0 to 49 do 41 | Assert.AreEqual(I, Integer(ReadBuffer[I])); 42 | 43 | Assert.AreEqual(50, CUT.Write(WriteBuffer)); 44 | 45 | Assert.AreEqual(100, CUT.Read(ReadBuffer)); 46 | for I := 0 to 49 do 47 | Assert.AreEqual(I + 50, Integer(ReadBuffer[I])); 48 | for I := 0 to 49 do 49 | Assert.AreEqual(I, Integer(ReadBuffer[I + 50])); 50 | finally 51 | CUT.Free; 52 | end; 53 | end; 54 | 55 | procedure TTestTgoRingBuffer.TestTryReadWrite; 56 | var 57 | CUT: TgoRingBuffer; 58 | WriteBuffer, ReadBuffer: array [0..70] of Integer; 59 | I, J, Block, BlockCount, ReadValue, WriteValue: Integer; 60 | begin 61 | CUT := TgoRingBuffer.Create(1000); 62 | try 63 | Assert.IsFalse(CUT.TryRead(ReadBuffer)); 64 | 65 | for I := 0 to 13 do 66 | Assert.IsTrue(CUT.TryWrite(WriteBuffer)); 67 | Assert.IsFalse(CUT.TryWrite(WriteBuffer)); 68 | 69 | for I := 0 to 13 do 70 | Assert.IsTrue(CUT.TryRead(ReadBuffer)); 71 | Assert.IsFalse(CUT.TryRead(ReadBuffer)); 72 | Assert.AreEqual(0, CUT.Count); 73 | 74 | ReadValue := 0; 75 | WriteValue := 0; 76 | 77 | for I := 0 to 999 do 78 | begin 79 | BlockCount := Random(5) + 1; 80 | for Block := 0 to BlockCount - 1 do 81 | begin 82 | for J := 0 to 70 do 83 | WriteBuffer[J] := WriteValue; 84 | if (CUT.TryWrite(WriteBuffer)) then 85 | Inc(WriteValue); 86 | end; 87 | 88 | BlockCount := Random(5) + 1; 89 | for Block := 0 to BlockCount - 1 do 90 | begin 91 | if (CUT.TryRead(ReadBuffer)) then 92 | begin 93 | for J := 0 to 70 do 94 | Assert.AreEqual(ReadValue, ReadBuffer[J]); 95 | Inc(ReadValue); 96 | end; 97 | end; 98 | end; 99 | 100 | while CUT.TryRead(ReadBuffer) do 101 | begin 102 | for J := 0 to 70 do 103 | Assert.AreEqual(ReadValue, ReadBuffer[J]); 104 | Inc(ReadValue); 105 | end; 106 | finally 107 | CUT.Free; 108 | end; 109 | end; 110 | 111 | initialization 112 | TDUnitX.RegisterTestFixture(TTestTgoRingBuffer); 113 | 114 | end. 115 | -------------------------------------------------------------------------------- /Grijjy.Social.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.Social; 2 | 3 | { Cross social network types and classes } 4 | 5 | { Note: This unit should only used by clients as it will embed social libraries and SDKs } 6 | 7 | {$I Grijjy.inc} 8 | 9 | interface 10 | 11 | uses 12 | System.Messaging, 13 | {$IFDEF TWTR} 14 | Grijjy.TWTR, 15 | {$ENDIF} 16 | Grijjy.FBSDK; 17 | 18 | type 19 | TgoSocialNetwork = (None, Facebook, Twitter); 20 | 21 | type 22 | TgoSocialLogin = record 23 | public 24 | Result: Boolean; 25 | Network: TgoSocialNetwork; 26 | Id: String; 27 | AccessToken: String; 28 | public 29 | procedure Initialize; 30 | end; 31 | 32 | TgoSocialLoginMessage = class(TMessage) 33 | public 34 | constructor Create(const ASocialLogin: TgoSocialLogin); 35 | end; 36 | 37 | type 38 | TgoSocial = class 39 | class var FFacebook: TgoFacebook; 40 | {$IFDEF TWTR} 41 | class var FTwitter: TTwitter; 42 | {$ENDIF} 43 | public 44 | class function Facebook: TgoFacebook; static; 45 | {$IFDEF TWTR} 46 | class function Twitter: TgoTwitter; static; 47 | {$ENDIF} 48 | public 49 | procedure Login(const ANetwork: TgoSocialNetwork); 50 | procedure GetSelf(const ANetwork: TgoSocialNetwork); 51 | public 52 | constructor Create; 53 | destructor Destroy; override; 54 | end; 55 | 56 | implementation 57 | 58 | { TgoSocialLogin } 59 | 60 | procedure TgoSocialLogin.Initialize; 61 | begin 62 | Result := False; 63 | Network := TgoSocialNetwork.None; 64 | Id := ''; 65 | AccessToken := ''; 66 | end; 67 | 68 | { TgoSocialLoginMessage } 69 | 70 | constructor TgoSocialLoginMessage.Create(const ASocialLogin: TgoSocialLogin); 71 | begin 72 | inherited Create(ASocialLogin); 73 | end; 74 | 75 | { TgoSocial } 76 | 77 | constructor TgoSocial.Create; 78 | begin 79 | {$IFDEF TWTR} 80 | FTwitter := nil; 81 | {$ENDIF} 82 | FFacebook := nil; 83 | end; 84 | 85 | destructor TgoSocial.Destroy; 86 | begin 87 | {$IFDEF TWTR} 88 | if FTwitter <> nil then 89 | FTwitter.Free; 90 | {$ENDIF} 91 | if FFacebook <> nil then 92 | FFacebook.Free; 93 | inherited; 94 | end; 95 | 96 | {$IFDEF TWTR} 97 | class function TgoSocial.Twitter: TgoTwitter; 98 | begin 99 | if FTwitter = nil then 100 | FTwitter := TgoTwitter.Create; 101 | Result := FTwitter; 102 | end; 103 | {$ENDIF} 104 | 105 | class function TgoSocial.Facebook: TgoFacebook; 106 | begin 107 | if FFacebook = nil then 108 | FFacebook := TgoFacebook.Create; 109 | Result := FFacebook; 110 | end; 111 | 112 | procedure TgoSocial.Login(const ANetwork: TgoSocialNetwork); 113 | begin 114 | case ANetwork of 115 | TgoSocialNetwork.Facebook: Facebook.Login; 116 | {$IFDEF TWTR} 117 | TgoSocialNetwork.Twitter: Twitter.Login; 118 | {$ENDIF} 119 | end; 120 | end; 121 | 122 | procedure TgoSocial.GetSelf(const ANetwork: TgoSocialNetwork); 123 | begin 124 | case ANetwork of 125 | TgoSocialNetwork.Facebook: Facebook.GetSelf; 126 | {$IFDEF TWTR} 127 | TgoSocialNetwork.Twitter: Twitter.GetSelf; 128 | {$ENDIF} 129 | end; 130 | end; 131 | 132 | end. 133 | -------------------------------------------------------------------------------- /Macapi.Gcd.pas: -------------------------------------------------------------------------------- 1 | unit Macapi.Gcd; 2 | { Mising header translations for Grand Central Dispatch for macOS and iOS } 3 | 4 | {$INCLUDE 'Grijjy.inc'} 5 | 6 | interface 7 | 8 | uses 9 | System.SysUtils, 10 | Macapi.Dispatch, 11 | Macapi.CoreServices, 12 | Macapi.CoreFoundation; 13 | 14 | const 15 | {$IFDEF IOS} 16 | libDispatch = '/usr/lib/libSystem.dylib'; // Workaround for incorrect setting for iOS in Macapi.Dispatch 17 | {$ELSE} 18 | libDispatch = '/usr/lib/system/libdispatch.dylib'; 19 | {$ENDIF} 20 | 21 | DISPATCH_QUEUE_SERIAL = nil; 22 | DISPATCH_QUEUE_PRIORITY_DEFAULT = 0; 23 | 24 | DISPATCH_TIMER_WALL_CLOCK = $4; 25 | DISPATCH_TIMER_INTERVAL = $8; 26 | DISPATCH_TIMER_WITH_AGGREGATE = $10; 27 | 28 | DISPATCH_TIMER_ONESHOT = $1; 29 | DISPATCH_TIMER_TYPE_MASK = $1; 30 | DISPATCH_TIMER_ABSOLUTE = $0; 31 | DISPATCH_TIMER_CLOCK_MASK = $2; 32 | 33 | type 34 | dispatch_queue_t = dispatch_object_t; 35 | dispatch_group_t = dispatch_object_t; 36 | dispatch_source_t = dispatch_object_t; 37 | dispatch_source_type_t = dispatch_object_t; 38 | dispatch_block_t = Pointer; 39 | 40 | function dispatch_group_create:dispatch_group_t; 41 | cdecl; external libDispatch name _PU + 'dispatch_group_create'; 42 | 43 | function dispatch_group_wait(group: dispatch_group_t; 44 | timeout: dispatch_time_t): UInt64; 45 | cdecl; external libDispatch name _PU + 'dispatch_group_wait'; 46 | 47 | function dispatch_get_global_queue(priority: LongInt; flags: LongInt): dispatch_queue_t; 48 | cdecl; external libDispatch name _PU + 'dispatch_get_global_queue'; 49 | 50 | procedure dispatch_group_async_f(group: dispatch_group_t; 51 | queue: dispatch_queue_t; context: pointer; 52 | work: dispatch_function_t); 53 | cdecl; external libDispatch name _PU + 'dispatch_group_async_f'; 54 | 55 | procedure dispatch_release(obj: dispatch_object_t); 56 | cdecl; external libDispatch name _PU + 'dispatch_release'; 57 | 58 | function dispatch_source_create(&type: dispatch_source_type_t; 59 | handle: NativeUInt; mask: NativeUInt; 60 | queue: dispatch_queue_t): dispatch_source_t; 61 | cdecl; external libDispatch name _PU + 'dispatch_source_create'; 62 | 63 | procedure dispatch_source_set_timer(source: dispatch_source_t; 64 | start: dispatch_time_t; 65 | interval: LongInt; leeway: LongInt); 66 | cdecl; external libDispatch name _PU + 'dispatch_source_set_timer'; 67 | 68 | procedure dispatch_source_set_event_handler(source: dispatch_source_t; 69 | handler: dispatch_block_t); 70 | cdecl; external libDispatch name _PU + 'dispatch_source_set_event_handler'; 71 | 72 | procedure dispatch_resume(source: dispatch_source_t); 73 | cdecl; external libDispatch name _PU + 'dispatch_resume'; 74 | 75 | procedure dispatch_source_cancel(source: dispatch_source_t); 76 | cdecl; external libDispatch name _PU + 'dispatch_source_cancel'; 77 | 78 | var 79 | DISPATCH_SOURCE_TYPE_TIMER: dispatch_source_type_t = nil; 80 | 81 | implementation 82 | 83 | function InitLibDispatch: Boolean; 84 | var 85 | HandleLibDispatch: HMODULE; 86 | begin 87 | Result := False; 88 | HandleLibDispatch := LoadLibrary(PWideChar(libdispatch)); 89 | if HandleLibDispatch <> 0 then 90 | try 91 | DISPATCH_SOURCE_TYPE_TIMER := dispatch_source_type_t(GetProcAddress(HandleLibDispatch, PWideChar('_dispatch_source_type_timer'))); 92 | 93 | Result := True; 94 | finally 95 | FreeLibrary(HandleLibDispatch); 96 | end; 97 | end; 98 | 99 | initialization 100 | InitLibDispatch; 101 | 102 | end. 103 | -------------------------------------------------------------------------------- /Grijjy.Hash.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.Hash; 2 | 3 | {$INCLUDE 'Grijjy.inc'} 4 | 5 | {$OVERFLOWCHECKS OFF} // required since overflow checks will fail (code works ok w/o checking on) 6 | 7 | interface 8 | 9 | type 10 | { Incremental Murmur-2 hash. 11 | See https://sites.google.com/site/murmurhash/ 12 | Uses the CMurmurHash2A variant, which can be used incrementally. 13 | The results are *not* the same as for goMurmurHash2 in Grijjy.SysUtils } 14 | TgoHashMurmur2 = record 15 | {$REGION 'Internal Declarations'} 16 | private const 17 | M = $5bd1e995; 18 | R = 24; 19 | private 20 | FHash: Cardinal; 21 | FTail: Cardinal; 22 | FCount: Cardinal; 23 | FSize: Cardinal; 24 | private 25 | class procedure Mix(var H, K: Cardinal); static; inline; 26 | private 27 | procedure MixTail(var AData: PByte; var ALength: Integer); 28 | {$ENDREGION 'Internal Declarations'} 29 | public 30 | { Starts a new hash. 31 | 32 | Parameters: 33 | ASeed: (optional) seed value for the hash. 34 | 35 | This is identical to calling Reset. } 36 | class function Create(const ASeed: Integer = 0): TgoHashMurmur2; static; inline; 37 | 38 | { Restarts the hash 39 | 40 | Parameters: 41 | ASeed: (optional) seed value for the hash. 42 | 43 | This is identical to using Create. } 44 | procedure Reset(const ASeed: Integer = 0); inline; 45 | 46 | { Updates the hash with new data. 47 | 48 | Parameters: 49 | AData: the data to hash 50 | ALength: the size of the data in bytes. } 51 | procedure Update(const AData; ALength: Integer); 52 | 53 | { Finishes the hash and returns the hash code. 54 | 55 | Returns: 56 | The hash code } 57 | function Finish: Cardinal; 58 | end; 59 | 60 | implementation 61 | 62 | { TgoHashMurmur2 } 63 | 64 | class function TgoHashMurmur2.Create(const ASeed: Integer): TgoHashMurmur2; 65 | begin 66 | Result.Reset(ASeed); 67 | end; 68 | 69 | function TgoHashMurmur2.Finish: Cardinal; 70 | begin 71 | Mix(FHash, FTail); 72 | Mix(FHash, FSize); 73 | 74 | FHash := FHash xor (FHash shr 13); 75 | FHash := FHash * M; 76 | FHash := FHash xor (FHash shr 15); 77 | 78 | Result := FHash; 79 | end; 80 | 81 | class procedure TgoHashMurmur2.Mix(var H, K: Cardinal); 82 | begin 83 | K := K * M; 84 | K := K xor (K shr R); 85 | K := K * M; 86 | H := H * M; 87 | H := H xor K; 88 | end; 89 | 90 | procedure TgoHashMurmur2.MixTail(var AData: PByte; var ALength: Integer); 91 | begin 92 | while (ALength <> 0) and ((ALength < 4) or (FCount <> 0)) do 93 | begin 94 | FTail := FTail or (AData^ shl (FCount * 8)); 95 | Inc(AData); 96 | Inc(FCount); 97 | Dec(ALength); 98 | 99 | if (FCount = 4) then 100 | begin 101 | Mix(FHash, FTail); 102 | FTail := 0; 103 | FCount := 0; 104 | end; 105 | end; 106 | end; 107 | 108 | procedure TgoHashMurmur2.Reset(const ASeed: Integer); 109 | begin 110 | FHash := ASeed; 111 | FTail := 0; 112 | FCount := 0; 113 | FSize := 0; 114 | end; 115 | 116 | procedure TgoHashMurmur2.Update(const AData; ALength: Integer); 117 | var 118 | Data: PByte; 119 | K: Cardinal; 120 | begin 121 | Inc(FSize, ALength); 122 | Data := @AData; 123 | MixTail(Data, ALength); 124 | while (ALength >= 4) do 125 | begin 126 | K := PCardinal(Data)^; 127 | Mix(FHash, K); 128 | Inc(Data, 4); 129 | Dec(ALength, 4); 130 | end; 131 | MixTail(Data, ALength); 132 | end; 133 | 134 | end. 135 | -------------------------------------------------------------------------------- /Linuxapi.Epoll.pas: -------------------------------------------------------------------------------- 1 | unit Linuxapi.Epoll; 2 | { Linux API for epoll } 3 | 4 | {$I Grijjy.inc} 5 | 6 | interface 7 | 8 | uses 9 | Posix.Base, 10 | Posix.Signal; 11 | 12 | const 13 | EPOLLIN = $01; 14 | EPOLLPRI = $02; 15 | EPOLLOUT = $04; 16 | EPOLLERR = $08; 17 | EPOLLHUP = $10; 18 | EPOLLRDNORM = $40; 19 | EPOLLRDBAND = $80; 20 | EPOLLWRNORM = $100; 21 | EPOLLWRBAND = $200; 22 | EPOLLMSG = $400; 23 | EPOLLRDHUP = $2000; 24 | EPOLLWAKEUP = 1 shl 29; 25 | EPOLLONESHOT = 1 shl 30; 26 | EPOLLET = UInt32(1 shl 31); 27 | 28 | { opcodes epoll_ctl } 29 | EPOLL_CTL_ADD = 1; 30 | EPOLL_CTL_DEL = 2; 31 | EPOLL_CTL_MOD = 3; 32 | 33 | type 34 | epoll_data = record 35 | case Integer of 36 | 0: (ptr: Pointer); 37 | 1: (fd: Integer); 38 | 2: (u32: UInt32); 39 | 3: (u64: UInt64); 40 | end; 41 | 42 | epoll_event = packed record 43 | events: UInt32; 44 | data : epoll_data; 45 | end; 46 | pepoll_event = ^epoll_event; 47 | 48 | ptsigset = ^sigset_t; 49 | 50 | // create an epoll instance 51 | function epoll_create(size: Integer): Integer; cdecl; external libc name _PU + 'epoll_create'; 52 | function epoll_create1(flags: Integer): Integer; cdecl; external libc name _PU + 'epoll_create1'; 53 | 54 | // apply an operation to an epoll instance 55 | function epoll_ctl(epfd: Integer; op: Integer; fd: Integer; event: pepoll_event): Integer; cdecl; external libc name _PU + 'epoll_ctl'; 56 | 57 | // wait for events on an epoll instance 58 | function epoll_wait(epfd: Integer; events: pepoll_event; maxevents, timeout: Integer): Integer; cdecl; external libc name _PU + 'epoll_wait'; 59 | function epoll_pwait(epfd: Integer; events: pepoll_event; maxevents, timeout: Integer; sigmask: ptsigset): Integer; cdecl; external libc name _PU + 'epoll_pwait'; 60 | 61 | { Helpers } 62 | 63 | function EventToString(const AEvent: epoll_event): UnicodeString; 64 | 65 | implementation 66 | 67 | uses 68 | SysUtils; 69 | 70 | { Helpers } 71 | 72 | function EventToString(const AEvent: epoll_event): UnicodeString; 73 | begin 74 | Result := ''; 75 | if (AEvent.events AND EPOLLIN) = EPOLLIN then 76 | Result := Result + 'EPOLLIN '; 77 | if (AEvent.events AND EPOLLPRI) = EPOLLPRI then 78 | Result := Result + 'EPOLLPRI '; 79 | if (AEvent.events AND EPOLLOUT) = EPOLLOUT then 80 | Result := Result + 'EPOLLOUT '; 81 | if (AEvent.events AND EPOLLERR) = EPOLLERR then 82 | Result := Result + 'EPOLLERR '; 83 | if (AEvent.events AND EPOLLHUP) = EPOLLHUP then 84 | Result := Result + 'EPOLLHUP '; 85 | if (AEvent.events AND EPOLLRDNORM) = EPOLLRDNORM then 86 | Result := Result + 'EPOLLRDNORM '; 87 | if (AEvent.events AND EPOLLRDBAND) = EPOLLRDBAND then 88 | Result := Result + 'EPOLLRDBAND '; 89 | if (AEvent.events AND EPOLLWRNORM) = EPOLLWRNORM then 90 | Result := Result + 'EPOLLWRNORM '; 91 | if (AEvent.events AND EPOLLWRBAND) = EPOLLWRBAND then 92 | Result := Result + 'EPOLLWRBAND '; 93 | if (AEvent.events AND EPOLLMSG) = EPOLLMSG then 94 | Result := Result + 'EPOLLMSG '; 95 | if (AEvent.events AND EPOLLRDHUP) = EPOLLRDHUP then 96 | Result := Result + 'EPOLLRDHUP '; 97 | if (AEvent.events AND EPOLLWAKEUP) = EPOLLWAKEUP then 98 | Result := Result + 'EPOLLWAKEUP '; 99 | if (AEvent.events AND EPOLLONESHOT) = EPOLLONESHOT then 100 | Result := Result + 'EPOLLONESHOT '; 101 | if (AEvent.events AND EPOLLET) = EPOLLET then 102 | Result := Result + 'EPOLLET '; 103 | Result := Result.Trim; 104 | end; 105 | 106 | end. 107 | -------------------------------------------------------------------------------- /Grijjy.MemoryPool.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.MemoryPool; 2 | 3 | { A reusable memory pooling class } 4 | 5 | {$I Grijjy.inc} 6 | 7 | interface 8 | 9 | uses 10 | System.Classes, 11 | System.SysUtils, 12 | System.SyncObjs, 13 | System.Generics.Collections; 14 | 15 | const 16 | MAX_BLOCKS_QUEUED = 1024; 17 | 18 | type 19 | TgoMemoryPool = class(TObject) 20 | private 21 | FBlockSize: Integer; 22 | FMaxBlocksQueued: Integer; 23 | FBlocks: TQueue; 24 | FLock: TCriticalSection; 25 | function GetCount: Integer; 26 | function GetSize: Integer; 27 | procedure Clear; 28 | public 29 | constructor Create(const ABlockSize: Integer; const AMaxBlocksQueued: Integer = MAX_BLOCKS_QUEUED); 30 | destructor Destroy; override; 31 | public 32 | function RequestMem: Pointer; overload; 33 | function RequestMem(const AName: String): Pointer; overload; 34 | procedure ReleaseMem(P: Pointer); overload; 35 | procedure ReleaseMem(P: Pointer; const AName: String); overload; 36 | public 37 | property BlockSize: Integer read FBlockSize; 38 | property Count: Integer read GetCount; 39 | property Size: Integer read GetSize; 40 | end; 41 | 42 | implementation 43 | 44 | { TgoMemoryPool } 45 | 46 | constructor TgoMemoryPool.Create(const ABlockSize: Integer; const AMaxBlocksQueued: Integer = MAX_BLOCKS_QUEUED); 47 | begin 48 | FBlockSize := ABlockSize; 49 | FMaxBlocksQueued := AMaxBlocksQueued; 50 | FBlocks := TQueue.Create; 51 | FLock := TCriticalSection.Create; 52 | end; 53 | 54 | destructor TgoMemoryPool.Destroy; 55 | begin 56 | Clear; 57 | FLock.Enter; 58 | try 59 | FBlocks.Free; 60 | finally 61 | FLock.Leave; 62 | end; 63 | FLock.Free; 64 | inherited Destroy; 65 | end; 66 | 67 | function TgoMemoryPool.RequestMem: Pointer; 68 | begin 69 | Result := nil; 70 | FLock.Enter; 71 | try 72 | if FBlocks.Count > 0 then 73 | Result := FBlocks.Dequeue; 74 | finally 75 | FLock.Leave; 76 | end; 77 | if Result = nil then 78 | begin 79 | GetMem(Result, FBlockSize); 80 | if Result <> nil then 81 | FillChar(Result^, FBlockSize, 0); 82 | end; 83 | end; 84 | 85 | function TgoMemoryPool.RequestMem(const AName: String): Pointer; 86 | begin 87 | Result := nil; 88 | FLock.Enter; 89 | try 90 | if FBlocks.Count > 0 then 91 | Result := FBlocks.Dequeue; 92 | finally 93 | FLock.Leave; 94 | end; 95 | if Result = nil then 96 | begin 97 | GetMem(Result, FBlockSize); 98 | if Result <> nil then 99 | FillChar(Result^, FBlockSize, 0); 100 | end; 101 | end; 102 | 103 | procedure TgoMemoryPool.ReleaseMem(P: Pointer); 104 | begin 105 | if P <> nil then 106 | begin 107 | FLock.Enter; 108 | try 109 | if FBlocks.Count < FMaxBlocksQueued then 110 | begin 111 | FBlocks.Enqueue(P); 112 | Exit; 113 | end; 114 | finally 115 | FLock.Leave; 116 | end; 117 | FreeMem(P); 118 | end; 119 | end; 120 | 121 | procedure TgoMemoryPool.ReleaseMem(P: Pointer; const AName: String); 122 | begin 123 | if P <> nil then 124 | begin 125 | FLock.Enter; 126 | try 127 | if FBlocks.Count < FMaxBlocksQueued then 128 | begin 129 | FBlocks.Enqueue(P); 130 | Exit; 131 | end; 132 | finally 133 | FLock.Leave; 134 | end; 135 | FreeMem(P); 136 | end; 137 | end; 138 | 139 | procedure TgoMemoryPool.Clear; 140 | begin 141 | FLock.Enter; 142 | try 143 | while FBlocks.Count > 0 do 144 | FreeMem(FBlocks.Dequeue); 145 | finally 146 | FLock.Leave; 147 | end; 148 | end; 149 | 150 | function TgoMemoryPool.GetCount: Integer; 151 | begin 152 | Result := FBlocks.Count; 153 | end; 154 | 155 | function TgoMemoryPool.GetSize: Integer; 156 | begin 157 | Result := FBlocks.Count * FBlockSize; 158 | end; 159 | 160 | end. -------------------------------------------------------------------------------- /Grijjy.DateUtils.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.DateUtils; 2 | {< System level date/time utilities } 3 | 4 | {$INCLUDE 'Grijjy.inc'} 5 | 6 | interface 7 | 8 | const 9 | { The minimum and maximum number of milliseconds since the Unix epoch that 10 | we can use to convert to and from a TDateTime value without loss in 11 | precision. Note that Delphi's TDateTime type can safely handle a larger 12 | range of milliseconds, but other languages may not. } 13 | MIN_MILLISECONDS_SINCE_EPOCH = -62135596800000; 14 | MAX_MILLISECONDS_SINCE_EPOCH = 253402300799999; 15 | 16 | { Converts a date/time value to a number of milliseconds since the Unix 17 | epoch. 18 | 19 | Parameters: 20 | AValue: the date/time value to convert. 21 | AInputIsUTC: whether AValue is in UTC format. 22 | 23 | Returns: 24 | The number of milliseconds since the Unix epoch. } 25 | function goDateTimeToMillisecondsSinceEpoch(const AValue: TDateTime; 26 | const AInputIsUTC: Boolean): Int64; 27 | 28 | { Converts a number of milliseconds since the Unix epoch to a date/time value. 29 | 30 | Parameters: 31 | AValue: number of milliseconds since the Unix epoch. 32 | AReturnUTC: whether to return the corresponding date/time value in 33 | local time (False) or universal time (True). 34 | 35 | Returns: 36 | The date/time value. 37 | 38 | Raises: 39 | EArgumentOutOfRangeException if AValue cannot be accurately converted to 40 | a date/time value } 41 | function goToDateTimeFromMillisecondsSinceEpoch(const AValue: Int64; 42 | const AReturnUTC: Boolean): TDateTime; 43 | 44 | { Converts a date/time value to a number of ticks that has passed since 45 | midnight, January 1, 0001 UTC. 46 | 47 | Parameters: 48 | AValue: the date/time value to convert. 49 | AInputIsUTC: whether AValue is in UTC format. 50 | 51 | Returns: 52 | The number of ticks. 53 | 54 | There are 10,000 ticks in a milliseconds (or 10 million ticks in a second). } 55 | function goDateTimeToTicks(const AValue: TDateTime; 56 | const AInputIsUTC: Boolean): Int64; 57 | 58 | { Converts a number of ticks that has passed since midnight, January 1, 0001 UTC 59 | to a date/time value. 60 | 61 | Parameters: 62 | AValue: the number of ticks. 63 | AReturnUTC: whether to return the corresponding date/time value in 64 | local time (False) or universal time (True). 65 | 66 | Returns: 67 | The date/time value. 68 | 69 | There are 10,000 ticks in a milliseconds (or 10 million ticks in a second). } 70 | function goDateTimeFromTicks(const AValue: Int64; 71 | const AReturnUTC: Boolean): TDateTime; 72 | 73 | implementation 74 | 75 | uses 76 | System.SysUtils, 77 | System.DateUtils, 78 | System.RTLConsts, 79 | System.TimeSpan; 80 | 81 | const 82 | UTC_MIDNIGHT_JAN_0001: TDateTime = -693593; 83 | 84 | function goDateTimeToMillisecondsSinceEpoch(const AValue: TDateTime; 85 | const AInputIsUTC: Boolean): Int64; 86 | var 87 | Date: TDateTime; 88 | begin 89 | if AInputIsUTC then 90 | Date := AValue 91 | else 92 | Date := TTimeZone.Local.ToUniversalTime(AValue); 93 | 94 | Result := MilliSecondsBetween(UnixDateDelta, Date); 95 | if (Date < UnixDateDelta) then 96 | Result := -Result; 97 | end; 98 | 99 | function goToDateTimeFromMillisecondsSinceEpoch( 100 | const AValue: Int64; const AReturnUTC: Boolean): TDateTime; 101 | begin 102 | if (AValue < MIN_MILLISECONDS_SINCE_EPOCH) or (AValue > MAX_MILLISECONDS_SINCE_EPOCH) then 103 | raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); 104 | 105 | if AReturnUTC then 106 | Result := IncMilliSecond(UnixDateDelta, AValue) 107 | else 108 | Result := TTimeZone.Local.ToLocalTime(IncMilliSecond(UnixDateDelta, AValue)); 109 | end; 110 | 111 | function goDateTimeToTicks(const AValue: TDateTime; 112 | const AInputIsUTC: Boolean): Int64; 113 | var 114 | Timespan: TTimeSpan; 115 | begin 116 | if (AInputIsUTC) then 117 | Timespan := TTimespan.Subtract(AValue, UTC_MIDNIGHT_JAN_0001) 118 | else 119 | Timespan := TTimespan.Subtract(TTimeZone.Local.ToUniversalTime(AValue), UTC_MIDNIGHT_JAN_0001); 120 | Result := Timespan.Ticks; 121 | end; 122 | 123 | function goDateTimeFromTicks(const AValue: Int64; 124 | const AReturnUTC: Boolean): TDateTime; 125 | var 126 | Timespan: TTimeSpan; 127 | begin 128 | Timespan := TTimeSpan.FromTicks(AValue); 129 | Result := UTC_MIDNIGHT_JAN_0001 + Timespan; 130 | if (not AReturnUTC) then 131 | Result := TTimeZone.Local.ToLocalTime(Result); 132 | end; 133 | 134 | end. 135 | -------------------------------------------------------------------------------- /Grijjy.TimerQueue.Win.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.TimerQueue.Win; 2 | { Windows based timer queue } 3 | 4 | {$I Grijjy.inc} 5 | 6 | interface 7 | 8 | uses 9 | System.Classes, 10 | System.SysUtils, 11 | System.SyncObjs, 12 | System.DateUtils, 13 | System.Generics.Collections, 14 | Winapi.Windows; 15 | 16 | type 17 | TgoTimer = class; 18 | TOnTimer = procedure(const ASender: TObject) of object; 19 | 20 | { Timer object } 21 | TgoTimer = class(TObject) 22 | private 23 | FHandle: THandle; 24 | FInterval: Cardinal; 25 | FOnTimer: TOnTimer; 26 | public 27 | constructor Create; 28 | destructor Destroy; override; 29 | public 30 | { Handle of the timer object } 31 | property Handle: THandle read FHandle; 32 | 33 | { Timer interval in milliseconds } 34 | property Interval: Cardinal read FInterval; 35 | 36 | { Timer callback event } 37 | property OnTimer: TOnTimer read FOnTimer write FOnTimer; 38 | end; 39 | 40 | { Timer queue instance } 41 | TgoTimerQueue = class(TObject) 42 | private 43 | FHandle: THandle; 44 | private 45 | procedure _Release(const ATimer: TgoTimer); 46 | procedure ReleaseAll; 47 | public 48 | constructor Create; 49 | destructor Destroy; override; 50 | public 51 | { Adds a new timer to the queue} 52 | function Add(const AInterval: Cardinal; const AOnTimer: TOnTimer): THandle; 53 | 54 | { Release an existing timer } 55 | procedure Release(const AHandle: THandle); 56 | 57 | { Change the internal rate of a timer } 58 | function SetInterval(const AHandle: THandle; const AInterval: Cardinal): Boolean; 59 | end; 60 | 61 | implementation 62 | 63 | var 64 | _Timers: TDictionary; 65 | _TimersLock: TCriticalSection; 66 | 67 | { TgoTimer } 68 | 69 | constructor TgoTimer.Create; 70 | begin 71 | inherited; 72 | FHandle := INVALID_HANDLE_VALUE; 73 | FInterval := 0; 74 | FOnTimer := nil; 75 | end; 76 | 77 | destructor TgoTimer.Destroy; 78 | begin 79 | inherited; 80 | end; 81 | 82 | { TgoTimerQueue } 83 | 84 | constructor TgoTimerQueue.Create; 85 | begin 86 | FHandle := CreateTimerQueue; 87 | end; 88 | 89 | destructor TgoTimerQueue.Destroy; 90 | begin 91 | ReleaseAll; 92 | DeleteTimerQueueEx(FHandle, INVALID_HANDLE_VALUE); 93 | FHandle := INVALID_HANDLE_VALUE; 94 | end; 95 | 96 | procedure WaitOrTimerCallback(Timer: TgoTimer; TimerOrWaitFired: ByteBool); stdcall; 97 | begin 98 | if Timer <> nil then 99 | begin 100 | _TimersLock.Enter; 101 | try 102 | if not _Timers.ContainsKey(Timer.Handle) then 103 | Exit; 104 | finally 105 | _TimersLock.Leave; 106 | end; 107 | if TimerOrWaitFired then 108 | if Assigned(Timer.OnTimer) then 109 | Timer.OnTimer(Timer); 110 | end; 111 | end; 112 | 113 | function TgoTimerQueue.Add(const AInterval: Cardinal; const AOnTimer: TOnTimer): THandle; 114 | var 115 | Timer: TgoTimer; 116 | begin 117 | Result := 0; 118 | 119 | { create a timer object } 120 | Timer := TgoTimer.Create; 121 | Timer.FInterval := AInterval; 122 | Timer.FOnTimer := AOnTimer; 123 | if CreateTimerQueueTimer(Timer.FHandle, FHandle, @WaitOrTimerCallback, Timer, 0, AInterval, 0) then 124 | begin 125 | _TimersLock.Enter; 126 | try 127 | _Timers.Add(Timer.Handle, Timer); 128 | Result := Timer.Handle; 129 | finally 130 | _TimersLock.Leave; 131 | end; 132 | end 133 | else 134 | FreeAndNil(Timer); 135 | end; 136 | 137 | procedure TgoTimerQueue._Release(const ATimer: TgoTimer); 138 | begin 139 | ATimer.OnTimer := nil; 140 | 141 | { the DeleteTimerQueueTimer API will block until all the callbacks are completed } 142 | if DeleteTimerQueueTimer(FHandle, ATimer.Handle, INVALID_HANDLE_VALUE) then 143 | ATimer.Free; 144 | end; 145 | 146 | procedure TgoTimerQueue.Release(const AHandle: THandle); 147 | var 148 | Timer: TgoTimer; 149 | begin 150 | Timer := nil; 151 | _TimersLock.Enter; 152 | try 153 | if _Timers.TryGetValue(AHandle, Timer) then 154 | _Timers.Remove(AHandle); 155 | finally 156 | _TimersLock.Leave; 157 | end; 158 | if Timer <> nil then 159 | _Release(Timer); 160 | end; 161 | 162 | procedure TgoTimerQueue.ReleaseAll; 163 | var 164 | Timer: TgoTimer; 165 | begin 166 | _TimersLock.Enter; 167 | try 168 | for Timer in _Timers.Values do 169 | _Release(Timer); 170 | _Timers.Clear; 171 | finally 172 | _TimersLock.Leave; 173 | end; 174 | end; 175 | 176 | function TgoTimerQueue.SetInterval(const AHandle: THandle; const AInterval: Cardinal): Boolean; 177 | var 178 | Timer: TgoTimer; 179 | begin 180 | Result := False; 181 | _TimersLock.Enter; 182 | try 183 | if _Timers.TryGetValue(AHandle, Timer) then 184 | if ChangeTimerQueueTimer(FHandle, Timer.Handle, 0, AInterval) then 185 | begin 186 | Timer.FInterval := AInterval; 187 | Result := True; 188 | end; 189 | finally 190 | _TimersLock.Leave; 191 | end; 192 | end; 193 | 194 | initialization 195 | _Timers := TDictionary.Create; 196 | _TimersLock := TCriticalSection.Create; 197 | 198 | finalization 199 | _TimersLock.Enter; 200 | try 201 | _Timers.Free; 202 | finally 203 | _TimersLock.Leave; 204 | end; 205 | _TimersLock.Free; 206 | 207 | end. 208 | -------------------------------------------------------------------------------- /Grijjy.RemotePush.Sender.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.RemotePush.Sender; 2 | 3 | { Remote push notifications for iOS and Android } 4 | 5 | {$I Grijjy.inc} 6 | 7 | { You should create and reuse an instance of this class to avoid creating 8 | multiple connections to the push notification host. One model would be to 9 | perform notifications in batches based upon time. } 10 | 11 | interface 12 | 13 | uses 14 | Classes, 15 | SysUtils, 16 | Grijjy.Http, 17 | Grijjy.SocketPool.Win, 18 | Grijjy.Bson; 19 | 20 | type 21 | { Remote push sender instance } 22 | TgoRemotePushSender = class(TObject) 23 | protected 24 | FHttp: TgoHTTPClient; 25 | FHttp2: TgoHTTPClient; 26 | private 27 | { Android } 28 | FAndroidAPIKey: String; 29 | private 30 | { iOS } 31 | FAPNSCertificate: TBytes; 32 | FAPNSKey: TBytes; 33 | FAPNSTopic: String; 34 | private 35 | { JSON payload format for Google } 36 | function GoogleCloud_Json_Payload(const ADeviceToken, ATitle, AMessage: String): String; 37 | 38 | { Google cloud push notification } 39 | function GoogleCloud_Send(const AJSON: String; 40 | out AResponse: String; out AStatusCode: Integer): Boolean; 41 | private 42 | { JSON payload format for Apple/iOS } 43 | function APNs_Json_Payload(const ATitle, AMessage: String; 44 | const ABadge: Integer; const ASound: String): String; 45 | 46 | { Apple/iOS push notification } 47 | function APNs_Send(const AJSON: String; const ADeviceToken: String; 48 | out AResponse: String; out AStatusCode: Integer): Boolean; 49 | public 50 | constructor Create; 51 | destructor Destroy; override; 52 | public 53 | { Send push notification } 54 | function Send(const APlatform: TOSVersion.TPlatform; const ADeviceToken: String; 55 | const ATitle, AMessage: String): Boolean; 56 | public 57 | { Android API Key for your app } 58 | property AndroidAPIKey: String read FAndroidAPIKey write FAndroidAPIKey; 59 | 60 | { iOS Certificate } 61 | property APNSCertificate: TBytes read FAPNSCertificate write FAPNSCertificate; 62 | 63 | { iOS Key } 64 | property APNSKey: TBytes read FAPNSKey write FAPNSKey; 65 | 66 | { iOS Topic } 67 | property APNSTopic: String read FAPNSTopic write FAPNSTopic; 68 | end; 69 | 70 | implementation 71 | 72 | uses 73 | System.SyncObjs, 74 | DateUtils, 75 | System.IOUtils; 76 | 77 | function TgoRemotePushSender.GoogleCloud_Json_Payload(const ADeviceToken: String; 78 | const ATitle, AMessage: String): String; 79 | var 80 | Doc, DocData: TgoBsonDocument; 81 | Ids: TgoBsonArray; 82 | begin 83 | DocData := TgoBsonDocument.Create; 84 | DocData['title'] := ATitle.Substring(0, 500); 85 | DocData['message'] := AMessage.Substring(0, 500); { limit to 500 chars } 86 | 87 | { append custom data to json here } 88 | 89 | Ids:= TgoBsonArray.Create; 90 | Ids.Add(ADeviceToken); 91 | 92 | Doc := TgoBsonDocument.Create; 93 | Doc['to'] := ADeviceToken; 94 | Doc['data'] := DocData; 95 | Result := Doc.ToJson; { cannot exceed 4096 bytes } 96 | end; 97 | 98 | function TgoRemotePushSender.GoogleCloud_Send(const AJSON: String; out AResponse: String; out AStatusCode: Integer): Boolean; 99 | begin 100 | if FHttp = nil then 101 | begin 102 | FHttp := TgoHTTPClient.Create; 103 | FHttp.Authorization := 'key=' + FAndroidAPIKey; 104 | FHttp.ContentType := 'application/json'; 105 | end; 106 | FHttp.RequestBody := AJSON; 107 | AResponse := FHttp.Post('https://gcm-http.googleapis.com/gcm/send'); 108 | AStatusCode := FHttp.ResponseStatusCode; 109 | Result := AStatusCode = 200; 110 | end; 111 | 112 | function TgoRemotePushSender.APNs_Json_Payload(const ATitle, AMessage: String; 113 | const ABadge: Integer; const ASound: String): String; 114 | var 115 | Doc, DocAlert, DocPayload: TgoBsonDocument; 116 | begin 117 | DocAlert := TgoBsonDocument.Create; 118 | DocAlert['title'] := ATitle.Substring(0, 500); 119 | DocAlert['body'] := AMessage.Substring(0, 500); { limit to 500 chars } 120 | 121 | DocPayload := TgoBsonDocument.Create; 122 | DocPayload['alert'] := DocAlert; 123 | DocPayload['badge'] := ABadge; 124 | DocPayload['sound'] := ASound; 125 | 126 | Doc := TgoBsonDocument.Create; 127 | Doc['aps'] := DocPayload; 128 | 129 | { append custom data to json here } 130 | 131 | Result := Doc.ToJson; { cannot exceed 4096 bytes for HTTP/2 iOS 9 or later } 132 | end; 133 | 134 | function TgoRemotePushSender.APNs_Send(const AJSON: String; const ADeviceToken: String; 135 | out AResponse: String; out AStatusCode: Integer): Boolean; 136 | begin 137 | if FHttp2 = nil then 138 | begin 139 | FHttp2 := TgoHTTPClient.Create(True); 140 | FHttp2.Certificate := FAPNSCertificate; 141 | FHttp2.PrivateKey := FAPNSKey; 142 | FHttp2.RequestHeaders.AddOrSet('apns-topic', FAPNSTopic); 143 | // FHttp2.RequestHeaders.AddOrSet('apns-id', ''); 144 | // FHttp2.RequestHeaders.AddOrSet('apns-expiration', '0'); 145 | // FHttp2.RequestHeaders.AddOrSet('apns-priority', '10'); 146 | end; 147 | FHttp2.RequestBody := AJSON; 148 | AResponse := FHttp2.Post('https://api.push.apple.com/3/device/' + ADeviceToken); 149 | AStatusCode := FHttp2.ResponseStatusCode; 150 | Result := AStatusCode = 200; 151 | end; 152 | 153 | { TgoRemotePushSender } 154 | 155 | constructor TgoRemotePushSender.Create; 156 | begin 157 | FHttp := nil; 158 | FHttp2 := nil; 159 | end; 160 | 161 | destructor TgoRemotePushSender.Destroy; 162 | begin 163 | if FHttp <> nil then 164 | FHttp.Free; 165 | if FHttp2 <> nil then 166 | FHttp2.Free; 167 | inherited; 168 | end; 169 | 170 | function TgoRemotePushSender.Send(const APlatform: TOSVersion.TPlatform; 171 | const ADeviceToken, ATitle, AMessage: String): Boolean; 172 | var 173 | JSON: String; 174 | Response: String; 175 | StatusCode: Integer; 176 | begin 177 | case APlatform of 178 | TOSVersion.TPlatform.pfiOS: 179 | begin 180 | JSON := APNs_Json_Payload(ATitle, AMessage, 1, 'default'); 181 | Result := APNs_Send(JSON, ADeviceToken, Response, StatusCode); 182 | end; 183 | TOSVersion.TPlatform.pfAndroid: 184 | begin 185 | JSON := GoogleCloud_Json_Payload(ADeviceToken, ATitle, AMessage); 186 | Result := GoogleCloud_Send(JSON, Response, StatusCode); 187 | end; 188 | else 189 | Result := False; 190 | end; 191 | end; 192 | 193 | end. 194 | -------------------------------------------------------------------------------- /Grijjy.BinaryCoding.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.BinaryCoding; 2 | 3 | { Binary encoding algorithms, such as Base64 } 4 | 5 | {$I Grijjy.inc} 6 | 7 | interface 8 | 9 | uses 10 | System.SysUtils; 11 | 12 | { Encodes binary data to a Base64 buffer. 13 | 14 | Parameters: 15 | AData: pointer to the binary data. 16 | ASize: size of the binary data. 17 | 18 | Returns: 19 | A byte array containing the Base64 encoded data } 20 | function goBase64Encode(const AData: Pointer; const ASize: Integer): TBytes; overload; 21 | 22 | { Encodes binary data to a Base64 buffer. 23 | 24 | Parameters: 25 | AData: byte array containing the binary data. 26 | 27 | Returns: 28 | A byte array containing the Base64 encoded data } 29 | function goBase64Encode(const AData: TBytes): TBytes; overload; inline; 30 | 31 | { Decodes Base64-encoded binary data. 32 | 33 | Parameters: 34 | AData: pointer to the Base64-encoded data. 35 | ASize: size of the Base64-encoded data. 36 | 37 | Returns: 38 | A byte array containing the decoded binary data data } 39 | function goBase64Decode(const AData: Pointer; const ASize: Integer): TBytes; overload; 40 | 41 | { Decodes Base64-encoded binary data. 42 | 43 | Parameters: 44 | AData: byte array containing the Base64-encoded data. 45 | 46 | Returns: 47 | A byte array containing the decoded binary data data } 48 | function goBase64Decode(const AData: TBytes): TBytes; overload; inline; 49 | 50 | implementation 51 | 52 | {$POINTERMATH ON} 53 | 54 | const 55 | BASE64_ENCODE: array[0..64] of Byte = ( 56 | // A..Z 57 | $41, $42, $43, $44, $45, $46, $47, $48, $49, $4A, $4B, $4C, $4D, 58 | $4E, $4F, $50, $51, $52, $53, $54, $55, $56, $57, $58, $59, $5A, 59 | // a..z 60 | $61, $62, $63, $64, $65, $66, $67, $68, $69, $6A, $6B, $6C, $6D, 61 | $6E, $6F, $70, $71, $72, $73, $74, $75, $76, $77, $78, $79, $7A, 62 | // 0..9 63 | $30, $31, $32, $33, $34, $35, $36, $37, $38, $39, 64 | // +, /, = 65 | $2B, $2F, $3D); 66 | 67 | const 68 | BASE64_DECODE: array[0..255] of Byte = ( 69 | $FE, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, 70 | $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, 71 | $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $3E, $FF, $FF, $FF, $3F, 72 | $34, $35, $36, $37, $38, $39, $3A, $3B, $3C, $3D, $FF, $FF, $FE, $FF, $FF, $FF, 73 | $FF, $00, $01, $02, $03, $04, $05, $06, $07, $08, $09, $0A, $0B, $0C, $0D, $0E, 74 | $0F, $10, $11, $12, $13, $14, $15, $16, $17, $18, $19, $FF, $FF, $FF, $FF, $FF, 75 | $FF, $1A, $1B, $1C, $1D, $1E, $1F, $20, $21, $22, $23, $24, $25, $26, $27, $28, 76 | $29, $2A, $2B, $2C, $2D, $2E, $2F, $30, $31, $32, $33, $FF, $FF, $FF, $FF, $FF, 77 | $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, 78 | $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, 79 | $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, 80 | $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, 81 | $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, 82 | $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, 83 | $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, 84 | $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF); 85 | 86 | function goBase64Encode(const AData: Pointer; const ASize: Integer): TBytes; 87 | var 88 | Src: PByte; 89 | I, SrcIndex, DstIndex: Integer; 90 | B: Byte; 91 | B64: array [0..3] of Byte; 92 | begin 93 | if (AData = nil) or (ASize = 0) then 94 | Exit(nil); 95 | 96 | SetLength(Result, ((ASize + 2) div 3) * 4); 97 | Src := AData; 98 | SrcIndex := 0; 99 | DstIndex := 0; 100 | 101 | while (SrcIndex < ASize) do 102 | begin 103 | B := Src[SrcIndex]; 104 | Inc(SrcIndex); 105 | 106 | B64[0] := B shr 2; 107 | B64[1] := (B and $03) shl 4; 108 | 109 | if (SrcIndex < ASize) then 110 | begin 111 | B := Src[SrcIndex]; 112 | Inc(SrcIndex); 113 | 114 | B64[1] := B64[1] + (B shr 4); 115 | B64[2] := (B and $0F) shl 2; 116 | 117 | if (SrcIndex < ASize) then 118 | begin 119 | B := Src[SrcIndex]; 120 | Inc(SrcIndex); 121 | 122 | B64[2] := B64[2] + (B shr 6); 123 | B64[3] := B and $3F; 124 | end 125 | else 126 | B64[3] := $40; 127 | end 128 | else 129 | begin 130 | B64[2] := $40; 131 | B64[3] := $40; 132 | end; 133 | 134 | for I := 0 to 3 do 135 | begin 136 | Assert(B64[I] < Length(BASE64_ENCODE)); 137 | Assert(DstIndex < Length(Result)); 138 | Result[DstIndex] := BASE64_ENCODE[B64[I]]; 139 | Inc(DstIndex); 140 | end; 141 | end; 142 | SetLength(Result, DstIndex); 143 | end; 144 | 145 | function goBase64Encode(const AData: TBytes): TBytes; 146 | begin 147 | if Assigned(AData) then 148 | Result := goBase64Encode(@AData[0], Length(AData)) 149 | else 150 | Result := nil; 151 | end; 152 | 153 | function goBase64Decode(const AData: Pointer; const ASize: Integer): TBytes; overload; 154 | var 155 | Src: PByte; 156 | SrcIndex, DstIndex, Count: Integer; 157 | B: Byte; 158 | C: Cardinal; 159 | begin 160 | if (AData = nil) or (ASize = 0) then 161 | Exit(nil); 162 | 163 | SetLength(Result, (ASize div 4) * 3 + 4); 164 | Src := AData; 165 | SrcIndex := 0; 166 | DstIndex := 0; 167 | C := 0; 168 | Count := 4; 169 | 170 | while (SrcIndex < ASize) do 171 | begin 172 | B := BASE64_DECODE[Src[SrcIndex]]; 173 | if (B = $FE) then 174 | Break 175 | else if (B <> $FF) then 176 | begin 177 | C := (C shl 6) or B; 178 | Dec(Count); 179 | if (Count = 0) then 180 | begin 181 | Result[DstIndex + 2] := Byte(C); 182 | Result[DstIndex + 1] := Byte(C shr 8); 183 | Result[DstIndex ] := Byte(C shr 16); 184 | Inc(DstIndex, 3); 185 | C := 0; 186 | Count := 4; 187 | end; 188 | end; 189 | Inc(SrcIndex); 190 | end; 191 | 192 | if (Count = 1) then 193 | begin 194 | Result[DstIndex + 1] := Byte(C shr 2); 195 | Result[DstIndex ] := Byte(C shr 10); 196 | Inc(DstIndex, 2); 197 | end 198 | else if (Count = 2) then 199 | begin 200 | Result[DstIndex] := Byte(C shr 4); 201 | Inc(DstIndex); 202 | end; 203 | 204 | SetLength(Result, DstIndex); 205 | end; 206 | 207 | function goBase64Decode(const AData: TBytes): TBytes; overload; inline; 208 | begin 209 | if Assigned(AData) then 210 | Result := goBase64Decode(@AData[0], Length(AData)) 211 | else 212 | Result := nil; 213 | end; 214 | 215 | end. 216 | -------------------------------------------------------------------------------- /Grijjy.Hooking.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.Hooking; 2 | 3 | { Cross-platform function hooking and VMT patching } 4 | 5 | interface 6 | 7 | { Tries to hook the code at ACodeAddress and redirect it to AHookAddress. 8 | Returns True on success or False on failure. 9 | 10 | Example usage: 11 | HookCode(@TObject.NewInstance, @HookedNewInstance); 12 | 13 | This redirects all call to the TObject.NewInstance method and redirect them 14 | to the HookedNewInstance routine. 15 | 16 | This kind of hooking will likely succeed on Windows, macOS, iOS Simulator and 17 | Linux, but is not supported on ARM platforms like iOS and Android. On those 18 | platforms, use HookVMT instead, } 19 | function HookCode(const ACodeAddress, AHookAddress: Pointer): Boolean; 20 | 21 | { Tries to hook entry AVMTEntry in a Virtual Method Table to point to the 22 | routine in AHookAddress. 23 | Returns True on success or False on failure. 24 | 25 | Example usage: 26 | var 27 | Entry: Pointer; 28 | begin 29 | Entry := Pointer(PByte(TObject) + vmtNewInstance); 30 | HookVMT(Entry, @HookedObjectNewInstance); 31 | end; 32 | 33 | Note that, unlike HookCode, you need to call this for EVERY class that you 34 | want to hook, since each each has its own Virtual Method Table. 35 | 36 | This kind of hooking wil likely succeed on Windows, iOS, Android and Linux, 37 | but fail on macOS and iOS Siumulator. On those platforms, use HookCode 38 | instead. } 39 | function HookVMT(const AVMTEntry, AHookAddress: Pointer): Boolean; 40 | 41 | implementation 42 | 43 | uses 44 | {$IF Defined(MSWINDOWS)} 45 | Winapi.Windows; 46 | {$ELSE} 47 | Posix.SysMman, 48 | Posix.Unistd; 49 | {$ENDIF} 50 | 51 | {$IF Defined(CPUX86) or Defined(CPUX64)} 52 | const 53 | { Size of a "jmp " instruction on Intel platforms (1 byte for 54 | the instruction mnemonic and 4 bytes for the displacement) } 55 | SIZE_OF_JUMP = 5; 56 | 57 | { Mnemonic value for the "jmp " opcode. } 58 | JMP_RELATIVE = $E9; 59 | {$ENDIF} 60 | 61 | {$IFNDEF MSWINDOWS} 62 | var 63 | { Will be set during initialization to the size of memory pages on Posix 64 | platforms. } 65 | GPageSize: Integer = 0; 66 | {$ENDIF} 67 | 68 | {$IF Defined(MSWINDOWS)} 69 | 70 | // Windows 71 | 72 | function HookCode(const ACodeAddress, AHookAddress: Pointer): Boolean; 73 | var 74 | OldProtect: DWORD; 75 | P: PByte; 76 | Displacement: Integer; 77 | begin 78 | { We want to replace the first 5 bytes at ACodeAddress with an assembly 79 | JMP instruction. We cannot just change executable code since it is located 80 | in read-only memory pages. We need to change the protection level at 81 | ACodeAddress so we can read, write and execute at that address. 82 | This should always succeed on Windows. } 83 | Result := VirtualProtect(ACodeAddress, SIZE_OF_JUMP, PAGE_EXECUTE_READWRITE, OldProtect); 84 | 85 | if (Result) then 86 | begin 87 | { Change the first byte at ACodeAddress with the opcode for a JMP instruction. } 88 | P := ACodeAddress; 89 | P^ := JMP_RELATIVE; 90 | Inc(P); 91 | 92 | { This kind of jump instruction requires a displacement value. That is the 93 | number of bytes to jump from the location AFTER the JMP instruction. We 94 | calculate this displacement by taking the difference between the address of 95 | our hooked function and the original code address (adjusted for the size of 96 | the jump itself). } 97 | Displacement := UIntPtr(AHookAddress) - (UIntPtr(ACodeAddress) + SIZE_OF_JUMP); 98 | PInteger(P)^ := Displacement; 99 | 100 | { Restore protection level. } 101 | VirtualProtect(ACodeAddress, SIZE_OF_JUMP, OldProtect, OldProtect); 102 | end; 103 | end; 104 | 105 | {$ELSEIF Defined(CPUX86) or Defined(CPUX64)} 106 | 107 | // macOS, iOS Simulator, Linux 108 | 109 | function HookCode(const ACodeAddress, AHookAddress: Pointer): Boolean; 110 | var 111 | AlignedCodeAddress: UIntPtr; 112 | P: PByte; 113 | Displacement: Integer; 114 | begin 115 | { This version is similar to HookCode on Windows, except that we need to use 116 | the "mprotect" API instead of "VirtualProtect". mprotect only works with 117 | while memory pages, so we must align ACodeAddress to the size of a memory 118 | page. This page size is retrieved during initialization using the 119 | "sysconf(_SC_PAGESIZE)" API. } 120 | AlignedCodeAddress := UIntPtr(ACodeAddress) and (not (GPageSize - 1)); 121 | 122 | Result := (mprotect(Pointer(AlignedCodeAddress), GPageSize, PROT_READ or PROT_WRITE or PROT_EXEC) = 0); 123 | 124 | if (Result) then 125 | begin 126 | P := ACodeAddress; 127 | P^ := JMP_RELATIVE; 128 | Inc(P); 129 | 130 | Displacement := UIntPtr(AHookAddress) - (UIntPtr(ACodeAddress) + SIZE_OF_JUMP); 131 | PInteger(P)^ := Displacement; 132 | 133 | { There is no way to query the original protection level, so we cannot restore 134 | to that protection level as we do on Windows. } 135 | end; 136 | end; 137 | 138 | {$ELSE} 139 | 140 | // iOS, Android 141 | 142 | function HookCode(const ACodeAddress, AHookAddress: Pointer): Boolean; 143 | begin 144 | { We are not allowed to change protection levels of executable memory pages 145 | on iOS and Android. } 146 | Result := False; 147 | end; 148 | 149 | {$ENDIF} 150 | 151 | {$IF Defined(MSWINDOWS)} 152 | 153 | // Windows 154 | 155 | function HookVMT(const AVMTEntry, AHookAddress: Pointer): Boolean; 156 | var 157 | OldProtect: DWORD; 158 | begin 159 | { AVMT entry is located in a read-only memory page. We need to change the 160 | protection level, so we can change it. This should always succeed on 161 | Windows. } 162 | 163 | Result := VirtualProtect(AVMTEntry, SizeOf(Pointer), PAGE_READWRITE, OldProtect); 164 | 165 | if (Result) then 166 | begin 167 | { Change entry in VMT } 168 | PPointer(AVMTEntry)^ := AHookAddress; 169 | 170 | { Restore protection level } 171 | VirtualProtect(AVMTEntry, SizeOf(Pointer), OldProtect, OldProtect); 172 | end; 173 | end; 174 | 175 | {$ELSE} 176 | 177 | // macOS, iOS (Simulator), Android, Linux 178 | 179 | function HookVMT(const AVMTEntry, AHookAddress: Pointer): Boolean; 180 | var 181 | AlignedCodeAddress: UIntPtr; 182 | begin 183 | { This version is similar to HookVMT on Windows, except that we need to use 184 | the "mprotect" API instead of "VirtualProtect". mprotect only works with 185 | while memory pages, so we must align AVMTEntry to the size of a memory 186 | page. This page size is retrieved during initialization using the 187 | "sysconf(_SC_PAGESIZE)" API. } 188 | AlignedCodeAddress := UIntPtr(AVMTEntry) and (not (GPageSize - 1)); 189 | 190 | Result := (mprotect(Pointer(AlignedCodeAddress), GPageSize, PROT_READ or PROT_WRITE) = 0); 191 | 192 | if (Result) then 193 | { Change entry in VMT } 194 | PPointer(AVMTEntry)^ := AHookAddress; 195 | end; 196 | 197 | {$ENDIF} 198 | 199 | initialization 200 | {$IFNDEF MSWINDOWS} 201 | GPageSize := sysconf(_SC_PAGESIZE); 202 | {$ENDIF} 203 | 204 | end. 205 | 206 | -------------------------------------------------------------------------------- /UnitTests/Tests/Tests.Grijjy.Collections.Lists.pas: -------------------------------------------------------------------------------- 1 | unit Tests.Grijjy.Collections.Lists; 2 | 3 | interface 4 | 5 | uses 6 | DUnitX.TestFramework, 7 | Tests.Grijjy.Collections.Base, 8 | Grijjy.Collections; 9 | 10 | type 11 | TTestTgoValueList = class(TTestCollectionBase) 12 | private const 13 | LIMIT = 1000; 14 | private type 15 | P = ^T; 16 | private 17 | FCUT: TgoValueList; 18 | FValues: TArray; 19 | procedure SimpleFillList; 20 | public 21 | [Setup] 22 | procedure SetUp; 23 | 24 | [Teardown] 25 | procedure TearDown; 26 | 27 | [Test] 28 | procedure TestInit; 29 | 30 | [Test] 31 | procedure TestAdd; 32 | 33 | [Test] 34 | procedure TestInsert; 35 | 36 | [Test] 37 | procedure TestSimpleDelete; 38 | 39 | [Test] 40 | procedure TestMultipleDelete; 41 | 42 | [Test] 43 | procedure TestClear; 44 | 45 | [Test] 46 | procedure TestFirst; 47 | 48 | [Test] 49 | procedure TestLast; 50 | 51 | [Test] 52 | procedure TestGetEnumerator; 53 | 54 | [Test] 55 | procedure TestModify; 56 | 57 | [Test] 58 | procedure TestSetCountIncrease; 59 | 60 | [Test] 61 | procedure TestSetCountDecrease; 62 | 63 | [Test] 64 | procedure TestDeleteRange; 65 | end; 66 | 67 | implementation 68 | 69 | { TTestTgoValueList } 70 | 71 | procedure TTestTgoValueList.SetUp; 72 | begin 73 | inherited; 74 | FCUT := TgoValueList.Create; 75 | end; 76 | 77 | procedure TTestTgoValueList.SimpleFillList; 78 | var 79 | I: Integer; 80 | begin 81 | FValues := CreateValues(3); 82 | for I := 0 to 2 do 83 | FCUT.Add(FValues[I]); 84 | end; 85 | 86 | procedure TTestTgoValueList.TearDown; 87 | begin 88 | FCUT.Free; 89 | inherited; 90 | end; 91 | 92 | procedure TTestTgoValueList.TestAdd; 93 | var 94 | Values: TArray; 95 | I: Integer; 96 | begin 97 | Values := CreateValues(LIMIT); 98 | for I := 0 to LIMIT - 1 do 99 | begin 100 | Assert.AreEqual(I, FCUT.Count); 101 | Assert.AreEqual(I, FCUT.Add(Values[I])); 102 | TestEquals(Values[I], FCUT[I]^); 103 | end; 104 | end; 105 | 106 | procedure TTestTgoValueList.TestClear; 107 | var 108 | Values: TArray; 109 | I: Integer; 110 | begin 111 | Values := CreateValues(LIMIT); 112 | for I := 0 to LIMIT - 1 do 113 | FCUT.Add(Values[I]); 114 | 115 | FCUT.Clear; 116 | Assert.AreEqual(0, FCUT.Count); 117 | end; 118 | 119 | procedure TTestTgoValueList.TestDeleteRange; 120 | var 121 | Values: TArray; 122 | begin 123 | Values := CreateValues([1, 2, 3, 2, 1]); 124 | FCUT.Add(Values[0]); 125 | FCUT.Add(Values[1]); 126 | FCUT.Add(Values[2]); 127 | FCUT.Add(Values[3]); 128 | FCUT.Add(Values[4]); 129 | FCUT.DeleteRange(1, 3); 130 | Assert.AreEqual(2, FCUT.Count); 131 | TestEquals(Values[0], FCUT[0]^); 132 | TestEquals(Values[4], FCUT[1]^); 133 | end; 134 | 135 | procedure TTestTgoValueList.TestFirst; 136 | begin 137 | SimpleFillList; 138 | TestEquals(FValues[0], FCUT.First^); 139 | end; 140 | 141 | procedure TTestTgoValueList.TestGetEnumerator; 142 | var 143 | Item: P; 144 | I: Integer; 145 | begin 146 | SimpleFillList; 147 | I := 0; 148 | for Item in FCUT do 149 | begin 150 | TestEquals(FValues[I], Item^); 151 | Inc(I); 152 | end; 153 | end; 154 | 155 | procedure TTestTgoValueList.TestInit; 156 | begin 157 | Assert.AreEqual(0, FCUT.Count); 158 | end; 159 | 160 | procedure TTestTgoValueList.TestInsert; 161 | var 162 | Values: TArray; 163 | I: Integer; 164 | begin 165 | Values := CreateValues(LIMIT); 166 | for I := 0 to LIMIT - 1 do 167 | begin 168 | Assert.AreEqual(I, FCUT.Count); 169 | FCUT.Insert(0, Values[I]); 170 | TestEquals(Values[I], FCUT[0]^); 171 | end; 172 | end; 173 | 174 | procedure TTestTgoValueList.TestLast; 175 | begin 176 | SimpleFillList; 177 | TestEquals(FValues[2], FCUT.Last^); 178 | end; 179 | 180 | procedure TTestTgoValueList.TestModify; 181 | var 182 | I: Integer; 183 | Value: P; 184 | NewValues: TArray; 185 | begin 186 | SimpleFillList; 187 | SetLength(NewValues, 3); 188 | for I := 0 to 2 do 189 | NewValues[I] := CreateValue(I + 10); 190 | 191 | for I := 0 to FCUT.Count - 1 do 192 | TestEquals(FValues[I], FCUT[I]^); 193 | 194 | for I := 0 to FCUT.Count - 1 do 195 | begin 196 | Value := FCUT[I]; 197 | Value^ := NewValues[I]; 198 | end; 199 | 200 | for I := 0 to FCUT.Count - 1 do 201 | TestEquals(NewValues[I], FCUT[I]^); 202 | end; 203 | 204 | procedure TTestTgoValueList.TestMultipleDelete; 205 | begin 206 | SimpleFillList; 207 | Assert.AreEqual(3, FCUT.Count); 208 | FCUT.Delete(0); 209 | Assert.AreEqual(2, FCUT.Count); 210 | FCUT.Delete(0); 211 | Assert.AreEqual(1, FCUT.Count); 212 | FCUT.Delete(0); 213 | Assert.AreEqual(0, FCUT.Count); 214 | end; 215 | 216 | procedure TTestTgoValueList.TestSetCountDecrease; 217 | var 218 | Values: TArray; 219 | begin 220 | Values := CreateValues([1, 2, 3, 2, 1]); 221 | FCUT.Add(Values[0]); 222 | FCUT.Add(Values[1]); 223 | FCUT.Add(Values[2]); 224 | FCUT.Add(Values[3]); 225 | FCUT.Add(Values[4]); 226 | FCUT.Count := 3; 227 | 228 | Assert.AreEqual(3, FCUT.Count); 229 | 230 | TestEquals(Values[0], FCUT[0]^); 231 | TestEquals(Values[1], FCUT[1]^); 232 | TestEquals(Values[2], FCUT[2]^); 233 | end; 234 | 235 | procedure TTestTgoValueList.TestSetCountIncrease; 236 | var 237 | Values: TArray; 238 | begin 239 | Values := CreateValues([1, 2, 3, 2, 1]); 240 | FCUT.Add(Values[0]); 241 | FCUT.Add(Values[1]); 242 | FCUT.Add(Values[2]); 243 | FCUT.Add(Values[3]); 244 | FCUT.Add(Values[4]); 245 | FCUT.Count := 7; 246 | 247 | Assert.AreEqual(7, FCUT.Count); 248 | 249 | TestEquals(Values[0], FCUT[0]^); 250 | TestEquals(Values[1], FCUT[1]^); 251 | TestEquals(Values[2], FCUT[2]^); 252 | TestEquals(Values[3], FCUT[3]^); 253 | TestEquals(Values[4], FCUT[4]^); 254 | {$IFNDEF FPC} 255 | TestEquals(Default(T), FCUT[5]^); 256 | TestEquals(Default(T), FCUT[6]^); 257 | {$ENDIF} 258 | end; 259 | 260 | procedure TTestTgoValueList.TestSimpleDelete; 261 | var 262 | Value: T; 263 | begin 264 | Value := CreateValue(1); 265 | FCUT.Add(Value); 266 | Assert.AreEqual(1, FCUT.Count); 267 | FCUT.Delete(0); 268 | Assert.AreEqual(0, FCUT.Count); 269 | end; 270 | 271 | initialization 272 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 273 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 274 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 275 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 276 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 277 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 278 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 279 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 280 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 281 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 282 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 283 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 284 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 285 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 286 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 287 | {$IFNDEF NEXTGEN} 288 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 289 | {$ENDIF} 290 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 291 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 292 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 293 | TDUnitX.RegisterTestFixture(TTestTgoValueList); 294 | end. 295 | -------------------------------------------------------------------------------- /Grijjy.TimerQueue.Linux.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.TimerQueue.Linux; 2 | { Linux based timer queue } 3 | 4 | {$I Grijjy.inc} 5 | 6 | interface 7 | 8 | uses 9 | Posix.Time, 10 | Linuxapi.Timerfd, 11 | Linuxapi.Epoll, 12 | System.Classes, 13 | System.SysUtils, 14 | System.SyncObjs, 15 | System.Generics.Collections; 16 | 17 | const 18 | INVALID_HANDLE_VALUE = THandle(-1); 19 | 20 | { EPoll consts } 21 | IGNORED = 1; 22 | MAX_EVENTS = 1024; 23 | 24 | type 25 | TgoTimer = class; 26 | TOnTimer = procedure(const ASender: TObject) of object; 27 | 28 | { Timer object } 29 | TgoTimer = class(TObject) 30 | private 31 | FHandle: THandle; 32 | FInterval: Cardinal; 33 | FOnTimer: TOnTimer; 34 | private 35 | { internal flags } 36 | FClose: Boolean; 37 | FClosed: TEvent; 38 | public 39 | constructor Create; 40 | destructor Destroy; override; 41 | public 42 | { Handle of the timer object } 43 | property Handle: THandle read FHandle write FHandle; 44 | 45 | { Timer interval in milliseconds } 46 | property Interval: Cardinal read FInterval write FInterval; 47 | 48 | { Timer callback event } 49 | property OnTimer: TOnTimer read FOnTimer write FOnTimer; 50 | end; 51 | 52 | { Timer queue instance } 53 | TgoTimerQueue = class(TObject) 54 | private 55 | function _SetInterval(const AHandle: THandle; const AInterval: Cardinal): Boolean; 56 | procedure _Release(const ATimer: TgoTimer); 57 | procedure ReleaseAll; 58 | public 59 | constructor Create; 60 | destructor Destroy; override; 61 | public 62 | { Adds a new timer to the queue} 63 | function Add(const AInterval: Cardinal; const AOnTimer: TOnTimer): THandle; 64 | 65 | { Release an existing timer } 66 | procedure Release(const AHandle: THandle); 67 | 68 | { Change the internal rate of a timer } 69 | function SetInterval(const AHandle: THandle; const AInterval: Cardinal): Boolean; 70 | end; 71 | 72 | { timer queue worker thread } 73 | TTimerQueuePool = class; 74 | TTimerQueueWorker = class(TThread) 75 | private 76 | FOwner: TTimerQueuePool; 77 | FEvents: array[0..MAX_EVENTS] of epoll_event; 78 | protected 79 | procedure Execute; override; 80 | public 81 | constructor Create(const AOwner: TTimerQueuePool); 82 | destructor Destroy; override; 83 | end; 84 | 85 | { Timer queue pool } 86 | TTimerQueuePool = class(TObject) 87 | private 88 | FHandle: THandle; 89 | FWorkers: array of TTimerQueueWorker; 90 | public 91 | constructor Create(const AWorkers: Integer = 0); 92 | destructor Destroy; override; 93 | public 94 | { EPoll_fd for instance } 95 | property Handle: THandle read FHandle; 96 | end; 97 | 98 | implementation 99 | 100 | uses 101 | Posix.Unistd, 102 | Posix.ErrNo; 103 | 104 | var 105 | _Timers: TDictionary; 106 | _TimersLock: TCriticalSection; 107 | _TimerQueuePool: TTimerQueuePool; 108 | 109 | { TgoTimer } 110 | 111 | constructor TgoTimer.Create; 112 | begin 113 | inherited; 114 | FHandle := INVALID_HANDLE_VALUE; 115 | FInterval := 0; 116 | FOnTimer := nil; 117 | FClose := False; 118 | FClosed := TEvent.Create(nil, True, False, ''); 119 | end; 120 | 121 | destructor TgoTimer.Destroy; 122 | begin 123 | FClosed.Free; 124 | inherited; 125 | end; 126 | 127 | { TgoTimerQueue } 128 | 129 | constructor TgoTimerQueue.Create; 130 | begin 131 | inherited; 132 | end; 133 | 134 | destructor TgoTimerQueue.Destroy; 135 | begin 136 | ReleaseAll; 137 | inherited; 138 | end; 139 | 140 | function TgoTimerQueue._SetInterval(const AHandle: THandle; const AInterval: Cardinal): Boolean; 141 | var 142 | NewValue: itimerspec; 143 | TS: timespec; 144 | begin 145 | FillChar(NewValue, SizeOf(itimerspec), 0); 146 | TS.tv_sec := AInterval DIV 1000; 147 | TS.tv_nsec := (AInterval MOD 1000) * 1000000; 148 | NewValue.it_value := TS; 149 | NewValue.it_interval := TS; 150 | Result := timerfd_settime(AHandle, 0, @NewValue, nil) <> -1; 151 | end; 152 | 153 | function TgoTimerQueue.Add(const AInterval: Cardinal; const AOnTimer: TOnTimer): THandle; 154 | var 155 | Handle: THandle; 156 | Timer: TgoTimer; 157 | Event: epoll_event; 158 | begin 159 | Result := INVALID_HANDLE_VALUE; 160 | 161 | { create a non-blocking timer descriptor } 162 | Handle := timerfd_create(CLOCK_MONOTONIC, TFD_NONBLOCK); 163 | if Handle <> -1 then 164 | begin 165 | { create a timer object } 166 | Timer := TgoTimer.Create; 167 | Timer.Handle := Handle; 168 | Timer.Interval := AInterval; 169 | Timer.OnTimer := AOnTimer; 170 | 171 | { add descriptor to the set } 172 | Event.data.ptr := Timer; 173 | Event.events := EPOLLIN or EPOLLET; 174 | if epoll_ctl(_TimerQueuePool.Handle, EPOLL_CTL_ADD, Handle, @Event) <> -1 then 175 | begin 176 | { start the timer } 177 | if _SetInterval(Handle, AInterval) then 178 | begin 179 | _TimersLock.Enter; 180 | try 181 | _Timers.Add(Handle, Timer); 182 | finally 183 | _TimersLock.Leave; 184 | end; 185 | Result := Handle; 186 | end 187 | else 188 | Timer.Free; 189 | end 190 | else 191 | begin 192 | __close(Handle); 193 | Timer.Free; 194 | end; 195 | end; 196 | end; 197 | 198 | procedure TgoTimerQueue._Release(const ATimer: TgoTimer); 199 | begin 200 | ATimer.FClose := True; 201 | 202 | { timeout quickly } 203 | _SetInterval(ATimer.Handle, 1); 204 | 205 | { wait for closed signal } 206 | ATimer.FClosed.WaitFor(INFINITE); 207 | ATimer.Free; 208 | end; 209 | 210 | procedure TgoTimerQueue.Release(const AHandle: THandle); 211 | var 212 | Timer: TgoTimer; 213 | begin 214 | Timer := nil; 215 | _TimersLock.Enter; 216 | try 217 | if _Timers.TryGetValue(AHandle, Timer) then 218 | _Timers.Remove(AHandle); 219 | finally 220 | _TimersLock.Leave; 221 | end; 222 | if Timer <> nil then 223 | _Release(Timer); 224 | end; 225 | 226 | procedure TgoTimerQueue.ReleaseAll; 227 | var 228 | Timer: TgoTimer; 229 | begin 230 | _TimersLock.Enter; 231 | try 232 | for Timer in _Timers.Values do 233 | _Release(Timer); 234 | _Timers.Clear; 235 | finally 236 | _TimersLock.Leave; 237 | end; 238 | end; 239 | 240 | function TgoTimerQueue.SetInterval(const AHandle: THandle; const AInterval: Cardinal): Boolean; 241 | var 242 | Timer: TgoTimer; 243 | begin 244 | Result := False; 245 | _TimersLock.Enter; 246 | try 247 | if _Timers.TryGetValue(AHandle, Timer) then 248 | if _SetInterval(AHandle, AInterval) then 249 | begin 250 | Timer.Interval := AInterval; 251 | Result := True; 252 | end; 253 | finally 254 | _TimersLock.Leave; 255 | end; 256 | end; 257 | 258 | { TTimerQueueWorker } 259 | 260 | constructor TTimerQueueWorker.Create(const AOwner: TTimerQueuePool); 261 | begin 262 | FOwner := AOwner; 263 | inherited Create(False); 264 | end; 265 | 266 | destructor TTimerQueueWorker.Destroy; 267 | begin 268 | inherited; 269 | end; 270 | 271 | procedure TTimerQueueWorker.Execute; 272 | var 273 | NumberOfEvents: Integer; 274 | I: Integer; 275 | Event: epoll_event; 276 | TotalTimeouts: Int64; 277 | Timer: TgoTimer; 278 | Error: Integer; 279 | begin 280 | while not Terminated do 281 | begin 282 | NumberOfEvents := epoll_wait(FOwner.Handle, @FEvents, MAX_EVENTS, 100); 283 | if NumberOfEvents = 0 then { timeout } 284 | Continue 285 | else 286 | if NumberOfEvents = -1 then { error } 287 | begin 288 | Error := errno; 289 | if Error = EINTR then 290 | Continue 291 | else 292 | Break; 293 | end; 294 | for I := 0 to NumberOfEvents - 1 do 295 | begin 296 | try 297 | Timer := FEvents[I].data.ptr; 298 | if not Timer.FClose then 299 | begin 300 | if (FEvents[I].events AND EPOLLIN) = EPOLLIN then 301 | begin 302 | if __read(Timer.Handle, @TotalTimeouts, SizeOf(TotalTimeouts)) >= 0 then 303 | begin 304 | if Assigned(Timer.FOnTimer) then 305 | Timer.FOnTimer(Timer); 306 | end 307 | else 308 | { read error } 309 | Timer.FClose := True; 310 | end; 311 | end; 312 | finally 313 | if Timer.FClose then 314 | begin 315 | { remove descriptor from the set } 316 | epoll_ctl(_TimerQueuePool.Handle, EPOLL_CTL_DEL, Timer.Handle, @Event); { -1 on error } 317 | 318 | { close the timer handle } 319 | __close(Timer.Handle); 320 | 321 | { trigger closed event } 322 | Timer.FClosed.SetEvent; 323 | end; 324 | end; 325 | end; 326 | end; 327 | end; 328 | 329 | { TTimerQueuePool } 330 | 331 | constructor TTimerQueuePool.Create(const AWorkers: Integer); 332 | var 333 | I: Integer; 334 | Workers: Integer; 335 | begin 336 | inherited Create; 337 | 338 | { create the epoll instance handle } 339 | FHandle := epoll_create(IGNORED); 340 | if FHandle <> -1 then 341 | begin 342 | { create worker threads to handle queued events } 343 | if AWorkers = 0 then 344 | Workers := CPUCount 345 | else 346 | Workers := AWorkers; 347 | SetLength(FWorkers, Workers); 348 | for I := 0 to Workers - 1 do 349 | FWorkers[I] := TTimerQueueWorker.Create(Self); 350 | end 351 | else 352 | raise Exception.Create(Format('epoll_create failed %s',[SysErrorMessage(errno)])); 353 | end; 354 | 355 | destructor TTimerQueuePool.Destroy; 356 | var 357 | Worker: TTimerQueueWorker; 358 | begin 359 | { signal the workers to quit } 360 | for Worker in FWorkers do 361 | Worker.Terminate; 362 | 363 | { wait for them to stop } 364 | for Worker in FWorkers do 365 | Worker.WaitFor; 366 | 367 | { destroy workers } 368 | for Worker in FWorkers do 369 | Worker.Free; 370 | 371 | { close the epoll instance handle } 372 | if FHandle <> -1 then 373 | __close(FHandle); 374 | 375 | inherited Destroy; 376 | end; 377 | 378 | initialization 379 | _TimerQueuePool := TTimerQueuePool.Create; 380 | _Timers := TDictionary.Create; 381 | _TimersLock := TCriticalSection.Create; 382 | 383 | finalization 384 | _TimersLock.Enter; 385 | try 386 | _Timers.Free; 387 | finally 388 | _TimersLock.Leave; 389 | end; 390 | _TimersLock.Free; 391 | _TimerQueuePool.Free; 392 | 393 | end. 394 | -------------------------------------------------------------------------------- /UnitTests/Tests/Tests.Grijjy.Collections.Sets.pas: -------------------------------------------------------------------------------- 1 | unit Tests.Grijjy.Collections.Sets; 2 | 3 | interface 4 | 5 | uses 6 | DUnitX.TestFramework, 7 | Tests.Grijjy.Collections.Base, 8 | Grijjy.Collections; 9 | 10 | type 11 | TTestTgoSet = class(TTestCollectionBase) 12 | private 13 | FCUT: TgoSet; 14 | FValues: TArray; 15 | procedure FillSet; 16 | procedure CheckItems(const AExpected: TArray); 17 | public 18 | [Setup] 19 | procedure SetUp; 20 | 21 | [Teardown] 22 | procedure TearDown; 23 | 24 | [Test] 25 | procedure TestAdd; 26 | 27 | [Test] 28 | procedure TestRemove; 29 | 30 | [Test] 31 | procedure TestClear; 32 | 33 | [Test] 34 | procedure TestAddOrSet; 35 | 36 | [Test] 37 | procedure TestContains; 38 | 39 | [Test] 40 | procedure TestToArray; 41 | 42 | [Test] 43 | procedure TestGetEnumerator; 44 | end; 45 | 46 | type 47 | TTestTgoObjectSet = class(TTestCollectionBase) 48 | private 49 | FCUT: TgoObjectSet; 50 | FValues: TArray; 51 | procedure FillSet; 52 | procedure CheckItems(const AExpectedIndices: array of Integer); 53 | public 54 | [Setup] 55 | procedure SetUp; 56 | 57 | [Teardown] 58 | procedure TearDown; 59 | 60 | [Test] 61 | procedure TestAdd; 62 | 63 | [Test] 64 | procedure TestRemove; 65 | 66 | [Test] 67 | procedure TestClear; 68 | 69 | [Test] 70 | procedure TestAddOrSet; 71 | 72 | [Test] 73 | procedure TestContains; 74 | 75 | [Test] 76 | procedure TestToArray; 77 | 78 | [Test] 79 | procedure TestGetEnumerator; 80 | 81 | [Test] 82 | procedure TestExtract; 83 | end; 84 | 85 | implementation 86 | 87 | uses 88 | System.SysUtils, 89 | System.Generics.Defaults; 90 | 91 | { TTestTgoSet } 92 | 93 | procedure TTestTgoSet.CheckItems(const AExpected: TArray); 94 | var 95 | Value: T; 96 | I: Integer; 97 | begin 98 | Assert.AreEqual(Length(AExpected), FCUT.Count); 99 | 100 | for I := 0 to Length(AExpected) - 1 do 101 | begin 102 | Value := AExpected[I]; 103 | Assert.IsTrue(FCUT.Contains(Value)); 104 | end; 105 | end; 106 | 107 | procedure TTestTgoSet.FillSet; 108 | begin 109 | FValues := CreateValues(3); 110 | FCUT.Add(FValues[0]); 111 | FCUT.Add(FValues[1]); 112 | FCUT.Add(FValues[2]); 113 | end; 114 | 115 | procedure TTestTgoSet.SetUp; 116 | begin 117 | inherited; 118 | FCUT := TgoSet.Create; 119 | end; 120 | 121 | procedure TTestTgoSet.TearDown; 122 | begin 123 | inherited; 124 | FCUT.Free; 125 | end; 126 | 127 | procedure TTestTgoSet.TestAdd; 128 | begin 129 | FillSet; 130 | CheckItems(FValues); 131 | end; 132 | 133 | procedure TTestTgoSet.TestAddOrSet; 134 | var 135 | Values: TArray; 136 | begin 137 | Values := CreateValues(4); 138 | FCUT.Add(Values[0]); 139 | FCUT.Add(Values[1]); 140 | FCUT.Add(Values[2]); 141 | Assert.AreEqual(3, FCUT.Count); 142 | 143 | FCUT.AddOrSet(Values[1]); 144 | Assert.AreEqual(3, FCUT.Count); 145 | 146 | FCUT.AddOrSet(Values[3]); 147 | CheckItems(Values); 148 | end; 149 | 150 | procedure TTestTgoSet.TestClear; 151 | begin 152 | FillSet; 153 | Assert.AreEqual(3, FCUT.Count); 154 | 155 | FCUT.Clear; 156 | Assert.AreEqual(0, FCUT.Count); 157 | end; 158 | 159 | procedure TTestTgoSet.TestContains; 160 | var 161 | RogueValue: T; 162 | begin 163 | FillSet; 164 | RogueValue := CreateValue(3); 165 | Assert.IsTrue(FCUT.Contains(FValues[0])); 166 | Assert.IsTrue(FCUT.Contains(FValues[1])); 167 | Assert.IsTrue(FCUT.Contains(FValues[2])); 168 | Assert.IsFalse(FCUT.Contains(RogueValue)); 169 | end; 170 | 171 | procedure TTestTgoSet.TestGetEnumerator; 172 | var 173 | Value: T; 174 | B: Byte; 175 | C: IEqualityComparer; 176 | begin 177 | FillSet; 178 | 179 | C := TEqualityComparer.Default; 180 | B := 0; 181 | for Value in FCUT do 182 | begin 183 | if (C.Equals(Value, FValues[0])) then 184 | B := B or $01 185 | else if (C.Equals(Value, FValues[1])) then 186 | B := B or $02 187 | else if (C.Equals(Value, FValues[2])) then 188 | B := B or $04 189 | else 190 | Assert.Fail('Unexpected item'); 191 | end; 192 | Assert.AreEqual($07, Integer(B)); 193 | end; 194 | 195 | procedure TTestTgoSet.TestRemove; 196 | var 197 | RogueValue: T; 198 | V: TArray; 199 | begin 200 | FillSet; 201 | RogueValue := CreateValue(3); 202 | Assert.AreEqual(3, FCUT.Count); 203 | 204 | FCUT.Remove(RogueValue); 205 | Assert.AreEqual(3, FCUT.Count); 206 | CheckItems(FValues); 207 | 208 | FCUT.Remove(FValues[0]); 209 | Assert.AreEqual(2, FCUT.Count); 210 | SetLength(V, 2); 211 | V[0] := FValues[1]; 212 | V[1] := FValues[2]; 213 | CheckItems(V); 214 | 215 | FCUT.Remove(FValues[2]); 216 | Assert.AreEqual(1, FCUT.Count); 217 | SetLength(V, 1); 218 | V[0] := FValues[1]; 219 | CheckItems(V); 220 | 221 | FCUT.Remove(FValues[1]); 222 | Assert.AreEqual(0, FCUT.Count); 223 | end; 224 | 225 | procedure TTestTgoSet.TestToArray; 226 | var 227 | A: TArray; 228 | C: IEqualityComparer; 229 | I: Integer; 230 | B: Byte; 231 | begin 232 | FillSet; 233 | C := TEqualityComparer.Default; 234 | A := FCUT.ToArray; 235 | Assert.AreEqual(3, Length(A)); 236 | B := 0; 237 | for I := 0 to 2 do 238 | begin 239 | if C.Equals(A[I], FValues[0]) then 240 | B := B or $01 241 | else if C.Equals(A[I], FValues[1]) then 242 | B := B or $02 243 | else if C.Equals(A[I], FValues[2]) then 244 | B := B or $04 245 | else 246 | Assert.Fail('Unexpected key in set'); 247 | end; 248 | Assert.AreEqual($07, Integer(B)); 249 | end; 250 | 251 | { TTestTgoObjectSet } 252 | 253 | procedure TTestTgoObjectSet.CheckItems( 254 | const AExpectedIndices: array of Integer); 255 | var 256 | I: Integer; 257 | Value: TFoo; 258 | begin 259 | Assert.AreEqual(Length(AExpectedIndices), FCUT.Count); 260 | 261 | for I := 0 to Length(AExpectedIndices) - 1 do 262 | begin 263 | Value := FValues[AExpectedIndices[I]]; 264 | Assert.IsTrue(FCUT.Contains(Value)); 265 | end; 266 | end; 267 | 268 | procedure TTestTgoObjectSet.FillSet; 269 | var 270 | I: Integer; 271 | begin 272 | SetLength(FValues, 3); 273 | for I := 0 to 2 do 274 | begin 275 | FValues[I] := TFoo.Create(I); 276 | FCUT.Add(FValues[I]); 277 | end; 278 | end; 279 | 280 | procedure TTestTgoObjectSet.SetUp; 281 | begin 282 | inherited; 283 | FCUT := TgoObjectSet.Create; 284 | end; 285 | 286 | procedure TTestTgoObjectSet.TearDown; 287 | var 288 | I: Integer; 289 | begin 290 | for I := 0 to Length(FValues) - 1 do 291 | FValues[I] := nil; 292 | FCUT.Free; 293 | FCUT := nil; 294 | inherited; 295 | end; 296 | 297 | procedure TTestTgoObjectSet.TestAdd; 298 | begin 299 | FillSet; 300 | CheckItems([0, 1, 2]); 301 | end; 302 | 303 | procedure TTestTgoObjectSet.TestAddOrSet; 304 | begin 305 | FillSet; 306 | Assert.AreEqual(3, FCUT.Count); 307 | 308 | FCUT.AddOrSet(FValues[1]); 309 | Assert.AreEqual(3, FCUT.Count); 310 | 311 | SetLength(FValues, 4); 312 | FValues[3] := TFoo.Create(5); 313 | FCUT.AddOrSet(FValues[3]); 314 | CheckItems([0, 1, 2, 3]); 315 | end; 316 | 317 | procedure TTestTgoObjectSet.TestClear; 318 | begin 319 | FillSet; 320 | Assert.AreEqual(3, FCUT.Count); 321 | 322 | FCUT.Clear; 323 | Assert.AreEqual(0, FCUT.Count); 324 | end; 325 | 326 | procedure TTestTgoObjectSet.TestContains; 327 | var 328 | RogueValue: TFoo; 329 | begin 330 | FillSet; 331 | RogueValue := TFoo.Create(5); 332 | Assert.IsTrue(FCUT.Contains(FValues[0])); 333 | Assert.IsTrue(FCUT.Contains(FValues[1])); 334 | Assert.IsTrue(FCUT.Contains(FValues[2])); 335 | Assert.IsFalse(FCUT.Contains(RogueValue)); 336 | RogueValue.Free; 337 | end; 338 | 339 | procedure TTestTgoObjectSet.TestExtract; 340 | var 341 | Value, RogueValue: TFoo; 342 | begin 343 | FillSet; 344 | RogueValue := TFoo.Create(5); 345 | 346 | Value := FCUT.Extract(FValues[1]); 347 | Assert.IsNotNull(Value); 348 | Value.Free; 349 | 350 | Value := FCUT.Extract(RogueValue); 351 | Assert.IsNull(Value); 352 | RogueValue.Free; 353 | end; 354 | 355 | procedure TTestTgoObjectSet.TestGetEnumerator; 356 | var 357 | Value: TFoo; 358 | B: Byte; 359 | begin 360 | FillSet; 361 | B := 0; 362 | for Value in FCUT do 363 | begin 364 | if (Value.Value = 0) then 365 | B := B or $01 366 | else if (Value.Value = 1) then 367 | B := B or $02 368 | else if (Value.Value = 2) then 369 | B := B or $04 370 | else 371 | Assert.Fail('Unexpected item'); 372 | end; 373 | Assert.AreEqual($07, Integer(B)); 374 | end; 375 | 376 | procedure TTestTgoObjectSet.TestRemove; 377 | var 378 | RogueValue: TFoo; 379 | begin 380 | FillSet; 381 | RogueValue := TFoo.Create(3); 382 | Assert.AreEqual(3, FCUT.Count); 383 | 384 | FCUT.Remove(RogueValue); 385 | Assert.AreEqual(3, FCUT.Count); 386 | CheckItems([0, 1, 2]); 387 | RogueValue.Free; 388 | 389 | FCUT.Remove(FValues[0]); 390 | Assert.AreEqual(2, FCUT.Count); 391 | CheckItems([1, 2]); 392 | 393 | FCUT.Remove(FValues[2]); 394 | Assert.AreEqual(1, FCUT.Count); 395 | CheckItems([1]); 396 | 397 | FCUT.Remove(FValues[1]); 398 | Assert.AreEqual(0, FCUT.Count); 399 | end; 400 | 401 | procedure TTestTgoObjectSet.TestToArray; 402 | var 403 | A: TArray; 404 | I: Integer; 405 | B: Byte; 406 | begin 407 | FillSet; 408 | A := FCUT.ToArray; 409 | Assert.AreEqual(3, Length(A)); 410 | B := 0; 411 | for I := 0 to 2 do 412 | begin 413 | if (A[I].Value = 0) then 414 | B := B or $01 415 | else if (A[I].Value = 1) then 416 | B := B or $02 417 | else if (A[I].Value = 2) then 418 | B := B or $04 419 | else 420 | Assert.Fail('Unexpected key in set'); 421 | end; 422 | Assert.AreEqual($07, Integer(B)); 423 | end; 424 | 425 | initialization 426 | TDUnitX.RegisterTestFixture(TTestTgoSet); 427 | TDUnitX.RegisterTestFixture(TTestTgoSet); 428 | TDUnitX.RegisterTestFixture(TTestTgoSet); 429 | TDUnitX.RegisterTestFixture(TTestTgoSet); 430 | TDUnitX.RegisterTestFixture(TTestTgoSet); 431 | TDUnitX.RegisterTestFixture(TTestTgoSet); 432 | TDUnitX.RegisterTestFixture(TTestTgoSet); 433 | TDUnitX.RegisterTestFixture(TTestTgoSet); 434 | TDUnitX.RegisterTestFixture(TTestTgoSet); 435 | TDUnitX.RegisterTestFixture(TTestTgoSet); 436 | TDUnitX.RegisterTestFixture(TTestTgoSet); 437 | TDUnitX.RegisterTestFixture(TTestTgoSet); 438 | TDUnitX.RegisterTestFixture(TTestTgoSet); 439 | TDUnitX.RegisterTestFixture(TTestTgoSet); 440 | TDUnitX.RegisterTestFixture(TTestTgoSet); 441 | TDUnitX.RegisterTestFixture(TTestTgoSet); 442 | TDUnitX.RegisterTestFixture(TTestTgoSet); 443 | TDUnitX.RegisterTestFixture(TTestTgoSet); 444 | TDUnitX.RegisterTestFixture(TTestTgoSet); 445 | TDUnitX.RegisterTestFixture(TTestTgoSet); 446 | {$IFNDEF NEXTGEN} 447 | TDUnitX.RegisterTestFixture(TTestTgoSet); 448 | TDUnitX.RegisterTestFixture(TTestTgoSet); 449 | TDUnitX.RegisterTestFixture(TTestTgoSet); 450 | TDUnitX.RegisterTestFixture(TTestTgoSet); 451 | TDUnitX.RegisterTestFixture(TTestTgoSet); 452 | TDUnitX.RegisterTestFixture(TTestTgoSet); 453 | TDUnitX.RegisterTestFixture(TTestTgoSet); 454 | {$ENDIF} 455 | TDUnitX.RegisterTestFixture(TTestTgoSet); 456 | TDUnitX.RegisterTestFixture(TTestTgoSet); 457 | TDUnitX.RegisterTestFixture(TTestTgoSet); 458 | TDUnitX.RegisterTestFixture(TTestTgoSet); 459 | TDUnitX.RegisterTestFixture(TTestTgoSet); 460 | TDUnitX.RegisterTestFixture(TTestTgoSet); 461 | TDUnitX.RegisterTestFixture(TTestTgoSet); 462 | TDUnitX.RegisterTestFixture(TTestTgoSet); 463 | TDUnitX.RegisterTestFixture(TTestTgoSet); 464 | TDUnitX.RegisterTestFixture(TTestTgoSet); 465 | TDUnitX.RegisterTestFixture(TTestTgoSet); 466 | TDUnitX.RegisterTestFixture(TTestTgoSet); 467 | 468 | TDUnitX.RegisterTestFixture(TTestTgoObjectSet); 469 | end. 470 | -------------------------------------------------------------------------------- /Grijjy.CodeBlocks.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.CodeBlocks; 2 | { Code block helper class for macOS and iOS to simplify the usage of ObjC code blocks} 3 | 4 | { 1. To create a call a code block 5 | TObjCBlock.CreateBlockWithProcedure( 6 | procedure(p1: NSInteger; p2: Pointer) 7 | begin 8 | grLog('OnTimer'); 9 | 10 | end)); 11 | 12 | 2. You may need to define a new TProc<> for your block if no suitable one 13 | exists with the correct parameters. } 14 | 15 | { Note: This class is based on TamoSoft implementation, 16 | 17 | Copyright(c) 2017 TamoSoft Limited 18 | https://habr.com/post/325204/ 19 | 20 | LICENSE: 21 | 22 | Permission is hereby granted, free of charge, to any person obtaining a copy 23 | of this software and associated documentation files (the "Software"), to deal 24 | in the Software without restriction, including without limitation the rights 25 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 26 | copies of the Software, and to permit persons to whom the Software is 27 | furnished to do so, subject to the following conditions: 28 | 29 | You may not use the Software in any projects published under viral licenses, 30 | including, but not limited to, GNU GPL. 31 | 32 | The above copyright notice and this permission notice shall be included in all 33 | copies or substantial portions of the Software. 34 | 35 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 36 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 37 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 38 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 39 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 40 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 41 | SOFTWARE } 42 | 43 | {$I Grijjy.inc} 44 | 45 | {$IFNDEF MACOS} 46 | {$MESSAGE Error 'This unit should only be used in macOS and iOS projects.'} 47 | {$ENDIF} 48 | 49 | interface 50 | 51 | uses 52 | System.SysUtils, 53 | {$IFDEF IOS} 54 | iOSapi.CocoaTypes, 55 | iOSapi.Foundation, 56 | {$ELSE} 57 | {$IFDEF MACOS} 58 | Macapi.Foundation, 59 | Macapi.CocoaTypes, 60 | {$ENDIF} 61 | {$ENDIF} 62 | Macapi.ObjectiveC, 63 | Macapi.Helpers, 64 | Macapi.ObjCRuntime; 65 | 66 | type 67 | TProc1 = TProc; 68 | TProc2 = TProc; 69 | TProc3 = TProc; 70 | TProc4 = TProc; 71 | TProc5 = TProc; 72 | TProc6 = TProc; 73 | TProc7 = TFunc; 74 | TProc8 = TProc; 75 | 76 | TProcType = (ptNone, pt1, pt2, pt3, pt4, pt5, pt6, pt7, pt8); 77 | 78 | TObjCBlock = record 79 | private 80 | class procedure SelfTest; static; 81 | class function CreateBlockWithCFunc(const ATProc: TProc; const AType: TProcType): Pointer; static; 82 | public 83 | class function CreateBlockWithProcedure(const AProc: TProc1): Pointer; overload; static; 84 | class function CreateBlockWithProcedure(const AProc: TProc2): Pointer; overload; static; 85 | class function CreateBlockWithProcedure(const AProc: TProc3): Pointer; overload; static; 86 | class function CreateBlockWithProcedure(const AProc: TProc4): Pointer; overload; static; 87 | class function CreateBlockWithProcedure(const AProc: TProc5): Pointer; overload; static; 88 | class function CreateBlockWithProcedure(const AProc: TProc6): Pointer; overload; static; 89 | class function CreateBlockWithProcedure(const AProc: TProc7): Pointer; overload; static; 90 | class function CreateBlockWithProcedure(const AProc: TProc8): Pointer; overload; static; 91 | end; 92 | 93 | implementation 94 | 95 | function imp_implementationWithBlock(block: Pointer): Pointer; 96 | cdecl; external libobjc name _PU + 'imp_implementationWithBlock'; 97 | function imp_removeBlock(anImp: Pointer): integer; 98 | cdecl; external libobjc name _PU + 'imp_removeBlock'; 99 | 100 | type 101 | Block_Descriptor = packed record 102 | Reserved: NativeUint; 103 | Size: NativeUint; 104 | copy_helper: Pointer; 105 | dispose_helper: Pointer; 106 | end; 107 | PBlock_Descriptor = ^Block_Descriptor; 108 | 109 | Block_Literal = packed record 110 | Isa: Pointer; 111 | Flags: integer; 112 | Reserved: integer; 113 | Invoke: Pointer; 114 | Descriptor: PBlock_Descriptor; 115 | end; 116 | PBlock_Literal = ^Block_Literal; 117 | 118 | TBlockInfo = packed record 119 | BlockStructure: Block_Literal; 120 | LocProc: TProc; 121 | ProcType: TProcType; 122 | end; 123 | PBlockInfo = ^TBlockInfo; 124 | 125 | TObjCBlockList = class (TObject) 126 | private 127 | FBlockList: TArray; 128 | procedure ClearAllBlocks; 129 | public 130 | constructor Create; 131 | destructor Destroy; override; 132 | function AddNewBlock(const ATProc: TProc; const AType: TProcType): Pointer; 133 | function FindMatchingBlock(const ACurrBlock: Pointer): integer; 134 | procedure ClearBlock(const AIdx: integer); 135 | property BlockList: TArray read FBlockList ; 136 | end; 137 | 138 | var 139 | BlockObj: TObjCBlockList; 140 | 141 | function InvokeCallback(aNSBlock, p1, p2, p3, p4: Pointer): Pointer; cdecl; 142 | var 143 | I: integer; 144 | Rect: NSRect; 145 | begin 146 | Result := nil; 147 | if Assigned(BlockObj) then 148 | begin 149 | TMonitor.Enter(BlockObj); 150 | try 151 | I:= BlockObj.FindMatchingBlock(aNSBlock); 152 | if I >= 0 then 153 | begin 154 | case BlockObj.BlockList[I].ProcType of 155 | TProcType.pt1: TProc1(BlockObj.BlockList[I].LocProc)(); 156 | TProcType.pt2: TProc2(BlockObj.BlockList[I].LocProc)(p1); 157 | TProcType.pt3: TProc3(BlockObj.BlockList[I].LocProc)(p1, p2); 158 | TProcType.pt4: TProc4(BlockObj.BlockList[I].LocProc)(p1, p2, p3); 159 | TProcType.pt5: TProc5(BlockObj.BlockList[I].LocProc)(p1, p2, p3, p4); 160 | TProcType.pt6: TProc6(BlockObj.BlockList[I].LocProc)(NSinteger(p1)); 161 | TProcType.pt7: 162 | begin 163 | Rect.origin.x := CGFloat(p1); 164 | Rect.origin.y := CGFloat(p2); 165 | Rect.size.width := CGFloat(p3); 166 | Rect.size.height:= CGFloat(p4); 167 | Result := Pointer(TProc7(BlockObj.BlockList[I].LocProc)(Rect)); 168 | end; 169 | TProcType.pt8: TProc8(BlockObj.BlockList[I].LocProc)(NSinteger(p1), p2); 170 | end; 171 | end; 172 | finally 173 | TMonitor.Exit(BlockObj); 174 | end; 175 | end; 176 | end; 177 | 178 | procedure DisposeCallback(ANSBlock: Pointer) cdecl; 179 | var 180 | I: integer; 181 | begin 182 | if Assigned(BlockObj) then 183 | begin 184 | TMonitor.Enter(BlockObj); 185 | try 186 | I:= BlockObj.FindMatchingBlock(ANSBlock); 187 | if I >= 0 188 | then BlockObj.ClearBlock(I); 189 | finally 190 | TMonitor.Exit(BlockObj); 191 | end; 192 | end; 193 | TNSObject.Wrap(ANSBlock).release; 194 | end; 195 | 196 | procedure CopyCallback(ASource, ADest: Pointer) cdecl; 197 | begin 198 | // 199 | end; 200 | 201 | class function TObjCBlock.CreateBlockWithProcedure(const AProc: TProc1): Pointer; 202 | begin 203 | Result := CreateBlockWithCFunc(TProc(AProc), TProcType.pt1); 204 | end; 205 | 206 | class function TObjCBlock.CreateBlockWithProcedure(const AProc: TProc2): Pointer; 207 | begin 208 | Result := CreateBlockWithCFunc(TProc(AProc), TProcType.pt2); 209 | end; 210 | 211 | class function TObjCBlock.CreateBlockWithProcedure(const AProc: TProc3): Pointer; 212 | begin 213 | Result := CreateBlockWithCFunc(TProc(AProc), TProcType.pt3); 214 | end; 215 | 216 | class function TObjCBlock.CreateBlockWithProcedure(const AProc: TProc4): Pointer; 217 | begin 218 | Result := CreateBlockWithCFunc(TProc(AProc), TProcType.pt4); 219 | end; 220 | 221 | class function TObjCBlock.CreateBlockWithProcedure(const AProc: TProc5): Pointer; 222 | begin 223 | Result := CreateBlockWithCFunc(TProc(AProc), TProcType.pt5); 224 | end; 225 | 226 | class function TObjCBlock.CreateBlockWithProcedure(const AProc: TProc6): Pointer; 227 | begin 228 | Result := CreateBlockWithCFunc(TProc(AProc), TProcType.pt6); 229 | end; 230 | 231 | class function TObjCBlock.CreateBlockWithProcedure(const AProc: TProc7): Pointer; 232 | begin 233 | Result := CreateBlockWithCFunc(TProc(AProc), TProcType.pt7); 234 | end; 235 | 236 | class function TObjCBlock.CreateBlockWithProcedure(const AProc: TProc8): Pointer; 237 | begin 238 | Result := CreateBlockWithCFunc(TProc(AProc), TProcType.pt8); 239 | end; 240 | 241 | class function TObjCBlock.CreateBlockWithCFunc(const ATProc: TProc; const AType: TProcType): Pointer; 242 | begin 243 | Result := nil; 244 | if Assigned(BlockObj) then 245 | begin 246 | TMonitor.Enter(BlockObj); 247 | try 248 | Result := BlockObj.AddNewBlock(ATProc, AType); 249 | finally 250 | TMonitor.Exit(BlockObj); 251 | end; 252 | end; 253 | end; 254 | 255 | class procedure TObjCBlock.SelfTest; 256 | var 257 | P: Pointer; 258 | Test: NativeUint; 259 | // _cmd is ignored 260 | func : procedure ( p1, _cmd, p2, p3, p4: Pointer); cdecl; 261 | begin 262 | Test:= 0; 263 | P:= TObjCBlock.CreateBlockWithProcedure( 264 | procedure (p1, p2, p3, p4: Pointer) 265 | begin 266 | Test:= NativeUint(p1) + NativeUint(p2) + 267 | NativeUint(p3) + NativeUint(p4); 268 | end); 269 | @func := imp_implementationWithBlock(P); 270 | // _cmd is ignored 271 | func(Pointer(1), nil, Pointer(2), Pointer(3), Pointer(4)); 272 | imp_removeBlock(@func); 273 | if Test <> (1 + 2 + 3 + 4) 274 | then raise Exception.Create('Objective-C code block self-test failed!'); 275 | end; 276 | 277 | { TObjCBlockList } 278 | 279 | constructor TObjCBlockList.Create; 280 | begin 281 | inherited; 282 | end; 283 | 284 | destructor TObjCBlockList.Destroy; 285 | begin 286 | TMonitor.Enter(Self); 287 | try 288 | ClearAllBlocks; 289 | finally 290 | TMonitor.Exit(Self); 291 | end; 292 | inherited Destroy; 293 | end; 294 | 295 | procedure TObjCBlockList.ClearBlock(const AIdx: integer); 296 | begin 297 | Dispose(FBlockList[AIdx].BlockStructure.Descriptor); 298 | FBlockList[AIdx].BlockStructure.isa:= nil; 299 | FBlockList[AIdx].LocProc:= nil; 300 | Delete(FBlockList, AIdx, 1); 301 | end; 302 | 303 | function TObjCBlockList.AddNewBlock(const ATProc: TProc; const AType: TProcType): Pointer; 304 | var 305 | aDesc: PBlock_Descriptor; 306 | const 307 | BLOCK_HAS_COPY_DISPOSE = 1 shl 25; 308 | begin 309 | SetLength(FBlockList, Length(FBlockList) + 1); 310 | FillChar(FBlockList[High(FBlockList)], SizeOf(TBlockInfo), 0); 311 | 312 | FBlockList[High(FBlockList)].BlockStructure.Isa := NSClassFromString ((StrToNSStr('NSBlock') as ILocalobject).GetObjectID); 313 | FBlockList[High(FBlockList)].BlockStructure.Invoke := @InvokeCallback; 314 | FBlockList[High(FBlockList)].BlockStructure.Flags := BLOCK_HAS_COPY_DISPOSE; 315 | FBlockList[High(FBlockList)].ProcType := AType; 316 | FBlockList[High(FBlockList)].LocProc := ATProc; 317 | 318 | New(aDesc); 319 | aDesc.Reserved := 0; 320 | aDesc.Size := SizeOf(Block_Literal); 321 | aDesc.copy_helper := @CopyCallback; 322 | aDesc.dispose_helper := @DisposeCallback; 323 | FBlockList[High(FBlockList)].BlockStructure.Descriptor := aDesc; 324 | 325 | Result := @FBlockList[High(FBlockList)].BlockStructure; 326 | end; 327 | 328 | procedure TObjCBlockList.ClearAllBlocks; 329 | var 330 | I: integer; 331 | begin 332 | for I := High(FBlockList) downto Low(FBlockList) do 333 | ClearBlock(I); 334 | end; 335 | 336 | function TObjCBlockList.FindMatchingBlock(const ACurrBlock: Pointer): integer; 337 | var 338 | I: integer; 339 | begin 340 | Result := -1; 341 | if ACurrBlock <> nil then 342 | begin 343 | for I:= Low(FBlockList) to High(FBlockList) do 344 | begin 345 | if FBlockList[I].BlockStructure.Descriptor = PBlock_Literal(ACurrBlock).Descriptor 346 | then Exit(I); 347 | end; 348 | end; 349 | end; 350 | 351 | initialization 352 | BlockObj:=TObjCBlockList.Create; 353 | TObjCBlock.SelfTest; 354 | 355 | finalization 356 | FreeAndNil(BlockObj); 357 | 358 | end. 359 | -------------------------------------------------------------------------------- /Grijjy.Winsock2.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.Winsock2; 2 | 3 | { Missing Winsock2 interfaces for IOCP and other things } 4 | 5 | {$I Grijjy.inc} 6 | 7 | interface 8 | 9 | uses 10 | Winsock2, 11 | Windows, 12 | System.SysUtils; 13 | 14 | const 15 | WINSOCK2_DLL = 'WS2_32.DLL'; 16 | WSHIP6_DLL = 'WSHIP6.DLL'; 17 | 18 | const 19 | IPHLPAPI_DLL = 'IPHLPAPI.dll'; 20 | 21 | { TCP states } 22 | TCP_STATES = 12; 23 | TCP_STATE: array[1..TCP_STATES] of String = ( 24 | 'CLOSED', 25 | 'LISTEN', 26 | 'SYN-SENT', 27 | 'SYN-RECEIVED', 28 | 'ESTABLISHED', 29 | 'FIN-WAIT-1', 30 | 'FIN-WAIT-2', 31 | 'CLOSE-WAIT', 32 | 'CLOSING', 33 | 'LAST-ACK', 34 | 'TIME-WAIT', 35 | 'delete TCB'); 36 | 37 | const 38 | TF_DISCONNECT = $01; 39 | TF_REUSE_SOCKET = $02; 40 | TF_WRITE_BEHIND = $04; 41 | TF_USE_DEFAULT_WORKER = $00; 42 | TF_USE_SYSTEM_THREAD = $10; 43 | TF_USE_KERNEL_APC = $20; 44 | 45 | type 46 | PPAddrInfoW = ^PAddrInfoW; 47 | PAddrInfoW = ^ADDRINFOW; 48 | ADDRINFOW = record 49 | ai_flags: Integer; 50 | ai_family: Integer; 51 | ai_socktype: Integer; 52 | ai_protocol: Integer; 53 | ai_addrlen: size_t; 54 | ai_canonname: PWideChar; 55 | ai_addr: PSockAddr; 56 | ai_next: PAddrInfoW; 57 | end; 58 | TAddrInfoW = ADDRINFOW; 59 | LPADDRINFOW = PAddrInfoW; 60 | 61 | type 62 | LPFN_BIND = function(const ASocket: TSocket; const AName: PSockAddr; const ANameLength: Integer): Integer; stdcall; 63 | LPFN_WSAIOCTL = function(const ASocket: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; 64 | lpcbBytesReturned: LPDWORD; AOverlapped: Pointer; lpCompletionRoutine: LPWSAOVERLAPPED_COMPLETION_ROUTINE): Integer; stdcall; 65 | LPFN_ACCEPTEX = function(AListenSocket, AAcceptSocket: TSocket; lpOutputBuffer: Pointer; dwReceiveDataLength, dwLocalAddressLength, 66 | dwRemoteAddressLength: DWORD; var lpdwBytesReceived: DWORD; lpOverlapped: POverlapped): BOOL; stdcall; 67 | LPFN_GETACCEPTEXSOCKADDRS = procedure(lpOutputBuffer: Pointer; 68 | dwReceiveDataLength, dwLocalAddressLength, dwRemoteAddressLength: DWORD; 69 | var LocalSockaddr: TSockAddr; var LocalSockaddrLength: Integer; 70 | var RemoteSockaddr: TSockAddr; var RemoteSockaddrLength: Integer); stdcall; 71 | LPFN_CONNECTEX = function(const ASocket: TSocket; const AName: PSockAddr; const ANameLength: Integer; lpSendBuffer: Pointer; 72 | dwSendDataLength: DWORD; var lpdwBytesSent: DWORD; lpOverlapped: LPWSAOVERLAPPED): BOOL; stdcall; 73 | LPFN_DISCONNECTEX = function(const ASocket: TSocket; AOverlapped: Pointer; const dwFlags: DWORD; const dwReserved: DWORD): BOOL; stdcall; 74 | 75 | type 76 | LPFN_GETADDRINFOW = function(NodeName: PWideChar; ServiceName: PWideChar; Hints: PaddrinfoW; ppResult: PPAddrInfoW): Integer; stdcall; 77 | LPFN_GETNAMEINFOW = function(sa: PSockAddr; salen: DWORD; host: PWideChar; hostlen: DWORD; serv: PWideChar; servlen: DWORD; flags: Integer): Integer; stdcall; 78 | LPFN_FREEADDRINFOW = procedure(ai: PaddrinfoW); stdcall; 79 | 80 | const 81 | WSAID_ACCEPTEX: TGuid = (D1:$b5367df1;D2:$cbac;D3:$11cf;D4:($95,$ca,$00,$80,$5f,$48,$a1,$92)); 82 | WSAID_CONNECTEX: TGuid = (D1:$25a207b9;D2:$ddf3;D3:$4660;D4:($8e,$e9,$76,$e5,$8c,$74,$06,$3e)); 83 | WSAID_DISCONNECTEX: TGuid = (D1:$7fda2e11;D2:$8630;D3:$436f;D4:($a0,$31,$f5,$36,$a6,$ee,$c1,$57)); 84 | WSAID_GETACCEPTEXSOCKADDRS: TGuid = (D1:$b5367df2;D2:$cbac;D3:$11cf;D4:($95,$ca,$00,$80,$5f,$48,$a1,$92)); 85 | 86 | type 87 | TCP_TABLE_CLASS = Integer; 88 | 89 | TMibTcpRowOwnerPid = packed record 90 | dwState: DWORD; 91 | dwLocalAddr: DWORD; 92 | dwLocalPort: DWORD; 93 | dwRemoteAddr: DWORD; 94 | dwRemotePort: DWORD; 95 | dwOwningPid: DWORD; 96 | end; 97 | PMibTcpRowOwnerPid = ^TMibTcpRowOwnerPid; 98 | 99 | PMIB_TCPTABLE_OWNER_PID = ^MIB_TCPTABLE_OWNER_PID; 100 | MIB_TCPTABLE_OWNER_PID = packed record 101 | dwNumEntries: DWORD; 102 | table: array [0..0] of TMibTcpRowOwnerPid; 103 | end; 104 | 105 | type 106 | LPFN_GetExtendedTcpTable = function(pTcpTable: Pointer; dwSize: PDWORD; bOrder: BOOL; lAf: ULONG; TableClass: TCP_TABLE_CLASS; Reserved: ULONG): DWord; stdcall; 107 | 108 | { Missing Winsock2 } 109 | function Init_Winsock: DWORD; 110 | procedure Finalize_Winsock; 111 | 112 | { Helpers } 113 | function IPV4ToString(const AValue: Integer): String; 114 | 115 | { NetStat } 116 | function EnumerateTCPConnections(out ATcpTable: PMIB_TCPTABLE_OWNER_PID): Boolean; 117 | procedure grNetstat; 118 | 119 | var 120 | bind: LPFN_BIND = nil; 121 | WSAIoctl: LPFN_WSAIOCTL = nil; 122 | AcceptEx: LPFN_ACCEPTEX = nil; 123 | GetAcceptExSockAddrs: LPFN_GETACCEPTEXSOCKADDRS = nil; 124 | ConnectEx: LPFN_CONNECTEX = nil; 125 | DisconnectEx: LPFN_DISCONNECTEX = nil; 126 | 127 | var 128 | GetAddrInfo: LPFN_GETADDRINFOW = nil; 129 | GetNameInfo: LPFN_GETNAMEINFOW = nil; 130 | FreeAddrInfo: LPFN_FREEADDRINFOW = nil; 131 | 132 | var 133 | HandleIPHLPAPI: THandle = 0; 134 | GetExtendedTcpTable: LPFN_GetExtendedTcpTable = nil; 135 | 136 | implementation 137 | 138 | var 139 | HandleWinsockDLL: THandle = 0; 140 | HandleWShipDLL: THandle = 0; 141 | 142 | function GetAddress(const AName: String): Pointer; inline; overload; 143 | begin 144 | Result := GetProcAddress(HandleWinsockDLL, PWideChar(AName)); 145 | end; 146 | 147 | function GetAddress(ASocket: TSocket; const AName: String; const AGuid: TGUID): Pointer; inline; overload; 148 | var 149 | BytesSend: DWORD; 150 | begin 151 | if WSAIoctl(ASocket, SIO_GET_EXTENSION_FUNCTION_POINTER, @AGuid, DWORD(SizeOf(TGuid)), 152 | @Result, DWORD(SizeOf(FARPROC)), PDWORD(@BytesSend), nil, nil) <> 0 then 153 | Result := nil; 154 | end; 155 | 156 | function Overload_AcceptEx(AListenSocket, AAcceptSocket: TSocket; 157 | lpOutputBuffer: Pointer; dwReceiveDataLength, dwLocalAddressLength, 158 | dwRemoteAddressLength: DWORD; var lpdwBytesReceived: DWORD; 159 | lpOverlapped: POverlapped): BOOL; stdcall; 160 | begin 161 | @GetAcceptExSockAddrs := GetAddress(AListenSocket, 'GetAcceptExSockaddrs', WSAID_GETACCEPTEXSOCKADDRS); 162 | @AcceptEx := GetAddress(AListenSocket, 'AcceptEx', WSAID_ACCEPTEX); 163 | if @AcceptEx <> nil then 164 | Result := AcceptEx(AListenSocket, AAcceptSocket, lpOutputBuffer, dwReceiveDataLength, 165 | dwLocalAddressLength, dwRemoteAddressLength, lpdwBytesReceived, lpOverlapped) 166 | else 167 | Result := False; 168 | end; 169 | 170 | function Overload_ConnectEx(const ASocket: TSocket; const AName: PSockAddr; const ANameLength: Integer; lpSendBuffer: Pointer; 171 | dwSendDataLength: DWORD; var lpdwBytesSent: DWORD; lpOverlapped: LPWSAOVERLAPPED): BOOL; stdcall; 172 | begin 173 | @ConnectEx := GetAddress(ASocket, 'ConnectEx', WSAID_CONNECTEX); 174 | if @ConnectEx <> nil then 175 | Result := ConnectEx(ASocket, AName, ANameLength, lpSendBuffer, dwSendDataLength, lpdwBytesSent, lpOverlapped) 176 | else 177 | Result := False; 178 | end; 179 | 180 | function Overload_DisconnectEx(const ASocket: TSocket; AOverlapped: Pointer; const dwFlags: DWord; const dwReserved: DWORD): BOOL; stdcall; 181 | begin 182 | @DisconnectEx := GetAddress(ASocket, 'DisconnectEx', WSAID_DISCONNECTEX); 183 | if @DisconnectEx <> nil then 184 | Result := DisconnectEx(ASocket, AOverlapped, dwFlags, dwReserved) 185 | else 186 | Result := False; 187 | end; 188 | 189 | procedure Init_Overloads; 190 | begin 191 | bind := GetAddress('bind'); 192 | AcceptEx := Overload_AcceptEx; 193 | ConnectEx := Overload_ConnectEx; 194 | DisconnectEx := Overload_DisconnectEx; 195 | WSAIoctl := GetAddress('WSAIoctl'); 196 | end; 197 | 198 | procedure Init_AddrInfo; 199 | var 200 | _GetAddrInfo: LPFN_GETADDRINFOW; 201 | _GetNameInfo: LPFN_GETNAMEINFOW; 202 | _FreeAddrInfo: LPFN_FREEADDRINFOW; 203 | Handle: THandle; 204 | begin 205 | Handle := HandleWinsockDLL; 206 | _GetAddrInfo := GetProcAddress(Handle, 'GetAddrInfoW'); 207 | if not Assigned(_GetAddrInfo) then 208 | begin 209 | HandleWShipDLL := SafeLoadLibrary(Wship6_dll); 210 | Handle := HandleWShipDLL; 211 | _GetAddrInfo := GetProcAddress(Handle, 'GetAddrInfoW'); 212 | end; 213 | if Assigned(_GetAddrInfo) then 214 | begin 215 | _GetNameInfo := GetProcAddress(Handle, 'GetNameInfoW'); 216 | _FreeAddrInfo := GetProcAddress(Handle, 'FreeAddrInfoW'); 217 | if Assigned(_FreeAddrInfo) then 218 | begin 219 | GetAddrInfo := _GetAddrInfo; 220 | GetNameInfo := _GetNameInfo; 221 | FreeAddrInfo := _FreeAddrInfo; 222 | end; 223 | end; 224 | end; 225 | 226 | function Init_Winsock: DWORD; 227 | var 228 | LData: TWSAData; 229 | begin 230 | Result := 0; 231 | if HandleWinsockDLL = 0 then 232 | begin 233 | HandleWinsockDLL := LoadLibrary(WINSOCK2_DLL); 234 | if HandleWinsockDLL <> 0 then 235 | begin 236 | Init_Overloads; 237 | if WSAStartup($202, LData) = 0 then 238 | begin 239 | Init_AddrInfo; 240 | Exit; 241 | end 242 | else 243 | begin 244 | FreeLibrary(HandleWinsockDLL); 245 | HandleWinsockDLL := 0; 246 | end 247 | end 248 | else 249 | end; 250 | Result := GetLastError; 251 | end; 252 | 253 | procedure Finalize_Winsock; 254 | begin 255 | if HandleWShipDLL <> 0 then 256 | begin 257 | FreeLibrary(HandleWShipDLL); 258 | HandleWShipDLL := 0; 259 | end; 260 | if HandleWinsockDLL <> 0 then 261 | begin 262 | WSACleanup; 263 | FreeLibrary(HandleWinsockDLL); 264 | HandleWinsockDLL := 0; 265 | end; 266 | end; 267 | 268 | function IPV4ToString(const AValue: Integer): String; 269 | var 270 | x1, x2: Word; 271 | y1, y2: Byte; 272 | begin 273 | Result := ''; 274 | x1 := AValue shr 16; 275 | x2 := AValue and $FFFF; 276 | y1 := x2 mod $100; 277 | y2 := x2 div $100; 278 | Result := IntToStr(y1) + '.' + IntToStr(y2) + '.'; 279 | y1 := x1 mod $100; 280 | y2 := x1 div $100; 281 | Result := Result + IntToStr(y1) + '.' + IntToStr(y2); 282 | end; 283 | 284 | function EnumerateTCPConnections(out ATcpTable: PMIB_TCPTABLE_OWNER_PID): Boolean; 285 | const 286 | TCP_TABLE_OWNER_PID_ALL = 5; 287 | var 288 | Size: DWORD; 289 | LastError: Integer; 290 | begin 291 | Result := False; 292 | if @GetExtendedTcpTable = nil then 293 | begin 294 | HandleIPHLPAPI := LoadLibrary(IPHLPAPI_DLL); 295 | if HandleIPHLPAPI <> 0 then 296 | GetExtendedTcpTable := GetProcAddress(HandleIPHLPAPI, 'GetExtendedTcpTable'); 297 | end; 298 | if @GetExtendedTcpTable <> nil then 299 | begin 300 | Size := 0; 301 | if GetExtendedTcpTable(nil, @Size, False, AF_INET, TCP_TABLE_OWNER_PID_ALL, 0) = ERROR_INSUFFICIENT_BUFFER then 302 | begin 303 | GetMem(ATcpTable, Size); 304 | if GetExtendedTcpTable(ATcpTable, @Size, TRUE, AF_INET, TCP_TABLE_OWNER_PID_ALL, 0) <> NO_ERROR then 305 | begin 306 | LastError := GetLastError; 307 | Writeln(Format('Error! GetExtendedTcpTable %d %s', [LastError, SysErrorMessage(LastError)])); 308 | end 309 | else 310 | Result := True; 311 | end; 312 | end 313 | else 314 | begin 315 | LastError := GetLastError; 316 | Writeln(Format('Error! GetProcAddress %d %s', [LastError, SysErrorMessage(LastError)])); 317 | end; 318 | end; 319 | 320 | procedure grNetstat; 321 | var 322 | TcpTable: PMIB_TCPTABLE_OWNER_PID; 323 | I: Integer; 324 | Count: array[1..TCP_STATES] of Integer; 325 | begin 326 | ZeroMemory(@Count, SizeOf(Count)); 327 | if EnumerateTCPConnections(TcpTable) then 328 | begin 329 | try 330 | Writeln(Format('%-16s %-6s %-16s %-6s %s',['Local IP','Port','Remote IP','Port','Status'])); 331 | for I := 0 to TcpTable.dwNumEntries - 1 do 332 | begin 333 | Writeln(Format('%-16s %-6d %-16s %-6d %s',[ 334 | IPV4ToString(TcpTable.Table[I].dwLocalAddr), 335 | Swap(TcpTable.Table[I].dwLocalPort), 336 | IPV4ToString(TcpTable.Table[I].dwRemoteAddr), 337 | Swap(TcpTable.Table[I].dwRemotePort), 338 | TCP_STATE[TcpTable.Table[I].dwState]])); 339 | Inc(Count[TcpTable.Table[I].dwState]); 340 | end; 341 | finally 342 | FreeMem(TcpTable); 343 | end; 344 | Writeln; 345 | for I := 1 to TCP_STATES do 346 | Writeln(Format('%16s %s',[TCP_STATE[I] + ' = ',IntToStr(Count[I])])); 347 | end; 348 | Readln; 349 | end; 350 | 351 | initialization 352 | Init_Winsock; 353 | 354 | finalization 355 | Finalize_Winsock; 356 | 357 | end. 358 | -------------------------------------------------------------------------------- /Grijjy.CloudLogging.Protocol.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.CloudLogging.Protocol; 2 | 3 | {$INCLUDE 'Grijjy.inc'} 4 | 5 | interface 6 | 7 | uses 8 | System.SysUtils, 9 | System.Messaging, 10 | Grijjy.ProtocolBuffers, 11 | PascalZMQ, 12 | ZMQ.ClientProtocol, 13 | ZMQ.Shared; 14 | 15 | type 16 | { Protocol buffer that defines the message and metadata for a log message } 17 | TgoLogMessageProtocol = record 18 | public 19 | { The log message } 20 | [Serialize(1)] MessageText: String; 21 | 22 | { The log level (Info, Warning or Error) } 23 | [Serialize(2)] Level: Integer; 24 | 25 | { The ID of the process that send the message } 26 | [Serialize(3)] ProcessId: FixedUInt32; 27 | 28 | { The ID of the thread that send the message } 29 | [Serialize(4)] ThreadId: FixedUInt32; 30 | 31 | { The name of the application that send the message } 32 | [Serialize(5)] AppName: String; 33 | 34 | { The date and time at which the message was sent } 35 | [Serialize(6)] TimeStamp: TDateTime; 36 | 37 | { Describes the format of any optional data } 38 | [Serialize(7)] DataFormat: Integer; 39 | 40 | { Any optional data to send along with the messsage } 41 | [Serialize(8)] Data: TBytes; 42 | end; 43 | 44 | type 45 | { Protocol buffer that defines a command from the log viewer } 46 | TgoLogCommandProtocol = record 47 | public 48 | { The command } 49 | [Serialize(1)] Command: Integer; 50 | 51 | { Serialized arguments } 52 | [Serialize(2)] Args: TBytes; 53 | end; 54 | 55 | type 56 | TgoHandleArray = record 57 | { Array of handles } 58 | [Serialize(1)] Handles: TArray; 59 | end; 60 | 61 | type 62 | { Text alignment options for watch values } 63 | TgoWatchAlign = (Left, Center, Right); 64 | 65 | type 66 | { A live watch as used by TgoLogLiveWatchesProtocol } 67 | TgoLiveWatch = record 68 | public 69 | { Name of the live watch } 70 | [Serialize(1)] Name: String; 71 | 72 | { Value of the live watch } 73 | [Serialize(2)] Value: String; 74 | 75 | { Display alignment of the value. } 76 | [Serialize(3)] ValueAlign: TgoWatchAlign; 77 | end; 78 | 79 | type 80 | { Protocol buffer that defines a list of live watches } 81 | TgoLogLiveWatchesProtocol = record 82 | public 83 | { Array of live watches } 84 | [Serialize(1)] Watches: TArray; 85 | end; 86 | 87 | type 88 | { Protocol buffer that defines a memory usage report } 89 | TgoLogMemoryUsageProtocol = record 90 | public type 91 | { Represents a single instance } 92 | TInstance = record 93 | { Caption to use to display details about the instance in the log viewer. 94 | For classes derived from TComponent, this will be the name of the owner 95 | and name of the instance if available. Otherwise, it will be its 96 | ToString value. } 97 | [Serialize(1)] Caption: String; 98 | end; 99 | public type 100 | { Single entry for a class } 101 | TEntry = record 102 | { Name of this class. } 103 | [Serialize(1)] ClassName: String; 104 | 105 | { Handle of this class. This is a TClass. But since TClass cannot be 106 | used across process boundaries, it is typecast to a THandle. It is 107 | only used for identification purposes. } 108 | [Serialize(2)] ClassHandle: THandle; 109 | 110 | { Number of live instances for this class. } 111 | [Serialize(3)] InstanceCount: Integer; 112 | 113 | { Live instances for this class (if requested). } 114 | [Serialize(4)] Instances: TArray; 115 | end; 116 | PEntry = ^TEntry; 117 | public 118 | { Array of class names and its number of instances } 119 | [Serialize(1)] Entries: TArray; 120 | 121 | { Approximate number of bytes allocated by the current process. } 122 | [Serialize(2)] AllocatedBytes: Int64; 123 | end; 124 | 125 | type 126 | { Protocol buffer for requesting recent memory allocations } 127 | TgoLogAllocationsRequestProtocol = record 128 | { Last number of milliseconds } 129 | [Serialize(1)] LastMs: Integer; 130 | end; 131 | 132 | type 133 | { Represents a single memory allocation } 134 | TgoMemoryAllocation = record 135 | { Allocation number } 136 | [Serialize(1)] AllocationNumber: Integer; 137 | 138 | { Memory address } 139 | [Serialize(2)] Address: UInt64; 140 | 141 | { Size of memory as requested by user } 142 | [Serialize(3)] Size: Integer; 143 | 144 | { Size of memory including headers } 145 | [Serialize(4)] BlockSize: Integer; 146 | 147 | { Number of milliseconds ago the allocation was made } 148 | [Serialize(5)] TimeAgoMs: Integer; 149 | 150 | { The type of memory allocated. Will be the text 'AnsiString', 151 | 'UnicodeString', a class name or an empty string for rawe memory. } 152 | [Serialize(6)] MemoryType: String; 153 | 154 | { The stack trace leading to this allocation, in FastMM5 log format } 155 | [Serialize(7)] StackTrace: String; 156 | end; 157 | 158 | type 159 | { Protocol buffer that defines a memory allocations report } 160 | TgoLogMemoryAllocationsProtocol = record 161 | public 162 | { Array of memory allocations } 163 | [Serialize(1)] Allocations: TArray; 164 | end; 165 | 166 | type 167 | TgoCloudLogger = class(TZMQClientProtocol) 168 | private 169 | { Internal } 170 | FBroker: String; 171 | FAppName: String; 172 | FProcessId: Cardinal; 173 | 174 | procedure SetBroker(const Value: String); 175 | private 176 | class function GetMemoryUsage(const AArgs: TBytes): TBytes; static; 177 | class function GetLiveWatches: TBytes; static; 178 | protected 179 | { Implements the DoRecv from the client protocol class } 180 | procedure DoRecv(const ACommand: TZMQCommand; 181 | var AMsg: PZMessage; var ASentFrom: PZFrame); override; 182 | public 183 | constructor Create; 184 | destructor Destroy; override; 185 | 186 | { Sends a message to the specified service, with optional data } 187 | procedure Send(const AService: String; const AMsg: String; 188 | const ALevel, ADataFormat: Integer; const AData: TBytes); reintroduce; 189 | 190 | property Broker: String read FBroker write SetBroker; 191 | end; 192 | 193 | type 194 | { This message is broadcast to receive fill a TgoLogMemoryUsageProtocol 195 | record with information about live instances. 196 | The Grijjy.CloudLogging.InstanceTracker unit listens for this message. } 197 | TgoGetInstancesMessage = class(TMessage) 198 | private 199 | FClasses: TArray; 200 | public 201 | constructor Create(const AClasses: TArray); 202 | 203 | { Is set to an array of classes for which to receive details (instances). 204 | This are the classes that are expanded in the corresponding tree view in 205 | the log viewer. If nil, only class summaries are returned. } 206 | property Classes: TArray read FClasses; 207 | public 208 | { The protocol to be filled in by the message listener. } 209 | Protocol: TgoLogMemoryUsageProtocol; 210 | end; 211 | 212 | const 213 | { These constants are used internally and are shared with the Log Viewer. 214 | You should not use these yourself. } 215 | LOG_FORMAT_NONE = 0; 216 | LOG_FORMAT_TSTRINGS = 1; 217 | LOG_FORMAT_MEMORY = 2; 218 | LOG_FORMAT_OBJECT = 3; 219 | 220 | LOG_FORMAT_CONNECTED = -1; 221 | LOG_FORMAT_MEMORY_USAGE = -2; 222 | LOG_FORMAT_LIVE_WATCHES = -3; 223 | LOG_FORMAT_ALLOCATIONS = -4; 224 | 225 | implementation 226 | 227 | uses 228 | System.Classes, 229 | {$IF Defined(MSWINDOWS)} 230 | Winapi.Windows, 231 | {$ELSEIF Defined(ANDROID)} 232 | Androidapi.Helpers, 233 | {$ELSEIF Defined(IOS)} 234 | iOSapi.Foundation, 235 | Macapi.Helpers, 236 | Macapi.ObjectiveC, 237 | {$ENDIF} 238 | {$IF Defined(POSIX)} 239 | Posix.Unistd, 240 | {$ENDIF} 241 | Grijjy.SysUtils, 242 | Grijjy.CloudLogging; 243 | 244 | { TgoCloudLogger } 245 | 246 | constructor TgoCloudLogger.Create; 247 | {$IF Defined(IOS)} 248 | var 249 | AppNameKey: Pointer; 250 | AppBundle: NSBundle; 251 | NSAppName: NSString; 252 | {$ENDIF} 253 | begin 254 | inherited Create; 255 | {$IF Defined(IOS)} 256 | AppNameKey := (StrToNSStr('CFBundleName') as ILocalObject).GetObjectID; 257 | AppBundle := TNSBundle.Wrap(TNSBundle.OCClass.mainBundle); 258 | NSAppName := TNSString.Wrap(AppBundle.infoDictionary.objectForKey(AppNameKey)); 259 | FAppName := UTF8ToString(NSAppName.UTF8String); 260 | {$ELSEIF Defined(Android)} 261 | FAppName := TAndroidHelper.ApplicationTitle; 262 | {$ELSE} 263 | FAppName := ChangeFileExt(ExtractFileName(GetModuleName(0)), ''); 264 | {$ENDIF} 265 | 266 | {$IF Defined(MSWINDOWS)} 267 | FProcessId := GetCurrentProcessId; 268 | {$ELSEIF Defined(POSIX)} 269 | FProcessId := getpid; 270 | {$ENDIF} 271 | end; 272 | 273 | destructor TgoCloudLogger.Destroy; 274 | begin 275 | inherited; 276 | end; 277 | 278 | { Sends a message to the specified service, with optional userdefined and data } 279 | procedure TgoCloudLogger.Send(const AService: String; const AMsg: String; 280 | const ALevel, ADataFormat: Integer; const AData: TBytes); 281 | var 282 | Msg: PZMessage; 283 | Protocol: TgoLogMessageProtocol; 284 | begin 285 | Msg := TZMessage.Create; 286 | try 287 | Protocol.MessageText := AMsg; 288 | Protocol.Level := ALevel; 289 | Protocol.ProcessId := FProcessId; 290 | Protocol.ThreadId := TThread.CurrentThread.ThreadID; 291 | Protocol.AppName := FAppName; 292 | Protocol.TimeStamp := Now; 293 | Protocol.DataFormat := ADataFormat; 294 | Protocol.Data := AData; 295 | Msg.PushProtocolBuffer(Protocol); 296 | 297 | if (AService = '') then 298 | inherited Send(GrijjyLog.Service, Msg) 299 | else 300 | inherited Send(AService, Msg); 301 | finally 302 | Msg.Free; 303 | end; 304 | end; 305 | 306 | procedure TgoCloudLogger.SetBroker(const Value: String); 307 | begin 308 | if (Value <> FBroker) then 309 | begin 310 | FBroker := Value; 311 | Connect(FBroker); 312 | end; 313 | end; 314 | 315 | { Implements the DoRecv from the client protocol class } 316 | procedure TgoCloudLogger.DoRecv(const ACommand: TZMQCommand; 317 | var AMsg: PZMessage; var ASentFrom: PZFrame); 318 | var 319 | Service: String; 320 | Protocol: TgoLogCommandProtocol; 321 | ReturnData: TBytes; 322 | begin 323 | Service := AMsg.PopString; 324 | AMsg.PopProtocolBuffer(Protocol); 325 | 326 | ReturnData := nil; 327 | case Protocol.Command of 328 | LOG_FORMAT_MEMORY_USAGE: 329 | ReturnData := GetMemoryUsage(Protocol.Args); 330 | 331 | LOG_FORMAT_LIVE_WATCHES: 332 | ReturnData := GetLiveWatches; 333 | else 334 | Exit; 335 | end; 336 | 337 | Send(Service, '', Ord(TgoLogLevel.Error), Protocol.Command, ReturnData); 338 | end; 339 | 340 | class function TgoCloudLogger.GetLiveWatches: TBytes; 341 | var 342 | Msg: TgoLiveWatchesMessage; 343 | Protocol: TgoLogLiveWatchesProtocol; 344 | begin 345 | Msg := TgoLiveWatchesMessage.Create; 346 | try 347 | {$IFDEF CONSOLE} 348 | TMessageManager.DefaultManager.SendMessage(nil, Msg, False); 349 | {$ELSE} 350 | { Listeners for this message may need to access the GUI, so always send 351 | this message in the UI thread. } 352 | TThread.Synchronize(nil, 353 | procedure 354 | begin 355 | TMessageManager.DefaultManager.SendMessage(nil, Msg, False); 356 | end); 357 | {$ENDIF} 358 | 359 | Protocol.Watches := Msg.GetWatches; 360 | Result := TgoProtocolBuffer.Serialize(Protocol); 361 | finally 362 | Msg.Free; 363 | end; 364 | end; 365 | 366 | class function TgoCloudLogger.GetMemoryUsage(const AArgs: TBytes): TBytes; 367 | var 368 | Msg: TgoGetInstancesMessage; 369 | Handles: TgoHandleArray; 370 | begin 371 | Handles.Handles := nil; 372 | if Assigned(AArgs) then 373 | TgoProtocolBuffer.Deserialize(Handles, AArgs); 374 | 375 | Msg := TgoGetInstancesMessage.Create(TArray(Handles.Handles)); 376 | try 377 | TMessageManager.DefaultManager.SendMessage(nil, Msg, False); 378 | Msg.Protocol.AllocatedBytes := goGetAllocatedMemory; 379 | Result := TgoProtocolBuffer.Serialize(Msg.Protocol); 380 | finally 381 | Msg.Free; 382 | end; 383 | end; 384 | 385 | { TgoGetInstancesMessage } 386 | 387 | constructor TgoGetInstancesMessage.Create(const AClasses: TArray); 388 | begin 389 | inherited Create; 390 | FClasses := AClasses; 391 | end; 392 | 393 | end. 394 | -------------------------------------------------------------------------------- /Grijjy.Scram.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.Scram; 2 | { Routines for handling Salted Challenge Response Authentication Mechanism (SCRAM) } 3 | 4 | { https://tools.ietf.org/html/rfc5802 5 | Currently supports SCRAM-SHA-1 and SCRAM-SHA-256 } 6 | 7 | {$INCLUDE 'Grijjy.inc'} 8 | 9 | interface 10 | 11 | uses 12 | System.SysUtils, 13 | Grijjy.System; 14 | 15 | const 16 | { GS2 header } 17 | SCRAM_GS2_HEADER = 'n,,'; 18 | 19 | type 20 | { Scram mechanism } 21 | TgoScramMechanism = (SCRAM_SHA_1, SCRAM_SHA_256); 22 | 23 | { Scram authentication helper class } 24 | TgoScram = class 25 | private 26 | FNonce: String; 27 | FScramGs2Header: String; 28 | FMechanism: TgoScramMechanism; 29 | FUsername: String; 30 | FPassword: String; 31 | 32 | { Step 1 } 33 | FClientFirstMsg: String; 34 | FConversationId: Integer; 35 | FServerFirstMsg: String; 36 | FServerNonce, FServerSalt: String; 37 | FServerIterations: Integer; 38 | 39 | { Step 2 } 40 | FSaltedPassword: TBytes; 41 | FAuthMessage: String; 42 | FServerSecondMsg: String; 43 | FActualServerSignature, FExpectedServerSignature: String; 44 | FClientFinalMsg: String; 45 | protected 46 | function PBKDF2(const APassword: TBytes; const ASalt: TBytes; const ACount: Integer; 47 | const AKeylength: Integer): TBytes; 48 | public 49 | constructor Create(const AMechanism: TgoScramMechanism; const AUsername, APassword: String); 50 | destructor Destroy; override; 51 | public 52 | { Creates the first client to server message } 53 | procedure CreateFirstMsg; 54 | 55 | { Processes the first server to client response message } 56 | procedure HandleServerFirstMsg(const AConversationId: Integer; const AServerFirstMsg: String); 57 | 58 | { Processes the second server to client response message } 59 | procedure HandleServerSecondMsg(const AServerSecondMsg: String); 60 | 61 | { Returns True if the expected server signature matches the actual signature } 62 | function ValidSignature: Boolean; 63 | public 64 | { Client random nonce } 65 | property Nonce: String read FNonce; 66 | 67 | { Client first message } 68 | property ClientFirstMsg: String read FClientFirstMsg; 69 | 70 | { Client conversation id } 71 | property ConversationId: Integer read FConversationId; 72 | 73 | { Client final message } 74 | property ClientFinalMsg: String read FClientFinalMsg; 75 | end; 76 | 77 | implementation 78 | 79 | uses 80 | System.Math, 81 | System.Hash, 82 | System.Generics.Collections, 83 | Grijjy.BinaryCoding; 84 | 85 | function CreateNonce: String; 86 | var 87 | Index: Integer; 88 | const 89 | Charset: String = '0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'; 90 | begin 91 | Randomize; 92 | for Index := 0 to 31 do 93 | Result := Result + Charset[Random(62) + 1]; { Note: This is not considered crypto strength, use OpenSsl's Rand() instead } 94 | end; 95 | 96 | function SplitString(const AString: String; const ASeparator: array of String): TDictionary; 97 | var 98 | Strings: TArray; 99 | S, Key, Value: String; 100 | Index: Integer; 101 | begin 102 | Result := TDictionary.Create; 103 | 104 | Strings := AString.Split(ASeparator); 105 | for S in Strings do 106 | begin 107 | Index := S.IndexOf('='); 108 | if Index = -1 then 109 | Continue; 110 | 111 | Key := S.Substring(0, Index); 112 | Value := S.Substring(Index + 1); 113 | Result.Add(Key, Value); 114 | end; 115 | end; 116 | 117 | function BytesToHexString(const ABytes: TBytes): String; 118 | var 119 | I: Integer; 120 | begin 121 | for I := Low(ABytes) to High(ABytes) do 122 | Result := Result + IntToHex(ABytes[I], 2); 123 | end; 124 | 125 | procedure XorBytes(var ADestBytes: TBytes; const ASourceBytes: TBytes); 126 | var 127 | I: Integer; 128 | begin 129 | for I := Low(ADestBytes) to High(ADestBytes) do 130 | ADestBytes[I] := ADestBytes[I] xor ASourceBytes[I]; 131 | end; 132 | 133 | function ConcatenateBytes(const ADestBytes: TBytes; const ASourceBytes: TBytes): TBytes; inline; 134 | begin 135 | SetLength(Result, Length(ADestBytes) + Length(ASourceBytes)); 136 | if Length(ADestBytes) > 0 then 137 | Move(ADestBytes[Low(ADestBytes)], Result[Low(Result)], Length(ADestBytes)); 138 | if Length(ASourceBytes) > 0 then 139 | Move(ASourceBytes[Low(ASourceBytes)], Result[Low(Result)+Length(ADestBytes)], Length(ASourceBytes)); 140 | end; 141 | 142 | function SaslPrepPassword(APassword: String): String; 143 | var 144 | I: Integer; 145 | begin 146 | Result := APassword; 147 | for I := 1 to Length(APassword) do 148 | case Word(APassword[I]) of 149 | $00A0, $1680, $2000, $2001, $2002, $2003, $2004, $2005, $2006, $2007, $2008, $2009, $200A, $202F, $205F, $3000: 150 | begin 151 | Result[I] := #$0020; 152 | end; 153 | end; 154 | end; 155 | 156 | { TgoScram } 157 | 158 | constructor TgoScram.Create(const AMechanism: TgoScramMechanism; const AUsername, APassword: String); 159 | begin 160 | FMechanism := AMechanism; 161 | FUsername := AUsername; 162 | FPassword := APassword; 163 | 164 | FNonce := CreateNonce; 165 | FScramGs2Header := TEncoding.Utf8.GetString(goBase64Encode(TEncoding.Utf8.GetBytes(SCRAM_GS2_HEADER))); 166 | end; 167 | 168 | destructor TgoScram.Destroy; 169 | begin 170 | 171 | inherited; 172 | end; 173 | 174 | function TgoScram.PBKDF2(const APassword: TBytes; const ASalt: TBytes; const ACount: Integer; 175 | const AKeylength: Integer): TBytes; 176 | var 177 | BlockCount: Integer; 178 | I: Int32; 179 | F: TBytes; 180 | U: TBytes; 181 | J: Integer; 182 | T: TBytes; 183 | HashLength: Integer; 184 | 185 | function INT_32_BE(const AValue: Int32): TBytes; 186 | begin 187 | Result := TBytes.Create(AValue shr 24, AValue shr 16, AValue shr 8, AValue); 188 | end; 189 | 190 | begin 191 | if FMechanism = TgoScramMechanism.SCRAM_SHA_1 then 192 | HashLength := Length(THashSHA1.GetHMACAsBytes('','')) 193 | else 194 | HashLength := Length(THashSHA2.GetHMACAsBytes('','')); 195 | BlockCount := Ceil(AKeylength / HashLength); 196 | for I := 1 to BlockCount do 197 | begin 198 | if FMechanism = TgoScramMechanism.SCRAM_SHA_1 then 199 | F := THashSHA1.GetHMACAsBytes(ConcatenateBytes(ASalt, INT_32_BE(I)), APassword) 200 | else 201 | F := THashSHA2.GetHMACAsBytes(ConcatenateBytes(ASalt, INT_32_BE(I)), APassword); 202 | U := Copy(F); 203 | for J := 2 to ACount do 204 | begin 205 | if FMechanism = TgoScramMechanism.SCRAM_SHA_1 then 206 | U := THashSHA1.GetHMACAsBytes(U, APassword) 207 | else 208 | U := THashSHA2.GetHMACAsBytes(U, APassword); 209 | XorBytes(F, U); 210 | end; 211 | T := ConcatenateBytes(T, F); 212 | end; 213 | Result := Copy(T, Low(T), AKeylength); 214 | end; 215 | 216 | procedure TgoScram.CreateFirstMsg; 217 | var 218 | Username: String; 219 | begin 220 | { Convert username characters so special characters are handled properly within payloads } 221 | Username := FUsername.Replace('=', '=3D').Replace(',', '=2C'); 222 | 223 | { Create the string of the client to server first message } 224 | FClientFirstMsg := 'n=' + Username + ',r=' + FNonce; 225 | end; 226 | 227 | procedure TgoScram.HandleServerFirstMsg(const AConversationId: Integer; 228 | const AServerFirstMsg: String); 229 | var 230 | ServerMsg: TDictionary; 231 | Iterations: String; 232 | SHA1: THashSHA1; 233 | SHA256: THashSHA2; 234 | MD5: THashMD5; 235 | MD5Digest: TBytes; 236 | HashedPassword: String; 237 | ClientFinalNoPf: String; 238 | ClientKey, StoredKey, ClientSignature, ClientProof: TBytes; 239 | begin 240 | FConversationId := AConversationId; 241 | 242 | { ex: r=PbeWTe0x6is8tezKDg44MeIsmVWOD1cis3W4HBsbkZEKSEkj+EEGvJiwNcK11dr5,s=J5P6oNGeHYmVlWE2j5a6tw==,i=10000 } 243 | FServerFirstMsg := AServerFirstMsg; 244 | 245 | { Parse the first server message } 246 | ServerMsg := SplitString(FServerFirstMsg, [',']); 247 | try 248 | ServerMsg.TryGetValue('r', FServerNonce); 249 | ServerMsg.TryGetValue('s', FServerSalt); 250 | ServerMsg.TryGetValue('i', Iterations); 251 | FServerIterations := StrToIntDef(Iterations, 10000); 252 | finally 253 | ServerMsg.Free; 254 | end; 255 | 256 | { Step 2 } 257 | 258 | if FMechanism = TgoScramMechanism.SCRAM_SHA_1 then 259 | begin 260 | { Calculate a hash of the normalized password } 261 | MD5 := THashMD5.Create; 262 | MD5.Update(TEncoding.UTF8.GetBytes(FUsername + ':mongo:' + FPassword)); 263 | MD5Digest := MD5.HashAsBytes; 264 | HashedPassword := BytesToHexString(MD5Digest).ToLower; 265 | 266 | { Calculate a Password-Based Key Derivation Function hash of the password using the server provided salt } 267 | FSaltedPassword := PBKDF2(TEncoding.Utf8.GetBytes(HashedPassword), 268 | goBase64Decode(TEncoding.Utf8.GetBytes(FServerSalt)), 269 | FServerIterations, 270 | 20); 271 | end 272 | else 273 | begin 274 | { Calculate a Password-Based Key Derivation Function hash of the password using the server provided salt } 275 | FSaltedPassword := PBKDF2(TEncoding.Utf8.GetBytes(SaslPrepPassword(FPassword)), 276 | goBase64Decode(TEncoding.Utf8.GetBytes(FServerSalt)), 277 | FServerIterations, 278 | 32); 279 | end; 280 | 281 | { Create the client final no proof 282 | Note that biws is a constant and is the just the GS2 header string 'n,,' Base64 encoded } 283 | { ex: "c=biws,r=fyko+d2lbbFgONRv9qkxdawLHo+Vgk7qvUOKUwuWLIWg4l/9SraGMHEE" } 284 | ClientFinalNoPf := 'c=' + FScramGs2Header + ',r=' + FServerNonce; 285 | 286 | { ex: "n=user,r=fyko+d2lbbFgONRv9qkxdawL,r=fyko+d2lbbFgONRv9qkxdawLHo+Vgk7qvUOKUwuWLIWg4l/9SraGMHEE,s=rQ9ZY3MntBeuP3E1TDVC4w==,i=10000,c=biws,r=fyko+d2lbbFgONRv9qkxdawLHo+Vgk7qvUOKUwuWLIWg4l/9SraGMHEE" } 287 | FAuthMessage := FClientFirstMsg + ',' + FServerFirstMsg + ',' + ClientFinalNoPf; 288 | 289 | { The string 'Client Key' is also constant and is used as a default message to be hashed by the (salted) password } 290 | { ex: 6e ca 60 b8 b0 46 77 1f c7 17 40 92 de 6e 7e 83 78 59 b3 56 } 291 | if FMechanism = TgoScramMechanism.SCRAM_SHA_1 then 292 | ClientKey := THashSHA1.GetHMACAsBytes('Client Key', FSaltedPassword) 293 | else 294 | ClientKey := THashSHA2.GetHMACAsBytes('Client Key', FSaltedPassword); 295 | 296 | { ex: a7 9c fa 9f b5 2d a9 ff a9 2c 19 1a 78 99 38 4f 77 81 38 e0 } 297 | if FMechanism = TgoScramMechanism.SCRAM_SHA_1 then 298 | begin 299 | SHA1 := THashSHA1.Create; 300 | SHA1.Update(ClientKey); 301 | StoredKey := SHA1.HashAsBytes; 302 | end 303 | else 304 | begin 305 | SHA256 := THashSHA2.Create; 306 | SHA256.Update(ClientKey); 307 | StoredKey := SHA256.HashAsBytes; 308 | end; 309 | 310 | { ex: 5e e7 f3 48 ab 9d ee 7b 9b 87 7c ae 7f 07 07 a2 20 78 73 70 } 311 | if FMechanism = TgoScramMechanism.SCRAM_SHA_1 then 312 | ClientSignature := THashSHA1.GetHMACAsBytes(FAuthMessage, StoredKey) 313 | else 314 | ClientSignature := THashSHA2.GetHMACAsBytes(FAuthMessage, StoredKey); 315 | 316 | { ex: 30 2d 93 f0 1b db 99 64 5c 90 3c 3c a1 69 79 21 58 21 c0 26 } 317 | ClientProof := ClientKey; 318 | XorBytes(ClientProof, ClientSignature); 319 | 320 | { ex: "c=biws,r=fyko+d2lbbFgONRv9qkxdawLHo+Vgk7qvUOKUwuWLIWg4l/9SraGMHEE,p=MC2T8BvbmWRckDw8oWl5IVghwCY=" } 321 | FClientFinalMsg := ClientFinalNoPf + ',p=' + TEncoding.Utf8.GetString(goBase64Encode(ClientProof)); 322 | end; 323 | 324 | procedure TgoScram.HandleServerSecondMsg(const AServerSecondMsg: String); 325 | var 326 | ServerMsg: TDictionary; 327 | ServerKey: TBytes; 328 | begin 329 | FServerSecondMsg := AServerSecondMsg; 330 | 331 | { Now it is our chance to validate the server and check that it also knows the user's password. 332 | Note the string "Server Key" is constant and is used as a default message to be hashed by the (salted) password. } 333 | ServerMsg := SplitString(FServerSecondMsg, [',']); 334 | try 335 | ServerMsg.TryGetValue('v', FActualServerSignature); 336 | finally 337 | ServerMsg.Free; 338 | end; 339 | 340 | { ex: 95 1a d5 1f 2a 8c 5f e3 8e a8 6b e9 72 fb fd 6a 79 40 f0 84 } 341 | if FMechanism = TgoScramMechanism.SCRAM_SHA_1 then 342 | ServerKey := THashSHA1.GetHMACAsBytes('Server Key', FSaltedPassword) 343 | else 344 | ServerKey := THashSHA2.GetHMACAsBytes('Server Key', FSaltedPassword); 345 | 346 | { The actual and expected signature should match } 347 | { ex: "UMWeI25JD1yNYZRMpZ4VHvhZ9e0=" } 348 | if FMechanism = TgoScramMechanism.SCRAM_SHA_1 then 349 | FExpectedServerSignature := TEncoding.Utf8.GetString(goBase64Encode(THashSHA1.GetHMACAsBytes(FAuthMessage, ServerKey))) 350 | else 351 | FExpectedServerSignature := TEncoding.Utf8.GetString(goBase64Encode(THashSHA2.GetHMACAsBytes(FAuthMessage, ServerKey))); 352 | end; 353 | 354 | function TgoScram.ValidSignature: Boolean; 355 | begin 356 | Result := FExpectedServerSignature = FActualServerSignature; 357 | end; 358 | 359 | end. 360 | -------------------------------------------------------------------------------- /UnitTests/Tests/Tests.Grijjy.Collections.Base.pas: -------------------------------------------------------------------------------- 1 | unit Tests.Grijjy.Collections.Base; 2 | 3 | interface 4 | 5 | uses 6 | System.TypInfo, 7 | System.SysUtils, 8 | System.Generics.Defaults, 9 | System.Generics.Collections, 10 | DUnitX.TestFramework; 11 | 12 | type 13 | TTestCollectionBase = class abstract 14 | private 15 | FTypeInfo: PTypeInfo; 16 | FTypeData: PTypeData; 17 | FAllocatedValues: TList; 18 | FComparer: IEqualityComparer; 19 | private 20 | procedure ReleaseValue(const AValue: T); 21 | protected 22 | procedure SetUp; 23 | procedure TearDown; 24 | function CreateValue(const AValue: Integer): T; 25 | function CreateValues(const ACount: Integer): TArray; overload; 26 | function CreateValues(const AValues: array of Integer): TArray; overload; 27 | procedure TestEquals(const AExpected, AActual: T); 28 | end; 29 | 30 | {$REGION 'Different sample types for testing generic collections'} 31 | type 32 | TDigit = (Zero, One, Two, Three, Four, Five, Six, Seven, Eight, Nine); 33 | TDigits = set of TDigit; 34 | TTestProc = procedure(const AParam: Integer); 35 | 36 | {$IFNDEF NEXTGEN} 37 | type 38 | {$IF (RTLVersion = 33)} 39 | // For some reason, Delphi 10.3 Rio raises AVs with short string of length 1 40 | TStr1 = String[2]; 41 | {$ELSE} 42 | TStr1 = String[1]; 43 | {$ENDIF} 44 | TStr2 = String[2]; 45 | TStr3 = String[3]; 46 | {$ENDIF} 47 | 48 | type 49 | TSimpleRecord = record 50 | A: Integer; 51 | B: Single; 52 | C: Double; 53 | D: Word; 54 | end; 55 | 56 | type 57 | TManagedRecord = record 58 | A: Integer; 59 | B: TBytes; 60 | C: String; 61 | end; 62 | 63 | type 64 | TBar = class; 65 | 66 | TFoo = class 67 | public class var 68 | InstanceCount: Integer; 69 | private 70 | FValue: Integer; 71 | FBar: TBar; 72 | public 73 | constructor Create(const AValue: Integer); 74 | destructor Destroy; override; 75 | 76 | property Value: Integer read FValue; 77 | property Bar: TBar read FBar write FBar; 78 | end; 79 | TFooClass = class of TFoo; 80 | 81 | TBar = class 82 | public class var 83 | InstanceCount: Integer; 84 | private 85 | FValue: Integer; 86 | [weak] FFoo: TFoo; 87 | public 88 | constructor Create(const AValue: Integer); 89 | destructor Destroy; override; 90 | function Equals(Obj: TObject): Boolean; override; 91 | function GetHashCode: Integer; override; 92 | 93 | property Value: Integer read FValue; 94 | property Foo: TFoo read FFoo write FFoo; 95 | end; 96 | 97 | type 98 | IBaz = interface 99 | ['{A6B59548-5982-4D6A-90CA-46134A514802}'] 100 | function GetValue: Integer; 101 | 102 | property Value: Integer read GetValue; 103 | end; 104 | 105 | type 106 | TBaz = class(TInterfacedObject, IBaz) 107 | private 108 | FValue: Integer; 109 | private 110 | function GetValue: Integer; 111 | public 112 | constructor Create(const AValue: Integer); 113 | end; 114 | 115 | type 116 | TFooBarRecord = record 117 | Foo: TFoo; 118 | Bar: TBar; 119 | end; 120 | 121 | type 122 | TTestArray = array [0..2] of Integer; 123 | TManagedArray = TArray; 124 | TFooBarArray = TArray; 125 | {$ENDREGION 'Different sample types for testing generic collections'} 126 | 127 | implementation 128 | 129 | { TFoo } 130 | 131 | constructor TFoo.Create(const AValue: Integer); 132 | begin 133 | inherited Create; 134 | FValue := AValue; 135 | Inc(InstanceCount); 136 | end; 137 | 138 | destructor TFoo.Destroy; 139 | begin 140 | Dec(InstanceCount); 141 | inherited; 142 | end; 143 | 144 | { TBar } 145 | 146 | constructor TBar.Create(const AValue: Integer); 147 | begin 148 | inherited Create; 149 | FValue := AValue; 150 | Inc(InstanceCount); 151 | end; 152 | 153 | destructor TBar.Destroy; 154 | begin 155 | Dec(InstanceCount); 156 | inherited; 157 | end; 158 | 159 | function TBar.Equals(Obj: TObject): Boolean; 160 | begin 161 | if (Obj = Self) then 162 | Exit(True); 163 | 164 | if (Obj = nil) then 165 | Exit(False); 166 | 167 | if (Obj is TBar) then 168 | Result := (FValue = TBar(Obj).FValue) 169 | else 170 | Result := False; 171 | end; 172 | 173 | function TBar.GetHashCode: Integer; 174 | begin 175 | Result := FValue; 176 | end; 177 | 178 | { TBaz } 179 | 180 | constructor TBaz.Create(const AValue: Integer); 181 | begin 182 | inherited Create; 183 | FValue := AValue; 184 | end; 185 | 186 | function TBaz.GetValue: Integer; 187 | begin 188 | Result := FValue; 189 | end; 190 | 191 | { TTestCollectionBase } 192 | 193 | function TTestCollectionBase.CreateValue(const AValue: Integer): T; 194 | var 195 | I1: Int8 absolute Result; 196 | U1: UInt8 absolute Result; 197 | I2: Int16 absolute Result; 198 | U2: UInt16 absolute Result; 199 | I4: Int32 absolute Result; 200 | U4: UInt32 absolute Result; 201 | I8: Int64 absolute Result; 202 | R4: Single absolute Result; 203 | R8: Double absolute Result; 204 | R10: Extended absolute Result; 205 | RI8: Comp absolute Result; 206 | RC8: Currency absolute Result; 207 | Obj: TObject absolute Result; 208 | Cls: TClass absolute Result; 209 | Intf: IInterface absolute Result; 210 | Ptr: Pointer absolute Result; 211 | Proc: TProcedure absolute Result; 212 | Method: TMethod absolute Result; 213 | UnicodeStr: UnicodeString absolute Result; 214 | V: Variant absolute Result; 215 | Bytes: TBytes absolute Result; 216 | WC: WideChar absolute Result; 217 | Arr: TTestArray absolute Result; 218 | SR: TSimpleRecord absolute Result; 219 | MR: TManagedRecord absolute Result; 220 | FB: TFooBarRecord absolute Result; 221 | MA: TManagedArray absolute Result; 222 | FBA: TFooBarArray absolute Result; 223 | Foo: TFoo; 224 | Bar: TBar; 225 | {$IFNDEF NEXTGEN} 226 | Str1: TStr1 absolute Result; 227 | Str2: TStr2 absolute Result; 228 | Str3: TStr3 absolute Result; 229 | StrN: ShortString absolute Result; 230 | AnsiStr: AnsiString absolute Result; 231 | WideStr: WideString absolute Result; 232 | AC: AnsiChar absolute Result; 233 | {$ENDIF} 234 | begin 235 | case FTypeInfo.Kind of 236 | tkInteger, 237 | tkEnumeration: 238 | begin 239 | case FTypeData.OrdType of 240 | otSByte: I1 := Int8(AValue); 241 | otUByte: U1 := UInt8(AValue); 242 | otSWord: I2 := Int16(AValue); 243 | otUWord: U2 := UInt16(AValue); 244 | otSLong: I4 := AValue; 245 | otULong: U4 := UInt32(AValue); 246 | else 247 | System.Assert(False); 248 | end; 249 | end; 250 | 251 | tkFloat: 252 | begin 253 | case FTypeData.FloatType of 254 | ftSingle : R4 := AValue; 255 | ftDouble : R8 := AValue; 256 | ftExtended: R10 := AValue; 257 | ftComp : RI8 := AValue; 258 | ftCurr : RC8 := AValue; 259 | else 260 | System.Assert(False); 261 | end; 262 | end; 263 | 264 | tkClass: 265 | begin 266 | System.Assert(TypeInfo(T) = TypeInfo(TFoo)); 267 | Obj := TFoo.Create(AValue); 268 | end; 269 | 270 | tkClassRef: 271 | Cls := TFoo; 272 | 273 | tkInterface: 274 | Intf := TBaz.Create(AValue); 275 | 276 | tkPointer: 277 | Ptr := Pointer(AValue); 278 | 279 | tkProcedure: 280 | Proc := Pointer(AValue); 281 | 282 | tkMethod: 283 | begin 284 | Method.Code := Pointer(AValue shr 4); 285 | Method.Data := Pointer(AValue and $0F); 286 | end; 287 | 288 | {$IFNDEF NEXTGEN} 289 | tkString: 290 | case SizeOf(T) of 291 | 2: begin Str1[0] := #1; Str1[1] := AnsiChar(AValue); end; 292 | 3: begin Str2[0] := #2; Str2[1] := AnsiChar(AValue); Str2[2] := AnsiChar(AValue shr 8) end; 293 | 4: begin Str3[0] := #3; Str3[1] := AnsiChar(AValue); Str3[2] := AnsiChar(AValue shr 8); Str3[3] := AnsiChar(AValue shr 16) end; 294 | else 295 | StrN := ShortString(IntToStr(AValue)); 296 | end; 297 | 298 | tkLString: 299 | AnsiStr := AnsiString(IntToStr(AValue)); 300 | 301 | tkWString: 302 | WideStr := WideString(IntToStr(AValue)); 303 | {$ENDIF} 304 | 305 | tkUString: 306 | UnicodeStr := UnicodeString(IntToStr(AValue)); 307 | 308 | tkVariant: 309 | V := AValue; 310 | 311 | tkInt64: 312 | I8 := AValue; 313 | 314 | tkDynArray: 315 | case FTypeData.DynArrElType^^.Kind of 316 | tkInteger: 317 | begin 318 | SetLength(Bytes, 2); 319 | Bytes[0] := AValue; 320 | Bytes[1] := AValue * 2; 321 | end; 322 | 323 | tkUString: 324 | begin 325 | SetLength(MA, 2); 326 | MA[0] := UnicodeString(IntToStr(AValue)); 327 | MA[1] := UnicodeString(IntToStr(AValue * 2)); 328 | end; 329 | 330 | tkRecord: 331 | begin 332 | SetLength(FBA, 2); 333 | FBA[0].Foo := TFoo.Create(AValue); 334 | FBA[0].Bar := TBar.Create(AValue * 2); 335 | FBA[0].Foo.Bar := FBA[0].Bar; 336 | FBA[0].Bar.Foo := FBA[0].Foo; 337 | 338 | FBA[1].Foo := TFoo.Create(AValue * 3); 339 | FBA[1].Bar := TBar.Create(AValue * 4); 340 | FBA[1].Foo.Bar := FBA[1].Bar; 341 | FBA[1].Bar.Foo := FBA[1].Foo; 342 | end 343 | else 344 | System.Assert(False); 345 | end; 346 | 347 | {$IFNDEF NEXTGEN} 348 | tkChar: 349 | AC := AnsiChar(AValue); 350 | {$ENDIF} 351 | 352 | tkWChar: 353 | WC := Char(AValue); 354 | 355 | tkSet: 356 | begin 357 | case SizeOf(T) of 358 | 1: U1 := AValue; 359 | 2: U2 := AValue; 360 | 4: U4 := AValue; 361 | else 362 | System.Assert(False); 363 | end; 364 | end; 365 | 366 | tkArray: 367 | begin 368 | Arr[0] := AValue; 369 | Arr[1] := AValue * 2; 370 | Arr[2] := AValue * 3; 371 | end; 372 | 373 | tkRecord: 374 | begin 375 | if (FTypeInfo.NameFld.ToString = 'TSimpleRecord') then 376 | begin 377 | SR.A := AValue; 378 | SR.B := AValue; 379 | SR.C := AValue; 380 | SR.D := AValue; 381 | end 382 | else if (FTypeInfo.NameFld.ToString = 'TManagedRecord') then 383 | begin 384 | MR.A := AValue; 385 | SetLength(MR.B, 1); 386 | MR.B[0] := Byte(AValue); 387 | MR.C := IntToStr(AValue); 388 | end 389 | else if (FTypeInfo.NameFld.ToString = 'TFooBarRecord') then 390 | begin 391 | Foo := TFoo.Create(AValue); 392 | Bar := TBar.Create(AValue * 2); 393 | 394 | { Create circular reference } 395 | Foo.Bar := Bar; 396 | Bar.Foo := Foo; 397 | FB.Foo := Foo; 398 | FB.Bar := Bar; 399 | end 400 | else 401 | System.Assert(False); 402 | end; 403 | else 404 | System.Assert(False); 405 | end; 406 | 407 | FAllocatedValues.Add(Result); 408 | end; 409 | 410 | function TTestCollectionBase.CreateValues(const ACount: Integer): TArray; 411 | var 412 | I: Integer; 413 | begin 414 | SetLength(Result, ACount); 415 | for I := 0 to ACount - 1 do 416 | Result[I] := CreateValue(I); 417 | end; 418 | 419 | function TTestCollectionBase.CreateValues( 420 | const AValues: array of Integer): TArray; 421 | var 422 | I: Integer; 423 | begin 424 | SetLength(Result, Length(AValues)); 425 | for I := 0 to Length(AValues) - 1 do 426 | Result[I] := CreateValue(AValues[I]); 427 | end; 428 | 429 | procedure TTestCollectionBase.ReleaseValue(const AValue: T); 430 | var 431 | Obj: TObject absolute AValue; 432 | FB: TFooBarRecord absolute AValue; 433 | FBA: TFooBarArray absolute AValue; 434 | I: Integer; 435 | begin 436 | case FTypeInfo.Kind of 437 | tkClass: 438 | Obj.Free; 439 | 440 | tkRecord: 441 | if (FTypeInfo.NameFld.ToString = 'TFooBarRecord') then 442 | begin 443 | FB.Foo.Free; 444 | FB.Bar.Free; 445 | end; 446 | 447 | tkDynArray: 448 | begin 449 | if (FTypeData.DynArrElType^^.Kind = tkRecord) then 450 | begin 451 | for I := 0 to Length(FBA) - 1 do 452 | begin 453 | FBA[I].Foo.Free; 454 | FBA[I].Bar.Free; 455 | end; 456 | end; 457 | end; 458 | end; 459 | end; 460 | 461 | procedure TTestCollectionBase.SetUp; 462 | begin 463 | FTypeInfo := System.TypeInfo(T); 464 | System.Assert(Assigned(FTypeInfo)); 465 | FTypeData := GetTypeData(FTypeInfo); 466 | System.Assert(Assigned(FTypeData)); 467 | FAllocatedValues := TList.Create; 468 | FComparer := TEqualityComparer.Default; 469 | TFoo.InstanceCount := 0; 470 | TBar.InstanceCount := 0; 471 | end; 472 | 473 | procedure TTestCollectionBase.TearDown; 474 | var 475 | Value: T; 476 | begin 477 | if Assigned(FAllocatedValues) then 478 | begin 479 | for Value in FAllocatedValues do 480 | ReleaseValue(Value); 481 | end; 482 | FAllocatedValues.Free; 483 | 484 | { For checking cycles between TFoo and TBar } 485 | Assert.AreEqual(0, TBar.InstanceCount, 'TBar leaks'); 486 | Assert.AreEqual(0, TFoo.InstanceCount, 'TFoo leaks'); 487 | end; 488 | 489 | procedure TTestCollectionBase.TestEquals(const AExpected, AActual: T); 490 | begin 491 | if (not FComparer.Equals(AExpected, AActual)) then 492 | Assert.Fail('Values not equal'); 493 | end; 494 | 495 | initialization 496 | ReportMemoryLeaksOnShutdown := True; 497 | 498 | end. 499 | -------------------------------------------------------------------------------- /UnitTests/Tests/Tests.Grijjy.Bson.Path.pas: -------------------------------------------------------------------------------- 1 | unit Tests.Grijjy.Bson.Path; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, 7 | DUnitX.TestFramework, 8 | Grijjy.Bson, 9 | Grijjy.Bson.Path; 10 | 11 | type 12 | TestBsonPathErrors = class 13 | private 14 | procedure TestFail(const AExpression: String); 15 | public 16 | [Test] procedure TestInvalidRoot; 17 | [Test] procedure TestInvalidOperator; 18 | [Test] procedure TestMissingMember; 19 | [Test] procedure TestMissingWildcardQuote; 20 | [Test] procedure TestWildcardQuoteMismatch; 21 | [Test] procedure TestWildcardMissingCloseBracket; 22 | [Test] procedure TestWildcardMissingCloseBracket2; 23 | [Test] procedure TestMissingNameQuote; 24 | [Test] procedure TestNameQuoteMismatch; 25 | [Test] procedure TestNameMissingCloseBracket; 26 | [Test] procedure TestEmptyName; 27 | [Test] procedure TestIndexMissingCloseBracket; 28 | [Test] procedure TestNegativeIndex; 29 | [Test] procedure TestNegativeListIndex; 30 | [Test] procedure TestTooManySliceArguments; 31 | [Test] procedure TestInvalidSliceStart; 32 | [Test] procedure TestInvalidSliceEnd; 33 | [Test] procedure TestInvalidSliceStep; 34 | [Test] procedure TestInvalidBracketOperator; 35 | [Test] procedure TestInvalidIndex; 36 | [Test] procedure TestInvalidIndexDelimiter; 37 | [Test] procedure TestSliceMissingCloseBracket; 38 | [Test] procedure TestIndicesMissingCloseBracket; 39 | [Test] procedure TestInvalidRecursiveDescent; 40 | end; 41 | 42 | type 43 | TestBsonPathBase = class 44 | protected 45 | FDoc: TgoBsonValue; 46 | procedure Test(const AExpression: String; 47 | const AExpected: array of String); 48 | end; 49 | 50 | type 51 | TestBsonPathExamples = class(TestBsonPathBase) 52 | public 53 | [Setup] procedure Setup; 54 | [Teardown] procedure Teardown; 55 | [Test] procedure TestMatchRoot; 56 | [Test] procedure TestMatchTitleOfFirstBookDot; 57 | [Test] procedure TestMatchTitleOfFirstBookBracket; 58 | [Test] procedure TestMatchAllAuthors; 59 | [Test] procedure TestMatchAuthorsFromAllBooks; 60 | [Test] procedure TestMatchAllThingsInStore; 61 | [Test] procedure TestMatchPriceOfAllThingsInStore; 62 | [Test] procedure TestMatchThirdBook; 63 | [Test] procedure TestMatchLastBook; 64 | [Test] procedure TestMatchFirstTwoBooksUsingSlice; 65 | [Test] procedure TestMatchFirstTwoBooksUsingList; 66 | [Test] procedure TestMatchAllBooks; 67 | [Test] procedure TestSingleMatch; 68 | end; 69 | 70 | type 71 | TesBJsonPath = class(TestBsonPathBase) 72 | public 73 | [Test] procedure Test1; 74 | [Test] procedure Test2; 75 | [Test] procedure Test3; 76 | end; 77 | 78 | implementation 79 | 80 | const 81 | JSON = 82 | '{ "store": {'#10+ 83 | ' "book": [ '#10+ 84 | ' { "category": "reference",'#10+ 85 | ' "author": "Nigel Rees",'#10+ 86 | ' "title": "Sayings of the Century",'#10+ 87 | ' "price": 8.95'#10+ 88 | ' },'#10+ 89 | ' { "category": "fiction",'#10+ 90 | ' "author": "Evelyn Waugh",'#10+ 91 | ' "title": "Sword of Honour",'#10+ 92 | ' "price": 12.99'#10+ 93 | ' },'#10+ 94 | ' { "category": "fiction",'#10+ 95 | ' "author": "Herman Melville",'#10+ 96 | ' "title": "Moby Dick",'#10+ 97 | ' "isbn": "0-553-21311-3",'#10+ 98 | ' "price": 8.99'#10+ 99 | ' },'#10+ 100 | ' { "category": "fiction",'#10+ 101 | ' "author": "J. R. R. Tolkien",'#10+ 102 | ' "title": "The Lord of the Rings",'#10+ 103 | ' "isbn": "0-395-19395-8",'#10+ 104 | ' "price": 22.99'#10+ 105 | ' }'#10+ 106 | ' ],'#10+ 107 | ' "bicycle": {'#10+ 108 | ' "color": "red",'#10+ 109 | ' "price": 19.95'#10+ 110 | ' }'#10+ 111 | ' }'#10+ 112 | '}'; 113 | 114 | { TestBsonPathErrors } 115 | 116 | procedure TestBsonPathErrors.TestEmptyName; 117 | begin 118 | TestFail('$[""]'); 119 | end; 120 | 121 | procedure TestBsonPathErrors.TestFail(const AExpression: String); 122 | begin 123 | Assert.WillRaise( 124 | procedure 125 | begin 126 | TgoBsonPath.Create(AExpression); 127 | end, EgoBsonPathError); 128 | end; 129 | 130 | procedure TestBsonPathErrors.TestIndexMissingCloseBracket; 131 | begin 132 | TestFail('$[1'); 133 | end; 134 | 135 | procedure TestBsonPathErrors.TestIndicesMissingCloseBracket; 136 | begin 137 | TestFail('$[1,2,3'); 138 | end; 139 | 140 | procedure TestBsonPathErrors.TestInvalidBracketOperator; 141 | begin 142 | TestFail('$[store]'); 143 | end; 144 | 145 | procedure TestBsonPathErrors.TestInvalidIndex; 146 | begin 147 | TestFail('$[1,2,a,4]'); 148 | end; 149 | 150 | procedure TestBsonPathErrors.TestInvalidIndexDelimiter; 151 | begin 152 | TestFail('$[1,2;4]'); 153 | end; 154 | 155 | procedure TestBsonPathErrors.TestInvalidOperator; 156 | begin 157 | TestFail('$store'); 158 | end; 159 | 160 | procedure TestBsonPathErrors.TestInvalidRecursiveDescent; 161 | begin 162 | TestFail('$..'); 163 | end; 164 | 165 | procedure TestBsonPathErrors.TestInvalidRoot; 166 | begin 167 | TestFail('.store.*'); 168 | end; 169 | 170 | procedure TestBsonPathErrors.TestInvalidSliceEnd; 171 | begin 172 | TestFail('$[1:a:3]'); 173 | end; 174 | 175 | procedure TestBsonPathErrors.TestInvalidSliceStart; 176 | begin 177 | TestFail('$[a:2:3]'); 178 | end; 179 | 180 | procedure TestBsonPathErrors.TestInvalidSliceStep; 181 | begin 182 | TestFail('$[1:2:a]'); 183 | end; 184 | 185 | procedure TestBsonPathErrors.TestMissingMember; 186 | begin 187 | TestFail('$.store.'); 188 | end; 189 | 190 | procedure TestBsonPathErrors.TestMissingNameQuote; 191 | begin 192 | TestFail('$["store]'); 193 | end; 194 | 195 | procedure TestBsonPathErrors.TestMissingWildcardQuote; 196 | begin 197 | TestFail('$["*]'); 198 | end; 199 | 200 | procedure TestBsonPathErrors.TestNameMissingCloseBracket; 201 | begin 202 | TestFail('$["store"'); 203 | end; 204 | 205 | procedure TestBsonPathErrors.TestNameQuoteMismatch; 206 | begin 207 | TestFail('$[''store"]'); 208 | end; 209 | 210 | procedure TestBsonPathErrors.TestNegativeIndex; 211 | begin 212 | TestFail('$[-1]'); 213 | end; 214 | 215 | procedure TestBsonPathErrors.TestNegativeListIndex; 216 | begin 217 | TestFail('$[1,-2,3]'); 218 | end; 219 | 220 | procedure TestBsonPathErrors.TestSliceMissingCloseBracket; 221 | begin 222 | TestFail('$[1:2:3'); 223 | end; 224 | 225 | procedure TestBsonPathErrors.TestTooManySliceArguments; 226 | begin 227 | TestFail('$[1:2:3:4]'); 228 | end; 229 | 230 | procedure TestBsonPathErrors.TestWildcardMissingCloseBracket; 231 | begin 232 | TestFail('$["*"'); 233 | end; 234 | 235 | procedure TestBsonPathErrors.TestWildcardMissingCloseBracket2; 236 | begin 237 | TestFail('$[*'); 238 | end; 239 | 240 | procedure TestBsonPathErrors.TestWildcardQuoteMismatch; 241 | begin 242 | TestFail('$[''*"]'); 243 | end; 244 | 245 | { TestBsonPathBase } 246 | 247 | procedure TestBsonPathBase.Test(const AExpression: String; 248 | const AExpected: array of String); 249 | var 250 | Matches: TArray; 251 | I: Integer; 252 | begin 253 | Matches := TgoBsonPath.Match(FDoc, AExpression); 254 | Assert.AreEqual(Length(AExpected), Length(Matches)); 255 | 256 | for I := 0 to Length(Matches) - 1 do 257 | Assert.AreEqual(AExpected[I], Matches[I].ToJson); 258 | end; 259 | 260 | { TestBsonPathExamples } 261 | 262 | procedure TestBsonPathExamples.Setup; 263 | begin 264 | FDoc := TgoBsonValue.Parse(JSON); 265 | end; 266 | 267 | procedure TestBsonPathExamples.Teardown; 268 | begin 269 | FDoc := nil; 270 | end; 271 | 272 | procedure TestBsonPathExamples.TestMatchAllAuthors; 273 | begin 274 | Test('$..author', ['"Nigel Rees"', '"Evelyn Waugh"', '"Herman Melville"', 275 | '"J. R. R. Tolkien"']); 276 | end; 277 | 278 | procedure TestBsonPathExamples.TestMatchAllBooks; 279 | begin 280 | Test('$.store.book[*]', [ 281 | '{ "category" : "reference", "author" : "Nigel Rees", "title" : "Sayings of the Century", "price" : 8.95 }', 282 | '{ "category" : "fiction", "author" : "Evelyn Waugh", "title" : "Sword of Honour", "price" : 12.99 }', 283 | '{ "category" : "fiction", "author" : "Herman Melville", "title" : "Moby Dick", "isbn" : "0-553-21311-3", "price" : 8.99 }', 284 | '{ "category" : "fiction", "author" : "J. R. R. Tolkien", "title" : "The Lord of the Rings", "isbn" : "0-395-19395-8", "price" : 22.99 }']); 285 | end; 286 | 287 | procedure TestBsonPathExamples.TestMatchAllThingsInStore; 288 | var 289 | Matches: TArray; 290 | begin 291 | Matches := TgoBsonPath.Match(FDoc, '$.store.*'); 292 | Assert.AreEqual(2, Length(Matches)); 293 | 294 | // First match is array of 4 books 295 | Assert.IsTrue(Matches[0].IsBsonArray); 296 | Assert.AreEqual(4, Matches[0].AsBsonArray.Count); 297 | 298 | // Second match is single dictionary with red bicycle 299 | Assert.IsTrue(Matches[1].IsBsonDocument); 300 | Assert.AreEqual('red', Matches[1].AsBsonDocument['color'].ToString); 301 | end; 302 | 303 | procedure TestBsonPathExamples.TestMatchAuthorsFromAllBooks; 304 | begin 305 | Test('$.store.book[*].author', ['"Nigel Rees"', '"Evelyn Waugh"', 306 | '"Herman Melville"', '"J. R. R. Tolkien"']); 307 | end; 308 | 309 | procedure TestBsonPathExamples.TestMatchFirstTwoBooksUsingList; 310 | begin 311 | Test('$..book[0,1]', [ 312 | '{ "category" : "reference", "author" : "Nigel Rees", "title" : "Sayings of the Century", "price" : 8.95 }', 313 | '{ "category" : "fiction", "author" : "Evelyn Waugh", "title" : "Sword of Honour", "price" : 12.99 }']); 314 | end; 315 | 316 | procedure TestBsonPathExamples.TestMatchFirstTwoBooksUsingSlice; 317 | begin 318 | Test('$..book[:2]', [ 319 | '{ "category" : "reference", "author" : "Nigel Rees", "title" : "Sayings of the Century", "price" : 8.95 }', 320 | '{ "category" : "fiction", "author" : "Evelyn Waugh", "title" : "Sword of Honour", "price" : 12.99 }']); 321 | end; 322 | 323 | procedure TestBsonPathExamples.TestMatchLastBook; 324 | begin 325 | Test('$..book[-1:]', ['{ "category" : "fiction", "author" : "J. R. R. Tolkien", "title" : "The Lord of the Rings", "isbn" : "0-395-19395-8", "price" : 22.99 }']); 326 | end; 327 | 328 | procedure TestBsonPathExamples.TestMatchPriceOfAllThingsInStore; 329 | begin 330 | Test('$.store..price', ['8.95', '12.99', '8.99', '22.99', '19.95']); 331 | end; 332 | 333 | procedure TestBsonPathExamples.TestMatchRoot; 334 | var 335 | Matches: TArray; 336 | begin 337 | Matches := TgoBsonPath.Match(FDoc, '$'); 338 | Assert.AreEqual(1, Length(Matches)); 339 | Assert.IsTrue(Matches[0] = FDoc); 340 | end; 341 | 342 | procedure TestBsonPathExamples.TestMatchThirdBook; 343 | begin 344 | Test('$..book[2]', ['{ "category" : "fiction", "author" : "Herman Melville", "title" : "Moby Dick", "isbn" : "0-553-21311-3", "price" : 8.99 }']); 345 | end; 346 | 347 | procedure TestBsonPathExamples.TestMatchTitleOfFirstBookBracket; 348 | begin 349 | Test('$["store"][''book''][0]["title"]', ['"Sayings of the Century"']); 350 | end; 351 | 352 | procedure TestBsonPathExamples.TestMatchTitleOfFirstBookDot; 353 | begin 354 | Test('$.store.book[0].title', ['"Sayings of the Century"']); 355 | end; 356 | 357 | procedure TestBsonPathExamples.TestSingleMatch; 358 | var 359 | Match: TgoBsonValue; 360 | begin 361 | Assert.IsTrue(TgoBsonPath.MatchSingle(FDoc, '$.store.bicycle', Match)); 362 | Assert.AreEqual('{ "color" : "red", "price" : 19.95 }', Match.ToJson); 363 | 364 | Assert.IsTrue(TgoBsonPath.MatchSingle(FDoc, '$.store.bicycle.*', Match)); 365 | Assert.AreEqual('"red"', Match.ToJson); 366 | end; 367 | 368 | { TesBJsonPath } 369 | 370 | { Tests from the original JSONPath package. } 371 | 372 | procedure TesBJsonPath.Test1; 373 | var 374 | Doc: TgoBsonDocument; 375 | begin 376 | Doc := TgoBsonDocument.Create; 377 | Doc.Add('a', 'a'); 378 | Doc.Add('b', 'b'); 379 | Doc.Add('c d', 'e'); 380 | FDoc := Doc; 381 | 382 | Test('$.a', ['"a"']); 383 | Test('$[''a'']', ['"a"']); 384 | Test('$["a"]', ['"a"']); 385 | Test('$["c d"]', ['"e"']); 386 | // Test('$."c d"', ['"e"']); // We don't support this syntax 387 | Test('$.*', ['"a"', '"b"', '"e"']); 388 | Test('$["*"]', ['"a"', '"b"', '"e"']); 389 | Test('$[*]', ['"a"', '"b"', '"e"']); 390 | end; 391 | 392 | procedure TesBJsonPath.Test2; 393 | var 394 | Arr: TgoBsonArray; 395 | begin 396 | Arr := TgoBsonArray.Create; 397 | Arr.Add(1); 398 | Arr.Add('2'); 399 | Arr.Add(3.14); 400 | Arr.Add(True); 401 | Arr.Add(TgoBsonNull.Value); 402 | FDoc := Arr; 403 | 404 | Test('$[0]', ['1']); 405 | Test('$[4]', ['null']); 406 | Test('$[*]', ['1', '"2"', '3.14', 'true', 'null']); 407 | Test('$[-1:]', ['null']); 408 | end; 409 | 410 | procedure TesBJsonPath.Test3; 411 | var 412 | Doc: TgoBsonDocument; 413 | Arr: TgoBsonArray; 414 | begin 415 | Doc := TgoBsonDocument.Create; 416 | FDoc := Doc; 417 | 418 | Arr := TgoBsonArray.Create; 419 | Doc.Add('points', Arr); 420 | 421 | Doc := TgoBsonDocument.Create; 422 | Arr.Add(Doc); 423 | Doc.Add('id', 'i1'); 424 | Doc.Add('x', 4); 425 | Doc.Add('y', -5); 426 | 427 | Doc := TgoBsonDocument.Create; 428 | Arr.Add(Doc); 429 | Doc.Add('id', 'i2'); 430 | Doc.Add('x', -2); 431 | Doc.Add('y', 2); 432 | Doc.Add('z', 1); 433 | 434 | Doc := TgoBsonDocument.Create; 435 | Arr.Add(Doc); 436 | Doc.Add('id', 'i3'); 437 | Doc.Add('x', 8); 438 | Doc.Add('y', 3); 439 | 440 | Doc := TgoBsonDocument.Create; 441 | Arr.Add(Doc); 442 | Doc.Add('id', 'i4'); 443 | Doc.Add('x', -6); 444 | Doc.Add('y', -1); 445 | 446 | Doc := TgoBsonDocument.Create; 447 | Arr.Add(Doc); 448 | Doc.Add('id', 'i5'); 449 | Doc.Add('x', 0); 450 | Doc.Add('y', 2); 451 | Doc.Add('z', 1); 452 | 453 | Doc := TgoBsonDocument.Create; 454 | Arr.Add(Doc); 455 | Doc.Add('id', 'i6'); 456 | Doc.Add('x', 1); 457 | Doc.Add('y', 4); 458 | 459 | Test('$.points[1]', ['{ "id" : "i2", "x" : -2, "y" : 2, "z" : 1 }']); 460 | Test('$.points[4].x', ['0']); 461 | Test('$.points[*].x', ['4', '-2', '8', '-6', '0', '1']); 462 | end; 463 | 464 | initialization 465 | TDUnitX.RegisterTestFixture(TestBsonPathErrors); 466 | TDUnitX.RegisterTestFixture(TestBsonPathExamples); 467 | TDUnitX.RegisterTestFixture(TesBJsonPath); 468 | 469 | end. 470 | -------------------------------------------------------------------------------- /Grijjy.OpenSSL.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.OpenSSL; 2 | 3 | { OpenSSL handler for Grijjy connections } 4 | 5 | {$I Grijjy.inc} 6 | 7 | interface 8 | 9 | uses 10 | Grijjy.OpenSSL.API, 11 | System.SysUtils, 12 | Grijjy.MemoryPool; 13 | 14 | const 15 | DEFAULT_BLOCK_SIZE = 4096; 16 | 17 | type 18 | { Callback events } 19 | TgoOpenSSLNotify = procedure of object; 20 | TgoOpenSSLData = procedure(const ABuffer: Pointer; const ASize: Integer) of object; 21 | 22 | { OpenSSL protocol handler } 23 | TgoOpenSSL = class(TObject) 24 | protected 25 | FOnConnected: TgoOpenSSLNotify; 26 | FOnRead: TgoOpenSSLData; 27 | FOnWrite: TgoOpenSSLData; 28 | private 29 | { OpenSSL related objects } 30 | FHandshaking: Boolean; 31 | FSSLContext: PSSL_CTX; 32 | FSSL: PSSL; 33 | FBIORead: PBIO; 34 | FBIOWrite: PBIO; 35 | FSSLWriteBuffer: Pointer; 36 | FSSLReadBuffer: Pointer; 37 | 38 | { Hostname for SNI } 39 | FHost: String; 40 | FPort: Word; 41 | 42 | { Certificate and Private Key } 43 | FCertificate: TBytes; 44 | FPrivateKey: TBytes; 45 | FPassword: UnicodeString; 46 | public 47 | constructor Create; 48 | destructor Destroy; override; 49 | public 50 | { Start SSL connect handshake } 51 | function Connect(const AALPN: Boolean = False): Boolean; 52 | 53 | { Free SSL related objects } 54 | procedure Release; 55 | 56 | { Do SSL read from socket } 57 | procedure Read(const ABuffer: Pointer = nil; const ASize: Integer = 0); 58 | 59 | { Do SSL write to socket } 60 | function Write(const ABuffer: Pointer; const ASize: Integer): Boolean; 61 | 62 | { Returns True if ALPN is negotiated } 63 | function ALPN: Boolean; 64 | public 65 | { Host } 66 | property Host: String read FHost write FHost; 67 | 68 | { Port } 69 | property Port: Word read FPort write FPort; 70 | 71 | { Certificate in PEM format } 72 | property Certificate: TBytes read FCertificate write FCertificate; 73 | 74 | { Private key in PEM format } 75 | property PrivateKey: TBytes read FPrivateKey write FPrivateKey; 76 | 77 | { Password for private key } 78 | property Password: UnicodeString read FPassword write FPassword; 79 | public 80 | { Fired when the SSL connection is established } 81 | property OnConnected: TgoOpenSSLNotify read FOnConnected write FOnConnected; 82 | 83 | { Fired when decrypted SSL data is ready to be read } 84 | property OnRead: TgoOpenSSLData read FOnRead write FOnRead; 85 | 86 | { Fired when encrypted SSL data is ready to be sent } 87 | property OnWrite: TgoOpenSSLData read FOnWrite write FOnWrite; 88 | end; 89 | 90 | { Helper class for SSL } 91 | TgoSSLHelper = class 92 | private class var 93 | FTarget: Integer; 94 | public 95 | class procedure LoadSSL; 96 | class procedure UnloadSSL; 97 | class procedure SetCertificate(ctx: PSSL_CTX; const ACertificate, APrivateKey: TBytes; 98 | const APassword: UnicodeString = ''); overload; 99 | class procedure SetCertificate(ctx: PSSL_CTX; const ACertificateFile, APrivateKeyFile: UnicodeString; 100 | const APassword: UnicodeString = ''); overload; 101 | public 102 | class function Sign_RSASHA256(const AData: TBytes; const APrivateKey: TBytes; 103 | out ASignature: TBytes): Boolean; 104 | class function HMAC_SHA256(const AKey, AData: RawByteString): String; 105 | class function HMAC_SHA1(const AKey, AData: RawByteString): TBytes; 106 | end; 107 | 108 | implementation 109 | 110 | uses 111 | System.IOUtils, 112 | System.SyncObjs, 113 | System.Classes; 114 | 115 | var 116 | _MemBufferPool: TgoMemoryPool; 117 | 118 | { TgoOpenSSL } 119 | 120 | constructor TgoOpenSSL.Create; 121 | begin 122 | inherited Create; 123 | FHandshaking := False; 124 | FSSL := nil; 125 | FSSLContext := nil; 126 | FSSLWriteBuffer := nil; 127 | FSSLReadBuffer := nil; 128 | end; 129 | 130 | destructor TgoOpenSSL.Destroy; 131 | begin 132 | Release; 133 | ERR_remove_thread_state(0); 134 | inherited Destroy; 135 | end; 136 | 137 | function TgoOpenSSL.Connect(const AALPN: Boolean): Boolean; 138 | begin 139 | Result := False; 140 | 141 | { create ssl context } 142 | FSSLContext := SSL_CTX_new(SSLv23_method); 143 | if FSSLContext <> nil then 144 | begin 145 | { if we are connecting using the http2 protocol and TLS } 146 | if AALPN then 147 | begin 148 | { force TLS 1.2 } 149 | SetSSLCTXOptions(FSSLContext, 150 | SSL_OP_ALL + SSL_OP_NO_SSLv2 + SSL_OP_NO_SSLv3 + SSL_OP_NO_COMPRESSION); 151 | 152 | { enable Application-Layer Protocol Negotiation Extension } 153 | SSL_CTX_set_alpn_protos(FSSLContext, #2'h2', 3); 154 | end; 155 | 156 | { no certificate validation } 157 | SSL_CTX_set_verify(FSSLContext, SSL_VERIFY_NONE, nil); 158 | 159 | { apply PEM Certificate } 160 | if FCertificate <> nil then 161 | begin 162 | if FPrivateKey = nil then 163 | TgoSSLHelper.SetCertificate(FSSLContext, FCertificate, FCertificate, FPassword) 164 | else 165 | TgoSSLHelper.SetCertificate(FSSLContext, FCertificate, FPrivateKey, FPassword); 166 | 167 | { Example loading certificate directly from a file: 168 | S := ExtractFilePath(ParamStr(0)) + 'Grijjy.pem'; 169 | SSL_CTX_use_certificate_file(FSSLContext, PAnsiChar(S), 1); 170 | SSL_CTX_use_RSAPrivateKey_file(FSSLContext, PAnsiChar(S), 1); 171 | } 172 | 173 | { Example loading CA certificate directly from a file: 174 | SSL_CTX_load_verify_locations(FSSLContext, 'entrust_2048_ca.cer', nil); 175 | } 176 | 177 | { Example loading CA certificate into memory: 178 | X509_Store := SSL_CTX_get_cert_store(FSSLContext); 179 | ABIO := BIO_new(BIO_s_file); 180 | BIO_read_filename(ABIO, PAnsiChar(AFile)); 181 | ACert := PEM_read_bio_X509(ABIO, nil, nil, nil); 182 | X509_STORE_add_cert(X509_Store, ACert); } 183 | end; 184 | 185 | { create an SSL struct for the connection } 186 | FSSL := SSL_new(FSSLContext); 187 | if FSSL <> nil then 188 | begin 189 | { Apply SNI hostname } 190 | SSL_set_tlsext_host_name(FSSL, FHost); 191 | 192 | { create the read and write BIO } 193 | FBIORead := BIO_new(BIO_s_mem); 194 | if FBIORead <> nil then 195 | begin 196 | FBIOWrite := BIO_new(BIO_s_mem); 197 | if FBIOWrite <> nil then 198 | begin 199 | FHandshaking := True; 200 | 201 | { relate the BIO to the SSL object } 202 | SSL_set_bio(FSSL, FBIORead, FBIOWrite); 203 | 204 | { ssl session should start the negotiation } 205 | SSL_set_connect_state(FSSL); 206 | 207 | { allocate buffers } 208 | FSSLWriteBuffer :=_MemBufferPool.RequestMem; 209 | FSSLReadBuffer :=_MemBufferPool.RequestMem; 210 | 211 | { start ssl handshake sequence } 212 | Read; 213 | 214 | { SSL success } 215 | Result := True; 216 | end; 217 | end; 218 | end; 219 | end; 220 | end; 221 | 222 | procedure TgoOpenSSL.Release; 223 | begin 224 | { free handle } 225 | if FSSL <> nil then 226 | begin 227 | SSL_shutdown(FSSL); 228 | SSL_free(FSSL); 229 | FSSL := nil; 230 | end; 231 | { free context } 232 | if FSSLContext <> nil then 233 | begin 234 | SSL_CTX_free(FSSLContext); 235 | FSSLContext := nil; 236 | end; 237 | { release buffers } 238 | if FSSLWriteBuffer <> nil then 239 | begin 240 | _MemBufferPool.ReleaseMem(FSSLWriteBuffer); 241 | FSSLWriteBuffer := nil; 242 | end; 243 | if FSSLReadBuffer <> nil then 244 | begin 245 | _MemBufferPool.ReleaseMem(FSSLReadBuffer); 246 | FSSLReadBuffer := nil; 247 | end; 248 | end; 249 | 250 | procedure TgoOpenSSL.Read(const ABuffer: Pointer; const ASize: Integer); 251 | var 252 | Bytes: Integer; 253 | Error: Integer; 254 | begin 255 | while True do 256 | begin 257 | BIO_write(FBIORead, ABuffer, ASize); 258 | if not BIORetry(FBIORead) then 259 | Break; 260 | end; 261 | 262 | while True do 263 | begin 264 | Bytes := SSL_read(FSSL, FSSLReadBuffer, DEFAULT_BLOCK_SIZE); 265 | if Bytes > 0 then 266 | begin 267 | if Assigned(FOnRead) then 268 | FOnRead(FSSLReadBuffer, Bytes) 269 | end 270 | else 271 | begin 272 | Error := SSL_get_error(FSSL, Bytes); 273 | if not SSLErrorFatal(Error) then 274 | Break 275 | else 276 | Exit; 277 | end; 278 | end; 279 | 280 | { handshake data needs to be written? } 281 | if BIO_ctrl(FBIOWrite, BIO_CTRL_PENDING, 0, nil) <> 0 then 282 | begin 283 | Bytes := BIO_read(FBIOWrite, FSSLWriteBuffer, DEFAULT_BLOCK_SIZE); 284 | if Bytes > 0 then 285 | begin 286 | if Assigned(FOnWrite) then 287 | FOnWrite(FSSLWriteBuffer, Bytes); 288 | end 289 | else 290 | begin 291 | Error := SSL_get_error(FSSL, Bytes); 292 | if SSLErrorFatal(Error) then 293 | Exit; 294 | end; 295 | end; 296 | 297 | { with ssl we are only connected and can write once the handshake is finished } 298 | if FHandshaking then 299 | if SSL_state(FSSL) = SSL_ST_OK then 300 | begin 301 | FHandshaking := False; 302 | if Assigned(FOnConnected) then 303 | FOnConnected; 304 | end 305 | end; 306 | 307 | function TgoOpenSSL.Write(const ABuffer: Pointer; const ASize: Integer): Boolean; 308 | var 309 | Bytes: Integer; 310 | Error: Integer; 311 | begin 312 | Result := False; 313 | 314 | Bytes := SSL_write(FSSL, ABuffer, ASize); 315 | if Bytes <> ASize then 316 | begin 317 | Error := SSL_get_error(FSSL, Bytes); 318 | if SSLErrorFatal(Error) then 319 | Exit; 320 | end; 321 | 322 | while BIO_ctrl(FBIOWrite, BIO_CTRL_PENDING, 0, nil) <> 0 do 323 | begin 324 | Bytes := BIO_read(FBIOWrite, FSSLWriteBuffer, DEFAULT_BLOCK_SIZE); 325 | if Bytes > 0 then 326 | begin 327 | Result := True; 328 | if Assigned(FOnWrite) then 329 | FOnWrite(FSSLWriteBuffer, Bytes); 330 | end 331 | else 332 | begin 333 | Error := SSL_get_error(FSSL, Bytes); 334 | if SSLErrorFatal(Error) then 335 | Exit; 336 | end; 337 | end; 338 | end; 339 | 340 | function TgoOpenSSL.ALPN: Boolean; 341 | var 342 | ALPN: MarshaledAString; 343 | ALPNLen: Integer; 344 | begin 345 | SSL_get0_alpn_selected(FSSL, ALPN, ALPNLen); 346 | Result := (ALPNLen = 2) and (ALPN[0] = 'h') and (ALPN[1] = '2'); 347 | end; 348 | 349 | { TgoSSLHelper } 350 | 351 | class procedure TgoSSLHelper.LoadSSL; 352 | begin 353 | if (TInterlocked.Increment(FTarget) = 1) then 354 | begin 355 | LoadLIBEAY; 356 | LoadSSLEAY; 357 | SSLInitialize; 358 | end; 359 | end; 360 | 361 | class procedure TgoSSLHelper.UnloadSSL; 362 | begin 363 | if (TInterlocked.Decrement(FTarget) = 0) then 364 | begin 365 | SSLFinalize; 366 | UnloadSSLEAY; 367 | UnloadLIBEAY; 368 | end; 369 | end; 370 | 371 | class procedure TgoSSLHelper.SetCertificate(ctx: PSSL_CTX; const ACertificate, APrivateKey: TBytes; 372 | const APassword: UnicodeString = ''); 373 | var 374 | BIOCert, BIOPrivateKey: PBIO; 375 | Certificate: PX509; 376 | PrivateKey: PEVP_PKEY; 377 | Password: RawByteString; 378 | begin 379 | BIOCert := BIO_new_mem_buf(@ACertificate[0], Length(ACertificate)); 380 | BIOPrivateKey := BIO_new_mem_buf(@APrivateKey[0], Length(APrivateKey)); 381 | Certificate := PEM_read_bio_X509(BIOCert, nil, nil, nil); 382 | if APassword <> '' then 383 | begin 384 | Password := MarshaledAString(RawByteString(APassword)); 385 | PrivateKey := PEM_read_bio_PrivateKey(BIOPrivateKey, nil, nil, @Password[1]); 386 | end 387 | else 388 | PrivateKey := PEM_read_bio_PrivateKey(BIOPrivateKey, nil, nil, nil); 389 | SSL_CTX_use_certificate(ctx, Certificate); 390 | SSL_CTX_use_privatekey(ctx, PrivateKey); 391 | X509_free(Certificate); 392 | EVP_PKEY_free(PrivateKey); 393 | BIO_free(BIOCert); 394 | BIO_free(BIOPrivateKey); 395 | if (SSL_CTX_check_private_key(ctx) = 0) then 396 | raise Exception.Create('Private key does not match the certificate public key'); 397 | end; 398 | 399 | class procedure TgoSSLHelper.SetCertificate(ctx: PSSL_CTX; const ACertificateFile, APrivateKeyFile: UnicodeString; 400 | const APassword: UnicodeString = ''); 401 | var 402 | Certificate, PrivateKey: TBytes; 403 | begin 404 | Certificate := TFile.ReadAllBytes(ACertificateFile); 405 | PrivateKey := TFile.ReadAllBytes(APrivateKeyFile); 406 | SetCertificate(ctx, Certificate, PrivateKey, APassword); 407 | end; 408 | 409 | class function TgoSSLHelper.Sign_RSASHA256(const AData: TBytes; const APrivateKey: TBytes; 410 | out ASignature: TBytes): Boolean; 411 | var 412 | BIOPrivateKey: PBIO; 413 | PrivateKey: PEVP_PKEY; 414 | Ctx: PEVP_MD_CTX; 415 | SHA256: PEVP_MD; 416 | Size: Cardinal; 417 | begin 418 | BIOPrivateKey := BIO_new_mem_buf(@APrivateKey[0], Length(APrivateKey)); 419 | PrivateKey := PEM_read_bio_PrivateKey(BIOPrivateKey, nil, nil, nil); 420 | Ctx := EVP_MD_CTX_create; 421 | try 422 | SHA256 := EVP_sha256; 423 | if (EVP_DigestSignInit(Ctx, nil, SHA256, nil, PrivateKey) > 0) and 424 | (EVP_DigestUpdate(Ctx, @AData[0], Length(AData)) > 0) and 425 | (EVP_DigestSignFinal(Ctx, nil, Size) > 0) then 426 | begin 427 | SetLength(ASignature, Size); 428 | Result := EVP_DigestSignFinal(Ctx, @ASignature[0], Size) > 0; 429 | end 430 | else 431 | Result := False; 432 | finally 433 | EVP_MD_CTX_destroy(Ctx); 434 | end; 435 | end; 436 | 437 | class function TgoSSLHelper.HMAC_SHA256(const AKey, AData: RawByteString): String; 438 | const 439 | EVP_MAX_MD_SIZE = 64; 440 | var 441 | MessageAuthCode: PByte; 442 | Size: Integer; 443 | Buffer, Text: TBytes; 444 | begin 445 | Size := EVP_MAX_MD_SIZE; 446 | SetLength(Buffer, Size); 447 | MessageAuthCode := HMAC(EVP_sha256, @AKey[1], Length(AKey), @AData[1], Length(AData), @Buffer[0], Size); 448 | if MessageAuthCode <> nil then 449 | begin 450 | SetLength(Text, Size * 2); 451 | BinToHex(Buffer, 0, Text, 0, Size); 452 | Result := TEncoding.UTF8.GetString(Text).ToLower; 453 | end; 454 | end; 455 | 456 | class function TgoSSLHelper.HMAC_SHA1(const AKey, AData: RawByteString): TBytes; 457 | const 458 | EVP_MAX_MD_SIZE = 20; 459 | var 460 | MessageAuthCode: PByte; 461 | Size: Integer; 462 | begin 463 | Size := EVP_MAX_MD_SIZE; 464 | SetLength(Result, Size); 465 | MessageAuthCode := HMAC(EVP_sha1, @AKey[1], Length(AKey), @AData[1], Length(AData), @Result[0], Size); 466 | if MessageAuthCode <> nil then 467 | SetLength(Result, Size); 468 | end; 469 | 470 | initialization 471 | TgoSSLHelper.LoadSSL; 472 | SSL_load_error_strings; 473 | SSL_library_init; 474 | _MemBufferPool := TgoMemoryPool.Create(DEFAULT_BLOCK_SIZE); 475 | 476 | finalization 477 | TgoSSLHelper.UnloadSSL; 478 | _MemBufferPool.Free; 479 | 480 | end. -------------------------------------------------------------------------------- /Grijjy.CloudLogging.InstanceTracker.pas: -------------------------------------------------------------------------------- 1 | unit Grijjy.CloudLogging.InstanceTracker; 2 | 3 | { When using this unit with TRACK_MEMORY defined, instances of most classes will 4 | be tracked for reporting to the Grijjy Log Viewer. 5 | 6 | For most accurate results, it is recommended to put this unit at the top of 7 | the uses-clause of the project (.dpr) file. 8 | 9 | When TRACK_MEMORY is *not* defined, this unit does nothing and has no impact 10 | on the application whatsoever. 11 | 12 | Note that using this unit with TRACK_MEMORY defined may slow down the 13 | application a bit and consume extra memory. } 14 | 15 | interface 16 | 17 | implementation 18 | 19 | {$IFDEF TRACK_MEMORY} 20 | 21 | uses 22 | System.Rtti, 23 | System.Classes, 24 | System.SysUtils, 25 | System.SyncObjs, 26 | System.Messaging, 27 | System.Generics.Collections, 28 | Grijjy.Hooking, 29 | Grijjy.Collections, 30 | Grijjy.CloudLogging, 31 | Grijjy.CloudLogging.Protocol; 32 | 33 | type 34 | { These "class opener" types give us access to the protected FRefCount 35 | fields of TObject and TInterfacedObject. } 36 | TObjectOpener = class(TObject); 37 | TInterfacedObjectOpener = class(TInterfacedObject); 38 | 39 | type 40 | TMessageListener = class 41 | private 42 | class function InstanceToString(const AInstance: TObject): String; static; 43 | private 44 | procedure HandleGetInstances(const Sender: TObject; const M: TMessage); 45 | public 46 | constructor Create; 47 | destructor Destroy; override; 48 | end; 49 | 50 | var 51 | { This set keeps track of all allocated objects. Note that it is a set of 52 | pointers instead of TObject's, since storing objects in the set would 53 | create a strong reference and prevent destruction of all objects! } 54 | GInstances: TgoSet = nil; 55 | 56 | { Lock to make GInstanceCounts thread-safe. } 57 | GLock: TCriticalSection = nil; 58 | 59 | { Listens for TgoGetInstancesMessage to provide a list of live instances. } 60 | GListener: TMessageListener = nil; 61 | 62 | procedure TrackInstance(const AInstance: TObject); 63 | begin 64 | if Assigned(AInstance) and Assigned(GLock) then 65 | begin 66 | GLock.Acquire; 67 | try 68 | if Assigned(GInstances) then 69 | GInstances.AddOrSet(AInstance); 70 | finally 71 | GLock.Release; 72 | end; 73 | end; 74 | end; 75 | 76 | procedure UntrackInstance(const AInstance: TObject); 77 | begin 78 | if Assigned(AInstance) and Assigned(GLock) then 79 | begin 80 | GLock.Acquire; 81 | try 82 | if Assigned(GInstances) then 83 | GInstances.Remove(AInstance); 84 | finally 85 | GLock.Release; 86 | end; 87 | end; 88 | end; 89 | 90 | { The following 3 routines implement the hooks for TObject.NewInstance, 91 | TInterfacedObject.NewInstance and TObject.FreeInstance. 92 | 93 | The implementation of these routines is identical to the original NewInstance 94 | and FreeInstance methods, but in addition it tracks (or untracks) an 95 | instance. } 96 | 97 | function HookedObjectNewInstance(const Self: TClass): TObject {$IFDEF AUTOREFCOUNT} unsafe {$ENDIF}; 98 | var 99 | Instance: Pointer; 100 | begin 101 | { This is the hook for TObject.NewInstance. Since this method is a 102 | (non-static) class method, it has an implicit Self parameter. But since it 103 | is a class method, this Self parameter represents a class, not an object. 104 | 105 | We start by mimicking the original source code for TObject.NewInstance: } 106 | GetMem(Instance, Self.InstanceSize); 107 | Result := Self.InitInstance(Instance); 108 | {$IFDEF AUTOREFCOUNT} 109 | { On ARC platforms, each object has a FRefCount field that must be 110 | initialized to 1. } 111 | TObjectOpener(Result).FRefCount := 1; 112 | {$ENDIF} 113 | 114 | { Now we can keep track of this instance. } 115 | TrackInstance(Result); 116 | end; 117 | 118 | function HookedInterfacedObjectNewInstance(const Self: TClass): TObject {$IFDEF AUTOREFCOUNT} unsafe {$ENDIF}; 119 | var 120 | Instance: Pointer; 121 | begin 122 | { This is the hook for TInterfacedObject.NewInstance. This method is mostly 123 | similar to TObject.NewInstance, with the exception that interfaced objects 124 | also have a FRefCount field on non-ARC platforms. } 125 | GetMem(Instance, Self.InstanceSize); 126 | Result := Self.InitInstance(Instance); 127 | TInterfacedObjectOpener(Result).FRefCount := 1; 128 | 129 | { Now we can keep track of this instance. } 130 | TrackInstance(Result); 131 | end; 132 | 133 | procedure HookedObjectFreeInstance(const Self: TObject); 134 | begin 135 | { This is the hook for TObject.FreeInstance. Since this is a (regular) method, 136 | it has an implicit Self parameter containing the instance. We first stop 137 | tracking this instance... } 138 | UntrackInstance(Self); 139 | 140 | { ...and then execute the original code in TObject.FreeInstance: } 141 | Self.CleanupInstance; 142 | FreeMem(Pointer(Self)); 143 | end; 144 | 145 | function InitializeCodeHooks: Boolean; 146 | begin 147 | { This function tries HookCode to hook the implementations of the 148 | TObject.NewInstance and TObject.FreeInstance methods. This will most likely 149 | only succeed on Windows, macOS, iOS Simulator and Linux. } 150 | Result := HookCode(@TObject.NewInstance, @HookedObjectNewInstance) 151 | and HookCode(@TObject.FreeInstance, @HookedObjectFreeInstance); 152 | end; 153 | 154 | { We are using the vmtNewInstance and vmtFreeInstance constants, which have been 155 | deprecated for a long time, but are still available. Turn off warnings for 156 | these. } 157 | {$WARN SYMBOL_DEPRECATED OFF} 158 | 159 | procedure InitializeVMTHooks; 160 | var 161 | Rtti: TRttiContext; 162 | RttiType: TRttiType; 163 | InstanceType: TRttiInstanceType; 164 | VMTEntryNewInstance, VMTEntryFreeInstance: PPointer; 165 | ObjectNewInstance, ObjectFreeInstance, InterfacedObjectNewInstance: Pointer; 166 | begin 167 | { This version uses HookVMT instead of HookCode to hook the 168 | TObject.NewInstance and TObject.FreeInstance methods. 169 | 170 | Each Delphi class has its own Virtual Method Table. This means that we need 171 | to hook the VMT's for all classes we care about. In this case, we use 172 | TRttiContext.GetTypes to get a list of all Delphi classes (and other types) 173 | linked into the application. We then change the VMT entries of each class 174 | in that list. 175 | 176 | The problem with this kind of hooking is that some classes may have 177 | overridden the NewInstance and/or FreeInstance methods. Changing the VMT of 178 | those classes would ignore any customizations those classes made to those 179 | methods, and we don't want that. Fortunately, there are very few classes 180 | that have overridden these methods. 181 | 182 | So we only change the VMT's of those classes that have not overridden 183 | NewInstance or FreeInstance. This single exception is the TInterfacedObject 184 | class, which is so common that we want to support it. This class has 185 | overridden the NewInstance method, so we need a separate hook for this 186 | version. 187 | 188 | First, we retrieve the code addresses of the original NewInstance and 189 | FreeInstance methods. We use these to check if they are overridden by a 190 | certain class. } 191 | ObjectNewInstance := @TObject.NewInstance; 192 | ObjectFreeInstance := @TObject.FreeInstance; 193 | InterfacedObjectNewInstance := @TInterfacedObject.NewInstance; 194 | 195 | { Get a list of all Delphi types in the application with RTTI support. } 196 | Rtti := TRttiContext.Create; 197 | for RttiType in Rtti.GetTypes do 198 | begin 199 | { Check if the type is a class type. } 200 | if (RttiType.TypeKind = tkClass) then 201 | begin 202 | { We can now safely typecase to TRttiInstanceType } 203 | InstanceType := TRttiInstanceType(RttiType); 204 | 205 | { Retrieve the entry in the VMT of the FreeInstance method for this class. } 206 | VMTEntryFreeInstance := PPointer(PByte(InstanceType.MetaclassType) + vmtFreeInstance); 207 | 208 | { Only track classes that didn't override TObject.FreeInstance. } 209 | if (VMTEntryFreeInstance^ = ObjectFreeInstance) then 210 | begin 211 | { Retrieve the entry in the VMT of the NewInstance method for this class. } 212 | VMTEntryNewInstance := PPointer(PByte(InstanceType.MetaclassType) + vmtNewInstance); 213 | 214 | { Only track classes that didn't override TObject.NewInstance or 215 | TInterfacedObject.NewInstance. } 216 | if (VMTEntryNewInstance^ = ObjectNewInstance) then 217 | begin 218 | { This class uses NewInstance and FreeInstance from TObject. 219 | Hook those VMT entries. } 220 | HookVMT(VMTEntryNewInstance, @HookedObjectNewInstance); 221 | HookVMT(VMTEntryFreeInstance, @HookedObjectFreeInstance); 222 | end 223 | else if (VMTEntryNewInstance^ = InterfacedObjectNewInstance) then 224 | begin 225 | { This class is (ultimately) derived from TInterfacedObject, so 226 | we need to hook to a separate version of NewInstance. } 227 | HookVMT(VMTEntryNewInstance, @HookedInterfacedObjectNewInstance); 228 | HookVMT(VMTEntryFreeInstance, @HookedObjectFreeInstance); 229 | end; 230 | end; 231 | end; 232 | end; 233 | end; 234 | 235 | {$WARN SYMBOL_DEPRECATED ON} 236 | 237 | procedure InitializeGlobals; 238 | begin 239 | { These globals are used to keep track of instances. } 240 | GLock := TCriticalSection.Create; 241 | GInstances := TgoSet.Create; 242 | GListener := TMessageListener.Create; 243 | end; 244 | 245 | procedure FinalizeGlobals; 246 | begin 247 | FreeAndNil(GLock); 248 | FreeAndNil(GInstances); 249 | FreeAndNil(GListener); 250 | end; 251 | 252 | { TMessageListener } 253 | 254 | constructor TMessageListener.Create; 255 | begin 256 | inherited Create; 257 | TMessageManager.DefaultManager.SubscribeToMessage(TgoGetInstancesMessage, 258 | HandleGetInstances) 259 | end; 260 | 261 | destructor TMessageListener.Destroy; 262 | begin 263 | TMessageManager.DefaultManager.Unsubscribe(TgoGetInstancesMessage, 264 | HandleGetInstances); 265 | inherited; 266 | end; 267 | 268 | procedure TMessageListener.HandleGetInstances(const Sender: TObject; 269 | const M: TMessage); 270 | type 271 | TInstances = TList; 272 | var 273 | Msg: TgoGetInstancesMessage absolute M; 274 | Instances: TArray; 275 | Instance: Pointer; 276 | Counts: TDictionary; 277 | Pair: TPair; 278 | DetailClasses: TObjectDictionary; 279 | DetailInstances: TInstances; 280 | DetailInstance: TgoLogMemoryUsageProtocol.TInstance; 281 | Obj: TObject; 282 | ObjClass: TClass; 283 | Component: TComponent absolute Obj; 284 | Count: Integer; 285 | begin 286 | Assert(M is TgoGetInstancesMessage); 287 | if (GLock = nil) then 288 | Exit; 289 | 290 | GLock.Acquire; 291 | try 292 | if (GInstances = nil) then 293 | Exit; 294 | 295 | Instances := GInstances.ToArray; 296 | if (Instances = nil) then 297 | Exit; 298 | 299 | DetailClasses := nil; 300 | Counts := TDictionary.Create; 301 | try 302 | DetailClasses := TObjectDictionary.Create([doOwnsValues]); 303 | for Count := 0 to Length(Msg.Classes) - 1 do 304 | DetailClasses.AddOrSetValue(Msg.Classes[Count], nil); 305 | 306 | for Instance in Instances do 307 | begin 308 | Obj := TObject(Instance); 309 | ObjClass := Obj.ClassType; 310 | if (Counts.TryGetValue(ObjClass, Count)) then 311 | Counts[ObjClass] := Count + 1 312 | else 313 | Counts.Add(ObjClass, 1); 314 | 315 | if (DetailClasses.TryGetValue(ObjClass, DetailInstances)) then 316 | begin 317 | { Details are requested for this class. } 318 | if (DetailInstances = nil) then 319 | begin 320 | DetailInstances := TInstances.Create; 321 | DetailClasses[ObjClass] := DetailInstances; 322 | end; 323 | 324 | if (DetailInstances.Count < GrijjyLog.MaxInstancesPerClass) then 325 | begin 326 | { Add string respresentation of this instance to details for the 327 | class. } 328 | if (Obj is TComponent) then 329 | begin 330 | DetailInstance.Caption := ''; 331 | if Assigned(Component.Owner) and (Component.Owner.Name <> '') then 332 | DetailInstance.Caption := Component.Owner.Name + '.'; 333 | if (Component.Name = '') then 334 | DetailInstance.Caption := DetailInstance.Caption + InstanceToString(Component) 335 | else 336 | DetailInstance.Caption := DetailInstance.Caption + Component.Name; 337 | end 338 | else 339 | DetailInstance.Caption := InstanceToString(Obj); 340 | 341 | DetailInstances.Add(DetailInstance); 342 | end; 343 | end; 344 | end; 345 | 346 | SetLength(Msg.Protocol.Entries, Counts.Count); 347 | Count := 0; 348 | for Pair in Counts do 349 | begin 350 | Assert(Count < Length(Msg.Protocol.Entries)); 351 | if Assigned(Pair.Key) then 352 | begin 353 | Msg.Protocol.Entries[Count].ClassName := Pair.Key.ClassName; 354 | Msg.Protocol.Entries[Count].ClassHandle := THandle(Pair.Key); 355 | end; 356 | Msg.Protocol.Entries[Count].InstanceCount := Pair.Value; 357 | 358 | if (DetailClasses.TryGetValue(Pair.Key, DetailInstances)) then 359 | Msg.Protocol.Entries[Count].Instances := DetailInstances.ToArray; 360 | 361 | Inc(Count); 362 | end; 363 | finally 364 | DetailClasses.Free; 365 | Counts.Free; 366 | end; 367 | finally 368 | GLock.Release; 369 | end; 370 | end; 371 | 372 | class function TMessageListener.InstanceToString( 373 | const AInstance: TObject): String; 374 | begin 375 | Result := AInstance.ToString; 376 | if (Result = AInstance.ClassName) then 377 | { The instance did not override the ToString method } 378 | Result := Result + Format(' @ %p', [Pointer(AInstance)]); 379 | end; 380 | 381 | initialization 382 | { First we try code hooking to hook into the NewInstance and FreeInstance 383 | methods. This is fastest and tracks all classes. } 384 | if (not InitializeCodeHooks) then 385 | { If the first method fails, try VMT hooking instead. This hooks the 386 | NewInstance and FreeInstance entries in the Virtual Method Tables of all 387 | classes that have RTTI. } 388 | InitializeVMTHooks; 389 | 390 | { Initialize some global variables. } 391 | InitializeGlobals; 392 | 393 | finalization 394 | FinalizeGlobals; 395 | 396 | {$ENDIF !TRACK_MEMORY} 397 | end. 398 | -------------------------------------------------------------------------------- /UnitTests/Tests/Tests.Grijjy.Collections.Dictionaries.pas: -------------------------------------------------------------------------------- 1 | unit Tests.Grijjy.Collections.Dictionaries; 2 | 3 | interface 4 | 5 | uses 6 | System.Generics.Defaults, 7 | System.Generics.Collections, 8 | DUnitX.TestFramework, 9 | Tests.Grijjy.Collections.Base, 10 | Grijjy.Collections; 11 | 12 | type 13 | TTestTgoValueDictionaryByKey = class(TTestCollectionBase) 14 | private type 15 | PValue = TgoPtr.P; 16 | TPair = TPair; 17 | private 18 | FCUT: TgoValueDictionary; 19 | FKeys: TArray; 20 | procedure FillDictionary; 21 | procedure CheckItems(const AExpectedKeys: TArray; 22 | const AExpectedValues: array of Integer); 23 | public 24 | [Setup] 25 | procedure SetUp; 26 | 27 | [Teardown] 28 | procedure TearDown; 29 | 30 | [Test] 31 | procedure TestAdd; 32 | 33 | [Test] 34 | procedure TestRemove; 35 | 36 | [Test] 37 | procedure TestClear; 38 | 39 | [Test] 40 | procedure TestTryGetValue; 41 | 42 | [Test] 43 | procedure TestAddOrSetValue; 44 | 45 | [Test] 46 | procedure TestContainsKey; 47 | 48 | [Test] 49 | procedure TestGetEnumerator; 50 | 51 | [Test] 52 | procedure TestGetItem; 53 | 54 | [Test] 55 | procedure TestKeys; 56 | 57 | [Test] 58 | procedure TestValues; 59 | end; 60 | 61 | type 62 | TTestTgoValueDictionaryByValue = class(TTestCollectionBase) 63 | private type 64 | PValue = ^TValue; 65 | TPair = TPair; 66 | private 67 | FCUT: TgoValueDictionary; 68 | FValues: TArray; 69 | procedure FillDictionary; 70 | procedure CheckItems(const AExpectedKeys: array of Integer; 71 | const AExpectedValues: TArray); 72 | public 73 | [Setup] 74 | procedure SetUp; 75 | 76 | [Teardown] 77 | procedure TearDown; 78 | 79 | [Test] 80 | procedure TestAdd; 81 | 82 | [Test] 83 | procedure TestRemove; 84 | 85 | [Test] 86 | procedure TestClear; 87 | 88 | [Test] 89 | procedure TestTryGetValue; 90 | 91 | [Test] 92 | procedure TestAddOrSetValue; 93 | 94 | [Test] 95 | procedure TestContainsKey; 96 | 97 | [Test] 98 | procedure TestGetEnumerator; 99 | 100 | [Test] 101 | procedure TestGetItem; 102 | 103 | [Test] 104 | procedure TestKeys; 105 | 106 | [Test] 107 | procedure TestValues; 108 | end; 109 | 110 | implementation 111 | 112 | uses 113 | System.SysUtils; 114 | 115 | { TTestTgoValueDictionaryByKey } 116 | 117 | procedure TTestTgoValueDictionaryByKey.CheckItems( 118 | const AExpectedKeys: TArray; const AExpectedValues: array of Integer); 119 | var 120 | Key: TKey; 121 | I: Integer; 122 | Value: PValue; 123 | begin 124 | Assert.AreEqual(Length(AExpectedKeys), FCUT.Count); 125 | Assert.AreEqual(Length(AExpectedValues), FCUT.Count); 126 | 127 | for I := 0 to Length(AExpectedKeys) - 1 do 128 | begin 129 | Key := AExpectedKeys[I]; 130 | Assert.IsTrue(FCUT.TryGetValue(Key, Value)); 131 | Assert.IsTrue(Value <> nil); 132 | Assert.AreEqual(AExpectedValues[I], Value^); 133 | end; 134 | end; 135 | 136 | procedure TTestTgoValueDictionaryByKey.FillDictionary; 137 | begin 138 | FKeys := CreateValues(3); 139 | FCUT.Add(FKeys[0], 10); 140 | FCUT.Add(FKeys[1], 20); 141 | FCUT.Add(FKeys[2], 30); 142 | end; 143 | 144 | procedure TTestTgoValueDictionaryByKey.SetUp; 145 | begin 146 | inherited; 147 | FCUT := TgoValueDictionary.Create; 148 | end; 149 | 150 | procedure TTestTgoValueDictionaryByKey.TearDown; 151 | begin 152 | FCUT.Free; 153 | inherited; 154 | end; 155 | 156 | procedure TTestTgoValueDictionaryByKey.TestAdd; 157 | begin 158 | FillDictionary; 159 | CheckItems(FKeys, [10, 20, 30]); 160 | end; 161 | 162 | procedure TTestTgoValueDictionaryByKey.TestAddOrSetValue; 163 | var 164 | Keys: TArray; 165 | begin 166 | Keys := CreateValues(4); 167 | FCUT.Add(Keys[0], 10); 168 | FCUT.Add(Keys[1], 20); 169 | FCUT.Add(Keys[2], 30); 170 | Assert.AreEqual(3, FCUT.Count); 171 | 172 | FCUT.AddOrSetValue(Keys[1], 40); 173 | Assert.AreEqual(3, FCUT.Count); 174 | 175 | FCUT.AddOrSetValue(Keys[3], 50); 176 | CheckItems(Keys, [10, 40, 30, 50]); 177 | end; 178 | 179 | procedure TTestTgoValueDictionaryByKey.TestClear; 180 | begin 181 | FillDictionary; 182 | Assert.AreEqual(3, FCUT.Count); 183 | 184 | FCUT.Clear; 185 | Assert.AreEqual(0, FCUT.Count); 186 | end; 187 | 188 | procedure TTestTgoValueDictionaryByKey.TestContainsKey; 189 | var 190 | RogueKey: TKey; 191 | begin 192 | FillDictionary; 193 | RogueKey := CreateValue(3); 194 | Assert.IsTrue(FCUT.ContainsKey(FKeys[0])); 195 | Assert.IsTrue(FCUT.ContainsKey(FKeys[1])); 196 | Assert.IsTrue(FCUT.ContainsKey(FKeys[2])); 197 | Assert.IsFalse(FCUT.ContainsKey(RogueKey)); 198 | end; 199 | 200 | procedure TTestTgoValueDictionaryByKey.TestGetEnumerator; 201 | var 202 | Pair: TPair; 203 | B: Byte; 204 | C: IEqualityComparer; 205 | begin 206 | FillDictionary; 207 | C := TEqualityComparer.Default; 208 | B := 0; 209 | for Pair in FCUT do 210 | begin 211 | Assert.IsTrue(Pair.Value <> nil); 212 | if (C.Equals(Pair.Key, FKeys[0])) then 213 | begin 214 | B := B or $01; 215 | Assert.AreEqual(10, PInteger(Pair.Value)^) 216 | end 217 | else if (C.Equals(Pair.Key, FKeys[1])) then 218 | begin 219 | B := B or $02; 220 | Assert.AreEqual(20, PInteger(Pair.Value)^) 221 | end 222 | else if (C.Equals(Pair.Key, FKeys[2])) then 223 | begin 224 | B := B or $04; 225 | Assert.AreEqual(30, PInteger(Pair.Value)^) 226 | end 227 | else 228 | Assert.Fail('Unexpected item'); 229 | end; 230 | Assert.AreEqual($07, Integer(B)); 231 | end; 232 | 233 | procedure TTestTgoValueDictionaryByKey.TestGetItem; 234 | begin 235 | FillDictionary; 236 | Assert.AreEqual(10, FCUT[FKeys[0]]^); 237 | Assert.AreEqual(20, FCUT[FKeys[1]]^); 238 | Assert.AreEqual(30, FCUT[FKeys[2]]^); 239 | end; 240 | 241 | procedure TTestTgoValueDictionaryByKey.TestKeys; 242 | var 243 | Key: TKey; 244 | B: Byte; 245 | C: IEqualityComparer; 246 | begin 247 | FillDictionary; 248 | B := 0; 249 | C := TEqualityComparer.Default; 250 | for Key in FCUT.Keys do 251 | begin 252 | if (C.Equals(Key, FKeys[0])) then 253 | B := B or $01 254 | else if (C.Equals(Key, FKeys[1])) then 255 | B := B or $02 256 | else if (C.Equals(Key, FKeys[2])) then 257 | B := B or $04 258 | else 259 | Assert.Fail('Unexpected item'); 260 | end; 261 | Assert.AreEqual($07, Integer(B)); 262 | end; 263 | 264 | procedure TTestTgoValueDictionaryByKey.TestRemove; 265 | var 266 | RogueKey: TKey; 267 | V: TArray; 268 | begin 269 | FillDictionary; 270 | RogueKey := CreateValue(3); 271 | Assert.AreEqual(3, FCUT.Count); 272 | 273 | FCUT.Remove(RogueKey); 274 | Assert.AreEqual(3, FCUT.Count); 275 | CheckItems(FKeys, [10, 20, 30]); 276 | 277 | FCUT.Remove(FKeys[0]); 278 | Assert.AreEqual(2, FCUT.Count); 279 | SetLength(V, 2); 280 | V[0] := FKeys[1]; 281 | V[1] := FKeys[2]; 282 | CheckItems(V, [20, 30]); 283 | 284 | FCUT.Remove(FKeys[2]); 285 | Assert.AreEqual(1, FCUT.Count); 286 | SetLength(V, 1); 287 | V[0] := FKeys[1]; 288 | CheckItems(V, [20]); 289 | 290 | FCUT.Remove(FKeys[1]); 291 | Assert.AreEqual(0, FCUT.Count); 292 | end; 293 | 294 | procedure TTestTgoValueDictionaryByKey.TestTryGetValue; 295 | var 296 | RogueKey: TKey; 297 | Value: PValue; 298 | begin 299 | FillDictionary; 300 | RogueKey := CreateValue(3); 301 | Assert.IsFalse(FCUT.TryGetValue(RogueKey, Value)); 302 | Assert.IsTrue(Value = nil); 303 | 304 | Assert.IsTrue(FCUT.TryGetValue(FKeys[1], Value)); 305 | Assert.IsTrue(Value <> nil); 306 | Assert.AreEqual(Value^, 20); 307 | end; 308 | 309 | procedure TTestTgoValueDictionaryByKey.TestValues; 310 | var 311 | Value: PValue; 312 | B: Byte; 313 | begin 314 | FillDictionary; 315 | B := 0; 316 | for Value in FCUT.Values do 317 | begin 318 | Assert.IsTrue(Value <> nil); 319 | if (Value^ = 10) then 320 | B := B or $01 321 | else if (Value^ = 20) then 322 | B := B or $02 323 | else if (Value^ = 30) then 324 | B := B or $04 325 | else 326 | Assert.Fail('Unexpected item'); 327 | end; 328 | Assert.AreEqual($07, Integer(B)); 329 | end; 330 | 331 | { TTestTgoValueDictionaryByValue } 332 | 333 | procedure TTestTgoValueDictionaryByValue.CheckItems( 334 | const AExpectedKeys: array of Integer; const AExpectedValues: TArray); 335 | var 336 | Value: PValue; 337 | I, Key: Integer; 338 | begin 339 | Assert.AreEqual(Length(AExpectedKeys), FCUT.Count); 340 | Assert.AreEqual(Length(AExpectedValues), FCUT.Count); 341 | 342 | for I := 0 to Length(AExpectedKeys) - 1 do 343 | begin 344 | Key := AExpectedKeys[I]; 345 | Assert.IsTrue(FCUT.TryGetValue(Key, Value)); 346 | Assert.IsTrue(Value <> nil); 347 | TestEquals(AExpectedValues[I], Value^); 348 | end; 349 | end; 350 | 351 | procedure TTestTgoValueDictionaryByValue.FillDictionary; 352 | begin 353 | FValues := CreateValues(3); 354 | FCUT.Add(10, FValues[0]); 355 | FCUT.Add(20, FValues[1]); 356 | FCUT.Add(30, FValues[2]); 357 | end; 358 | 359 | procedure TTestTgoValueDictionaryByValue.SetUp; 360 | begin 361 | inherited; 362 | FCUT := TgoValueDictionary.Create; 363 | end; 364 | 365 | procedure TTestTgoValueDictionaryByValue.TearDown; 366 | begin 367 | FCUT.Free; 368 | inherited; 369 | end; 370 | 371 | procedure TTestTgoValueDictionaryByValue.TestAdd; 372 | begin 373 | FillDictionary; 374 | CheckItems([10, 20, 30], FValues); 375 | end; 376 | 377 | procedure TTestTgoValueDictionaryByValue.TestAddOrSetValue; 378 | var 379 | Values, NewValues: TArray; 380 | begin 381 | Values := CreateValues(5); 382 | FCUT.Add(10, Values[0]); 383 | FCUT.Add(20, Values[1]); 384 | FCUT.Add(30, Values[2]); 385 | Assert.AreEqual(3, FCUT.Count); 386 | 387 | FCUT.AddOrSetValue(20, Values[3]); 388 | Assert.AreEqual(3, FCUT.Count); 389 | 390 | FCUT.AddOrSetValue(40, Values[4]); 391 | 392 | SetLength(NewValues, 4); 393 | NewValues[0] := Values[0]; 394 | NewValues[1] := Values[3]; 395 | NewValues[2] := Values[2]; 396 | NewValues[3] := Values[4]; 397 | CheckItems([10, 20, 30, 40], NewValues); 398 | end; 399 | 400 | procedure TTestTgoValueDictionaryByValue.TestClear; 401 | begin 402 | FillDictionary; 403 | Assert.AreEqual(3, FCUT.Count); 404 | 405 | FCUT.Clear; 406 | Assert.AreEqual(0, FCUT.Count); 407 | end; 408 | 409 | procedure TTestTgoValueDictionaryByValue.TestContainsKey; 410 | begin 411 | FillDictionary; 412 | Assert.IsTrue(FCUT.ContainsKey(10)); 413 | Assert.IsTrue(FCUT.ContainsKey(20)); 414 | Assert.IsTrue(FCUT.ContainsKey(30)); 415 | Assert.IsFalse(FCUT.ContainsKey(40)); 416 | end; 417 | 418 | procedure TTestTgoValueDictionaryByValue.TestGetEnumerator; 419 | var 420 | Pair: TPair; 421 | B: Byte; 422 | C: IEqualityComparer; 423 | begin 424 | FillDictionary; 425 | C := TEqualityComparer.Default; 426 | B := 0; 427 | for Pair in FCUT do 428 | begin 429 | Assert.IsTrue(Pair.Value <> nil); 430 | if (Pair.Key = 10) then 431 | begin 432 | B := B or $01; 433 | Assert.IsTrue(C.Equals(PValue(Pair.Value)^, FValues[0])) 434 | end 435 | else if (Pair.Key = 20) then 436 | begin 437 | B := B or $02; 438 | Assert.IsTrue(C.Equals(PValue(Pair.Value)^, FValues[1])) 439 | end 440 | else if (Pair.Key = 30) then 441 | begin 442 | B := B or $04; 443 | Assert.IsTrue(C.Equals(PValue(Pair.Value)^, FValues[2])) 444 | end 445 | else 446 | Assert.Fail('Unexpected item'); 447 | end; 448 | Assert.AreEqual($07, Integer(B)); 449 | end; 450 | 451 | procedure TTestTgoValueDictionaryByValue.TestGetItem; 452 | begin 453 | FillDictionary; 454 | TestEquals(FValues[0], FCUT[10]^); 455 | TestEquals(FValues[1], FCUT[20]^); 456 | TestEquals(FValues[2], FCUT[30]^); 457 | end; 458 | 459 | procedure TTestTgoValueDictionaryByValue.TestKeys; 460 | var 461 | Key: Integer; 462 | B: Byte; 463 | begin 464 | FillDictionary; 465 | B := 0; 466 | for Key in FCUT.Keys do 467 | begin 468 | if (Key = 10) then 469 | B := B or $01 470 | else if (Key = 20) then 471 | B := B or $02 472 | else if (Key = 30) then 473 | B := B or $04 474 | else 475 | Assert.Fail('Unexpected item'); 476 | end; 477 | Assert.AreEqual($07, Integer(B)); 478 | end; 479 | 480 | procedure TTestTgoValueDictionaryByValue.TestRemove; 481 | var 482 | V: TArray; 483 | begin 484 | FillDictionary; 485 | Assert.AreEqual(3, FCUT.Count); 486 | 487 | FCUT.Remove(40); 488 | Assert.AreEqual(3, FCUT.Count); 489 | CheckItems([10, 20, 30], FValues); 490 | 491 | FCUT.Remove(10); 492 | Assert.AreEqual(2, FCUT.Count); 493 | SetLength(V, 2); 494 | V[0] := FValues[1]; 495 | V[1] := FValues[2]; 496 | CheckItems([20, 30], V); 497 | 498 | FCUT.Remove(30); 499 | Assert.AreEqual(1, FCUT.Count); 500 | SetLength(V, 1); 501 | V[0] := FValues[1]; 502 | CheckItems([20], V); 503 | 504 | FCUT.Remove(20); 505 | Assert.AreEqual(0, FCUT.Count); 506 | end; 507 | 508 | procedure TTestTgoValueDictionaryByValue.TestTryGetValue; 509 | var 510 | Value: PValue; 511 | C: IEqualityComparer; 512 | begin 513 | FillDictionary; 514 | C := TEqualityComparer.Default; 515 | 516 | Assert.IsFalse(FCUT.TryGetValue(40, Value)); 517 | Assert.IsTrue(Value = nil); 518 | 519 | Assert.IsTrue(FCUT.TryGetValue(20, Value)); 520 | Assert.IsTrue(Value <> nil); 521 | Assert.IsTrue(C.Equals(FValues[1], Value^)); 522 | end; 523 | 524 | procedure TTestTgoValueDictionaryByValue.TestValues; 525 | var 526 | Value: PValue; 527 | B: Byte; 528 | C: IEqualityComparer; 529 | begin 530 | FillDictionary; 531 | C := TEqualityComparer.Default; 532 | B := 0; 533 | for Value in FCUT.Values do 534 | begin 535 | Assert.IsTrue(Value <> nil); 536 | if (C.Equals(Value^, FValues[0])) then 537 | B := B or $01 538 | else if (C.Equals(Value^, FValues[1])) then 539 | B := B or $02 540 | else if (C.Equals(Value^, FValues[2])) then 541 | B := B or $04 542 | else 543 | Assert.Fail('Unexpected item'); 544 | end; 545 | Assert.AreEqual($07, Integer(B)); 546 | end; 547 | 548 | initialization 549 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 550 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 551 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 552 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 553 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 554 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 555 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 556 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 557 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 558 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 559 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 560 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 561 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 562 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 563 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 564 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 565 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 566 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 567 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 568 | {$IFNDEF NEXTGEN} 569 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 570 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 571 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 572 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 573 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 574 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 575 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 576 | {$ENDIF} 577 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 578 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 579 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 580 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 581 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 582 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 583 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 584 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 585 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 586 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 587 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 588 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByKey); 589 | 590 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 591 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 592 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 593 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 594 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 595 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 596 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 597 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 598 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 599 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 600 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 601 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 602 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 603 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 604 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 605 | {$IFNDEF NEXTGEN} 606 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 607 | {$ENDIF} 608 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 609 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 610 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 611 | TDUnitX.RegisterTestFixture(TTestTgoValueDictionaryByValue); 612 | end. 613 | --------------------------------------------------------------------------------