├── .github └── FUNDING.yml ├── .gitignore ├── .gitmodules ├── LICENSE ├── README.md ├── examples ├── asyncpipe │ ├── asyncpipe.dpr │ ├── asyncpipe.dproj │ ├── asyncpipe.lpi │ └── asyncpipe.res └── worker │ ├── workerdemo.dpr │ ├── workerdemo.dproj │ └── workerdemo.lpi └── src ├── Compat.pas ├── ThreadPool.pas └── common.inc /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: tondrej -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | *.otares 48 | 49 | # Delphi autogenerated files (duplicated info) 50 | *.cfg 51 | *.ddp 52 | *.dof 53 | *.hpp 54 | *Resource.rc 55 | 56 | # Delphi local files (user-specific info) 57 | *.local 58 | *.identcache 59 | *.projdata 60 | *.tvsconfig 61 | *.dsk 62 | 63 | # Delphi history and backups 64 | __history/ 65 | __recovery/ 66 | *.~* 67 | 68 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 69 | *.stat 70 | 71 | # FPC local files (user-specific info) 72 | *.lps 73 | 74 | # Lazarus backup directories 75 | backup 76 | 77 | # project-specific paths 78 | bin 79 | lib 80 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "ext/jedi"] 2 | path = ext/jedi 3 | url = https://github.com/tondrej/jedi.git 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Ondrej Kelle 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # iocp-delphi 2 | Windows IO Completion Port wrapper class for Delphi and Free Pascal 3 | 4 | Supported compilers: Delphi 7 or higher, Free Pascal 3.0.4 or higher 5 | 6 | Supported targets: Windows XP/Windows Server 2003 or higher, both 32 and 64-bit 7 | -------------------------------------------------------------------------------- /examples/asyncpipe/asyncpipe.dpr: -------------------------------------------------------------------------------- 1 | (* 2 | 3 | MIT License 4 | 5 | Copyright (c) 2021 Ondrej Kelle 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in all 15 | copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | SOFTWARE. 24 | 25 | *) 26 | 27 | program asyncpipe; 28 | 29 | {$i common.inc} 30 | 31 | {$APPTYPE CONSOLE} 32 | 33 | uses 34 | Windows, 35 | Types, 36 | Classes, 37 | SysUtils, 38 | {$ifdef HAS_ANSISTRINGS} 39 | AnsiStrings, 40 | {$endif} 41 | ThreadPool in '..\..\src\ThreadPool.pas', 42 | Compat in '..\..\src\Compat.pas'; 43 | 44 | const 45 | PIPE_REJECT_REMOTE_CLIENTS = 8; 46 | PIPE_UNLIMITED_INSTANCES = 255; 47 | 48 | InstanceCount = 128; 49 | MaxBufferSize = 1024; 50 | 51 | type 52 | TOperation = (opConnect, opRead, opWrite); 53 | 54 | PPipeInfo = ^TPipeInfo; 55 | TPipeInfo = record 56 | Overlapped: TOverlapped; 57 | Handle: THandle; 58 | Operation: TOperation; 59 | Buffer: array[0..MaxBufferSize - 1] of AnsiChar; 60 | end; 61 | 62 | TInfoProc = procedure (Info: PPipeInfo; BytesTransferred: Cardinal = 0; Callback: Boolean = False; E: Exception = nil); 63 | 64 | const 65 | OpStrings: array[TOperation, Boolean] of string = ( 66 | ('connecting', 'connected'), 67 | ('reading', 'read'), 68 | ('writing', 'written') 69 | ); 70 | PipeName = '\\.\pipe\ASYNCPIPE'; 71 | 72 | var 73 | Pool: TThreadPool; 74 | ServerList: TThreadList; 75 | InfoProc: TInfoProc = nil; 76 | 77 | procedure Server_Handler(BytesTransferred: Cardinal; Overlapped: POverlapped; E: Exception); forward; 78 | 79 | procedure Disconnect(Info: PPipeInfo); 80 | begin 81 | with ServerList.LockList do 82 | try 83 | Remove(Info); 84 | finally 85 | ServerList.UnlockList; 86 | end; 87 | CloseHandle(Info^.Handle); 88 | FreeMem(Info); 89 | end; 90 | 91 | procedure RequestConnect(HandlerProc: TWorkerProc); 92 | var 93 | Info: PPipeInfo; 94 | LastError: Cardinal; 95 | begin 96 | Info := AllocMem(SizeOf(TPipeInfo)); 97 | try 98 | Info^.Handle := CreateNamedPipe(PipeName, PIPE_ACCESS_DUPLEX or FILE_FLAG_OVERLAPPED, 99 | PIPE_TYPE_MESSAGE or PIPE_READMODE_MESSAGE or PIPE_WAIT, 100 | InstanceCount, MaxBufferSize, MaxBufferSize, 0, nil); 101 | if Info^.Handle = INVALID_HANDLE_VALUE then 102 | RaiseLastOSError; 103 | 104 | Pool.Bind(Server_Handler, Info^.Handle); 105 | 106 | with ServerList.LockList do 107 | try 108 | Add(Info); 109 | finally 110 | ServerList.UnlockList; 111 | end; 112 | 113 | Info^.Operation := opConnect; 114 | if ConnectNamedPipe(Info^.Handle, Pointer(Info)) then // connected synchronously 115 | // nothing to do, callback invoked by IOCP 116 | else 117 | begin 118 | LastError := GetLastError; 119 | case LastError of 120 | ERROR_PIPE_CONNECTED, ERROR_PIPE_LISTENING, ERROR_IO_PENDING: 121 | ; 122 | else 123 | RaiseLastOSError(LastError); 124 | end; 125 | end; 126 | except 127 | FreeMem(Info); 128 | raise; 129 | end; 130 | end; 131 | 132 | function RequestRead(Info: PPipeInfo): Boolean; 133 | var 134 | BytesRead, LastError: Cardinal; 135 | begin 136 | Info^.Operation := opRead; 137 | if Assigned(InfoProc) then 138 | InfoProc(Info); 139 | BytesRead := 0; 140 | Result := ReadFile(Info^.Handle, Info^.Buffer, MaxBufferSize, BytesRead, Pointer(Info)); 141 | if Result then // read completed synchronously 142 | // nothing to do, callback invoked by IOCP 143 | else 144 | begin 145 | LastError := GetLastError; 146 | if LastError <> ERROR_IO_PENDING then 147 | RaiseLastOSError(LastError); 148 | end; 149 | end; 150 | 151 | function RequestWrite(Info: PPipeInfo): Boolean; 152 | var 153 | BytesWritten, LastError: Cardinal; 154 | begin 155 | Info^.Operation := opWrite; 156 | if Assigned(InfoProc) then 157 | InfoProc(Info); 158 | BytesWritten := 0; 159 | Result := WriteFile(Info^.Handle, Info^.Buffer, {$ifdef HAS_ANSISTRINGS}AnsiStrings.{$endif}StrLen(Info^.Buffer) + 1, 160 | BytesWritten, Pointer(Info)); 161 | if Result then // write completed synchronously 162 | // nothing to do, callback invoked by IOCP 163 | else 164 | begin 165 | LastError := GetLastError; 166 | if LastError <> ERROR_IO_PENDING then 167 | RaiseLastOSError(LastError); 168 | end; 169 | end; 170 | 171 | procedure Server_Handler(BytesTransferred: Cardinal; Overlapped: POverlapped; E: Exception); 172 | var 173 | Info: PPipeInfo absolute Overlapped; 174 | begin 175 | if Assigned(InfoProc) then 176 | InfoProc(Info, BytesTransferred, True, E); 177 | 178 | if Assigned(E) then 179 | begin 180 | E.Free; 181 | Disconnect(Info); 182 | RequestConnect(Server_Handler); 183 | Exit; 184 | end; 185 | 186 | case Info^.Operation of 187 | opConnect: 188 | RequestRead(Info); 189 | opRead: 190 | begin 191 | {$ifdef HAS_ANSISTRINGS} 192 | AnsiStrings.StrLCopy(Info^.Buffer, PAnsiChar(AnsiStrings.UpperCase(Info^.Buffer)), MaxBufferSize - 1); 193 | {$else} 194 | StrLCopy(Info^.Buffer, PAnsiChar(UpperCase(Info^.Buffer)), MaxBufferSize - 1); 195 | {$endif} 196 | RequestWrite(Info); 197 | end; 198 | opWrite: 199 | RequestRead(Info); 200 | end; 201 | end; 202 | 203 | procedure ServerInfoProc(Info: PPipeInfo; BytesTransferred: Cardinal; Callback: Boolean; E: Exception); 204 | var 205 | SBytes, SData: string; 206 | begin 207 | SBytes := ''; 208 | SData := ''; 209 | if Callback then 210 | SBytes := Format(' (%u bytes)', [BytesTransferred]); 211 | 212 | if Assigned(E) then 213 | WriteLn(Format('[%s][%u] server %u %s: [%s] %s', [FormatDateTime('hh:nn:ss.zzz', Now), 214 | GetCurrentThreadId, Info^.Handle, OpStrings[Info^.Operation, Callback] + SBytes, E.ClassName, E.Message])) 215 | else 216 | begin 217 | if Callback or (Info^.Operation = opWrite) then 218 | SData := Format(' ''%s''', [PAnsiChar(Info^.Buffer)]); 219 | 220 | case Info^.Operation of 221 | opWrite, opRead: 222 | WriteLn(Format('[%s][%u] server %u %s' + SData, [FormatDateTime('hh:nn:ss.zzz', Now), 223 | GetCurrentThreadId, Info^.Handle, OpStrings[Info^.Operation, Callback] + SBytes, PAnsiChar(Info^.Buffer)])); 224 | else 225 | WriteLn(Format('[%s][%u] server %u %s', [FormatDateTime('hh:nn:ss.zzz', Now), 226 | GetCurrentThreadId, Info^.Handle, OpStrings[Info^.Operation, Callback]])); 227 | end; 228 | end; 229 | end; 230 | 231 | procedure ServerMain; 232 | var 233 | I: Integer; 234 | begin 235 | InfoProc := ServerInfoProc; 236 | ServerList := nil; 237 | Pool := TThreadPool.Create; 238 | try 239 | ServerList := TThreadList.Create; 240 | ServerList.LockList; 241 | try 242 | for I := 0 to InstanceCount - 1 do 243 | RequestConnect(Server_Handler); 244 | finally 245 | ServerList.UnlockList; 246 | end; 247 | 248 | Writeln(Format('%d instances listening. Press Enter to quit...', [InstanceCount])); 249 | Readln; 250 | finally 251 | Pool.Free; 252 | if Assigned(ServerList) then 253 | begin 254 | with ServerList.LockList do 255 | try 256 | for I := 0 to Count - 1 do 257 | begin 258 | CloseHandle(PPipeInfo(Items[I])^.Handle); 259 | FreeMem(Items[I]); 260 | end; 261 | Clear; 262 | finally 263 | ServerList.UnlockList; 264 | end; 265 | ServerList.Free; 266 | end; 267 | end; 268 | end; 269 | 270 | procedure NewRequest(Info: PPipeInfo); 271 | var 272 | SHello: AnsiString; 273 | begin 274 | SHello := Format('Hello %d', [Random(101)]); 275 | {$ifdef HAS_ANSISTRINGS}AnsiStrings.{$endif}StrLCopy(Info^.Buffer, PAnsiChar(SHello), MaxBufferSize - 1); 276 | end; 277 | 278 | procedure Client_Handler(BytesTransferred: Cardinal; Overlapped: POverlapped; E: Exception); 279 | var 280 | Info: PPipeInfo absolute Overlapped; 281 | begin 282 | if Assigned(InfoProc) then 283 | InfoProc(Info, BytesTransferred, True, E); 284 | 285 | if Assigned(E) then 286 | begin 287 | E.Free; 288 | Exit; 289 | end; 290 | 291 | case Info^.Operation of 292 | opRead: 293 | begin 294 | NewRequest(Info); 295 | RequestWrite(Info); 296 | end; 297 | opWrite: 298 | RequestRead(Info); 299 | end; 300 | end; 301 | 302 | procedure ClientInfoProc(Info: PPipeInfo; BytesTransferred: Cardinal; Callback: Boolean; E: Exception); 303 | var 304 | SBytes, SData: string; 305 | begin 306 | SBytes := ''; 307 | SData := ''; 308 | if Callback then 309 | SBytes := Format(' (%u bytes)', [BytesTransferred]); 310 | 311 | if Assigned(E) then 312 | WriteLn(Format('[%s][%u] client %u %s: [%s] %s', [FormatDateTime('hh:nn:ss.zzz', Now), GetCurrentThreadId, 313 | Info^.Handle, OpStrings[Info^.Operation, Callback] + SBytes, E.ClassName, E.Message])) 314 | else 315 | begin 316 | if Callback or (Info^.Operation = opWrite) then 317 | SData := Format(' ''%s''', [PAnsiChar(Info^.Buffer)]); 318 | 319 | WriteLn(Format('[%s][%u] client %u %s' + SData, [FormatDateTime('hh:nn:ss.zzz', Now), GetCurrentThreadId, 320 | Info^.Handle, OpStrings[Info^.Operation, Callback] + SBytes])); 321 | end; 322 | end; 323 | 324 | procedure ClientMain; 325 | var 326 | ClientHandle: THandle; 327 | Info: PPipeInfo; 328 | PipeState: Cardinal; 329 | begin 330 | Randomize; 331 | InfoProc := ClientInfoProc; 332 | 333 | Info := nil; 334 | Pool := nil; 335 | try 336 | Pool := TThreadPool.Create; 337 | ClientHandle := CreateFile(PipeName, GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, 338 | FILE_FLAG_OVERLAPPED, 0); 339 | if ClientHandle = INVALID_HANDLE_VALUE then 340 | RaiseLastOSError; 341 | try 342 | PipeState := PIPE_READMODE_MESSAGE; 343 | Win32Check(SetNamedPipeHandleState(ClientHandle, PipeState, nil, nil)); 344 | 345 | Pool.Bind(Client_Handler, ClientHandle); 346 | 347 | Info := AllocMem(SizeOf(TPipeInfo)); 348 | Info^.Handle := ClientHandle; 349 | Info^.Operation := opWrite; 350 | 351 | NewRequest(Info); 352 | RequestWrite(Info); 353 | Readln; 354 | finally 355 | CloseHandle(ClientHandle); 356 | end; 357 | finally 358 | Pool.Free; 359 | if Assigned(Info) then 360 | FreeMem(Info); 361 | end; 362 | end; 363 | 364 | procedure Main; 365 | begin 366 | if (ParamCount = 1) and SameText('/server', ParamStr(1)) then 367 | ServerMain 368 | else 369 | ClientMain; 370 | end; 371 | 372 | begin 373 | try 374 | Main; 375 | except 376 | on E: Exception do 377 | begin 378 | ExitCode := 1; 379 | Writeln(Format('[%s] %s', [E.ClassName, E.Message])); 380 | end; 381 | end; 382 | end. 383 | -------------------------------------------------------------------------------- /examples/asyncpipe/asyncpipe.dproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | {3473D985-8522-4659-A0A1-42FB89FBB466} 4 | asyncpipe.dpr 5 | True 6 | Debug 7 | 1 8 | Console 9 | None 10 | 16.1 11 | Win32 12 | 13 | 14 | true 15 | 16 | 17 | true 18 | Base 19 | true 20 | 21 | 22 | true 23 | Base 24 | true 25 | 26 | 27 | true 28 | Base 29 | true 30 | 31 | 32 | true 33 | Cfg_2 34 | true 35 | true 36 | 37 | 38 | 1 39 | false 40 | false 41 | false 42 | false 43 | vcl;rtl;vclx;indy;inet;xmlrtl;vclie;inetdbbde;inetdbxpress;dbrtl;dsnap;dsnapcon;vcldb;soaprtl;VclSmp;dbexpress;dbxcds;inetdb;bdertl;vcldbx;webdsnap;websnap;adortl;ibxpress;teeui;teedb;tee;dss;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOfficeXP;JclDeveloperTools;Jcl;JclVcl;JclContainers;GR32_DSGN_D7;GR32_D7;$(DCC_UsePackage) 44 | false 45 | None 46 | asyncpipe 47 | 1031 48 | bin\$(Platform)\$(Config) 49 | System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace) 50 | 1 51 | lib\$(Platform)\$(Config) 52 | 00400000 53 | true 54 | ..\..\src;$(DCC_UnitSearchPath) 55 | CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= 56 | false 57 | 58 | 59 | 1033 60 | System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 61 | 62 | 63 | false 64 | 0 65 | 0 66 | RELEASE;$(DCC_Define) 67 | 68 | 69 | true 70 | false 71 | DEBUG;$(DCC_Define) 72 | 73 | 74 | /server 75 | None 76 | 1033 77 | 78 | 79 | 80 | MainSource 81 | 82 | 83 | 84 | 85 | Cfg_2 86 | Base 87 | 88 | 89 | Base 90 | 91 | 92 | Cfg_1 93 | Base 94 | 95 | 96 | 97 | Delphi.Personality.12 98 | 99 | 100 | 101 | 102 | asyncpipe.dpr 103 | 104 | 105 | Embarcadero C++Builder Office 2000 Servers Package 106 | Embarcadero C++Builder Office XP Servers Package 107 | Microsoft Office 2000 Sample Automation Server Wrapper Components 108 | Microsoft Office XP Sample Automation Server Wrapper Components 109 | 110 | 111 | 112 | False 113 | True 114 | False 115 | 116 | 117 | 12 118 | 119 | 120 | 121 | 122 | -------------------------------------------------------------------------------- /examples/asyncpipe/asyncpipe.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | <UseAppBundle Value="False"/> 16 | <ResourceType Value="res"/> 17 | </General> 18 | <BuildModes Count="2"> 19 | <Item1 Name="Debug" Default="True"/> 20 | <Item2 Name="Release"> 21 | <CompilerOptions> 22 | <Version Value="11"/> 23 | <PathDelim Value="\"/> 24 | <Target> 25 | <Filename Value="asyncpipe"/> 26 | </Target> 27 | <SearchPaths> 28 | <IncludeFiles Value="$(ProjOutDir)"/> 29 | <OtherUnitFiles Value="..\..\src"/> 30 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 31 | </SearchPaths> 32 | <CodeGeneration> 33 | <SmartLinkUnit Value="True"/> 34 | <Optimizations> 35 | <OptimizationLevel Value="3"/> 36 | </Optimizations> 37 | </CodeGeneration> 38 | <Linking> 39 | <Debugging> 40 | <GenerateDebugInfo Value="False"/> 41 | </Debugging> 42 | <LinkSmart Value="True"/> 43 | </Linking> 44 | </CompilerOptions> 45 | </Item2> 46 | </BuildModes> 47 | <PublishOptions> 48 | <Version Value="2"/> 49 | </PublishOptions> 50 | <RunParams> 51 | <local> 52 | <FormatVersion Value="1"/> 53 | <CommandLineParams Value="/server"/> 54 | </local> 55 | </RunParams> 56 | <Units Count="3"> 57 | <Unit0> 58 | <Filename Value="asyncpipe.dpr"/> 59 | <IsPartOfProject Value="True"/> 60 | </Unit0> 61 | <Unit1> 62 | <Filename Value="..\..\src\ThreadPool.pas"/> 63 | <IsPartOfProject Value="True"/> 64 | </Unit1> 65 | <Unit2> 66 | <Filename Value="..\..\src\Compat.pas"/> 67 | <IsPartOfProject Value="True"/> 68 | </Unit2> 69 | </Units> 70 | </ProjectOptions> 71 | <CompilerOptions> 72 | <Version Value="11"/> 73 | <PathDelim Value="\"/> 74 | <Target> 75 | <Filename Value="bin\$(TargetCPU)-$(TargetOS)\$(BuildMode)\asyncpipe"/> 76 | </Target> 77 | <SearchPaths> 78 | <IncludeFiles Value="$(ProjOutDir);..\..\src"/> 79 | <OtherUnitFiles Value="..\..\src"/> 80 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\$(BuildMode)"/> 81 | </SearchPaths> 82 | <Parsing> 83 | <SyntaxOptions> 84 | <IncludeAssertionCode Value="True"/> 85 | </SyntaxOptions> 86 | </Parsing> 87 | <CodeGeneration> 88 | <Checks> 89 | <IOChecks Value="True"/> 90 | <RangeChecks Value="True"/> 91 | <OverflowChecks Value="True"/> 92 | <StackChecks Value="True"/> 93 | </Checks> 94 | <VerifyObjMethodCallValidity Value="True"/> 95 | </CodeGeneration> 96 | <Linking> 97 | <Debugging> 98 | <DebugInfoType Value="dsDwarf2Set"/> 99 | <UseHeaptrc Value="True"/> 100 | <TrashVariables Value="True"/> 101 | <UseExternalDbgSyms Value="True"/> 102 | </Debugging> 103 | </Linking> 104 | </CompilerOptions> 105 | <Debugging> 106 | <Exceptions Count="3"> 107 | <Item1> 108 | <Name Value="EAbort"/> 109 | </Item1> 110 | <Item2> 111 | <Name Value="ECodetoolError"/> 112 | </Item2> 113 | <Item3> 114 | <Name Value="EFOpenError"/> 115 | </Item3> 116 | </Exceptions> 117 | </Debugging> 118 | </CONFIG> 119 | -------------------------------------------------------------------------------- /examples/asyncpipe/asyncpipe.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tondrej/iocp-delphi/d2620d99b208e393a658aa998cde31a3833137eb/examples/asyncpipe/asyncpipe.res -------------------------------------------------------------------------------- /examples/worker/workerdemo.dpr: -------------------------------------------------------------------------------- 1 | (* 2 | 3 | MIT License 4 | 5 | Copyright (c) 2021 Ondrej Kelle 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in all 15 | copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | SOFTWARE. 24 | 25 | *) 26 | 27 | program workerdemo; 28 | 29 | {$IFDEF FPC} 30 | {$MODE Delphi} 31 | {$ENDIF} 32 | 33 | {$APPTYPE CONSOLE} 34 | 35 | uses 36 | Windows, 37 | SysUtils, 38 | SyncObjs, 39 | ThreadPool in '..\..\src\ThreadPool.pas', 40 | Compat in '..\..\src\Compat.pas'; 41 | 42 | var 43 | Lock: TCriticalSection; 44 | 45 | procedure Writeln(const S: string); 46 | begin 47 | Lock.Acquire; 48 | try 49 | System.Writeln(S); 50 | finally 51 | Lock.Release; 52 | end; 53 | end; 54 | 55 | var 56 | PendingCount: Integer; 57 | Cancelled: Boolean; 58 | 59 | function Fibonacci(Index: Int64): Int64; 60 | begin 61 | if Cancelled then 62 | Result := 0 63 | else if Index < 3 then 64 | Result := 1 65 | else 66 | Result := Fibonacci(Index - 1) + Fibonacci(Index - 2); 67 | end; 68 | 69 | procedure WorkerProc(BytesTransferred: Cardinal; Overlapped: POverlapped; E: Exception); 70 | var 71 | I, F: Int64; 72 | TaskID: NativeUInt absolute Overlapped; 73 | begin 74 | if Assigned(E) then 75 | begin 76 | Writeln(Format('Task %u: [%s] %s', [TaskID, E.ClassName, E.Message])); 77 | E.Free; 78 | Exit; 79 | end; 80 | 81 | I := Random(42); 82 | F := Fibonacci(I); 83 | if Cancelled then 84 | Writeln(Format('Task %u: [%u] cancelled', [TaskID, GetCurrentThreadId])) 85 | else 86 | Writeln(Format('Task %u: [%u] Fibonacci(%d) = %d', [TaskID, GetCurrentThreadId, I, F])); 87 | InterlockedDecrement(PendingCount); 88 | end; 89 | 90 | procedure Main; 91 | const 92 | TaskCount = 1024; 93 | var 94 | ThreadPool: TThreadPool; 95 | I: NativeUInt; 96 | begin 97 | Randomize; 98 | ThreadPool := TThreadPool.Create(64, 32); // optional: override the thread count defaults 99 | try 100 | PendingCount := TaskCount; 101 | ThreadPool.Bind(WorkerProc); // optional: initialize beforehand so you can see the actual thread counts 102 | Writeln(Format('Posting %d tasks to a pool with %d running threads (%d concurrent). Press Enter to cancel...', 103 | [TaskCount, ThreadPool.RunningThreadCount, ThreadPool.ConcurrentThreadCount])); 104 | for I := 0 to TaskCount - 1 do 105 | ThreadPool.Queue(0, WorkerProc, Pointer(I)); 106 | Readln; 107 | if PendingCount > 0 then 108 | begin 109 | Writeln(Format('Cancelling %u pending tasks...', [PendingCount])); 110 | Cancelled := True; 111 | end; 112 | finally 113 | ThreadPool.Free; 114 | end; 115 | end; 116 | 117 | begin 118 | try 119 | Lock := TCriticalSection.Create; 120 | try 121 | Main; 122 | finally 123 | Lock.Free; 124 | end; 125 | except 126 | on E: Exception do 127 | begin 128 | ExitCode := 1; 129 | Writeln(Format('[%s] %s', [E.ClassName, E.Message])); 130 | end; 131 | end; 132 | end. 133 | -------------------------------------------------------------------------------- /examples/worker/workerdemo.dproj: -------------------------------------------------------------------------------- 1 | <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> 2 | <PropertyGroup> 3 | <ProjectGuid>{263DF4DB-FE68-4D04-83BA-7E5FF7CD394C}</ProjectGuid> 4 | <MainSource>workerdemo.dpr</MainSource> 5 | <Base>True</Base> 6 | <Config Condition="'$(Config)'==''">Debug</Config> 7 | <TargetedPlatforms>3</TargetedPlatforms> 8 | <AppType>Console</AppType> 9 | <FrameworkType>None</FrameworkType> 10 | <ProjectVersion>16.1</ProjectVersion> 11 | <Platform Condition="'$(Platform)'==''">Win32</Platform> 12 | </PropertyGroup> 13 | <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> 14 | <Base>true</Base> 15 | </PropertyGroup> 16 | <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> 17 | <Base_Win32>true</Base_Win32> 18 | <CfgParent>Base</CfgParent> 19 | <Base>true</Base> 20 | </PropertyGroup> 21 | <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> 22 | <Base_Win64>true</Base_Win64> 23 | <CfgParent>Base</CfgParent> 24 | <Base>true</Base> 25 | </PropertyGroup> 26 | <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> 27 | <Cfg_1>true</Cfg_1> 28 | <CfgParent>Base</CfgParent> 29 | <Base>true</Base> 30 | </PropertyGroup> 31 | <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> 32 | <Cfg_2>true</Cfg_2> 33 | <CfgParent>Base</CfgParent> 34 | <Base>true</Base> 35 | </PropertyGroup> 36 | <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''"> 37 | <Cfg_2_Win32>true</Cfg_2_Win32> 38 | <CfgParent>Cfg_2</CfgParent> 39 | <Cfg_2>true</Cfg_2> 40 | <Base>true</Base> 41 | </PropertyGroup> 42 | <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> 43 | <Cfg_2_Win64>true</Cfg_2_Win64> 44 | <CfgParent>Cfg_2</CfgParent> 45 | <Cfg_2>true</Cfg_2> 46 | <Base>true</Base> 47 | </PropertyGroup> 48 | <PropertyGroup Condition="'$(Base)'!=''"> 49 | <DCC_N>false</DCC_N> 50 | <DCC_ExeOutput>bin\$(Platform)\$(Config)</DCC_ExeOutput> 51 | <DCC_DcuOutput>lib\$(Platform)\$(Config)</DCC_DcuOutput> 52 | <DCC_S>false</DCC_S> 53 | <SanitizedProjectName>workerdemo</SanitizedProjectName> 54 | <DCC_K>false</DCC_K> 55 | <DCC_F>false</DCC_F> 56 | <DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)</DCC_Namespace> 57 | <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys> 58 | <DCC_E>false</DCC_E> 59 | <Manifest_File>None</Manifest_File> 60 | <DCC_ImageBase>00400000</DCC_ImageBase> 61 | <VerInfo_Locale>2057</VerInfo_Locale> 62 | </PropertyGroup> 63 | <PropertyGroup Condition="'$(Base_Win32)'!=''"> 64 | <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> 65 | <VerInfo_Locale>1033</VerInfo_Locale> 66 | <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> 67 | </PropertyGroup> 68 | <PropertyGroup Condition="'$(Base_Win64)'!=''"> 69 | <DCC_Namespace>System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> 70 | <VerInfo_Locale>1033</VerInfo_Locale> 71 | <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> 72 | </PropertyGroup> 73 | <PropertyGroup Condition="'$(Cfg_1)'!=''"> 74 | <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> 75 | <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> 76 | <DCC_DebugInformation>0</DCC_DebugInformation> 77 | <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> 78 | </PropertyGroup> 79 | <PropertyGroup Condition="'$(Cfg_2)'!=''"> 80 | <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> 81 | <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> 82 | <DCC_Optimize>false</DCC_Optimize> 83 | </PropertyGroup> 84 | <PropertyGroup Condition="'$(Cfg_2_Win32)'!=''"> 85 | <VerInfo_Locale>1033</VerInfo_Locale> 86 | <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> 87 | </PropertyGroup> 88 | <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> 89 | <Manifest_File>None</Manifest_File> 90 | <VerInfo_Locale>1033</VerInfo_Locale> 91 | <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> 92 | </PropertyGroup> 93 | <ItemGroup> 94 | <DelphiCompile Include="$(MainSource)"> 95 | <MainSource>MainSource</MainSource> 96 | </DelphiCompile> 97 | <DCCReference Include="..\..\src\ThreadPool.pas"/> 98 | <DCCReference Include="..\..\src\Compat.pas"/> 99 | <BuildConfiguration Include="Debug"> 100 | <Key>Cfg_2</Key> 101 | <CfgParent>Base</CfgParent> 102 | </BuildConfiguration> 103 | <BuildConfiguration Include="Base"> 104 | <Key>Base</Key> 105 | </BuildConfiguration> 106 | <BuildConfiguration Include="Release"> 107 | <Key>Cfg_1</Key> 108 | <CfgParent>Base</CfgParent> 109 | </BuildConfiguration> 110 | </ItemGroup> 111 | <ProjectExtensions> 112 | <Borland.Personality>Delphi.Personality.12</Borland.Personality> 113 | <Borland.ProjectType/> 114 | <BorlandProject> 115 | <Delphi.Personality> 116 | <Source> 117 | <Source Name="MainSource">workerdemo.dpr</Source> 118 | </Source> 119 | <Excluded_Packages> 120 | <Excluded_Packages Name="$(BDSBIN)\bcboffice2k210.bpl">Embarcadero C++Builder Office 2000 Servers Package</Excluded_Packages> 121 | <Excluded_Packages Name="$(BDSBIN)\bcbofficexp210.bpl">Embarcadero C++Builder Office XP Servers Package</Excluded_Packages> 122 | <Excluded_Packages Name="$(BDSBIN)\dcloffice2k210.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages> 123 | <Excluded_Packages Name="$(BDSBIN)\dclofficexp210.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages> 124 | </Excluded_Packages> 125 | </Delphi.Personality> 126 | <Platforms> 127 | <Platform value="OSX32">False</Platform> 128 | <Platform value="Win32">True</Platform> 129 | <Platform value="Win64">True</Platform> 130 | </Platforms> 131 | <Deployment> 132 | <DeployFile LocalName="bin\Win32\Debug\workerdemo.exe" Configuration="Debug" Class="ProjectOutput"> 133 | <Platform Name="Win32"> 134 | <RemoteName>workerdemo.exe</RemoteName> 135 | <Overwrite>true</Overwrite> 136 | </Platform> 137 | </DeployFile> 138 | <DeployFile LocalName="$(BDS)\Redist\osx32\libcgunwind.1.0.dylib" Class="DependencyModule"> 139 | <Platform Name="OSX32"> 140 | <Overwrite>true</Overwrite> 141 | </Platform> 142 | <Platform Name="iOSSimulator"> 143 | <Overwrite>true</Overwrite> 144 | </Platform> 145 | </DeployFile> 146 | <DeployFile LocalName="..\..\bin\Win64\Debug\workerdemo.exe" Configuration="Debug" Class="ProjectOutput"> 147 | <Platform Name="Win64"> 148 | <RemoteName>workerdemo.exe</RemoteName> 149 | <Overwrite>true</Overwrite> 150 | </Platform> 151 | </DeployFile> 152 | <DeployClass Required="true" Name="DependencyPackage"> 153 | <Platform Name="iOSDevice"> 154 | <Operation>1</Operation> 155 | <Extensions>.dylib</Extensions> 156 | </Platform> 157 | <Platform Name="Win32"> 158 | <Operation>0</Operation> 159 | <Extensions>.bpl</Extensions> 160 | </Platform> 161 | <Platform Name="OSX32"> 162 | <Operation>1</Operation> 163 | <Extensions>.dylib</Extensions> 164 | </Platform> 165 | <Platform Name="iOSSimulator"> 166 | <Operation>1</Operation> 167 | <Extensions>.dylib</Extensions> 168 | </Platform> 169 | </DeployClass> 170 | <DeployClass Name="DependencyModule"> 171 | <Platform Name="OSX32"> 172 | <Operation>1</Operation> 173 | <Extensions>.dylib</Extensions> 174 | </Platform> 175 | <Platform Name="Win32"> 176 | <Operation>0</Operation> 177 | <Extensions>.dll;.bpl</Extensions> 178 | </Platform> 179 | </DeployClass> 180 | <DeployClass Name="iPad_Launch2048"> 181 | <Platform Name="iOSDevice"> 182 | <Operation>1</Operation> 183 | </Platform> 184 | <Platform Name="iOSSimulator"> 185 | <Operation>1</Operation> 186 | </Platform> 187 | </DeployClass> 188 | <DeployClass Name="ProjectOSXInfoPList"/> 189 | <DeployClass Name="ProjectiOSDeviceDebug"> 190 | <Platform Name="iOSDevice"> 191 | <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> 192 | <Operation>1</Operation> 193 | </Platform> 194 | </DeployClass> 195 | <DeployClass Name="Android_SplashImage470"> 196 | <Platform Name="Android"> 197 | <RemoteDir>res\drawable-normal</RemoteDir> 198 | <Operation>1</Operation> 199 | </Platform> 200 | </DeployClass> 201 | <DeployClass Name="AndroidLibnativeX86File"> 202 | <Platform Name="Android"> 203 | <RemoteDir>library\lib\x86</RemoteDir> 204 | <Operation>1</Operation> 205 | </Platform> 206 | </DeployClass> 207 | <DeployClass Name="ProjectiOSResource"> 208 | <Platform Name="iOSDevice"> 209 | <Operation>1</Operation> 210 | </Platform> 211 | <Platform Name="iOSSimulator"> 212 | <Operation>1</Operation> 213 | </Platform> 214 | </DeployClass> 215 | <DeployClass Name="ProjectOSXEntitlements"/> 216 | <DeployClass Name="AndroidGDBServer"> 217 | <Platform Name="Android"> 218 | <RemoteDir>library\lib\armeabi-v7a</RemoteDir> 219 | <Operation>1</Operation> 220 | </Platform> 221 | </DeployClass> 222 | <DeployClass Name="iPhone_Launch640"> 223 | <Platform Name="iOSDevice"> 224 | <Operation>1</Operation> 225 | </Platform> 226 | <Platform Name="iOSSimulator"> 227 | <Operation>1</Operation> 228 | </Platform> 229 | </DeployClass> 230 | <DeployClass Name="Android_SplashImage960"> 231 | <Platform Name="Android"> 232 | <RemoteDir>res\drawable-xlarge</RemoteDir> 233 | <Operation>1</Operation> 234 | </Platform> 235 | </DeployClass> 236 | <DeployClass Name="Android_LauncherIcon96"> 237 | <Platform Name="Android"> 238 | <RemoteDir>res\drawable-xhdpi</RemoteDir> 239 | <Operation>1</Operation> 240 | </Platform> 241 | </DeployClass> 242 | <DeployClass Name="iPhone_Launch320"> 243 | <Platform Name="iOSDevice"> 244 | <Operation>1</Operation> 245 | </Platform> 246 | <Platform Name="iOSSimulator"> 247 | <Operation>1</Operation> 248 | </Platform> 249 | </DeployClass> 250 | <DeployClass Name="Android_LauncherIcon144"> 251 | <Platform Name="Android"> 252 | <RemoteDir>res\drawable-xxhdpi</RemoteDir> 253 | <Operation>1</Operation> 254 | </Platform> 255 | </DeployClass> 256 | <DeployClass Name="AndroidLibnativeMipsFile"> 257 | <Platform Name="Android"> 258 | <RemoteDir>library\lib\mips</RemoteDir> 259 | <Operation>1</Operation> 260 | </Platform> 261 | </DeployClass> 262 | <DeployClass Name="AndroidSplashImageDef"> 263 | <Platform Name="Android"> 264 | <RemoteDir>res\drawable</RemoteDir> 265 | <Operation>1</Operation> 266 | </Platform> 267 | </DeployClass> 268 | <DeployClass Name="DebugSymbols"> 269 | <Platform Name="OSX32"> 270 | <Operation>1</Operation> 271 | </Platform> 272 | <Platform Name="iOSSimulator"> 273 | <Operation>1</Operation> 274 | </Platform> 275 | <Platform Name="Win32"> 276 | <Operation>0</Operation> 277 | </Platform> 278 | </DeployClass> 279 | <DeployClass Name="DependencyFramework"> 280 | <Platform Name="OSX32"> 281 | <Operation>1</Operation> 282 | <Extensions>.framework</Extensions> 283 | </Platform> 284 | <Platform Name="Win32"> 285 | <Operation>0</Operation> 286 | </Platform> 287 | </DeployClass> 288 | <DeployClass Name="Android_SplashImage426"> 289 | <Platform Name="Android"> 290 | <RemoteDir>res\drawable-small</RemoteDir> 291 | <Operation>1</Operation> 292 | </Platform> 293 | </DeployClass> 294 | <DeployClass Name="ProjectiOSEntitlements"/> 295 | <DeployClass Name="AdditionalDebugSymbols"> 296 | <Platform Name="OSX32"> 297 | <Operation>1</Operation> 298 | </Platform> 299 | <Platform Name="Win32"> 300 | <RemoteDir>Contents\MacOS</RemoteDir> 301 | <Operation>0</Operation> 302 | </Platform> 303 | </DeployClass> 304 | <DeployClass Name="AndroidClassesDexFile"> 305 | <Platform Name="Android"> 306 | <RemoteDir>classes</RemoteDir> 307 | <Operation>1</Operation> 308 | </Platform> 309 | </DeployClass> 310 | <DeployClass Name="ProjectiOSInfoPList"/> 311 | <DeployClass Name="iPad_Launch1024"> 312 | <Platform Name="iOSDevice"> 313 | <Operation>1</Operation> 314 | </Platform> 315 | <Platform Name="iOSSimulator"> 316 | <Operation>1</Operation> 317 | </Platform> 318 | </DeployClass> 319 | <DeployClass Name="Android_DefaultAppIcon"> 320 | <Platform Name="Android"> 321 | <RemoteDir>res\drawable</RemoteDir> 322 | <Operation>1</Operation> 323 | </Platform> 324 | </DeployClass> 325 | <DeployClass Name="ProjectOSXResource"> 326 | <Platform Name="OSX32"> 327 | <RemoteDir>Contents\Resources</RemoteDir> 328 | <Operation>1</Operation> 329 | </Platform> 330 | </DeployClass> 331 | <DeployClass Name="ProjectiOSDeviceResourceRules"/> 332 | <DeployClass Name="iPad_Launch768"> 333 | <Platform Name="iOSDevice"> 334 | <Operation>1</Operation> 335 | </Platform> 336 | <Platform Name="iOSSimulator"> 337 | <Operation>1</Operation> 338 | </Platform> 339 | </DeployClass> 340 | <DeployClass Required="true" Name="ProjectOutput"> 341 | <Platform Name="iOSDevice"> 342 | <Operation>1</Operation> 343 | </Platform> 344 | <Platform Name="Android"> 345 | <RemoteDir>library\lib\armeabi-v7a</RemoteDir> 346 | <Operation>1</Operation> 347 | </Platform> 348 | <Platform Name="Win32"> 349 | <Operation>0</Operation> 350 | </Platform> 351 | <Platform Name="OSX32"> 352 | <Operation>1</Operation> 353 | </Platform> 354 | <Platform Name="iOSSimulator"> 355 | <Operation>1</Operation> 356 | </Platform> 357 | </DeployClass> 358 | <DeployClass Name="AndroidLibnativeArmeabiFile"> 359 | <Platform Name="Android"> 360 | <RemoteDir>library\lib\armeabi</RemoteDir> 361 | <Operation>1</Operation> 362 | </Platform> 363 | </DeployClass> 364 | <DeployClass Name="Android_SplashImage640"> 365 | <Platform Name="Android"> 366 | <RemoteDir>res\drawable-large</RemoteDir> 367 | <Operation>1</Operation> 368 | </Platform> 369 | </DeployClass> 370 | <DeployClass Name="File"> 371 | <Platform Name="iOSDevice"> 372 | <Operation>0</Operation> 373 | </Platform> 374 | <Platform Name="Android"> 375 | <Operation>0</Operation> 376 | </Platform> 377 | <Platform Name="Win32"> 378 | <Operation>0</Operation> 379 | </Platform> 380 | <Platform Name="OSX32"> 381 | <Operation>0</Operation> 382 | </Platform> 383 | <Platform Name="iOSSimulator"> 384 | <Operation>0</Operation> 385 | </Platform> 386 | </DeployClass> 387 | <DeployClass Name="iPhone_Launch640x1136"> 388 | <Platform Name="iOSDevice"> 389 | <Operation>1</Operation> 390 | </Platform> 391 | <Platform Name="iOSSimulator"> 392 | <Operation>1</Operation> 393 | </Platform> 394 | </DeployClass> 395 | <DeployClass Name="Android_LauncherIcon36"> 396 | <Platform Name="Android"> 397 | <RemoteDir>res\drawable-ldpi</RemoteDir> 398 | <Operation>1</Operation> 399 | </Platform> 400 | </DeployClass> 401 | <DeployClass Name="AndroidSplashStyles"> 402 | <Platform Name="Android"> 403 | <RemoteDir>res\values</RemoteDir> 404 | <Operation>1</Operation> 405 | </Platform> 406 | </DeployClass> 407 | <DeployClass Name="iPad_Launch1536"> 408 | <Platform Name="iOSDevice"> 409 | <Operation>1</Operation> 410 | </Platform> 411 | <Platform Name="iOSSimulator"> 412 | <Operation>1</Operation> 413 | </Platform> 414 | </DeployClass> 415 | <DeployClass Name="Android_LauncherIcon48"> 416 | <Platform Name="Android"> 417 | <RemoteDir>res\drawable-mdpi</RemoteDir> 418 | <Operation>1</Operation> 419 | </Platform> 420 | </DeployClass> 421 | <DeployClass Name="Android_LauncherIcon72"> 422 | <Platform Name="Android"> 423 | <RemoteDir>res\drawable-hdpi</RemoteDir> 424 | <Operation>1</Operation> 425 | </Platform> 426 | </DeployClass> 427 | <DeployClass Name="ProjectAndroidManifest"> 428 | <Platform Name="Android"> 429 | <Operation>1</Operation> 430 | </Platform> 431 | </DeployClass> 432 | <ProjectRoot Platform="Android" Name="$(PROJECTNAME)"/> 433 | <ProjectRoot Platform="iOSDevice" Name="$(PROJECTNAME).app"/> 434 | <ProjectRoot Platform="Win32" Name="$(PROJECTNAME)"/> 435 | <ProjectRoot Platform="OSX32" Name="$(PROJECTNAME)"/> 436 | <ProjectRoot Platform="iOSSimulator" Name="$(PROJECTNAME).app"/> 437 | <ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/> 438 | </Deployment> 439 | </BorlandProject> 440 | <ProjectFileVersion>12</ProjectFileVersion> 441 | </ProjectExtensions> 442 | <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> 443 | <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> 444 | <Import Project="$(MSBuildProjectName).deployproj" Condition="Exists('$(MSBuildProjectName).deployproj')"/> 445 | </Project> 446 | -------------------------------------------------------------------------------- /examples/worker/workerdemo.lpi: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectOptions> 4 | <Version Value="10"/> 5 | <PathDelim Value="\"/> 6 | <General> 7 | <Flags> 8 | <MainUnitHasUsesSectionForAllUnits Value="False"/> 9 | <MainUnitHasCreateFormStatements Value="False"/> 10 | <MainUnitHasTitleStatement Value="False"/> 11 | <MainUnitHasScaledStatement Value="False"/> 12 | </Flags> 13 | <SessionStorage Value="InProjectDir"/> 14 | <MainUnit Value="0"/> 15 | <Title Value="IOCP Worker demo"/> 16 | <UseAppBundle Value="False"/> 17 | <ResourceType Value="res"/> 18 | </General> 19 | <BuildModes Count="3"> 20 | <Item1 Name="Default" Default="True"/> 21 | <Item2 Name="Debug"> 22 | <CompilerOptions> 23 | <Version Value="11"/> 24 | <PathDelim Value="\"/> 25 | <Target> 26 | <Filename Value="bin\$(TargetCPU)-$(TargetOS)\$(BuildMode)\workerdemo"/> 27 | </Target> 28 | <SearchPaths> 29 | <IncludeFiles Value="..\..\ext\jedi;..\..\src;$(ProjOutDir)"/> 30 | <Libraries Value="..\..\ext\jedi"/> 31 | <OtherUnitFiles Value="..\..\ext\jedi;..\..\src"/> 32 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\$(BuildMode)"/> 33 | <ObjectPath Value="ext\jedi"/> 34 | </SearchPaths> 35 | <Parsing> 36 | <SyntaxOptions> 37 | <SyntaxMode Value="Delphi"/> 38 | <IncludeAssertionCode Value="True"/> 39 | </SyntaxOptions> 40 | </Parsing> 41 | <CodeGeneration> 42 | <Checks> 43 | <IOChecks Value="True"/> 44 | <RangeChecks Value="True"/> 45 | <OverflowChecks Value="True"/> 46 | <StackChecks Value="True"/> 47 | </Checks> 48 | <VerifyObjMethodCallValidity Value="True"/> 49 | </CodeGeneration> 50 | <Linking> 51 | <Debugging> 52 | <DebugInfoType Value="dsDwarf2Set"/> 53 | <UseHeaptrc Value="True"/> 54 | <TrashVariables Value="True"/> 55 | <UseExternalDbgSyms Value="True"/> 56 | </Debugging> 57 | </Linking> 58 | <Other> 59 | <CustomOptions Value="-dBorland -dVer150 -dDelphi7 -dCompiler6_Up -dPUREPASCAL"/> 60 | </Other> 61 | </CompilerOptions> 62 | </Item2> 63 | <Item3 Name="Release"> 64 | <CompilerOptions> 65 | <Version Value="11"/> 66 | <PathDelim Value="\"/> 67 | <Target> 68 | <Filename Value="bin\$(TargetCPU)-$(TargetOS)\$(BuildMode)\workerdemo"/> 69 | </Target> 70 | <SearchPaths> 71 | <IncludeFiles Value="..\..\ext\jedi;..\..\src;$(ProjOutDir)"/> 72 | <Libraries Value="..\..\ext\jedi"/> 73 | <OtherUnitFiles Value="..\..\ext\jedi;..\..\src"/> 74 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\$(BuildMode)"/> 75 | <ObjectPath Value="ext\jedi"/> 76 | </SearchPaths> 77 | <Parsing> 78 | <SyntaxOptions> 79 | <SyntaxMode Value="Delphi"/> 80 | </SyntaxOptions> 81 | </Parsing> 82 | <CodeGeneration> 83 | <SmartLinkUnit Value="True"/> 84 | <TargetCPU Value="x86_64"/> 85 | <TargetOS Value="win64"/> 86 | <Optimizations> 87 | <OptimizationLevel Value="3"/> 88 | </Optimizations> 89 | </CodeGeneration> 90 | <Linking> 91 | <Debugging> 92 | <GenerateDebugInfo Value="False"/> 93 | </Debugging> 94 | <LinkSmart Value="True"/> 95 | </Linking> 96 | <Other> 97 | <CustomOptions Value="-dBorland -dVer150 -dDelphi7 -dCompiler6_Up -dPUREPASCAL"/> 98 | </Other> 99 | </CompilerOptions> 100 | </Item3> 101 | </BuildModes> 102 | <PublishOptions> 103 | <Version Value="2"/> 104 | </PublishOptions> 105 | <RunParams> 106 | <local> 107 | <FormatVersion Value="1"/> 108 | </local> 109 | </RunParams> 110 | <RequiredPackages Count="1"> 111 | <Item1> 112 | <PackageName Value="LCL"/> 113 | </Item1> 114 | </RequiredPackages> 115 | <Units Count="3"> 116 | <Unit0> 117 | <Filename Value="workerdemo.dpr"/> 118 | <IsPartOfProject Value="True"/> 119 | </Unit0> 120 | <Unit1> 121 | <Filename Value="..\..\src\Compat.pas"/> 122 | <IsPartOfProject Value="True"/> 123 | </Unit1> 124 | <Unit2> 125 | <Filename Value="..\..\src\ThreadPool.pas"/> 126 | <IsPartOfProject Value="True"/> 127 | </Unit2> 128 | </Units> 129 | </ProjectOptions> 130 | <CompilerOptions> 131 | <Version Value="11"/> 132 | <PathDelim Value="\"/> 133 | <Target> 134 | <Filename Value="bin\$(TargetCPU)-$(TargetOS)\$(BuildMode)\workerdemo"/> 135 | </Target> 136 | <SearchPaths> 137 | <IncludeFiles Value="..\..\ext\jedi;..\..\src;$(ProjOutDir)"/> 138 | <Libraries Value="..\..\ext\jedi"/> 139 | <OtherUnitFiles Value="..\..\ext\jedi;..\..\src"/> 140 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\$(BuildMode)"/> 141 | <ObjectPath Value="ext\jedi"/> 142 | </SearchPaths> 143 | <Parsing> 144 | <SyntaxOptions> 145 | <SyntaxMode Value="Delphi"/> 146 | </SyntaxOptions> 147 | </Parsing> 148 | <Other> 149 | <CustomOptions Value="-dBorland -dVer150 -dDelphi7 -dCompiler6_Up -dPUREPASCAL"/> 150 | </Other> 151 | </CompilerOptions> 152 | <Debugging> 153 | <Exceptions Count="3"> 154 | <Item1> 155 | <Name Value="EAbort"/> 156 | </Item1> 157 | <Item2> 158 | <Name Value="ECodetoolError"/> 159 | </Item2> 160 | <Item3> 161 | <Name Value="EFOpenError"/> 162 | </Item3> 163 | </Exceptions> 164 | </Debugging> 165 | </CONFIG> 166 | -------------------------------------------------------------------------------- /src/Compat.pas: -------------------------------------------------------------------------------- 1 | (* 2 | 3 | MIT License 4 | 5 | Copyright (c) 2021 Ondrej Kelle 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in all 15 | copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | SOFTWARE. 24 | 25 | *) 26 | 27 | unit Compat; 28 | 29 | interface 30 | 31 | {$include common.inc} 32 | 33 | {$ifdef FPC} 34 | {$macro ON} 35 | {$endif} 36 | 37 | uses 38 | {$ifdef FPC} 39 | Types, 40 | {$endif} 41 | {$ifdef DELPHI} 42 | Windows, 43 | {$endif} 44 | SysUtils; 45 | 46 | {$ifndef HAS_NATIVEUINT} 47 | type 48 | PNativeUInt = ^NativeUInt; 49 | NativeUInt = Cardinal; 50 | {$endif} 51 | 52 | {$ifndef HAS_RAWBYTESTRING} 53 | type 54 | RawByteString = AnsiString; 55 | {$endif} 56 | 57 | {$ifndef HAS_UINTPTR} 58 | type 59 | PUIntPtr = ^UIntPtr; 60 | UIntPtr = NativeUInt; 61 | {$endif} 62 | 63 | {$ifndef HAS_WSTRPOS} 64 | function WStrPos(const Str1, Str2: PWideChar): PWideChar; 65 | {$endif} 66 | 67 | type 68 | PUnicodeChar = ^UnicodeChar; 69 | UnicodeChar = WideChar; 70 | {$ifdef FPC} 71 | TSize = Types.TSize; 72 | {$else} 73 | TSize = Windows.TSize; 74 | {$endif} 75 | 76 | {$ifndef SUPPORTS_UNICODE_STRING} 77 | type 78 | PUnicodeString = ^UnicodeString; 79 | UnicodeString = WideString; 80 | {$endif} 81 | 82 | function GetBuildInfoString: string; 83 | function GetExeFileVersionString: string; 84 | 85 | {$ifdef FPC} 86 | var 87 | UTF8ToString: function(const S: RawByteString): UnicodeString = @UTF8Decode; 88 | {$endif} 89 | 90 | {$ifdef DELPHI} 91 | // initialize to US format settings (use point as decimal separator for float values) 92 | var 93 | DefaultFormatSettings: TFormatSettings; 94 | 95 | procedure InitCriticalSection(var Lock: TRTLCriticalSection); 96 | procedure DoneCriticalSection(var Lock: TRTLCriticalSection); 97 | 98 | {$ifndef HAS_RAISELASTOSERROR} 99 | procedure RaiseLastOSError; overload; 100 | procedure RaiseLastOSError(LastError: Cardinal); overload; 101 | {$endif} 102 | 103 | {$ifndef HAS_WIDESTRUTILS} 104 | function WideStringReplace(const S, OldPattern, NewPattern: Widestring; Flags: TReplaceFlags): Widestring; 105 | {$endif} 106 | 107 | {$ifndef UNICODE} 108 | var 109 | UTF8ToString: function(const S: UTF8String): WideString; 110 | {$endif} 111 | {$endif} 112 | 113 | implementation 114 | 115 | uses 116 | {$ifdef FPC} 117 | {$ifdef WINDOWS} 118 | winpeimagereader, 119 | {$endif} 120 | {$ifdef LINUX} 121 | elfreader, 122 | {$endif} 123 | {$ifdef DARWIN} 124 | machoreader, 125 | {$endif} 126 | fileinfo; 127 | {$else} 128 | SysConst; 129 | {$endif} 130 | 131 | {$ifdef FPC} 132 | function GetBuildInfoString: string; 133 | begin 134 | Result := Format('FPC %d.%d.%d for %s-%s', [FPC_VERSION, FPC_RELEASE, FPC_PATCH, lowercase({$i %FPCTARGETOS%}), lowercase({$i %FPCTARGETCPU%})]) 135 | end; 136 | 137 | function GetExeFileVersionString: string; 138 | var 139 | FileVersionInfo: TFileVersionInfo; 140 | begin 141 | FileVersionInfo := TFileVersionInfo.Create(nil); 142 | try 143 | FileVersionInfo.ReadFileInfo; 144 | Result := FileVersionInfo.VersionStrings.Values['FileVersion']; 145 | finally 146 | FileVersionInfo.Free; 147 | end; 148 | end; 149 | 150 | {$ifndef HAS_WSTRPOS} 151 | function WStrPos(const Str1, Str2: PWideChar): PWideChar; 152 | begin 153 | Result := strpos(Str1, Str2); 154 | end; 155 | {$endif} 156 | {$endif} 157 | 158 | {$ifdef DELPHI} 159 | 160 | procedure InitCriticalSection(var Lock: TRTLCriticalSection); 161 | begin 162 | InitializeCriticalSection(Lock); 163 | end; 164 | 165 | procedure DoneCriticalSection(var Lock: TRTLCriticalSection); 166 | begin 167 | Windows.DeleteCriticalSection(Lock); 168 | end; 169 | 170 | {$ifndef HAS_RAISELASTOSERROR} 171 | procedure RaiseLastOSError; 172 | begin 173 | SysUtils.RaiseLastOSError; 174 | end; 175 | 176 | procedure RaiseLastOSError(LastError: Cardinal); 177 | var 178 | Error: EOSError; 179 | begin 180 | if LastError <> 0 then 181 | Error := EOSError.CreateResFmt(@SOSError, [LastError, 182 | SysErrorMessage(LastError)]) 183 | else 184 | Error := EOSError.CreateRes(@SUnkOSError); 185 | Error.ErrorCode := LastError; 186 | raise Error; 187 | end; 188 | {$endif} 189 | 190 | {$ifndef HAS_WIDESTRUTILS} 191 | function WideStringReplace(const S, OldPattern, NewPattern: Widestring; Flags: TReplaceFlags): Widestring; 192 | var 193 | SearchStr, Patt, NewStr: Widestring; 194 | Offset: Integer; 195 | begin 196 | if rfIgnoreCase in Flags then 197 | begin 198 | SearchStr := WideUpperCase(S); 199 | Patt := WideUpperCase(OldPattern); 200 | end else 201 | begin 202 | SearchStr := S; 203 | Patt := OldPattern; 204 | end; 205 | NewStr := S; 206 | Result := ''; 207 | while SearchStr <> '' do 208 | begin 209 | Offset := Pos(Patt, SearchStr); 210 | if Offset = 0 then 211 | begin 212 | Result := Result + NewStr; 213 | Break; 214 | end; 215 | Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern; 216 | NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); 217 | if not (rfReplaceAll in Flags) then 218 | begin 219 | Result := Result + NewStr; 220 | Break; 221 | end; 222 | SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); 223 | end; 224 | end; 225 | {$endif} 226 | 227 | {$ifdef DELPHIXE2_UP} 228 | const 229 | ArchitectureStrings: array[TOSVersion.TArchitecture] of string = ('x86', 'x64', 'arm32'{$ifdef DELPHIX_BERLIN_UP}, 'arm64'{$endif}); 230 | PlatformStrings: array[TOSVersion.TPlatform] of string = ('Windows', 'MacOS', 'iOS', 'Android', 'WinRT', 'Linux'); 231 | {$endif} 232 | 233 | function GetBuildInfoString: string; 234 | begin 235 | {$ifdef DELPHIXE2_UP} 236 | Result := Format('Delphi %.1f for %s-%s', [System.CompilerVersion, PlatformStrings[TOSVersion.Platform], 237 | ArchitectureStrings[TOSVersion.Architecture]], DefaultFormatSettings); 238 | {$else} 239 | Result := Format('Delphi %.1f for Windows-x86', [CompilerVersion], DefaultFormatSettings); 240 | {$endif} 241 | end; 242 | 243 | function GetExeFileVersionString: string; 244 | var 245 | Ver: LongRec; 246 | begin 247 | Ver := LongRec(GetFileVersion(Paramstr(0))); 248 | Result := Format('%u.%u', [Ver.Hi, Ver.Lo]); 249 | end; 250 | 251 | {$ifndef HAS_WSTRPOS} 252 | function WStrPos(const Str1, Str2: PWideChar): PWideChar; 253 | var 254 | Str, SubStr: PWideChar; 255 | Ch: WideChar; 256 | begin 257 | Result := nil; 258 | if (Str1 = nil) or (Str1^ = #0) or (Str2 = nil) or (Str2^ = #0) then Exit; 259 | Result := Str1; 260 | Ch := Str2^; 261 | repeat 262 | if Result^ = Ch then 263 | begin 264 | Str := Result; 265 | SubStr := Str2; 266 | repeat 267 | Inc(Str); 268 | Inc(SubStr); 269 | if SubStr^ = #0 then exit; 270 | if Str^ = #0 then 271 | begin 272 | Result := nil; 273 | exit; 274 | end; 275 | if Str^ <> SubStr^ then break; 276 | until (FALSE); 277 | end; 278 | Inc(Result); 279 | until (Result^ = #0); 280 | Result := nil; 281 | end; 282 | {$endif} 283 | {$endif} 284 | 285 | initialization 286 | {$ifdef DELPHI} 287 | {$ifndef UNICODE} 288 | UTF8ToString := @UTF8Decode; 289 | {$endif} 290 | {$ifdef DELPHIXE_UP} 291 | DefaultFormatSettings := TFormatSettings.Create('en-US'); 292 | {$else} 293 | GetLocaleFormatSettings(1033, DefaultFormatSettings); 294 | {$endif} 295 | {$endif} 296 | {$ifdef FPC} 297 | {$ifdef WINDOWS} 298 | GetLocaleFormatSettings(1033, DefaultFormatSettings); 299 | {$endif} 300 | {$endif} 301 | 302 | finalization 303 | 304 | end. 305 | 306 | 307 | -------------------------------------------------------------------------------- /src/ThreadPool.pas: -------------------------------------------------------------------------------- 1 | (* 2 | 3 | MIT License 4 | 5 | Copyright (c) 2021 Ondrej Kelle 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in all 15 | copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | SOFTWARE. 24 | 25 | *) 26 | 27 | unit ThreadPool; 28 | 29 | {$IFDEF FPC} 30 | {$MODE Delphi} 31 | {$ENDIF} 32 | 33 | interface 34 | 35 | uses 36 | Windows, Classes, SysUtils, SyncObjs, 37 | Compat; 38 | 39 | type 40 | TWorkerProc = procedure (BytesTransferred: Cardinal; Overlapped: POverlapped; E: Exception); 41 | 42 | TThreadPool = class 43 | private 44 | FConcurrentThreadCount: Integer; 45 | FFinalized: TSimpleEvent; 46 | FHandle: THandle; 47 | FInitialized: TSimpleEvent; 48 | FRunningThreadCount: Integer; 49 | FThreadCount: Integer; 50 | 51 | FOnThreadDone: TNotifyEvent; 52 | FOnThreadStarted: TNotifyEvent; 53 | 54 | procedure ThreadDone(CompletionKey: NativeUInt); 55 | procedure ThreadStarted; 56 | protected 57 | function Broadcast(CompletionKey: UIntPtr; Overlapped: POverlapped = nil): Boolean; 58 | procedure DoThreadStarted; virtual; 59 | procedure DoThreadDone; virtual; 60 | procedure Finalize; 61 | procedure Initialize(AThreadCount: Cardinal = 0); 62 | 63 | property Handle: THandle read FHandle; 64 | public 65 | constructor Create(AThreadCount: Cardinal = 0; AConcurrentCount: Cardinal = 0); 66 | destructor Destroy; override; 67 | 68 | function BeginShutdown: Boolean; 69 | procedure Bind(Worker: TWorkerProc; AHandle: THandle = INVALID_HANDLE_VALUE); 70 | procedure Queue(BytesTransferred: Cardinal; Worker: TWorkerProc; Overlapped: POverlapped = nil); 71 | procedure Shutdown; 72 | procedure WaitFor(Timeout: Cardinal); 73 | 74 | property ConcurrentThreadCount: Integer read FConcurrentThreadCount; 75 | property RunningThreadCount: Integer read FRunningThreadCount; 76 | property ThreadCount: Integer read FThreadCount; 77 | 78 | property OnThreadDone: TNotifyEvent read FOnThreadDone write FOnThreadDone; 79 | property OnThreadStarted: TNotifyEvent read FOnThreadStarted write FOnThreadStarted; 80 | end; 81 | 82 | implementation 83 | 84 | const 85 | CompletionKeyShutDown = 0; 86 | 87 | function ThreadPoolWorker(ThreadPool: TThreadPool): Cardinal; stdcall; 88 | var 89 | BytesTransferred: Cardinal; 90 | CompletionKey: NativeUInt; 91 | Worker: TWorkerProc absolute CompletionKey; 92 | Overlapped: POverlapped; 93 | E: Exception; 94 | begin 95 | Result := 0; 96 | ThreadPool.ThreadStarted; 97 | try 98 | repeat 99 | BytesTransferred := 0; 100 | try 101 | if not GetQueuedCompletionStatus(ThreadPool.Handle, BytesTransferred, 102 | CompletionKey, Overlapped, INFINITE) then 103 | RaiseLastOSError; 104 | 105 | case CompletionKey of 106 | CompletionKeyShutDown: 107 | Break; 108 | else 109 | Worker(BytesTransferred, Overlapped, nil); 110 | end; 111 | except 112 | if CompletionKey <> 0 then 113 | begin 114 | E := AcquireExceptionObject; 115 | Worker(BytesTransferred, Overlapped, E); 116 | end; 117 | end; 118 | until False; 119 | finally 120 | ThreadPool.ThreadDone(CompletionKey); 121 | end; 122 | end; 123 | 124 | { TThreadPool private } 125 | 126 | procedure TThreadPool.ThreadDone(CompletionKey: NativeUInt); 127 | begin 128 | DoThreadDone; 129 | 130 | if InterlockedDecrement(FRunningThreadCount) <= 0 then 131 | begin 132 | FRunningThreadCount := 0; 133 | if CompletionKey = CompletionKeyShutDown then 134 | FFinalized.SetEvent; 135 | end; 136 | end; 137 | 138 | procedure TThreadPool.ThreadStarted; 139 | begin 140 | DoThreadStarted; 141 | 142 | if InterlockedIncrement(FRunningThreadCount) >= FThreadCount then 143 | FInitialized.SetEvent; 144 | end; 145 | 146 | { TThreadPool protected } 147 | 148 | function TThreadPool.Broadcast(CompletionKey: UIntPtr; Overlapped: POverlapped): Boolean; 149 | var 150 | Count: Cardinal; 151 | I: Integer; 152 | begin 153 | Count := FRunningThreadCount; 154 | Result := Count > 0; 155 | if not Result then 156 | Exit; 157 | 158 | for I := 0 to Count - 1 do 159 | PostQueuedCompletionStatus(FHandle, 0, CompletionKey, Overlapped); 160 | end; 161 | 162 | procedure TThreadPool.DoThreadDone; 163 | begin 164 | if Assigned(FOnThreadDone) then 165 | FOnThreadDone(Self); 166 | end; 167 | 168 | procedure TThreadPool.DoThreadStarted; 169 | begin 170 | if Assigned(FOnThreadStarted) then 171 | FOnThreadStarted(Self); 172 | end; 173 | 174 | procedure TThreadPool.Finalize; 175 | begin 176 | Shutdown; 177 | end; 178 | 179 | procedure TThreadPool.Initialize(AThreadCount: Cardinal); 180 | var 181 | SystemInfo: TSystemInfo; 182 | I: Integer; 183 | ThreadHandle: THandle; 184 | ThreadId: Cardinal; 185 | begin 186 | FInitialized.ResetEvent; 187 | FThreadCount := AThreadCount; 188 | if FThreadCount = 0 then 189 | begin 190 | GetSystemInfo(SystemInfo); 191 | FThreadCount := SystemInfo.dwNumberOfProcessors * 2; 192 | if FConcurrentThreadCount = 0 then 193 | FConcurrentThreadCount := SystemInfo.dwNumberOfProcessors; 194 | end; 195 | try 196 | for I := 0 to FThreadCount - 1 do 197 | begin 198 | ThreadHandle := CreateThread(nil, 0, @ThreadPoolWorker, Self, 0, ThreadId); 199 | if ThreadHandle = 0 then 200 | RaiseLastOSError; 201 | end; 202 | FInitialized.WaitFor(INFINITE); 203 | except 204 | Finalize; 205 | raise; 206 | end; 207 | end; 208 | 209 | { TThreadPool public } 210 | 211 | constructor TThreadPool.Create(AThreadCount, AConcurrentCount: Cardinal); 212 | begin 213 | inherited Create; 214 | FHandle := 0; 215 | FThreadCount := AThreadCount; 216 | FConcurrentThreadCount := AConcurrentCount; 217 | FInitialized := TSimpleEvent.Create; 218 | FFinalized := TSimpleEvent.Create; 219 | end; 220 | 221 | destructor TThreadPool.Destroy; 222 | begin 223 | Shutdown; 224 | FFinalized.Free; 225 | FInitialized.Free; 226 | if FHandle <> 0 then 227 | CloseHandle(FHandle); 228 | inherited Destroy; 229 | end; 230 | 231 | function TThreadPool.BeginShutdown: Boolean; 232 | begin 233 | Result := Broadcast(CompletionKeyShutDown); 234 | end; 235 | 236 | procedure TThreadPool.Bind(Worker: TWorkerProc; AHandle: THandle); 237 | var 238 | NewHandle: Boolean; 239 | CompletionKey: NativeUInt absolute Worker; 240 | begin 241 | NewHandle := FHandle = 0; 242 | FHandle := CreateIoCompletionPort(AHandle, FHandle, CompletionKey, FConcurrentThreadCount); 243 | if FHandle = 0 then 244 | RaiseLastOSError; 245 | if NewHandle then 246 | Initialize(FThreadCount); 247 | end; 248 | 249 | procedure TThreadPool.Queue(BytesTransferred: Cardinal; Worker: TWorkerProc; Overlapped: POverlapped); 250 | var 251 | CompletionKey: NativeUint absolute Worker; 252 | begin 253 | if FHandle = 0 then 254 | Bind(Worker); 255 | 256 | Win32Check(PostQueuedCompletionStatus(FHandle, BytesTransferred, CompletionKey, Overlapped)); 257 | end; 258 | 259 | procedure TThreadPool.Shutdown; 260 | begin 261 | if BeginShutdown then 262 | WaitFor(INFINITE); 263 | end; 264 | 265 | procedure TThreadPool.WaitFor(Timeout: Cardinal); 266 | begin 267 | FFinalized.WaitFor(Timeout); 268 | end; 269 | 270 | initialization 271 | IsMultiThread := True; 272 | 273 | finalization 274 | 275 | end. 276 | -------------------------------------------------------------------------------- /src/common.inc: -------------------------------------------------------------------------------- 1 | (* 2 | 3 | MIT License 4 | 5 | Copyright (c) 2021 Ondrej Kelle 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in all 15 | copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | SOFTWARE. 24 | 25 | *) 26 | 27 | {$include ..\ext\jedi\jedi.inc} 28 | 29 | {$ifdef MSWINDOWS} 30 | {$define WINDOWS} 31 | {$endif} 32 | 33 | {$ifdef FPC} 34 | {$define HAS_NATIVEUINT} 35 | {$define HAS_RAWBYTESTRING} 36 | {$define HAS_UINTPTR} 37 | {$define SUPPORTS_CLASS_FIELDS} 38 | {$define SUPPORTS_UNICODE_STRING} 39 | {$endif} 40 | 41 | {$ifdef DELPHI} 42 | {$ifdef DELPHIXE_UP} 43 | {$define HAS_NATIVEUINT} 44 | {$endif} 45 | {$ifdef DELPHI2009_UP} 46 | {$define HAS_ANSISTRINGS} 47 | {$define HAS_RAWBYTESTRING} 48 | {$endif} 49 | {$ifdef DELPHIXE2_UP} 50 | {$define HAS_UINTPTR} 51 | {$endif} 52 | {$ifdef DELPHI2007_UP} 53 | {$define HAS_WIDESTRUTILS} 54 | {$define HAS_RAISELASTOSERROR} 55 | {$endif} 56 | {$endif} 57 | --------------------------------------------------------------------------------