1{ 2 This file is part of the Free Component Library (FCL) 3 Copyright (c) 2015 by Ondrej Pokorny 4 5 Unit implementing two-way (request/response) IPC between 1 server and more 6 clients, based on files. 7 The order of message processing is not deterministic (if there are more 8 pending messages, the server won't process them in the order they have 9 been sent to the server. 10 SendRequest and PostRequest+PeekResponse sequences from 1 client are 11 blocking and processed in correct order. 12 13 See the file COPYING.FPC, included in this distribution, 14 for details about the copyright. 15 16 This program is distributed in the hope that it will be useful, 17 but WITHOUT ANY WARRANTY; without even the implied warranty of 18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 19 20 *** 21 This unit is a duplicate of AdvancedIPC.pp from FPC (added in 3.1.1). 22 It should be removed when support of older FPC versions is dropped. 23 24 **********************************************************************} 25 26unit LazAdvancedIPC; 27 28{$mode objfpc} 29{$H+} 30 31interface 32 33uses 34 {$IFDEF UNIX} 35 baseunix, 36 {$endif} 37 sysutils, Classes, LazFileUtils 38 {$IF FPC_FULLVERSION<20701} 39 ,LazSysUtils 40 {$ENDIF} 41 ; 42 43const 44 HEADER_VERSION = 2; 45 46type 47 TMessageType = LongInt; 48 TMessageHeader = packed record 49 HeaderVersion: Byte; 50 FileLock: Byte;//0 = unlocked, 1 = locked 51 MsgType: TMessageType; 52 MsgLen: Integer; 53 MsgVersion: Integer; 54 end; 55 56 TFileHandle = Classes.THandle; 57 58 TReleaseHandleStream = class(THandleStream) 59 public 60 destructor Destroy; override; 61 end; 62 63 TIPCBase = class(TComponent) 64 private 65 FGlobal: Boolean; 66 FFileName: string; 67 FServerID: string; 68 FMessageVersion: Integer; 69 protected 70 class function ServerIDToFileName(const aServerID: string; const aGlobal: Boolean): string; 71 function GetResponseFileName(const aRequestID: Integer): string; 72 function GetResponseFileName(const aRequestFileName: string): string; 73 function GetPeekedRequestFileName(const aRequestID: Integer): string; 74 function GetPeekedRequestFileName(const aRequestFileName: string): string; 75 function GetRequestPrefix: string; 76 function GetRequestFileName(const aRequestID: Integer): string; 77 function RequestFileNameToID(const aFileName: string): Integer; 78 function RequestExists(const aRequestFileName: string): Boolean; 79 80 procedure SetServerID(const aServerID: string); virtual; 81 procedure SetGlobal(const aGlobal: Boolean); virtual; 82 83 function CanReadMessage(const aFileName: string; out outStream: TStream; out outMsgType: TMessageType; out outMsgLen: Integer): Boolean; 84 procedure DoPostMessage(const aFileName: string; const aMsgType: TMessageType; const aStream: TStream); overload; 85 procedure DoPostMessage(const aFileStream: TFileStream; const aMsgType: TMessageType; const aStream: TStream); overload; 86 function DoReadMessage(const aFileName: string; const aStream: TStream; out outMsgType: TMessageType): Boolean; 87 88 property FileName: string read FFileName; 89 public 90 class procedure FindRunningServers(const aServerIDPrefix: string; 91 const outServerIDs: TStrings; const aGlobal: Boolean = False); 92 class function ServerRunning(const aServerID: string; const aGlobal: Boolean = False): Boolean; overload; 93 public 94 //ServerID: name/ID of the server. Use only ['a'..'z', 'A'..'Z', '0'..'9', '_'] characters 95 property ServerID: string read FServerID write SetServerID; 96 //Global: if true, processes from different users can communicate; false, processes only from current user can communicate 97 property Global: Boolean read FGlobal write SetGlobal; 98 //MessageVersion: only messages with the same MessageVersion can be delivered between server/client 99 property MessageVersion: Integer read FMessageVersion write FMessageVersion; 100 end; 101 102 TIPCClient = class(TIPCBase) 103 private 104 FLastRequestID: Integer; 105 106 function CreateUniqueRequest(out outFileStream: TFileStream): Integer; 107 function DoPeekResponse(const aResponseFileName: string; const aStream: TStream; out outMsgType: TMessageType; const aTimeOut: Integer): Boolean; 108 public 109 constructor Create(aOwner: TComponent); override; 110 public 111 //post request to server, do not wait until request is peeked; returns request ID 112 function PostRequest(const aMsgType: TMessageType; const aStream: TStream): Integer; 113 //send request to server, wait until request is peeked; returns True if request was peeked within the aTimeOut limit 114 function SendRequest(const aMsgType: TMessageType; const aStream: TStream; const aTimeOut: Integer): Boolean; 115 function SendRequest(const aMsgType: TMessageType; const aStream: TStream; const aTimeOut: Integer; out outRequestID: Integer): Boolean; 116 //peek a response from last request from this client 117 function PeekResponse(const aStream: TStream; out outMsgType: TMessageType): Boolean; overload; 118 function PeekResponse(const aStream: TStream; out outMsgType: TMessageType; const aTimeOut: Integer): Boolean; overload; 119 //peek a response from request by ID 120 function PeekResponse(const aRequestID: Integer; const aStream: TStream; out outMsgType: TMessageType): Boolean; overload; 121 function PeekResponse(const aRequestID: Integer; const aStream: TStream; out outMsgType: TMessageType; const aTimeOut: Integer): Boolean; overload; 122 //delete last request from this client, returns true if request file existed and was deleted 123 function DeleteRequest: Boolean; overload; 124 //delete request by ID, returns true if request existed file and was deleted 125 function DeleteRequest(const aRequestID: Integer): Boolean; overload; 126 //check if server is running 127 function ServerRunning: Boolean; overload; 128 end; 129 130 TIPCServer = class(TIPCBase) 131 private 132 FFileHandle: TFileHandle; 133 FActive: Boolean; 134 135 function FindFirstRequest(out outFileName: string; out outStream: TStream; out outMsgType: TMessageType; out outMsgLen: Integer): Integer; 136 137 protected 138 procedure SetServerID(const aServerID: string); override; 139 procedure SetGlobal(const aGlobal: Boolean); override; 140 public 141 constructor Create(aOwner: TComponent); override; 142 destructor Destroy; override; 143 public 144 //peek request and read the message into a stream 145 function PeekRequest(const aStream: TStream; out outMsgType: TMessageType): Boolean; overload; 146 function PeekRequest(const aStream: TStream; out outRequestID: Integer; out outMsgType: TMessageType): Boolean; overload; 147 function PeekRequest(const aStream: TStream; out outRequestID: Integer; out outMsgType: TMessageType; const aTimeOut: Integer): Boolean; overload; 148 //only peek request, you have to read/delete the request manually with ReadRequest/DeleteRequest 149 function PeekRequest(out outMsgType: TMessageType): Boolean; overload; 150 function PeekRequest(out outRequestID: Integer; out outMsgType: TMessageType): Boolean; overload; 151 function PeekRequest(out outRequestID: Integer; out outMsgType: TMessageType; const aTimeOut: Integer): Boolean; overload; 152 //read a peeked request (that hasn't been read yet) 153 function ReadRequest(const aRequestID: Integer; const aStream: TStream): Boolean; 154 //delete a peeked request (that hasn't been read yet), returns true if request file existed and was deleted 155 function DeleteRequest(const aRequestID: Integer): Boolean; 156 157 //post response to a request 158 procedure PostResponse(const aRequestID: Integer; const aMsgType: TMessageType; const aStream: TStream); 159 160 //find the highest request ID from all pending requests 161 function FindHighestPendingRequestId: Integer; 162 //get the pending request count 163 function GetPendingRequestCount: Integer; 164 165 //start server: returns true if unique and started 166 function StartServer(const aDeletePendingRequests: Boolean = True): Boolean; 167 //stop server: returns true if stopped 168 function StopServer(const aDeletePendingRequests: Boolean = True): Boolean; 169 170 //delete all pending requests and responses 171 procedure DeletePendingRequests; 172 public 173 //true if server runs (was started) 174 property Active: Boolean read FActive; 175 end; 176 177 EICPException = class(Exception); 178 179resourcestring 180 SErrInvalidServerID = 'Invalid server ID "%s". Please use only alphanumerical characters and underlines.'; 181 SErrSetGlobalActive = 'You cannot change the global property when the server is active.'; 182 SErrSetServerIDActive = 'You cannot change the server ID when the server is active.'; 183 184implementation 185 186type 187 TIPCSearchRec = {$IF FPC_FULLVERSION>=20701}TRawByteSearchRec{$ELSE}TSearchRec{$ENDIF}; 188 189const 190 {$IFDEF UNIX} 191 GLOBAL_RIGHTS = S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH; 192 {$ELSE} 193 GLOBAL_RIGHTS = 0; 194 {$ENDIF} 195 196var 197 CreateUniqueRequestCritSec: TRTLCriticalSection; 198 199{ TIPCBase } 200 201function TIPCBase.CanReadMessage(const aFileName: string; out 202 outStream: TStream; out outMsgType: TMessageType; out outMsgLen: Integer 203 ): Boolean; 204var 205 xFileHandle: TFileHandle; 206 xHeader: TMessageHeader; 207begin 208 outStream := nil; 209 outMsgType := -1; 210 outMsgLen := 0; 211 Result := FileExists(aFileName); 212 if not Result then 213 Exit; 214 215 xFileHandle := FileOpen(aFileName, fmOpenRead or fmShareExclusive); 216 Result := xFileHandle <> feInvalidHandle; 217 if not Result then 218 Exit; 219 220 outStream := TReleaseHandleStream.Create(xFileHandle); 221 222 Result := (outStream.Size >= SizeOf(xHeader)); 223 if not Result then 224 begin 225 FreeAndNil(outStream); 226 Exit; 227 end; 228 229 outStream.ReadBuffer(xHeader{%H-}, SizeOf(xHeader)); 230 Result := 231 (xHeader.HeaderVersion = HEADER_VERSION) and (xHeader.FileLock = 0) and 232 (xHeader.MsgVersion = MessageVersion) and 233 (outStream.Size = Int64(SizeOf(xHeader))+Int64(xHeader.MsgLen)); 234 if not Result then 235 begin 236 FreeAndNil(outStream); 237 Exit; 238 end; 239 outMsgType := xHeader.MsgType; 240 outMsgLen := xHeader.MsgLen; 241end; 242 243function TIPCBase.DoReadMessage(const aFileName: string; 244 const aStream: TStream; out outMsgType: TMessageType): Boolean; 245var 246 xStream: TStream; 247 xMsgLen: Integer; 248begin 249 aStream.Size := 0; 250 xStream := nil; 251 try 252 Result := CanReadMessage(aFileName, xStream, outMsgType, xMsgLen); 253 if Result then 254 begin 255 if xMsgLen > 0 then 256 aStream.CopyFrom(xStream, xMsgLen); 257 FreeAndNil(xStream); 258 aStream.Position := 0; 259 DeleteFile(aFileName); 260 end; 261 finally 262 xStream.Free; 263 end; 264end; 265 266function TIPCBase.RequestExists(const aRequestFileName: string): Boolean; 267begin 268 Result := 269 (FileExists(aRequestFileName) or 270 FileExists(GetResponseFileName(aRequestFileName)) or 271 FileExists(GetPeekedRequestFileName(aRequestFileName))); 272end; 273 274class function TIPCBase.ServerRunning(const aServerID: string; 275 const aGlobal: Boolean): Boolean; 276var 277 xServerFileHandle: TFileHandle; 278 xFileName: String; 279begin 280 xFileName := ServerIDToFileName(aServerID, aGlobal); 281 Result := FileExists(xFileName); 282 if Result then 283 begin//+ check -> we should not be able to access the file 284 xServerFileHandle := FileCreate(xFileName, fmOpenReadWrite or fmShareExclusive, GLOBAL_RIGHTS); 285 Result := (xServerFileHandle=feInvalidHandle); 286 if not Result then 287 FileClose(xServerFileHandle); 288 end; 289end; 290 291class function TIPCBase.ServerIDToFileName(const aServerID: string; 292 const aGlobal: Boolean): string; 293begin 294 Result := GetTempDir(aGlobal)+aServerID; 295end; 296 297procedure TIPCBase.SetGlobal(const aGlobal: Boolean); 298begin 299 if FGlobal = aGlobal then Exit; 300 301 FGlobal := aGlobal; 302 FFileName := ServerIDToFileName(FServerID, FGlobal); 303end; 304 305procedure TIPCBase.DoPostMessage(const aFileName: string; 306 const aMsgType: TMessageType; const aStream: TStream); 307var 308 xStream: TFileStream; 309begin 310 xStream := TFileStream.Create(aFileName, fmCreate or fmShareExclusive, GLOBAL_RIGHTS); 311 try 312 DoPostMessage(xStream, aMsgType, aStream); 313 finally 314 xStream.Free; 315 end; 316end; 317 318procedure TIPCBase.DoPostMessage(const aFileStream: TFileStream; 319 const aMsgType: TMessageType; const aStream: TStream); 320var 321 xHeader: TMessageHeader; 322begin 323 xHeader.HeaderVersion := HEADER_VERSION; 324 xHeader.FileLock := 1;//locking 325 xHeader.MsgType := aMsgType; 326 if Assigned(aStream) then 327 xHeader.MsgLen := aStream.Size-aStream.Position 328 else 329 xHeader.MsgLen := 0; 330 xHeader.MsgVersion := MessageVersion; 331 332 aFileStream.WriteBuffer(xHeader, SizeOf(xHeader)); 333 if Assigned(aStream) and (aStream.Size-aStream.Position > 0) then 334 aFileStream.CopyFrom(aStream, aStream.Size-aStream.Position); 335 336 aFileStream.Position := 0;//unlocking 337 xHeader.FileLock := 0; 338 aFileStream.WriteBuffer(xHeader, SizeOf(xHeader)); 339 aFileStream.Seek(0, soEnd); 340end; 341 342function TIPCBase.RequestFileNameToID(const aFileName: string): Integer; 343begin 344 //the function prevents all responses/temp files to be handled 345 //only valid response files are returned 346 if (Length(aFileName) > 9) and (aFileName[Length(aFileName)-8] = '-') then 347 Result := StrToIntDef('$'+Copy(aFileName, Length(aFileName)-7, 8), -1) 348 else 349 Result := -1; 350end; 351 352class procedure TIPCBase.FindRunningServers(const aServerIDPrefix: string; 353 const outServerIDs: TStrings; const aGlobal: Boolean); 354var 355 xRec: TIPCSearchRec; 356begin 357 if FindFirstUTF8(ServerIDToFileName(aServerIDPrefix+AllFilesMask, aGlobal), faAnyFile, xRec) = 0 then 358 begin 359 repeat 360 if (Pos('-', xRec.Name) = 0) and//file that we found is a pending message 361 ServerRunning(xRec.Name, aGlobal) 362 then 363 outServerIDs.Add(xRec.Name); 364 until FindNextUTF8(xRec) <> 0; 365 end; 366 FindCloseUTF8(xRec); 367end; 368 369function TIPCBase.GetPeekedRequestFileName(const aRequestID: Integer): string; 370begin 371 Result := GetPeekedRequestFileName(GetRequestFileName(aRequestID)); 372end; 373 374function TIPCBase.GetPeekedRequestFileName(const aRequestFileName: string 375 ): string; 376begin 377 Result := aRequestFileName+'-t'; 378end; 379 380function TIPCBase.GetRequestFileName(const aRequestID: Integer): string; 381begin 382 Result := GetRequestPrefix+IntToHex(aRequestID, 8); 383end; 384 385function TIPCBase.GetRequestPrefix: string; 386begin 387 Result := FFileName+'-'; 388end; 389 390function TIPCBase.GetResponseFileName(const aRequestID: Integer): string; 391begin 392 Result := GetResponseFileName(GetRequestFileName(aRequestID)); 393end; 394 395function TIPCBase.GetResponseFileName(const aRequestFileName: string): string; 396begin 397 Result := aRequestFileName+'-r'; 398end; 399 400procedure TIPCBase.SetServerID(const aServerID: string); 401var 402 I: Integer; 403begin 404 if FServerID = aServerID then Exit; 405 406 for I := 1 to Length(aServerID) do 407 if not (aServerID[I] in ['a'..'z', 'A'..'Z', '0'..'9', '_']) then 408 raise EICPException.CreateFmt(SErrInvalidServerID , [aServerID]); 409 410 FServerID := aServerID; 411 412 FFileName := ServerIDToFileName(FServerID, FGlobal); 413end; 414 415{ TIPCClient } 416 417constructor TIPCClient.Create(aOwner: TComponent); 418begin 419 inherited Create(aOwner); 420 421 FLastRequestID := -1; 422end; 423 424function TIPCClient.DeleteRequest(const aRequestID: Integer): Boolean; 425var 426 xRequestFileName: string; 427begin 428 xRequestFileName := GetRequestFileName(aRequestID); 429 Result := DeleteFile(xRequestFileName); 430 if (aRequestID = FLastRequestID) and not FileExists(xRequestFileName) then 431 FLastRequestID := -1; 432end; 433 434function TIPCClient.DeleteRequest: Boolean; 435begin 436 if FLastRequestID >= 0 then 437 Result := DeleteRequest(FLastRequestID) 438 else 439 Result := False; 440end; 441 442function TIPCClient.DoPeekResponse(const aResponseFileName: string; 443 const aStream: TStream; out outMsgType: TMessageType; const aTimeOut: Integer 444 ): Boolean; 445var 446 xStart: QWord; 447begin 448 aStream.Size := 0; 449 Result := False; 450 xStart := GetTickCount64; 451 repeat 452 if DoReadMessage(aResponseFileName, aStream, outMsgType) then 453 Exit(True) 454 else if aTimeOut > 20 then 455 Sleep(10); 456 until (GetTickCount64-xStart > aTimeOut); 457end; 458 459function TIPCClient.CreateUniqueRequest(out outFileStream: TFileStream): Integer; 460var 461 xFileName: string; 462begin 463 outFileStream := nil; 464 EnterCriticalsection(CreateUniqueRequestCritSec); 465 try 466 Randomize; 467 repeat 468 //if Randomize/Random is started from 2 processes at exactly same moment, it returns the same number! -> prevent duplicates by xor GetProcessId 469 //the result must be of range 0..$7FFFFFFF (High(Integer)) 470 Result := Integer((PtrInt(Random($7FFFFFFF)) xor {%H-}PtrInt(GetProcessID)) and $7FFFFFFF); 471 xFileName := GetRequestFileName(Result); 472 until not RequestExists(xFileName); 473 474 outFileStream := TFileStream.Create(xFileName, fmCreate or fmShareExclusive, GLOBAL_RIGHTS); 475 finally 476 LeaveCriticalsection(CreateUniqueRequestCritSec); 477 end; 478end; 479 480function TIPCClient.PeekResponse(const aRequestID: Integer; 481 const aStream: TStream; out outMsgType: TMessageType): Boolean; 482begin 483 Result := DoReadMessage(GetResponseFileName(aRequestID), aStream, outMsgType); 484end; 485 486function TIPCClient.PeekResponse(const aRequestID: Integer; 487 const aStream: TStream; out outMsgType: TMessageType; const aTimeOut: Integer 488 ): Boolean; 489begin 490 Result := DoPeekResponse(GetResponseFileName(aRequestID), aStream, outMsgType, aTimeOut); 491end; 492 493function TIPCClient.PeekResponse(const aStream: TStream; out 494 outMsgType: TMessageType): Boolean; 495begin 496 Result := DoReadMessage(GetResponseFileName(FLastRequestID), aStream, outMsgType); 497end; 498 499function TIPCClient.PeekResponse(const aStream: TStream; out 500 outMsgType: TMessageType; const aTimeOut: Integer): Boolean; 501begin 502 Result := DoPeekResponse(GetResponseFileName(FLastRequestID), aStream, outMsgType, aTimeOut); 503end; 504 505function TIPCClient.PostRequest(const aMsgType: TMessageType; 506 const aStream: TStream): Integer; 507var 508 xRequestFileStream: TFileStream; 509begin 510 xRequestFileStream := nil; 511 try 512 Result := CreateUniqueRequest(xRequestFileStream); 513 DoPostMessage(xRequestFileStream, aMsgType, aStream); 514 finally 515 xRequestFileStream.Free; 516 end; 517 FLastRequestID := Result; 518end; 519 520function TIPCClient.SendRequest(const aMsgType: TMessageType; 521 const aStream: TStream; const aTimeOut: Integer): Boolean; 522var 523 xRequestID: Integer; 524begin 525 Result := SendRequest(aMsgType, aStream, aTimeOut, xRequestID); 526end; 527 528function TIPCClient.SendRequest(const aMsgType: TMessageType; 529 const aStream: TStream; const aTimeOut: Integer; out outRequestID: Integer 530 ): Boolean; 531var 532 xStart: QWord; 533 xRequestFileName: string; 534begin 535 outRequestID := PostRequest(aMsgType, aStream); 536 Result := False; 537 538 xRequestFileName := GetRequestFileName(outRequestID); 539 xStart := GetTickCount64; 540 repeat 541 if not FileExists(xRequestFileName) then 542 Exit(True) 543 else if aTimeOut > 20 then 544 Sleep(10); 545 until (GetTickCount64-xStart > aTimeOut); 546end; 547 548function TIPCClient.ServerRunning: Boolean; 549begin 550 Result := ServerRunning(ServerID, Global); 551end; 552 553{ TReleaseHandleStream } 554 555destructor TReleaseHandleStream.Destroy; 556begin 557 FileClose(Handle); 558 559 inherited Destroy; 560end; 561 562{ TIPCServer } 563 564procedure TIPCServer.DeletePendingRequests; 565var 566 xRec: TIPCSearchRec; 567 xDir: string; 568begin 569 xDir := ExtractFilePath(FFileName); 570 if FindFirstUTF8(GetRequestPrefix+AllFilesMask, faAnyFile, xRec) = 0 then 571 begin 572 repeat 573 DeleteFile(xDir+xRec.Name); 574 until FindNextUTF8(xRec) <> 0; 575 end; 576 FindCloseUTF8(xRec); 577end; 578 579function TIPCServer.DeleteRequest(const aRequestID: Integer): Boolean; 580begin 581 Result := DeleteFile(GetPeekedRequestFileName(aRequestID)); 582end; 583 584constructor TIPCServer.Create(aOwner: TComponent); 585begin 586 inherited Create(aOwner); 587 588 FFileHandle := feInvalidHandle; 589end; 590 591destructor TIPCServer.Destroy; 592begin 593 if Active then 594 StopServer; 595 596 inherited Destroy; 597end; 598 599function TIPCServer.FindFirstRequest(out outFileName: string; out 600 outStream: TStream; out outMsgType: TMessageType; out outMsgLen: Integer 601 ): Integer; 602var 603 xRec: TIPCSearchRec; 604begin 605 outFileName := ''; 606 outStream := nil; 607 outMsgType := -1; 608 outMsgLen := 0; 609 Result := -1; 610 if FindFirstUTF8(GetRequestPrefix+AllFilesMask, faAnyFile, xRec) = 0 then 611 begin 612 repeat 613 Result := RequestFileNameToID(xRec.Name); 614 if Result >= 0 then 615 begin 616 outFileName := GetRequestFileName(Result); 617 if not CanReadMessage(outFileName, outStream, outMsgType, outMsgLen) then 618 Result := -1; 619 end; 620 until (Result >= 0) or (FindNextUTF8(xRec) <> 0); 621 end; 622 FindCloseUTF8(xRec); 623end; 624 625function TIPCServer.FindHighestPendingRequestId: Integer; 626var 627 xRec: TIPCSearchRec; 628 xRequestID: LongInt; 629begin 630 Result := -1; 631 if FindFirstUTF8(GetRequestPrefix+AllFilesMask, faAnyFile, xRec) = 0 then 632 begin 633 repeat 634 xRequestID := RequestFileNameToID(xRec.Name); 635 if xRequestID > Result then 636 Result := xRequestID; 637 until FindNextUTF8(xRec) <> 0; 638 end; 639 FindCloseUTF8(xRec); 640end; 641 642function TIPCServer.GetPendingRequestCount: Integer; 643var 644 xRec: TIPCSearchRec; 645begin 646 Result := 0; 647 if FindFirstUTF8(GetRequestPrefix+AllFilesMask, faAnyFile, xRec) = 0 then 648 begin 649 repeat 650 if RequestFileNameToID(xRec.Name) >= 0 then 651 Inc(Result); 652 until FindNextUTF8(xRec) <> 0; 653 end; 654 FindCloseUTF8(xRec); 655end; 656 657function TIPCServer.PeekRequest(out outRequestID: Integer; out 658 outMsgType: TMessageType): Boolean; 659var 660 xStream: TStream; 661 xMsgLen: Integer; 662 xMsgFileName: string; 663begin 664 outMsgType := -1; 665 xMsgFileName := ''; 666 xStream := nil; 667 try 668 outRequestID := FindFirstRequest(xMsgFileName, xStream, outMsgType, xMsgLen); 669 Result := outRequestID >= 0; 670 if Result then 671 begin 672 FreeAndNil(xStream); 673 RenameFile(xMsgFileName, GetPeekedRequestFileName(xMsgFileName)); 674 end; 675 finally 676 xStream.Free; 677 end; 678end; 679 680function TIPCServer.PeekRequest(out outRequestID: Integer; out 681 outMsgType: TMessageType; const aTimeOut: Integer): Boolean; 682var 683 xStart: QWord; 684begin 685 Result := False; 686 xStart := GetTickCount64; 687 repeat 688 if PeekRequest(outRequestID, outMsgType) then 689 Exit(True) 690 else if aTimeOut > 20 then 691 Sleep(10); 692 until (GetTickCount64-xStart > aTimeOut); 693end; 694 695function TIPCServer.PeekRequest(out outMsgType: TMessageType): Boolean; 696var 697 xRequestID: Integer; 698begin 699 Result := PeekRequest(xRequestID, outMsgType); 700end; 701 702function TIPCServer.PeekRequest(const aStream: TStream; out outRequestID: Integer; 703 out outMsgType: TMessageType): Boolean; 704begin 705 Result := PeekRequest(outRequestID, outMsgType); 706 if Result then 707 Result := ReadRequest(outRequestID, aStream); 708end; 709 710function TIPCServer.PeekRequest(const aStream: TStream; out outRequestID: Integer; 711 out outMsgType: TMessageType; const aTimeOut: Integer): Boolean; 712begin 713 Result := PeekRequest(outRequestID, outMsgType, aTimeOut); 714 if Result then 715 Result := ReadRequest(outRequestID, aStream); 716end; 717 718function TIPCServer.PeekRequest(const aStream: TStream; out 719 outMsgType: TMessageType): Boolean; 720var 721 xRequestID: Integer; 722begin 723 Result := PeekRequest(aStream, xRequestID, outMsgType); 724end; 725 726procedure TIPCServer.PostResponse(const aRequestID: Integer; 727 const aMsgType: TMessageType; const aStream: TStream); 728begin 729 DoPostMessage(GetResponseFileName(aRequestID), aMsgType, aStream); 730end; 731 732function TIPCServer.ReadRequest(const aRequestID: Integer; const aStream: TStream 733 ): Boolean; 734var 735 xMsgType: TMessageType; 736begin 737 Result := DoReadMessage(GetPeekedRequestFileName(aRequestID), aStream, xMsgType); 738end; 739 740procedure TIPCServer.SetGlobal(const aGlobal: Boolean); 741begin 742 if Active then 743 raise EICPException.Create(SErrSetGlobalActive); 744 745 inherited SetGlobal(aGlobal); 746end; 747 748procedure TIPCServer.SetServerID(const aServerID: string); 749begin 750 if Active then 751 raise EICPException.Create(SErrSetServerIDActive); 752 753 inherited SetServerID(aServerID); 754end; 755 756function TIPCServer.StartServer(const aDeletePendingRequests: Boolean): Boolean; 757begin 758 if Active then 759 Exit(True); 760 761 FFileHandle := FileCreate(FFileName, fmCreate or fmShareExclusive, GLOBAL_RIGHTS); 762 Result := (FFileHandle<>feInvalidHandle); 763 FActive := Result; 764 if Result and aDeletePendingRequests then 765 DeletePendingRequests; 766end; 767 768function TIPCServer.StopServer(const aDeletePendingRequests: Boolean): Boolean; 769begin 770 if not Active then 771 Exit(True); 772 773 if FFileHandle<>feInvalidHandle then 774 FileClose(FFileHandle); 775 Result := DeleteFile(FFileName); 776 777 if aDeletePendingRequests then 778 DeletePendingRequests; 779 780 FActive := False; 781end; 782 783initialization 784 InitCriticalSection(CreateUniqueRequestCritSec); 785 786finalization 787 DoneCriticalsection(CreateUniqueRequestCritSec); 788 789end. 790